Commit 4453b644 authored by Martijn Vervoort's avatar Martijn Vervoort
Browse files

minor changes to files associated with dynamics. Most notably is the

use of the TypeVarHeap.
parent f604a8f3
...@@ -52,33 +52,53 @@ F a b = b ...@@ -52,33 +52,53 @@ F a b = b
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File) //write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File) write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] !*TypeHeaps -> (.Bool,.File,!*TypeHeaps)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules type_heaps
#! tcl_file # write_type_info_state2
= write_type_info common_defs tcl_file = { WriteTypeInfoState |
#! tcl_file wtis_type_heaps = type_heaps
= write_type_info directly_imported_dcl_modules tcl_file , wtis_n_type_vars = 0
};
# (j,tcl_file)
= fposition tcl_file
// | True
// = abort ("TypeVar " +++ toString j)
#! (tcl_file,write_type_info_state)
= write_type_info common_defs tcl_file write_type_info_state2
#! (tcl_file,write_type_info_state)
= write_type_info directly_imported_dcl_modules tcl_file write_type_info_state
#! (type_heaps,_)
= f write_type_info_state //!type_heaps;
#! tcl_file #! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file = fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
#! tcl_file #! tcl_file
= fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file = fwritei (size main_dcl_module.dcl_common.com_cons_defs) tcl_file
= (True,tcl_file) = (True,tcl_file,type_heaps)
where
f write_type_info_state=:{wtis_type_heaps}
= (wtis_type_heaps,{write_type_info_state & wtis_type_heaps = abort "convertDynamics.icl"});
//---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs); //---> ("dcl",size main_dcl_module.dcl_common.com_type_defs, "icl", size common_defs.com_type_defs);
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String] convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String]
-> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File)) -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File))
convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules
// TD ... // TD ...
# tcl_file # (tcl_file,type_heaps)
= case tcl_file of = case tcl_file of
No No
-> No -> (No,type_heaps)
(Yes tcl_file) (Yes tcl_file)
# (ok,tcl_file) # (ok,tcl_file,type_heaps)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules type_heaps
| not ok | not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file" -> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> Yes tcl_file -> (Yes tcl_file,type_heaps)
// ... TD // ... TD
......
...@@ -8,9 +8,15 @@ import scanner, general, Heap, typeproperties, utilities, checksupport ...@@ -8,9 +8,15 @@ import scanner, general, Heap, typeproperties, utilities, checksupport
import StdEnv import StdEnv
:: WriteTypeInfoState
= {
wtis_type_heaps :: !.TypeHeaps
, wtis_n_type_vars :: !Int
};
class WriteTypeInfo a class WriteTypeInfo a
where where
write_type_info :: a !*File -> !*File write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a
......
...@@ -22,108 +22,99 @@ import type_io_common ...@@ -22,108 +22,99 @@ import type_io_common
//import DebugUtilities; //import DebugUtilities;
F a b :== b; F a b :== b;
/* :: WriteTypeInfoState
class NormaliseTypeDef a = {
where wtis_type_heaps :: !.TypeHeaps
normalise_type_def :: a -> a , wtis_n_type_vars :: !Int
*/ };
//import RWSDebug
/*
instance NormaliseTypeDef TypeRhs
where
normalise_type_def (AlgType defined_symbols)
// algebraic data types are further normalized by an alphabetical sort on the
// constructor names.
= AlgType (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
normalise_type_def i
= i
//1.3
instance NormaliseTypeDef TypeDef rhs | NormaliseTypeDef rhs
//3.1
/*2.0
instance NormaliseTypeDef (TypeDef rhs) | NormaliseTypeDef rhs
0.2*/
where
normalise_type_def type_def=:{td_args,td_arity}
= type_def
*/
class WriteTypeInfo a class WriteTypeInfo a
where where
write_type_info :: a !*File -> !*File write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
instance WriteTypeInfo CommonDefs instance WriteTypeInfo CommonDefs
where where
write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info com_type_defs tcl_file = write_type_info com_type_defs tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info com_cons_defs tcl_file = write_type_info com_cons_defs tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info com_selector_defs tcl_file = write_type_info com_selector_defs tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo SelectorDef instance WriteTypeInfo SelectorDef
where where
write_type_info {sd_type} tcl_file write_type_info {sd_type} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info sd_type tcl_file = write_type_info sd_type tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo ConsDef instance WriteTypeInfo ConsDef
where where
write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file wtis=:{wtis_n_type_vars}
# tcl_file // normalize ...
= write_type_info cons_symb tcl_file # (th_vars,wtis)
# tcl_file = sel_type_var_heap wtis
= write_type_info cons_type tcl_file # (_,(_,th_vars))
# tcl_file = mapSt normalize_type_var cons_exi_vars (wtis_n_type_vars,th_vars)
= write_type_info cons_arg_vars tcl_file # wtis
# tcl_file = { wtis &
= write_type_info cons_priority tcl_file wtis_type_heaps = { wtis.wtis_type_heaps & th_vars = th_vars }
}
// ... normalize
# tcl_file # (tcl_file,wtis)
= write_type_info cons_index tcl_file = write_type_info cons_symb tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info cons_type_index tcl_file = write_type_info cons_type tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info cons_exi_vars tcl_file = write_type_info cons_arg_vars tcl_file wtis
// # (tcl_file,wtis)
// = write_type_info cons_priority tcl_file wtis
# (tcl_file,wtis)
= write_type_info cons_index tcl_file wtis
# (tcl_file,wtis)
= write_type_info cons_type_index tcl_file wtis
# (tcl_file,wtis)
= write_type_info cons_exi_vars tcl_file wtis
= tcl_file = (tcl_file,wtis)
/*
instance WriteTypeInfo Priority instance WriteTypeInfo Priority
where where
write_type_info (Prio assoc i) tcl_file write_type_info (Prio assoc i) tcl_file wtis
# tcl_file # tcl_file
= fwritec PrioCode tcl_file = fwritec PrioCode tcl_file
# tcl_file # (tcl_file,wtis)
= write_type_info assoc tcl_file = write_type_info assoc tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info i tcl_file = write_type_info i tcl_file wtis
= tcl_file = (tcl_file,wtis)
write_type_info NoPrio tcl_file write_type_info NoPrio tcl_file wtis
# tcl_file # tcl_file
= fwritec NoPrioCode tcl_file = fwritec NoPrioCode tcl_file
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo Assoc instance WriteTypeInfo Assoc
where where
write_type_info LeftAssoc tcl_file write_type_info LeftAssoc tcl_file wtis
# tcl_file # tcl_file
= fwritec LeftAssocCode tcl_file = fwritec LeftAssocCode tcl_file
= tcl_file = (tcl_file,wtis)
write_type_info RightAssoc tcl_file write_type_info RightAssoc tcl_file wtis
# tcl_file # tcl_file
= fwritec RightAssocCode tcl_file = fwritec RightAssocCode tcl_file
= tcl_file = (tcl_file,wtis)
write_type_info NoAssoc tcl_file write_type_info NoAssoc tcl_file wtis
# tcl_file # tcl_file
= fwritec NoAssocCode tcl_file = fwritec NoAssocCode tcl_file
= tcl_file = (tcl_file,wtis)
*/
//1.3 //1.3
instance WriteTypeInfo TypeDef TypeRhs instance WriteTypeInfo TypeDef TypeRhs
...@@ -132,232 +123,273 @@ instance WriteTypeInfo TypeDef TypeRhs ...@@ -132,232 +123,273 @@ instance WriteTypeInfo TypeDef TypeRhs
instance WriteTypeInfo (TypeDef TypeRhs) instance WriteTypeInfo (TypeDef TypeRhs)
0.2*/ 0.2*/
where where
write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file wtis
#! tcl_file // normalize ...
= write_type_info td_name tcl_file # (th_vars,wtis)
#! tcl_file = sel_type_var_heap wtis
= write_type_info td_arity tcl_file # (_,(n_type_vars,th_vars))
#! tcl_file = mapSt normalize_type_var td_args (0,th_vars)
= write_type_info td_args tcl_file # wtis
#! tcl_file = { wtis &
= write_type_info td_rhs tcl_file wtis_type_heaps = { wtis.wtis_type_heaps & th_vars = th_vars }
= tcl_file , wtis_n_type_vars = n_type_vars
}
// ... normalize
# (tcl_file,wtis)
= write_type_info td_name tcl_file wtis
# (tcl_file,wtis)
= write_type_info td_arity tcl_file wtis
# (tcl_file,wtis)
= write_type_info td_args tcl_file wtis
# (tcl_file,wtis)
= write_type_info td_rhs tcl_file wtis
= (tcl_file,wtis)
normalize_type_var :: !ATypeVar (!Int,!*TypeVarHeap) -> (!Int,(!Int,!*TypeVarHeap))
normalize_type_var td_arg=:{atv_variable={tv_info_ptr}} (id,th_vars)
# th_vars
= writePtr tv_info_ptr (TVI_Normalized id) th_vars
= (id,(inc id,th_vars));
sel_type_var_heap :: !*WriteTypeInfoState -> (!*TypeVarHeap,!*WriteTypeInfoState)
sel_type_var_heap wtis=:{wtis_type_heaps}
# (th_vars,wtis_type_heaps)
= sel wtis_type_heaps
= (th_vars,{ wtis & wtis_type_heaps = wtis_type_heaps} )
where
sel wtis_type_heaps=:{th_vars}
= (th_vars,{ wtis_type_heaps & th_vars = newHeap } )
instance WriteTypeInfo ATypeVar instance WriteTypeInfo ATypeVar
where where
write_type_info {atv_annotation,atv_variable} tcl_file write_type_info {atv_annotation,atv_variable} tcl_file wtis
#! tcl_file # (tcl_file,wtis)
= write_type_info atv_annotation tcl_file = write_type_info atv_annotation tcl_file wtis
#! tcl_file # (tcl_file,wtis)
= write_type_info atv_variable tcl_file = write_type_info atv_variable tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo Annotation instance WriteTypeInfo Annotation
where where
write_type_info AN_Strict tcl_file write_type_info AN_Strict tcl_file wtis
= fwritec '!' tcl_file = (fwritec '!' tcl_file,wtis)
write_type_info AN_None tcl_file write_type_info AN_None tcl_file wtis
= fwritec ' ' tcl_file = (fwritec ' ' tcl_file,wtis)
instance WriteTypeInfo TypeVar instance WriteTypeInfo TypeVar
where where
write_type_info {tv_name} tcl_file write_type_info {tv_info_ptr} tcl_file wtis
// writing tv_name as number suffices # (th_vars,wtis)
= write_type_info tv_name tcl_file = sel_type_var_heap wtis
# ( v,th_vars)
= readPtr tv_info_ptr th_vars
# tcl_file
= fwritei (get_type_var_nf_number v) tcl_file
# wtis
= { wtis &
wtis_type_heaps = { wtis.wtis_type_heaps & th_vars = th_vars }
}
= (tcl_file,wtis)
where
get_type_var_nf_number (TVI_Normalized i) = i
instance WriteTypeInfo TypeRhs instance WriteTypeInfo TypeRhs
where where
write_type_info (AlgType defined_symbols) tcl_file write_type_info (AlgType defined_symbols) tcl_file wtis
#! tcl_file # tcl_file
= fwritec AlgTypeCode tcl_file; = fwritec AlgTypeCode tcl_file
# defined_symbols # defined_symbols
= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols) = (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
# tcl_file # (tcl_file,wtis)
= write_type_info defined_symbols tcl_file = write_type_info defined_symbols tcl_file wtis
= tcl_file = (tcl_file,wtis)
write_type_info (SynType _) tcl_file write_type_info (SynType _) tcl_file wtis
#! tcl_file # tcl_file
= fwritec SynTypeCode tcl_file; = fwritec SynTypeCode tcl_file;
// unimplemented // unimplemented
= tcl_file = (tcl_file,wtis)
write_type_info (RecordType {rt_fields}) tcl_file write_type_info (RecordType {rt_fields}) tcl_file wtis
#! tcl_file #! tcl_file
= fwritec RecordTypeCode tcl_file; = fwritec RecordTypeCode tcl_file;
= write_type_info rt_fields tcl_file = write_type_info rt_fields tcl_file wtis
write_type_info (AbstractType _) tcl_file write_type_info (AbstractType _) tcl_file wtis
#! tcl_file #! tcl_file
= fwritec AbstractTypeCode tcl_file; = fwritec AbstractTypeCode tcl_file;
// unimplemented // unimplemented
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo DefinedSymbol instance WriteTypeInfo DefinedSymbol
where where
write_type_info {ds_ident,ds_arity,ds_index} tcl_file write_type_info {ds_ident,ds_arity,ds_index} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info ds_ident tcl_file = write_type_info ds_ident tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info ds_arity tcl_file = write_type_info ds_arity tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info ds_index tcl_file = write_type_info ds_index tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo Ident instance WriteTypeInfo Ident
where where
write_type_info {id_name} tcl_file write_type_info {id_name} tcl_file wtis
# tcl_file # tcl_file
= fwritei (size id_name) tcl_file = fwritei (size id_name) tcl_file
= fwrites id_name tcl_file = (fwrites id_name tcl_file,wtis)
instance WriteTypeInfo FieldSymbol instance WriteTypeInfo FieldSymbol
where where
write_type_info {fs_name,fs_var,fs_index} tcl_file write_type_info {fs_name,fs_var,fs_index} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info fs_name tcl_file = write_type_info fs_name tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info fs_var tcl_file = write_type_info fs_var tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info fs_index tcl_file = write_type_info fs_index tcl_file wtis
= tcl_file = (tcl_file,wtis)
// NEW -> // NEW ->
instance WriteTypeInfo SymbolType instance WriteTypeInfo SymbolType
where where
write_type_info {st_vars,st_args,st_arity,st_result} tcl_file write_type_info {st_vars,st_args,st_arity,st_result} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info st_vars tcl_file = write_type_info st_vars tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info st_args tcl_file = write_type_info st_args tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info st_arity tcl_file = write_type_info st_arity tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info st_result tcl_file = write_type_info st_result tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo AType instance WriteTypeInfo AType
where where
write_type_info {at_annotation,at_type} tcl_file write_type_info {at_annotation,at_type} tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info at_annotation tcl_file = write_type_info at_annotation tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info at_type tcl_file = write_type_info at_type tcl_file wtis
= tcl_file = (tcl_file,wtis)
instance WriteTypeInfo Type instance WriteTypeInfo Type
where where
write_type_info (TA type_symb_ident atypes) tcl_file write_type_info (TA type_symb_ident atypes) tcl_file wtis
# tcl_file # tcl_file
= fwritec TypeTACode tcl_file = fwritec TypeTACode tcl_file
# tcl_file # (tcl_file,wtis)
= write_type_info type_symb_ident tcl_file = write_type_info type_symb_ident tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info atypes tcl_file = write_type_info atypes tcl_file wtis
= tcl_file = (tcl_file,wtis)
write_type_info (atype1 --> atype2) tcl_file write_type_info (atype1 --> atype2) tcl_file wtis
# tcl_file # tcl_file
= fwritec TypeArrowCode tcl_file = fwritec TypeArrowCode tcl_file
# tcl_file # (tcl_file,wtis)
= write_type_info atype1 tcl_file = write_type_info atype1 tcl_file wtis
# tcl_file # (tcl_file,wtis)
= write_type_info atype2 tcl_file = write_type_info atype2 tcl_file wtis
= tcl_file = (tcl_file,wtis)
write_type_info (cons_variable :@: atypes) tcl_file write_type_info (cons_variable :@: atypes) tcl_file wtis
# tcl_file # tcl_file
= fwritec TypeConsApplyCode tcl_file