Skip to content

GitLab

Commit 1e03d0bb authored by Vincent Zweije's avatar Vincent Zweije
Browse files

Add debugging info. 

Fix ==(Graph) bug that hung comparing graphs.
Current version optimises hello world.
parent e42e36f8
Expand all Hide whitespace changes
Inline Side-by-side
coclmaindll/cocl.prj
View file @ 1e03d0bb
This diff is collapsed.
frontend/frontend.icl
View file @ 1e03d0bb
......@@ -200,10 +200,10 @@ frontEndInterface opts mod_ident dcl_modules functions_and_macros predef_symbols
// VZ..
// Select fusion style and do fusion
# (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap, predef_symbols, error, out)
# (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap, predef_symbols, error, out, files)
= do_fusion opts.feo_fusionstyle main_dcl_module_n common_defs imported_funs dcl_types used_conses_in_dynamics type_def_infos type_heaps
array_instances components fun_defs var_heap expression_heap icl_specials list_inferred_types icl_common
dcl_mods icl_used_module_numbers predef_symbols error out icl_import global_fun_range icl_instances generic_range
dcl_mods icl_used_module_numbers predef_symbols error out icl_import global_fun_range icl_instances generic_range files
// ..VZ
| upToPhase == FrontEndPhaseTransformGroups
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap}
......@@ -383,16 +383,22 @@ where
do_fusion fusionstyle main_dcl_module_n common_defs imported_funs dcl_types used_conses_in_dynamics type_def_infos type_heaps
array_instances components fun_defs var_heap expression_heap icl_specials list_inferred_types icl_common
dcl_mods icl_used_module_numbers predef_symbols error out icl_import global_fun_range icl_instances generic_range
dcl_mods icl_used_module_numbers predef_symbols error out icl_import global_fun_range icl_instances generic_range files
= case fusionstyle of
FS_offline
# (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups common_defs array_instances main_dcl_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap
# (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap)
= transformGroups cleanup_info main_dcl_module_n (components -*-> "Transform") fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics type_def_infos var_heap type_heaps expression_heap
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out)
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out, files)
FS_online
# (fun_defs,var_heap,expression_heap,supercompile_range) = supercompile dcl_mods main_dcl_module_n (fun_defs -*-> "Supercompile") var_heap expression_heap
# (opened,logfile,files) = fopen "C:\Vincent\Sucl\supercom.log" FWriteText files
| not opened
-> abort "Could not open supercompilation log file"
# (fun_defs,var_heap,expression_heap,supercompile_range,predef_symbols,logfile) = supercompile dcl_mods main_dcl_module_n (fun_defs -*-> "Supercompile") var_heap expression_heap predef_symbols logfile
# (closed,files) = fclose logfile files
| not closed
-> abort "Could not close supercompilation log file"
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "Repartition functions") [global_fun_range, icl_instances, icl_specials, generic_range, supercompile_range]
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap}
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error, out)
......@@ -404,7 +410,7 @@ do_fusion fusionstyle main_dcl_module_n common_defs imported_funs dcl_types used
# var_heap = heaps.hp_var_heap
type_heaps = heaps.hp_type_heaps
expression_heap = heaps.hp_expression_heap
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out)
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out, files)
FS_none
#! _ = 0 -*-> "No fusion"
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out)
-> (components, fun_defs, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, predef_symbols, error, out, files)
sucl/basic.dcl
View file @ 1e03d0bb
......@@ -15,6 +15,7 @@ Basic types and functions.
*/
from general import Optional
from StdFile import <<<
import StdOverloaded
import StdString
......@@ -72,6 +73,9 @@ foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) |
// Foldoptional is the standard fold for the optional type.
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
// Force evaluation of first argument to root normal form before returning second
force :: !.a .b -> .b
// Forget drops a mapped value from a map given by a list.
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
......@@ -97,6 +101,12 @@ join :: a ![.[a]] -> .[a]
*/
kleene :: !.[symbol] -> .[[symbol]]
// Lazy variant of the predefined abort function
error :: .String -> .a
// Determine the string representation of a list
listToString :: [a] -> String | toString a
// Lookup finds a value mapped in a list mapping.
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
......@@ -130,6 +140,9 @@ maptl :: .(x:[.a] -> u:[.a]) !w:[.a] -> v:[.a], [u <= v, w <= x]
// Map three functions onto a triple.
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
// String representation of line terminator
nl :: String
// Pairwith pairs a value with its result under a given function
pairwith :: .(arg -> .res) arg -> (arg,.res)
......@@ -156,12 +169,18 @@ relimg :: ![(a,.b)] a -> [.b] | == a
// `Remap x y mapping' alters the mapping by associating y with x, removing the old values.
remap :: a b [.(a,b)] -> .[(a,b)] | == a
// A variant of foldl that is strict in its accumulator
sfoldl :: (.a -> .(.b -> .a)) !.a [.b] -> .a
// `Shorter xs' determines whether a list is shorter than list `xs'.
shorter :: ![.a] [.b] -> .Bool
// `Showbool b' is the string representation of boolean `b'.
showbool :: .(!.Bool -> a) | fromBool a
// Determine a string representation of a list
showlist :: (.elem -> .String) ![.elem] -> String
// `Showoptional showa opt' is the string representation of optional value `opt',
// where `showa' determines the string representation of the inner value.
showoptional :: .(.a -> .String) !(Optional .a) -> String
......@@ -187,3 +206,9 @@ superset :: .[a] -> .(.[a] -> Bool) | == a
// zipwith zips up two lists with a joining function
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
// Strict version of --->, which evaluates its lhs first
(<---) infix :: !.a !b -> .a | <<< b
// Sequential evaluation of left and right arguments
($) infixr :: !.a .b -> .b
sucl/basic.icl
View file @ 1e03d0bb
......@@ -25,7 +25,7 @@ Implementation
//:: Optional t = Absent | Present t
// Now using Optional type from cocl's general module
from general import Optional,No,Yes
from general import Optional,No,Yes,--->
instance == (Optional a) | == a
where (==) No No = True
......@@ -56,15 +56,16 @@ results recursively, and so on. Duplicates are removed. */
depthfirst :: (res->.[elem]) (elem->res) !.[elem] -> .[res] | == elem
depthfirst generate process xs
= snd (collect xs ([],[]))
where collect [] seenrest = seenrest
collect [x:xs] (seen,rest)
= snd (collect xs ([],[]))
where collect [] seenrest = seenrest
collect [x:xs] seenrest
| isMember x seen
= collect xs (seen,rest)
= (seen``,[y:rest``])
where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
(seen``,rest`) = collect xs ( seen`,rest)
y = process x
= collect xs seenrest
= (seen``,[y:rest``])
where (seen`,rest``) = collect (generate y) ([x:seen],rest`)
(seen``,rest`) = collect xs ( seen`,rest)
y = process x
(seen,rest) = seenrest
// `Disjoint xs ys' checks whether xs and ys are disjoint.
......@@ -89,22 +90,28 @@ foldlm f (l,[m:ms])
(l``,ms`) = foldlm f (l`,ms)
foldlr :: (.elem -> .((.lrinfo,.rlinfo) -> (.lrinfo,.rlinfo))) !(.lrinfo,.rlinfo) ![.elem] -> (.lrinfo,.rlinfo)
foldlr f (l,r) []
= (l,r)
foldlr f (l,r) [x:xs]
foldlr f lr []
= lr
foldlr f lr [x:xs]
= (l``,r``)
where (l``,r`) = foldlr f (l`,r) xs
(l`,r``) = f x (l,r`)
(l,r) = lr
foldmap :: (x:res -> w:res`) w:res` -> u:(![(arg,x:res)] -> v:(arg -> w:res`)) | == arg, [v u <= w, v <= x]
foldmap f d
= foldr foldmap` (const d)
where foldmap` (x,y) g v = if (x==v) (f y) (g v)
= foldr foldmap` (const d)
where foldmap` xy g v
= if (x==v) (f y) (g v)
where (x,y) = xy
foldoptional :: .res .(.t -> .res) !(Optional .t) -> .res
foldoptional no yes No = no
foldoptional no yes (Yes x) = yes x
force :: !.a .b -> .b
force x y = y
forget :: val -> .(![.(val,res)] -> .[(val,res)]) | == val
forget x = filter (neq x o fst)
neq x y = x <> y
......@@ -159,6 +166,14 @@ kleene symbols
= flatten (map appendstrings symbols)
where appendstrings symbol = map (cons symbol) strings
// Lazy variant of the predefined abort function
error :: .String -> .a
error message = abort message
// Determine the string representation of a list
listToString :: [a] -> String | toString a
listToString xs = showlist toString xs
lookup :: u:([(arg,w:res)] -> v:(arg -> w:res)) | == arg, [v u <= w]
lookup = foldmap id (abort "lookup: not found")
......@@ -211,6 +226,10 @@ maptl f [x:xs] = [x:f xs]
maptriple :: x:(.a -> .b) w:(.c -> .d) v:(.e -> .f) -> u:((.a,.c,.e) -> (.b,.d,.f)), [u <= v, u <= w, u <= x]
maptriple f g h = app3 (f,g,h)
// String representation of line terminator
nl :: String
nl =: "\n"
partition :: (a -> b) (a -> .c) -> .(!.[a] -> [(b,[.c])]) | == b
partition f g
= h
......@@ -227,6 +246,14 @@ relimg rel x` = [y\\(x,y)<-rel|x==x`]
remap :: a b [.(a,b)] -> .[(a,b)] | == a
remap x y xys = [(x,y):forget x xys]
// A variant of foldl that is strict in its accumulator
sfoldl :: (.a -> .(.b -> .a)) !.a [.b] -> .a
sfoldl f a xxs
#! a = a
= case xxs
of [] -> a
[x:xs] -> sfoldl f (f a x) xs
shorter :: ![.a] [.b] -> .Bool
shorter [] yys = False
shorter [x:xs] [] = True
......@@ -235,6 +262,14 @@ shorter [x:xs] [y:ys] = shorter xs ys
showbool :: .(!.Bool -> a) | fromBool a
showbool = fromBool
showlist :: (.elem -> .String) ![.elem] -> String
showlist showa xs
= "["+++inner xs+++"]"
where inner [] = ""
inner [x:xs] = showa x+++continue xs
continue [] = ""
continue [x:xs] = ","+++showa x+++continue xs
showoptional :: .(.a -> .String) !(Optional .a) -> String
showoptional showa No = "No"
showoptional showa (Yes a) = "(Yes "+++showa a+++")"
......@@ -268,3 +303,15 @@ superset set = isEmpty o (removeMembers set)
zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
// Strict version of --->, which evaluates its lhs first
(<---) infix :: !.a !b -> .a | <<< b
(<---) value message = value ---> message
($) infixr :: !.a .b -> .b
($) x y = y
(writeList) infixl :: !*File [a] -> .File | <<< a
(writeList) file [] = file
(writeList) file [x:xs]
= file <<< x writeList xs
sucl/canon.icl
View file @ 1e03d0bb
......@@ -5,6 +5,7 @@ implementation module canon
import rule
import graph
import basic
import general
import StdEnv
/*
......@@ -60,7 +61,7 @@ steps:
canonise :: (sym -> Rule tsym tvar) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
canonise typerule heap rg
= (relabel heap o etaexpand typerule o splitrg o relabel localheap) rg
= ((relabel heap o etaexpand typerule o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
/*
......@@ -113,9 +114,10 @@ localheap =: [0..]
foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
foldarea label rgraph
= (label rgraph,foldsingleton single nosingle rgraph)
= ((id (labelrgraph,foldsingleton single nosingle rgraph)) <--- "canon.foldarea ends") ---> "canon.foldarea begins"
where single root sym args = args
nosingle = snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph])
labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
/*
------------------------------------------------------------------------
......@@ -139,13 +141,13 @@ foldarea label rgraph
labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
labelarea areas labels rg
= foldmap id nolabel (maketable areas labels) rg
= ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") ((areas<---"canon.labelarea.areas ends")--->"canon.labelarea.areas begins") ((labels<---"canon.labelarea.labels ends")--->"canon.labelarea.labels begins")) ((rg<---"canon.labelarea.rg ends")--->"canon.labelarea.rg begins") <--- "canon.labelarea ends") ---> "canon.labelarea begins"
where nolabel = abort "canon: labelarea: no label assigned to area"
maketable :: [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
maketable [] _ = []
maketable [] _ = [] <--- "canon.maketable ends empty"
maketable [area:areas] labels
= [(area,label):maketable areas labels`]
= [(((area<---"canon.maketable.area ends")--->"canon.maketable.area begins",(label<---"canon.maketable.label ends")--->"canon.maketable.label begins") <--- "canon.maketable.head ends") ---> "canon.maketable.head begins":(maketable--->"canon.maketable begins from maketable") areas labels`] <--- "canon.maketable ends nonempty"
where (label,labels`) = getlabel (nc aroot) labels
getlabel (True,(asym,aargs)) labels
| not (or (map (fst o nc) aargs))
......
sucl/complete.icl
View file @ 1e03d0bb
......@@ -3,6 +3,7 @@ implementation module complete
// $Id$
import graph
import basic
import StdEnv
/*
......@@ -78,10 +79,11 @@ coveredby complete subject pvarss [svar:svars]
| complete (map fst3 closeds)
= and (map covered closeds)
= coveredby complete subject opens svars
where (opens,closeds) = split pvarss
covered (sym,repvar`,pvarss`) = coveredby complete subject pvarss` (repvar (repvar` undef) svar++svars)
where (opens,closeds) = psplit pvarss
covered (sym,repvar`,pvarss`) = coveredby complete subject pvarss` (repvar (repvar` dummyvar) svar++svars)
(sdef,(ssym,sargs)) = varcontents subject svar
tmpvalue = (fst (foldr (spl (repvar sargs) ssym) ([],[]) pvarss))
dummyvar = abort "complete: error: accessing dummy variable"
repvar pvars svar = map (const svar) pvars
......@@ -94,7 +96,7 @@ multipatterns with an open pattern are expanded and added as well.
*/
split
psplit
:: [Pattern sym var]
-> ( [Pattern sym var]
, [ ( sym
......@@ -106,14 +108,14 @@ split
| == sym
& == var
split [] = ([],[])
split [(subject,[svar:svars]):svarss]
psplit [] = ([],[])
psplit [(subject,[svar:svars]):svarss]
| not sdef
= ([(subject,svars):opens`],map add closeds`)
= (opens,[(ssym,repvar,[(subject,sargs++svars):ins]):closeds])
where (opens`,closeds`) = split svarss
where (opens`,closeds`) = psplit svarss
add (sym,repvar,svarss`) = (sym,repvar,[(subject,repvar svar++svars):svarss`])
(opens,closeds) = split outs
(opens,closeds) = psplit outs
(ins,outs) = foldr (spl repvar ssym) ([],[]) svarss
repvar svar = map (const svar) sargs
(sdef,(ssym,sargs)) = varcontents subject svar
......
sucl/convert.dcl
View file @ 1e03d0bb
......@@ -8,6 +8,7 @@ from rule import Rule
from coreclean import SuclTypeSymbol,SuclTypeVariable,SuclSymbol,SuclSymbolKind,SuclVariable
from checksupport import DclModule
from syntax import FunDef,FunType,ExpressionHeap
from predef import PredefinedSymbols,PredefinedSymbol
// Transitively required stuff
from newfold import FuncBody
......@@ -36,17 +37,21 @@ cts_function
//Cocl to Sucl for exports (function decls from main dcl)
cts_exports ::
{#DclModule} // List of imported DCL modules
Int // Index of current module
-> [SuclSymbol]
{#DclModule} // List of imported DCL modules
*PredefinedSymbols // Table of predefined symbols (for looking up the start symbol)
Int // Index of current module
-> ( .PredefinedSymbols // Consulted predefined symbol table
, [SuclSymbol] // Exported symbols
)
//Cocl to Sucl for (algebraic) type specifications
cts_getconstrs ::
{#DclModule} // Info from used DCL modules
-> [(SuclTypeSymbol,[SuclSymbol])] // List of constructor symbols for each type symbol
{#DclModule} // Info from used DCL modules
-> [(SuclTypeSymbol,[SuclSymbol])] // List of constructor symbols for each type symbol
//Sucl to Cocl for function bodies
stc_funcdefs ::
PredefinedSymbol // Compiler-predefined String symbol
{#.DclModule} // DCL for looking up constructor types
Int // Index of current module
Int // Index of first new generated function
......
sucl/convert.icl
View file @ 1e03d0bb
This diff is collapsed.
sucl/coreclean.dcl
View file @ 1e03d0bb
......@@ -5,6 +5,8 @@ definition module coreclean
from strat import Strategy
from rule import Rule
from syntax import TypeSymbIdent,Ident,TypeVar,ExprInfoPtr,VarInfoPtr,SymbKind
from StdOverloaded import ==,toString
from StdFile import <<<
// Transitive necessities
from strat import Substrategy
......@@ -13,7 +15,6 @@ from graph import Graph,Node
from syntax import SymbolPtr,SymbolTableEntry,STE_Kind,Index,Level,Global,TypeSymbProperties,SignClassification,PropClassification,TypeVarInfoPtr,TypeVarInfo,ExprInfo,VarInfo
from general import BITVECT
from Heap import Ptr,PtrN,HeapN
from StdOverloaded import ==
from StdString import String
:: SuclTypeSymbol
......@@ -23,6 +24,7 @@ from StdString import String
| SuclCHAR // Etc.
| SuclREAL
| SuclBOOL
| SuclSTRING
| SuclDYNAMIC
| SuclFILE
| SuclWORLD
......@@ -41,6 +43,7 @@ sucltypeheap :: [SuclTypeVariable]
| SuclChar Char
| SuclReal Real
| SuclBool Bool
| SuclString String
:: SuclSymbolKind
= SuclFunction
......@@ -58,6 +61,17 @@ instance == SuclTypeVariable
instance == SuclSymbol
instance == SuclVariable
instance toString SuclTypeSymbol
instance <<< SuclTypeSymbol
instance toString SuclTypeVariable
instance <<< SuclTypeVariable
instance toString SuclSymbol
instance <<< SuclSymbol
instance toString SuclSymbolKind
instance <<< SuclSymbolKind
instance toString SuclVariable
instance <<< SuclVariable
// Get the type rule and strictness of a built in core clean symbol
coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
corestricts :: SuclSymbol -> [Bool]
......
sucl/coreclean.icl
View file @ 1e03d0bb
......@@ -18,6 +18,7 @@ import syntax
| SuclCHAR
| SuclREAL
| SuclBOOL
| SuclSTRING
| SuclDYNAMIC
| SuclFILE
| SuclWORLD
......@@ -37,6 +38,7 @@ sucltypeheap =: map SuclANONYMOUS [0..]
| SuclChar Char
| SuclReal Real
| SuclBool Bool
| SuclString String
:: SuclSymbolKind
= SuclFunction
......@@ -57,16 +59,42 @@ where (==) (SuclUSER tsid1 ) (SuclUSER tsid2 ) = tsid1==tsid2
(==) SuclCHAR SuclCHAR = True
(==) SuclREAL SuclREAL = True
(==) SuclBOOL SuclBOOL = True
(==) SuclSTRING SuclSTRING = True
(==) SuclDYNAMIC SuclDYNAMIC = True
(==) SuclFILE SuclFILE = True
(==) SuclWORLD SuclWORLD = True
(==) _ _ = False
instance toString SuclTypeSymbol
where toString (SuclUSER tsid ) = toString tsid
toString (SuclFN arity) = "Arrow/"+++toString arity
toString SuclINT = "Int"
toString SuclCHAR = "Char"
toString SuclREAL = "Real"
toString SuclBOOL = "Bool"
toString SuclSTRING = "String"
toString SuclDYNAMIC = "Dynamic"
toString SuclFILE = "File"
toString SuclWORLD = "World"
instance <<< SuclTypeSymbol
where (<<<) file tsym = file <<< toString tsym
instance == SuclTypeVariable
where (==) (SuclANONYMOUS i1) (SuclANONYMOUS i2) = i1 == i2
(==) (SuclNAMED p1) (SuclNAMED p2) = p1 == p2
(==) _ _ = False
instance toString SuclTypeVariable
where toString (SuclANONYMOUS i) = "V_"+++toString i
toString (SuclNAMED p) = "N_"+++toString p
instance toString TypeVar
where toString tv = toString tv.tv_info_ptr
instance <<< SuclTypeVariable
where (<<<) file tvar = file <<< toString tvar
instance == SuclSymbol
where (==) (SuclUser id1 ) (SuclUser id2 ) = id1 == id2
(==) (SuclCase eptr1) (SuclCase eptr2) = eptr1 == eptr2
......@@ -74,8 +102,44 @@ where (==) (SuclUser id1 ) (SuclUser id2 ) = id1 == id2
(==) (SuclInt int1 ) (SuclInt int2 ) = int1 == int2
(==) (SuclReal real1) (SuclReal real2) = real1 == real2
(==) (SuclBool bool1) (SuclBool bool2) = bool1 == bool2
(==) (SuclString str1) (SuclString str2) = str1 == str2
(==) _ _ = False
instance toString SuclSymbol
where toString (SuclUser sk ) = toString sk
toString (SuclCase eptr) = "<anonymous lifted case function>"
toString (SuclApply int ) = "Apply/"+++toString int
toString (SuclInt int ) = toString int
toString (SuclReal real) = toString real
toString (SuclBool bool) = toString bool
toString (SuclString str) = toString str
instance <<< SuclSymbol
where (<<<) file sym = file <<< toString sym
instance toString SymbKind
where toString SK_Unknown = "Unknown"
toString (SK_Function gi) = "Function "+++toString gi
toString (SK_LocalMacroFunction i) = "LocalMacroFunction "+++toString i
toString (SK_OverloadedFunction gi) = "OverloadedFunction "+++toString gi
toString (SK_Generic gi tk) = "Generic "+++toString gi+++" "+++toString tk
toString (SK_Constructor gi) = "Constructor "+++toString gi
toString (SK_Macro gi) = "Macro "+++toString gi
toString (SK_GeneratedFunction fip i) = "GeneratedFunction "+++toString fip+++" "+++toString i
toString SK_TypeCode = "TypeCode"
instance <<< SymbKind
where (<<<) file sk = file <<< toString sk
instance toString Global a | toString a
where toString {glob_module,glob_object} = toString glob_module+++"."+++toString glob_object
instance toString Ptr a
where toString p = "p:"+++toString (ptrToInt p)
instance <<< Ptr a
where (<<<) file p = file <<< toString p
instance == SymbKind
where (==) SK_Unknown SK_Unknown = True
(==) (SK_Function gi1) (SK_Function gi2) = gi1==gi2
......@@ -88,11 +152,26 @@ where (==) SK_Unknown SK_Unknown = Tr
(==) SK_TypeCode SK_TypeCode = True
(==) _ _ = False
instance toString SuclSymbolKind
where toString SuclFunction = "SuclFunction"
toString SuclConstructor = "SuclConstructor"
toString SuclPrimitive = "SuclPrimitive"
instance <<< SuclSymbolKind
where (<<<) file ssk = file <<< toString ssk
instance == SuclVariable
where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
(==) (SuclNamed p1) (SuclNamed p2) = p1 == p2
(==) _ _ = False
instance toString SuclVariable
where toString (SuclAnonymous i) = "v_"+++toString i
toString (SuclNamed p) = "n_"+++toString p
instance <<< SuclVariable
where (<<<) file var = file <<< toString var
// Get the type rule and strictness of a built in core clean symbol
corestricts :: SuclSymbol -> [Bool]
......@@ -117,6 +196,7 @@ coretyperule (SuclInt _) = consttyperule SuclINT
coretyperule (SuclChar _) = consttyperule SuclCHAR
coretyperule (SuclReal _) = consttyperule SuclREAL
coretyperule (SuclBool _) = consttyperule SuclBOOL
coretyperule (SuclString _) = consttyperule SuclSTRING
coretyperule (SuclUser _) = abort "coreclean: coretyperule: untyped user symbol"
coretyperule (SuclCase _) = abort "coreclean: coretyperule: untyped case symbol"
......@@ -132,6 +212,7 @@ 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 SuclSTRING = const False
corecomplete SuclDYNAMIC = const False
corecomplete SuclFILE = const False
corecomplete SuclWORLD = const False
sucl/dnc.icl
View file @ 1e03d0bb
......@@ -3,6 +3,7 @@ implementation module dnc
// $Id$
import graph