Commit bc3f3995 authored by Vincent Zweije's avatar Vincent Zweije
Browse files

Define Cocl to Sucl conversion of (algebraic) type specifications

parent 6657e71a
...@@ -5,11 +5,11 @@ definition module absmodule ...@@ -5,11 +5,11 @@ definition module absmodule
from rule import Rule from rule import Rule
:: Module sym pvar tsym tvar :: Module sym pvar tsym tvar
= { exportedtypesymbols :: [tsym] // Exported type symbols (from DCL) = { //exportedtypesymbols :: [tsym] // Exported type symbols (from DCL)
, typealias :: [(tsym,Rule tsym tvar)] // Alias types //, typealias :: [(tsym,Rule tsym tvar)] // Alias types
, typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols , 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) , 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 , rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
} }
...@@ -42,11 +42,11 @@ Module implementation. ...@@ -42,11 +42,11 @@ Module implementation.
*/ */
:: Module sym pvar tsym tvar :: Module sym pvar tsym tvar
= { exportedtypesymbols :: [tsym] // Exported type symbols (from DCL) = {// exportedtypesymbols :: [tsym] // Exported type symbols (from DCL)
, typealias :: [(tsym,Rule tsym tvar)] // Alias types //, typealias :: [(tsym,Rule tsym tvar)] // Alias types
, typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type typeconstructors :: [(tsym,[sym])] // All constructor symbols of each declared algebraic type
, exportedsymbols :: [sym] // Exported function/constructor symbols , 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) , 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 , rules :: [(sym,[Rule sym pvar])] // Rewrite rules of each symbol, absent if imported
} }
......
...@@ -153,7 +153,7 @@ typerule m sym ...@@ -153,7 +153,7 @@ typerule m sym
*/ */
clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var 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 = ( 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 checklaws cleanlaws // Checks for special (hard coded) rules (+x0=x /y1=y ...)
o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules o checkrules matchable (foldmap id [] rs) // Checks normal rewrite rules
......
...@@ -34,6 +34,11 @@ cts_exports :: ...@@ -34,6 +34,11 @@ cts_exports ::
Int // Index of current module Int // Index of current module
-> [SuclSymbol] -> [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 //Sucl to Cocl for function bodies
stc_funcdef :: stc_funcdef ::
{#DclModule} // DCL for looking up constructor types {#DclModule} // DCL for looking up constructor types
......
...@@ -105,7 +105,7 @@ convert_atype atype (heap,(graph,rest,srest)) ...@@ -105,7 +105,7 @@ convert_atype atype (heap,(graph,rest,srest))
-> (heap``,updategraph typevar (typesym,typeargs) graph`,typevar) -> (heap``,updategraph typevar (typesym,typeargs) graph`,typevar)
where (heap``,(graph`,typeargs,_)) = convert_atypes (heap`,graph) atypes // _ => forget annotations of subtypes where (heap``,(graph`,typeargs,_)) = convert_atypes (heap`,graph) atypes // _ => forget annotations of subtypes
[typevar:heap`] = heap [typevar:heap`] = heap
typesym = SuclUSER typename typesym = SuclUSER typename.type_index
// A function type (a->b) // A function type (a->b)
functype --> argtype functype --> argtype
...@@ -143,6 +143,36 @@ convert_btype BT_File = SuclFILE ...@@ -143,6 +143,36 @@ convert_btype BT_File = SuclFILE
convert_btype BT_World = SuclWORLD convert_btype BT_World = SuclWORLD
convert_btype _ = abort "convert: convert_btype: unhandled BasicType constructor" 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 * * EXPRESSION CONVERSION *
******************************************************************************/ ******************************************************************************/
......
...@@ -17,7 +17,7 @@ from StdOverloaded import == ...@@ -17,7 +17,7 @@ from StdOverloaded import ==
from StdString import String from StdString import String
:: SuclTypeSymbol :: 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 | SuclFN Int // THE function type for a function with specified arity
| SuclINT // Built-in integer | SuclINT // Built-in integer
| SuclCHAR // Etc. | SuclCHAR // Etc.
......
...@@ -12,7 +12,7 @@ import syntax ...@@ -12,7 +12,7 @@ import syntax
//import StdEnv //import StdEnv
:: SuclTypeSymbol :: SuclTypeSymbol
= SuclUSER TypeSymbIdent = SuclUSER (Global Index)
| SuclFN Int | SuclFN Int
| SuclINT | SuclINT
| SuclCHAR | SuclCHAR
......
...@@ -18,8 +18,8 @@ from general import BITVECT,Optional ...@@ -18,8 +18,8 @@ from general import BITVECT,Optional
from Heap import Heap,HeapN,Ptr,PtrN from Heap import Heap,HeapN,Ptr,PtrN
from StdString import String from StdString import String
supercompile supercompile ::
:: !{# CommonDefs} // common_defs !{# CommonDefs} // common_defs
!IndexRange // array_instances !IndexRange // array_instances
!{#DclModule} // dcl_mods !{#DclModule} // dcl_mods
!Int // main_dcl_module_n !Int // main_dcl_module_n
......
...@@ -8,8 +8,8 @@ import syntax ...@@ -8,8 +8,8 @@ import syntax
import transform import transform
import trans import trans
supercompile supercompile ::
:: !{# CommonDefs} // common_defs !{# CommonDefs} // common_defs
!IndexRange // array_instances !IndexRange // array_instances
!{#DclModule} // dcl_mods !{#DclModule} // dcl_mods
!Int // main_dcl_module_n !Int // main_dcl_module_n
...@@ -39,5 +39,7 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f ...@@ -39,5 +39,7 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f
_ = cts_function fun_defs _ = cts_function fun_defs
// Determine exported functions // Determine exported functions
_ = cts_exports fun_defs dcl_mods main_dcl_module_n _ = 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 // Convert sucl-generated function body back to core clean
(expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef (expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment