Bugfix: add current node to spine nodes when checking history

Add lots of debugging code
Changes to make partly Clean-2.0 compilable

frontend/frontend.icl

@@ -227,7 +227,7 @@ frontEndInterface opts mod_ident dcl_modules functions_and_macros predef_symbols
 	# heaps = {hp_var_heap = var_heap, hp_expression_heap=expression_heap, hp_type_heaps=type_heaps}
 //	  (components, fun_defs, error)	= showTypes components 0 fun_defs error
 //	  (dcl_mods, out) = showDclModules dcl_mods out
-//	  (components, fun_defs, out) = showComponents components 0 False fun_defs out
+	  (components, fun_defs, out) = showComponents components 0 False fun_defs out
 
 	#! 	fe ={	fe_icl =
 //							 {icl_mod & icl_functions=fun_defs }
@@ -392,10 +392,10 @@ do_fusion fusionstyle main_dcl_module_n common_defs imported_funs dcl_types used
  			= 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, files)
 	FS_online
-		# (opened,logfile,files) = fopen "C:\Vincent\Sucl\supercom.log" FWriteText files
+		# (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
+		# (fun_defs,var_heap,expression_heap,supercompile_range,predef_symbols,logfile) = supercompile dcl_mods main_dcl_module_n icl_common (fun_defs -*-> "Supercompile") var_heap expression_heap predef_symbols logfile
 		# (closed,files) = fclose logfile files
 		| not closed
 		  -> abort "Could not close supercompilation log file"

frontend/generics.icl

@@ -1709,7 +1709,7 @@ where
 	where
 		r2={r1 & [s]=el}
 		r1={r0 & [i]=array.[i] \\ i<-[0..s-1]} 	
-		r0 = _createArray (s+1)
+		r0 = undef // _createArray (s+1)
 		s = size array		
 0.2*/
 	copy_array array = {x \\ x <-: array}	
@@ -2118,8 +2118,8 @@ where
 		# (alts, free_vars, gs) =  build_alts (i+1) n type_def_mod cons_def_syms cons_infos gs 		
 		= ([alt:alts], fvs ++ free_vars, gs)
 
-	build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState 
-		-> (AlgebraicPattern, [FreeVar], !*GenericState)
+//	build_alt :: !Int !Int !Int !DefinedSymbol !DefinedSymbol !*GenericState 
+//		-> (AlgebraicPattern, [FreeVar], !*GenericState)
 	build_alt 
 			i n type_def_mod def_symbol=:{ds_ident, ds_arity} cons_info 
 			gs=:{gs_heaps, gs_predefs, gs_main_dcl_module_n}		
@@ -2240,8 +2240,8 @@ where
 		# vars = [var : left_vars ++ right_vars]	
 		= (case_expr, vars, heaps) 
 	
-	build_cons_app :: !Index !DefinedSymbol !*Heaps 
-		-> (!Expression, [FreeVar], !*Heaps)
+//	build_cons_app :: !Index !DefinedSymbol !*Heaps 
+//		-> (!Expression, [FreeVar], !*Heaps)
 	build_cons_app cons_mod def_symbol=:{ds_arity} heaps
 		# names = ["x"  +++ toString k \\ k <- [1..ds_arity]]
 		# (var_exprs, vars, heaps) = buildVarExprs names heaps 
@@ -2308,8 +2308,8 @@ where
 		# (alts, free_vars, gs) = build_alts iso_dir (i+1) n type_def_mod def_symbols arg_vars type_def gs 		
 		= ([alt:alts], fvs ++ free_vars, gs)
 
-	build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState 
-		-> (AlgebraicPattern, [FreeVar], !*GenericState)
+//	build_alt :: !IsoDirection !Int !Int !Int !DefinedSymbol ![FreeVar] !CheckedTypeDef !*GenericState 
+//		-> (AlgebraicPattern, [FreeVar], !*GenericState)
 	build_alt 
 			iso_dir i n type_def_mod def_symbol=:{ds_ident, ds_arity, ds_index} 
 			fun_arg_vars type_def gs=:{gs_heaps, gs_modules}		
@@ -2329,8 +2329,8 @@ where
 			}
 		= (alg_pattern, cons_arg_vars, {gs & gs_heaps = gs_heaps})
 	
-	build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState 
-		-> ([!Expression], !*GenericState)
+//	build_cons_args :: !IsoDirection ![AType] ![FreeVar] ![FreeVar] !CheckedTypeDef !*GenericState 
+//		-> ([!Expression], !*GenericState)
 	build_cons_args iso_dir [] [] fun_arg_vars type_def gs = ([], gs) 	
 	build_cons_args	iso_dir [arg_type:arg_types] [cons_arg_var:cons_arg_vars] fun_arg_vars type_def gs
 		# (arg_expr, gs) = build_cons_arg iso_dir arg_type cons_arg_var fun_arg_vars type_def gs
@@ -2403,8 +2403,8 @@ where
 		# (tv, heaps) = buildTypeVar name heaps
 		= (makeAType (TV tv) (TA_Var av), heaps)	
 
-buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState
-	-> (!FunDef, !*GenericState)
+//buildIsomapForTypeDef :: !DefinedSymbol !Int !Int !CheckedTypeDef !DefinedSymbol !DefinedSymbol !*GenericState
+//	-> (!FunDef, !*GenericState)
 buildIsomapForTypeDef	
 		fun_def_sym group_index type_def_mod 
 		type_def=:{td_name, td_index, td_arity, td_pos}
@@ -2497,8 +2497,8 @@ where
 		# (var_expr, gs_heaps) = buildExprForTypeVar type_var arg_type_vars arg_vars gs_predefs gs_heaps 
 		= (var_expr, {gs & gs_heaps = gs_heaps})
 	
-buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState
-	-> (!FunDef, !*GenericState)
+//buildInstance :: !DefinedSymbol !Int !ClassInstance !GenericDef !*GenericState
+//	-> (!FunDef, !*GenericState)
 buildInstance 
 		def_sym group_index 
 		instance_def=:{ins_type, ins_generic, ins_pos, ins_ident} 
@@ -2676,8 +2676,8 @@ where
 								= find_in_array (inc index) array el	
 
 
-buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState
-	-> (!FunDef, !*GenericState)
+//buildKindConstInstance :: !DefinedSymbol !Int !Index !DefinedSymbol !TypeKind !GenericState
+//	-> (!FunDef, !*GenericState)
 buildKindConstInstance 
 		def_sym group_index 
 		generic_module generic_def_sym kind=:(KindArrow kinds) 
@@ -3225,7 +3225,7 @@ buildVarExpr name heaps=:{hp_var_heap, hp_expression_heap}
 	# heaps = { heaps & hp_var_heap = hp_var_heap, hp_expression_heap = hp_expression_heap } 
 	= (var, fv, heaps)
 
-buildVarExprs :: ![String] !*Heaps -> (![Expression], [!FreeVar], !*Heaps)	 		
+//buildVarExprs :: ![String] !*Heaps -> (![Expression], [!FreeVar], !*Heaps)	 		
 buildVarExprs [] heaps = ([], [], heaps)
 buildVarExprs [name:names] heaps 
 	# (expr, var, heaps) = buildVarExpr name heaps

sucl/Makefile

@@ -6,7 +6,7 @@ COCL = cocl
 #COCLFLAGS = -lat
 SYS = Clean\ System\ Files
 
-MODULES = basic pretty pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
+MODULES = cleanversion basic pfun graph dnc rule trd rewr complete history spine trace absmodule strat loop coreclean law canon cli extract newfold newtest convert supercompile
 
 ABC = $(patsubst %,$(SYS)/%.abc,$(MODULES))
 
@@ -47,5 +47,6 @@ $(SYS)/rule.abc: rule.icl rule.dcl graph.dcl basic.dcl
 $(SYS)/dnc.abc: dnc.icl dnc.dcl graph.dcl
 $(SYS)/graph.abc: graph.icl graph.dcl pfun.dcl basic.dcl
 $(SYS)/pfun.abc: pfun.icl pfun.dcl basic.dcl
-$(SYS)/pretty.abc: pretty.icl pretty.dcl
+#$(SYS)/pretty.abc: pretty.icl pretty.dcl
 $(SYS)/basic.abc: basic.icl basic.dcl
+$(SYS)/cleanversion.abc: cleanversion.icl cleanversion.dcl

sucl/basic.dcl

@@ -213,5 +213,8 @@ zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
 // Sequential evaluation of left and right arguments
 ($) infixr :: !.a .b -> .b
 
+// List subtraction (lazier than removeMembers)
+(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
+
 // Write a list of things, each one terminated by a newline
 (writeList) infixl :: !*File [a] -> .File | <<< a

sucl/basic.icl

@@ -299,7 +299,7 @@ stub modulename functionname message
 = abort (modulename+++": "+++functionname+++": "+++message)
 
 superset :: .[a] -> .(.[a] -> Bool) | == a
-superset set = isEmpty o (removeMembers set)
+superset set = isEmpty o ((--) set)
 
 zipwith :: (.a .b->.c) ![.a] [.b] -> [.c]
 zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
@@ -311,6 +311,14 @@ zipwith f xs ys = [f x y \\ x<-xs & y<-ys]
 ($) infixr :: !.a .b -> .b
 ($) x y = y
 
+// List subtraction (lazier than removeMembers)
+(--) infixl :: !.[elem] .[elem] -> .[elem] | == elem
+(--) []     ys = []
+(--) [x:xs] ys = f maybeeqs
+                 where (noteqs,maybeeqs) = span ((<>)x) ys
+                       f []     = [x:xs--noteqs]    // x wasn't in ys
+                       f [y:ys] = xs--(noteqs++ys)  // x==y
+
 (writeList) infixl :: !*File [a] -> .File | <<< a
 (writeList) file [] = file
 (writeList) file [x:xs]

sucl/canon.dcl

@@ -9,10 +9,10 @@ from StdOverloaded import ==
 // Canonises area into task expression
 // so equivalent ones can be detected through '==' comparison.
 canonise ::
-    (sym -> Rule tsym tvar) // Get type rule of a symbol (for eta expansion)
-    [var2]                  // Heap (nodespace) for consistent relabeling
-    (Rgraph sym var1)       // Input rooted graph
- -> Rgraph sym var2         // Canonised rooted graph
+    (sym -> Int)        // Get arity of a symbol (for eta expansion)
+    [var2]              // Heap (nodespace) for consistent relabeling
+    (Rgraph sym var1)   // Input rooted graph
+ -> Rgraph sym var2     // Canonised rooted graph
  |  == var1
 
 // Fold an area in a subject graph
@@ -23,6 +23,7 @@ foldarea ::
  |  == var
 
 labelarea ::
+    (sym->Bool)         // Whether a function symbol can be reused for a generated function
     [Rgraph sym var]    // List of areas to be labeled
     [sym]               // List of symbols to assign to them
     (Rgraph sym var)    // Rooted graph to label

sucl/canon.icl

@@ -59,9 +59,9 @@ 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 <--- "canon.canonise ends") ---> "canon.canonise begins"
+canonise :: (sym -> Int) [var2] (Rgraph sym var1) -> Rgraph sym var2 | == var1
+canonise arity heap rg
+ = ((relabel heap o etaexpand arity o splitrg o relabel localheap) rg <--- "canon.canonise ends") ---> "canon.canonise begins"
 
 /*
 
@@ -75,7 +75,7 @@ canonise typerule heap rg
 splitrg :: (Rgraph sym Int) -> Rgraph sym Int
 splitrg rgraph
  = foldsingleton single rgraph rgraph
-   where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (removeMembers localheap [root]))) emptygraph)
+   where single root sym args = mkrgraph root (updategraph root (sym,fst (claim args (localheap--[root]))) emptygraph)
 
 /*
 >   uncurry :: (*->rule **** *****) -> rgraph * num -> rgraph * num
@@ -89,12 +89,11 @@ splitrg rgraph
 >             root = rgraphroot rgraph; graph = rgraphgraph rgraph
 */
 
-etaexpand :: (sym->Rule tsym tvar) (Rgraph sym Int) -> Rgraph sym Int
-etaexpand typerule rgraph
+etaexpand :: (sym->Int) (Rgraph sym Int) -> Rgraph sym Int
+etaexpand arity rgraph
  = f (nc root)
    where f (True,(sym,args))
-          = mkrgraph root (updategraph root (sym,fst (claim targs (args++(removeMembers localheap (varlist graph [root]))))) graph)
-            where targs = arguments (typerule sym)
+          = mkrgraph root (updategraph root (sym,take (arity sym) (args++(localheap--(varlist graph [root])))) graph)
          f cont = rgraph
          nc = varcontents graph
          root = rgraphroot rgraph; graph = rgraphgraph rgraph
@@ -115,8 +114,8 @@ localheap =: [0..]
 foldarea :: ((Rgraph sym var) -> sym) (Rgraph sym var) -> Node sym var | == var
 foldarea label rgraph
  = (((labelrgraph<---"canon.foldarea.labelrgraph begins")--->"canon.foldarea.labelrgraph ends",(foldsingleton single nosingle rgraph<---"canon.foldarea.foldsingleton ends")--->"canon.foldarea.foldsingleton begins") <--- "canon.foldarea ends") ---> "canon.foldarea begins"
-   where single root sym args = map (\arg->(arg<---"newfold.foldarea.single.arg begins")--->"newfold.foldarea.single.arg ends") args
-         nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg begins")--->"newfold.foldarea.nosingle.arg ends") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
+   where single root sym args = map (\arg->(arg<---"canon.foldarea.single.arg ends")--->"canon.foldarea.single.arg begins") args
+         nosingle = map (\arg->(arg<---"newfold.foldarea.nosingle.arg ends")--->"newfold.foldarea.nosingle.arg begins") (snd (graphvars (rgraphgraph rgraph) [rgraphroot rgraph]))
          labelrgraph = (label rgraph <--- "canon.foldarea.labelrgraph ends") ---> "canon.foldarea.labelrgraph begins"
 
 /*
@@ -139,18 +138,18 @@ foldarea label rgraph
 >             aroot = rgraphroot area; agraph = rgraphgraph area
 */
 
-labelarea :: [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
-labelarea 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"
+labelarea :: (sym->Bool) [Rgraph sym var] [sym] (Rgraph sym var) -> sym | == sym & == var
+labelarea reusable areas labels rg
+ = ((foldmap--->"canon.labelarea uses foldmap") id nolabel ((maketable--->"canon.maketable begins from canon.labelarea") reusable ((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 [] _ = [] <--- "canon.maketable ends empty"
-maketable [area: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"
+maketable :: (sym->Bool) [Rgraph sym var] [sym] -> [(Rgraph sym var,sym)] | == var
+maketable _ [] _ = [] <--- "canon.maketable ends empty"
+maketable reusable [area: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") reusable 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))
+          | reusable asym && not (or (map (fst o nc) aargs))
             = (asym,labels)
          getlabel acont [label:labels]
           = (label,labels)

sucl/cleanversion.dcl

+definition module cleanversion
+
+//1.3
+from StdString import String
+//3.1
+
+/*2.0
+:: String :== {#Char}
+0.2*/

sucl/cleanversion.icl

+implementation module cleanversion
+
+//1.3
+from StdString import String
+//3.1
+
+/*2.0
+:: String :== {#Char}
+0.2*/

sucl/cli.dcl

@@ -17,6 +17,7 @@ from graph import Node
 
 :: Cli
 
+arity :: Cli SuclSymbol -> Int
 typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
 exports :: Cli -> [SuclSymbol]
 complete :: Cli -> [SuclSymbol] -> Bool
@@ -24,11 +25,11 @@ clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) ->
 
 // Build a cli structure
 mkcli ::
-    [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
-    [(SuclSymbol,[Bool])]
-    [SuclSymbol]
-    [(SuclTypeSymbol,[SuclSymbol])]
-    [(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
+    [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]                             // Type rules of local and imported functions
+    [(SuclSymbol,[Bool])]                                                           // Strictness information derived from function types
+    [SuclSymbol]                                                                    // Exported symbols
+    [(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])] // (Algebraic) types with their constructors, and the constructors' type info
+    [(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]                             // Function bodies with their arities and their rules
  -> Cli
 
 instance <<< Cli

sucl/cli.icl

@@ -9,6 +9,7 @@ import absmodule
 import rule
 import dnc
 import basic
+import general
 import StdEnv
 
 /*
@@ -123,6 +124,11 @@ Abstype implementation.
 exports :: Cli -> [SuclSymbol]
 exports (CliAlias m) = m.exportedsymbols
 
+// Determine the arity of a core clean symbol
+arity :: Cli SuclSymbol -> Int
+arity (CliAlias m) sym
+= extendfn m.arities (length o arguments o (extendfn m.typerules coretyperule)) sym
+
 /*
 >   typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
 */
@@ -160,8 +166,9 @@ clistrategy (CliAlias {arities=as,typeconstructors=tcs,typerules=ts,rules=rs}) m
    o checkimport islocal                            // Checks for delta symbols
    o checkconstr (flip isMember (flatten (map snd tcs))) // Checks for constructors
    ) (corestrategy matchable)                       // Checks rules for symbols in the language core (IF, _AP, ...)
-   where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
-         islocal rsym = True                        // Symbols in the language core are always completely known
+   where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)// User-defined symbols can be imported, so they're known if we have a list of rules for them
+         islocal rsym               = True                      // Symbols in the language core (the rest) are always completely known
+                                                                // This includes lifted case symbols; we lifted them ourselves, after all
 
 typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
 typearity ti = length (arguments ti)
@@ -321,17 +328,17 @@ mkcli ::
     [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
     [(SuclSymbol,[Bool])]
     [SuclSymbol]
-    [(SuclTypeSymbol,[SuclSymbol])]
+    [(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
     [(SuclSymbol,(Int,[Rule SuclSymbol SuclVariable]))]
  -> Cli
 
 mkcli typerules stricts exports constrs bodies
 = CliAlias
   { arities          = map (mapsnd fst) bodies
-  , typeconstructors = constrs
+  , typeconstructors = map (mapsnd (map fst)) constrs
   , exportedsymbols  = exports
-  , typerules        = typerules
-  , stricts          = stricts
+  , typerules        = typerules++flatten ((map (map (mapsnd fst) o snd)) constrs)
+  , stricts          = stricts++flatten ((map (map (mapsnd snd) o snd)) constrs)
   , rules            = map (mapsnd snd) bodies
   }
 

sucl/convert.dcl

@@ -9,6 +9,9 @@ from coreclean import SuclTypeSymbol,SuclTypeVariable,SuclSymbol,SuclSymbolKind,
 from checksupport import DclModule
 from syntax import FunDef,FunType,ExpressionHeap
 from predef import PredefinedSymbols,PredefinedSymbol
+/*2.0
+from StdArray import Array
+0.2*/
 
 // Transitively required stuff
 from newfold import FuncBody
@@ -16,7 +19,7 @@ from trace import Trace,Transformation
 from spine import Answer,Spine,Subspine
 from history import History,HistoryAssociation,HistoryPattern
 from rule import Rgraph
-from StdString import String
+from cleanversion import String
 from checksupport import CommonDefs,ConversionTable,Declarations
 from syntax import Ident,Priority,FunctionBody,Optional,SymbolType,Position,DefOrImpFunKind,FunInfo,SymbolPtr,TypeVar,AType,AType,TypeContext,AttributeVar,AttrInequality,FunCall,Index,Level,FreeVar,FreeVar,ExprInfoPtr,BITVECT,Ptr,Specials,SymbolTableEntry,TypeVarInfoPtr,TypeAttribute,Annotation,Type,Context,Global,DefinedSymbol,Type,VarInfoPtr,AttrVarInfoPtr,Expression,VarInfoPtr,Ptr,ExprInfo,PtrN,HeapN,PtrN,STE_Kind,TypeVarInfo,VarInfo,AttrVarInfo,CheckedTypeDef,ClassDef,ClassInstance,ConsDef,Declaration,GenericDef,IndexRange,MemberDef,SelectorDef,ATypeVar,DeclarationRecord,GenericClassInfos,GenericType,InstanceType,TypeDef,TypeKind,TypeRhs,GenericClassInfo
 from containers import NumberSet
@@ -44,12 +47,15 @@ cts_exports ::
     , [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
+	Int				// Index of current module in DCL module array
+	CommonDefs		// CommonDefs in ICL module (excluding FunDefs)
+ -> [(SuclTypeSymbol,[(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))])]
+                    // List of constructor symbols for each type symbol
 
 //Sucl to Cocl for function bodies
+//1.3
 stc_funcdefs ::
     PredefinedSymbol    // Compiler-predefined String symbol
     {#.DclModule}       // DCL for looking up constructor types
@@ -64,3 +70,20 @@ stc_funcdefs ::
     , .(Heap VarInfo)   // Remaining variable space
     , .{#FunDef}        // Converted function definitions
     )
+//3.1
+/*2.0
+stc_funcdefs ::
+    PredefinedSymbol
+    {#.DclModule}
+    Int
+    Int
+    *ExpressionHeap
+    *(Heap VarInfo)
+    [Symredresult SuclSymbol .SuclVariable a b]
+    *(c FunDef)
+ -> ( .ExpressionHeap
+    , .(Heap VarInfo)
+    , .{#FunDef}
+    )
+ |  Array c FunDef
+0.2*/

sucl/coreclean.dcl

@@ -15,7 +15,7 @@ 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 StdString import String
+from cleanversion import String
 
 :: SuclTypeSymbol
  = SuclUSER (Global Index)  // A user-defined type symbol (index into com_type_def array)
@@ -28,6 +28,7 @@ from StdString import String
  | SuclDYNAMIC
  | SuclFILE
  | SuclWORLD
+ | SuclERROR				// Type error
 
 :: SuclTypeVariable
  = SuclANONYMOUS Int
@@ -72,6 +73,9 @@ instance <<< SuclSymbolKind
 instance toString SuclVariable
 instance <<< SuclVariable
 
+instance toString (Ptr a)
+instance <<< (Ptr a)
+
 // Get the type rule and strictness of a built in core clean symbol
 coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
 corestricts :: SuclSymbol -> [Bool]

sucl/coreclean.icl

@@ -10,6 +10,7 @@ import basic
 import StdCompare
 import syntax
 //import StdEnv
+import general
 
 :: SuclTypeSymbol
  = SuclUSER (Global Index)
@@ -22,6 +23,7 @@ import syntax
  | SuclDYNAMIC
  | SuclFILE
  | SuclWORLD
+ | SuclERROR				// Type error
 
 :: SuclTypeVariable
  = SuclANONYMOUS Int
@@ -63,6 +65,7 @@ where (==) (SuclUSER tsid1 ) (SuclUSER tsid2 ) = tsid1==tsid2
       (==)  SuclDYNAMIC       SuclDYNAMIC      = True
       (==)  SuclFILE          SuclFILE         = True
       (==)  SuclWORLD         SuclWORLD        = True
+      (==)  SuclERROR         SuclERROR        = True
       (==)  _                 _                = False
 
 instance toString SuclTypeSymbol
@@ -76,6 +79,7 @@ where toString (SuclUSER tsid ) = toString tsid
       toString  SuclDYNAMIC     = "Dynamic"
       toString  SuclFILE        = "File"
       toString  SuclWORLD       = "World"
+      toString  SuclERROR       = "Error"
 
 instance <<< SuclTypeSymbol
 where (<<<) file tsym = file <<< toString tsym
@@ -107,7 +111,7 @@ where (==) (SuclUser  id1  )  (SuclUser  id2  )  = id1   == id2
 
 instance toString SuclSymbol
 where toString (SuclUser  sk  ) = toString sk
-      toString (SuclCase  eptr) = "<anonymous lifted case function>"
+      toString (SuclCase  eptr) = "<anonymous lifted case function for expression "+++toString eptr+++">"
       toString (SuclApply int ) = "Apply/"+++toString int
       toString (SuclInt   int ) = toString int
       toString (SuclReal  real) = toString real
@@ -131,13 +135,13 @@ where toString SK_Unknown = "Unknown"
 instance <<< SymbKind
 where (<<<) file sk = file <<< toString sk
 
-instance toString Global a | toString a
+instance toString (Global a) | toString a
 where toString {glob_module,glob_object} = toString glob_module+++"."+++toString glob_object
 
-instance toString Ptr a
+instance toString (Ptr a)
 where toString p = "p:"+++toString (ptrToInt p)
 
-instance <<< Ptr a
+instance <<< (Ptr a)
 where (<<<) file p = file <<< toString p
 
 instance == SymbKind
@@ -197,8 +201,7 @@ 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"
+coretyperule sym = error ("coreclean: coretyperule: untyped user symbol: "+++toString sym)
 
 consttyperule tsym
  = mkrule [] root (updategraph root (tsym,[]) emptygraph)
@@ -216,3 +219,4 @@ corecomplete SuclSTRING = const False
 corecomplete SuclDYNAMIC = const False
 corecomplete SuclFILE = const False
 corecomplete SuclWORLD = const False
+corecomplete SuclERROR = const False

sucl/dnc.dcl

@@ -3,7 +3,7 @@ definition module dnc
 // $Id$
 
 from graph import Graph,Node
-from StdString import String
+from cleanversion import String
 from StdOverloaded import ==
 
 // dnc is like varcontents, but can give a more reasonable error message

sucl/extract.icl

@@ -80,7 +80,7 @@ actualfold deltanodes rnfnodes foldarea self foldcont hist rule
 = Yes (mkrule rargs rroot rgraph``,areas`)
   where rargs = arguments rule; rroot = ruleroot rule; rgraph = rulegraph rule
 
-        list2 = map (pairwith (findoccs hist rule)) (removeMembers (varlist rgraph [rroot]) (varlist rgraph rargs))
+        list2 = map (pairwith (findoccs hist rule)) (varlist rgraph [rroot]--varlist rgraph rargs)
         // list2: list combining every node with list of every instantiable history graph
 
         list3 = [(rnode,mapping) \\ (rnode,[mapping:_])<-list2]
@@ -120,7 +120,7 @@ findoccs hist rule rnode
         unshared rnode (hroot,hgraph) mapping
         = disjoint inner outer
           where inner = map (lookup mapping) (fst (graphvars hgraph [hroot]))
-                outer = removeMembers (varlist (prunegraph rnode rgraph) [rroot:rargs]) [rnode]
+                outer = varlist (prunegraph rnode rgraph) [rroot:rargs]--[rnode]
 
 /*
 ------------------------------------------------------------------------
@@ -148,8 +148,8 @@ splitrule fold rnfnodes deltanodes rule area
         rgraph` = updategraph aroot (fold area`) rgraph
         area` = mkrgraph aroot agraph`
         agraph` = foldr addnode emptygraph ins
-        ins = removeMembers (varlist agraph [aroot]) outs
-        outs = removeMembers (varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]) [aroot]
+        ins = varlist agraph [aroot]--outs
+        outs = varlist (prunegraph aroot rgraph) [rroot:rargs++snd (graphvars agraph [aroot])]--[aroot]
 
         addnode node = updategraph node (snd (dnc (const "in splitrule") rgraph node))
 
@@ -180,11 +180,11 @@ finishfold foldarea fixednodes singlenodes root graph
         process aroot
         = mkrgraph aroot (foldr addnode emptygraph ins)
           where outs_and_aroot = varlist (prunegraph aroot graph) arearoots++fixednodes
-                ins = [aroot:removeMembers (varlist graph [aroot]) outs_and_aroot]
+                ins = [aroot:varlist graph [aroot]--outs_and_aroot]
         generate area
-        = removeMembers (snd (graphvars agraph [aroot])) fixednodes
+        = snd (graphvars agraph [aroot])--fixednodes
           where aroot = rgraphroot area; agraph = rgraphgraph area
-        arearoots = removeMembers (removeDup [root:singlenodes++singfixargs]) fixednodes
+        arearoots = removeDup [root:singlenodes++singfixargs]--fixednodes
         singfixargs = flatten (map arguments (singlenodes++fixednodes))
 
         arguments node

sucl/graph.dcl

@@ -4,7 +4,8 @@ definition module graph