Define Cocl to Sucl conversion of (algebraic) type specifications

sucl/absmodule.dcl

@@ -5,11 +5,11 @@ definition module absmodule
 from rule import Rule
 
 :: Module sym pvar tsym tvar
-   = { exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
-     , typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
-     , typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
+   = { //exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
+   //, typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
+       typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
      , exportedsymbols     :: [sym]                             // Exported function/constructor symbols
-     , aliases             :: [(sym,Rule sym pvar)]             // Macros
+   //, aliases             :: [(sym,Rule sym pvar)]             // Macros
      , typerules           :: [(sym,(Rule tsym tvar,[Bool]))]   // Info from type rules (actual type and argument strictnesses)
      , rules               :: [(sym,[Rule sym pvar])]           // Rewrite rules of each symbol, absent if imported
      }

sucl/absmodule.icl

@@ -42,11 +42,11 @@ Module implementation.
 */
 
 :: Module sym pvar tsym tvar
-   = { exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
-     , typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
-     , typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
+   = {// exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
+     //, typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
+       typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
      , exportedsymbols     :: [sym]                             // Exported function/constructor symbols
-     , aliases             :: [(sym,Rule sym pvar)]             // Macros
+   //, aliases             :: [(sym,Rule sym pvar)]             // Macros
      , typerules           :: [(sym,(Rule tsym tvar,[Bool]))]   // Info from type rules (actual type and argument strictnesses)
      , rules               :: [(sym,[Rule sym pvar])]           // Rewrite rules of each symbol, absent if imported
      }

sucl/cli.icl

@@ -153,7 +153,7 @@ typerule m sym
 */
 
 clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
-clistrategy cli=:{exportedtypesymbols=tes,typealias=tas,typeconstructors=tcs,exportedsymbols=es,aliases=as,typerules=ts,rules=rs} matchable
+clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
  = ( checkarity (typearity o maxtypeinfo ts)        // Checks curried occurrences and strict arguments
    o checklaws cleanlaws                            // Checks for special (hard coded) rules (+x0=x /y1=y ...)
    o checkrules matchable (foldmap id [] rs)        // Checks normal rewrite rules

sucl/convert.dcl

@@ -34,6 +34,11 @@ cts_exports ::
     Int             // Index of current module
  -> [SuclSymbol]
 
+//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
+
 //Sucl to Cocl for function bodies
 stc_funcdef ::
     {#DclModule}                        // DCL for looking up constructor types

sucl/convert.icl

@@ -105,7 +105,7 @@ convert_atype atype (heap,(graph,rest,srest))
                -> (heap``,updategraph typevar (typesym,typeargs) graph`,typevar)
                   where (heap``,(graph`,typeargs,_)) = convert_atypes (heap`,graph) atypes // _ => forget annotations of subtypes
                         [typevar:heap`] = heap
-                        typesym = SuclUSER typename
+                        typesym = SuclUSER typename.type_index
 
               // A function type (a->b)
               functype --> argtype
@@ -143,6 +143,36 @@ convert_btype BT_File = SuclFILE
 convert_btype BT_World = SuclWORLD
 convert_btype _ = abort "convert: convert_btype: unhandled BasicType constructor"
 
+
+/******************************************************************************
+*  ALGEBRAIC TYPE CONVERSION                                                  *
+******************************************************************************/
+
+
+cts_getconstrs ::
+    {#DclModule}					// Info from used DCL modules
+ -> [(SuclTypeSymbol,[SuclSymbol])]	// List of constructor symbols for each type symbol
+
+cts_getconstrs dcl_mods
+= flatten (zipwith f (a2l dcl_mods) [0..])
+  where f dcl_mod dcli
+        = [convert_typedef dcli typedef \\ typedef <-: dcl_mod.dcl_common.com_type_defs]
+
+a2l a = [e \\ e<-:a]
+
+convert_typedef :: Index (TypeDef TypeRhs) -> (SuclTypeSymbol,[SuclSymbol])
+convert_typedef dcli typedef
+= (SuclUSER (mkglobal dcli typedef.td_index),getconstrs dcli typedef.td_rhs)
+
+getconstrs dcli (AlgType constrs)
+= map mkalgconstr constrs
+  where mkalgconstr defsymb = SuclUser (SK_Constructor (mkglobal dcli defsymb.ds_index))
+getconstrs _ _
+= mstub "getconstrs" "unhandled TypeRhs form"
+
+mkglobal gmod gob = {glob_module = gmod, glob_object = gob}
+
+
 /******************************************************************************
 *  EXPRESSION CONVERSION                                                      *
 ******************************************************************************/

sucl/coreclean.dcl

@@ -17,7 +17,7 @@ from StdOverloaded import ==
 from StdString import String
 
 :: SuclTypeSymbol
- = SuclUSER TypeSymbIdent   // A user-defined type symbol
+ = SuclUSER (Global Index)  // A user-defined type symbol (index into com_type_def array)
  | SuclFN Int               // THE function type for a function with specified arity
  | SuclINT                  // Built-in integer
  | SuclCHAR                 // Etc.

sucl/coreclean.icl

@@ -12,7 +12,7 @@ import syntax
 //import StdEnv
 
 :: SuclTypeSymbol
- = SuclUSER TypeSymbIdent
+ = SuclUSER (Global Index)
  | SuclFN Int
  | SuclINT
  | SuclCHAR

sucl/supercompile.dcl

@@ -18,8 +18,8 @@ from general import BITVECT,Optional
 from Heap import Heap,HeapN,Ptr,PtrN
 from StdString import String
 
-supercompile
- :: !{# CommonDefs}             // common_defs
+supercompile ::
+    !{# CommonDefs}             // common_defs
     !IndexRange                 // array_instances
     !{#DclModule}               // dcl_mods
     !Int                        // main_dcl_module_n

sucl/supercompile.icl

@@ -8,8 +8,8 @@ import syntax
 import transform
 import trans
 
-supercompile
- :: !{# CommonDefs}             // common_defs
+supercompile ::
+    !{# CommonDefs}             // common_defs
     !IndexRange                 // array_instances
     !{#DclModule}               // dcl_mods
     !Int                        // main_dcl_module_n
@@ -39,5 +39,7 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f
         _ = cts_function fun_defs
 		// Determine exported functions
         _ = cts_exports fun_defs dcl_mods main_dcl_module_n
+		// Get constructor lists of algebraic types
+		_ = cts_getconstrs dcl_mods main_dcl_module_n
         // Convert sucl-generated function body back to core clean
         (expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef