coreclean.icl 4.88 KB
Newer Older
1
2
3
4
implementation module coreclean

// $Id$

5
6
7
8
import strat
import spine
import rule
import graph
9
10
import basic
import StdCompare
Vincent Zweije's avatar
Refine    
Vincent Zweije committed
11
import syntax
12
//import StdEnv
Vincent Zweije's avatar
Refine    
Vincent Zweije committed
13

14
:: SuclTypeSymbol
15
 = SuclUSER (Global Index)
16
 | SuclFN Int
17
18
19
20
21
22
23
 | SuclINT
 | SuclCHAR
 | SuclREAL
 | SuclBOOL
 | SuclDYNAMIC
 | SuclFILE
 | SuclWORLD
24
25
26

:: SuclTypeVariable
 = SuclANONYMOUS Int
27
28
29
30
 | SuclNAMED TypeVar

sucltypeheap :: [SuclTypeVariable]
sucltypeheap =: map SuclANONYMOUS [0..]
31
32

:: SuclSymbol
33
 = SuclUser SymbKind
34
 | SuclCase ExprInfoPtr
35
 | SuclApply Int
36
 | SuclInt Int
37
 | SuclChar Char
38
 | SuclReal Real
39
 | SuclBool Bool
40
41
42
43
44
45
46
47

:: SuclSymbolKind
 = SuclFunction
 | SuclConstructor
 | SuclPrimitive

:: SuclVariable
 = SuclAnonymous Int
48
49
 | SuclNamed VarInfoPtr

50
51
52
suclheap :: [SuclVariable]
suclheap =: map SuclAnonymous [0..]

53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
instance == SuclTypeSymbol
where (==) (SuclUSER tsid1 ) (SuclUSER tsid2 ) = tsid1==tsid2
      (==) (SuclFN   arity1) (SuclFN   arity2) = arity1==arity2
      (==)  SuclINT           SuclINT          = True
      (==)  SuclCHAR          SuclCHAR         = True
      (==)  SuclREAL          SuclREAL         = True
      (==)  SuclBOOL          SuclBOOL         = True
      (==)  SuclDYNAMIC       SuclDYNAMIC      = True
      (==)  SuclFILE          SuclFILE         = True
      (==)  SuclWORLD         SuclWORLD        = True
      (==)  _                 _                = False

instance == SuclTypeVariable
where (==) (SuclANONYMOUS i1) (SuclANONYMOUS i2) = i1 == i2
      (==) (SuclNAMED     p1) (SuclNAMED     p2) = p1 == p2
      (==) _                  _                  = False

70
instance == SuclSymbol
71
where (==) (SuclUser  id1  )  (SuclUser  id2  )  = id1   == id2
72
73
74
75
76
77
78
      (==) (SuclCase  eptr1)  (SuclCase  eptr2)  = eptr1 == eptr2
      (==) (SuclApply int1 )  (SuclApply int2 )  = int1  == int2
      (==) (SuclInt   int1 )  (SuclInt   int2 )  = int1  == int2
      (==) (SuclReal  real1)  (SuclReal  real2)  = real1 == real2
      (==) (SuclBool  bool1)  (SuclBool  bool2)  = bool1 == bool2
      (==) _                  _                  = False

79
80
81
82
83
84
85
86
87
88
89
90
instance == SymbKind
where (==) SK_Unknown                       SK_Unknown                      = True
      (==) (SK_Function gi1)                (SK_Function gi2)               = gi1==gi2
      (==) (SK_LocalMacroFunction i1)       (SK_LocalMacroFunction i2)      = i1==i2
      (==) (SK_OverloadedFunction gi1)      (SK_OverloadedFunction gi2)     = gi1==gi2
      (==) (SK_Generic gi1 tk1)             (SK_Generic gi2 tk2)            = gi1==gi2 && tk1==tk2
      (==) (SK_Constructor gi1)             (SK_Constructor gi2)            = gi1==gi2
      (==) (SK_Macro gi1)                   (SK_Macro gi2)                  = gi1==gi2
      (==) (SK_GeneratedFunction fip1 i1)   (SK_GeneratedFunction fip2 i2)  = fip1==fip2 && i1==i2
      (==) SK_TypeCode                      SK_TypeCode                     = True
      (==) _                                _                               = False

91
92
93
94
instance == SuclVariable
where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
      (==) (SuclNamed     p1) (SuclNamed     p2) = p1 == p2
      (==) _                  _                  = False
95
96

// Get the type rule and strictness of a built in core clean symbol
97
98
99
100
101
102
103
104
105

corestricts :: SuclSymbol -> [Bool]
corestricts sym
= case sym
  of (SuclApply argc)
      -> maphd (const True) stricts
     _
      -> stricts
  where stricts = map (const False) (arguments (coretyperule sym))
106
107
108
109
110
111
112
113
114
115

coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
coretyperule (SuclApply argc)
 = mkrule [infunctype,argtype] outfunctype` (updategraph infunctype (SuclFN argc,[argtype:argtypes]++[restype]) outfuncgraph)
   where [infunctype,outfunctype,argtype,restype:sucltypeheap`] = sucltypeheap
         argtypes = take argc sucltypeheap`
         (outfunctype`,outfuncgraph)
          = if (argc==0)
               (restype,emptygraph)
               (outfunctype,updategraph outfunctype (SuclFN (argc-1),argtypes++[restype]) emptygraph)
Vincent Zweije's avatar
Vincent Zweije committed
116
coretyperule (SuclInt _) = consttyperule SuclINT
117
coretyperule (SuclChar _) = consttyperule SuclCHAR
Vincent Zweije's avatar
Vincent Zweije committed
118
119
120
121
122
123
124
125
coretyperule (SuclReal _) = consttyperule SuclREAL
coretyperule (SuclBool _) = consttyperule SuclBOOL
coretyperule (SuclUser _) = abort "coreclean: coretyperule: untyped user symbol"
coretyperule (SuclCase _) = abort "coreclean: coretyperule: untyped case symbol"

consttyperule tsym
 = mkrule [] root (updategraph root (tsym,[]) emptygraph)
   where root = SuclANONYMOUS 0
126
127
128
129
130
131
132
133
134
135
136
137

corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool

corecomplete (SuclUSER tsid) = const False  // Must be an abstype...
corecomplete (SuclFN arity) = const False
corecomplete SuclINT = const False
corecomplete SuclCHAR = superset (map (SuclChar o toChar) [0..255]) // 256 alternatives... doubtful is this is useful, but hey...
corecomplete SuclREAL = const False
corecomplete SuclBOOL = superset (map SuclBool [False,True])
corecomplete SuclDYNAMIC = const False
corecomplete SuclFILE = const False
corecomplete SuclWORLD = const False