1 
    2 -- ==========================================================--
    3 -- === Build abstract domains     File: MakeDomains.m (1) ===--
    4 -- ==========================================================--
    5 
    6 module MakeDomains where
    7 import BaseDefs
    8 import Utils
    9 import Dependancy
   10 
   11 import List(nub) -- 1.3
   12 
   13 -- ==========================================================--
   14 --
   15 mdFreeTVarsIn :: TypeDef ->  -- a type definition
   16                  [Naam]      -- variables free in it
   17 
   18 mdFreeTVarsIn (tn, tvl, cal)
   19    = utSetToList 
   20        (utSetSubtraction 
   21           (utSetFromList allVars)
   22           (utSetFromList (tvl ++ ["int", "bool", "char"])))
   23      where
   24         allVars = concat (map f cal)
   25         f (n, tel) = concat (map allTVs tel)
   26         allTVs (TDefVar n) = [n]
   27         allTVs (TDefCons n tel) = n:concat (map allTVs tel)
   28 
   29 
   30 -- ==========================================================--
   31 --
   32 mdMakeEdges :: [TypeDef] ->    -- all type definitions
   33                [(Naam, Naam)]  -- all edges resulting (from, to)
   34 
   35 mdMakeEdges tdl
   36    = concat (map mergeFromTo (zip froms tos))
   37      where
   38         k13sel (a, b, c) = a
   39         froms = map k13sel tdl
   40         tos = map mdFreeTVarsIn tdl
   41         mergeFromTo (f, tol) = [(f, t) | t <- tol]
   42 
   43 
   44 -- ==========================================================--
   45 --
   46 mdTypeDependancy :: [TypeDef] ->    -- all type definitions
   47                     TypeDependancy  -- list of groups & rec flag
   48 
   49 mdTypeDependancy tdl
   50    = map (singleRec.utSetToList) (deScc ins outs roots)
   51      where
   52         edges = mdMakeEdges tdl
   53         ins  v = [u | (u, w) <- edges, v==w]
   54         outs v = [w | (u, w) <- edges, v==u]
   55         roots = nub (map f tdl)
   56                 where 
   57                    f (a, b, c) = a
   58         singleRec (a:b:abs) = (True, a:b:abs)
   59         singleRec [a] 
   60            = (a `elem` (mdFreeTVarsIn (findAIn tdl)), [a])
   61              where
   62                 findAIn ((tn, tvl, cal):rest) | a==tn      = (tn, tvl, cal)
   63                                               | otherwise  = findAIn rest
   64 
   65 
   66 -- ==========================================================--
   67 --
   68 mdIsRecursiveType :: TypeDependancy -> 
   69                      Naam ->
   70                      Bool
   71 
   72 mdIsRecursiveType typedependancy typeName
   73    = search typedependancy
   74      where
   75         search ((rf, names):rest) 
   76            | typeName `elem` names   = rf
   77            | otherwise               = search rest
   78 
   79      
   80 -- ==========================================================--
   81 -- === end                              MakeDomains.m (1) ===--
   82 -- ==========================================================--