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
//write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file :: !Int {#DclModule} CommonDefs !*File [String] -> (.Bool,.File)
write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file directly_imported_dcl_modules
#! tcl_file
= write_type_info common_defs tcl_file
#! tcl_file
= write_type_info directly_imported_dcl_modules tcl_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 type_heaps
# write_type_info_state2
= { WriteTypeInfoState |
wtis_type_heaps = type_heaps
, 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
= fwritei (size main_dcl_module.dcl_common.com_type_defs) tcl_file
#! 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);
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))
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 ...
# tcl_file
# (tcl_file,type_heaps)
= case tcl_file of
No
-> No
-> (No,type_heaps)
(Yes tcl_file)
# (ok,tcl_file)
= write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file /* TD */ directly_imported_dcl_modules
# (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 type_heaps
| not ok
-> abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
-> Yes tcl_file
-> (Yes tcl_file,type_heaps)
// ... TD
......
......@@ -8,9 +8,15 @@ import scanner, general, Heap, typeproperties, utilities, checksupport
import StdEnv
:: WriteTypeInfoState
= {
wtis_type_heaps :: !.TypeHeaps
, wtis_n_type_vars :: !Int
};
class WriteTypeInfo a
where
write_type_info :: a !*File -> !*File
write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
instance WriteTypeInfo CommonDefs, Char, [a] | WriteTypeInfo a
......
......@@ -22,108 +22,99 @@ import type_io_common
//import DebugUtilities;
F a b :== b;
/*
class NormaliseTypeDef a
where
normalise_type_def :: a -> a
*/
//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
*/
:: WriteTypeInfoState
= {
wtis_type_heaps :: !.TypeHeaps
, wtis_n_type_vars :: !Int
};
class WriteTypeInfo a
where
write_type_info :: a !*File -> !*File
write_type_info :: a !*File !*WriteTypeInfoState -> (!*File,!*WriteTypeInfoState)
instance WriteTypeInfo CommonDefs
where
write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file
# tcl_file
= write_type_info com_type_defs tcl_file
# tcl_file
= write_type_info com_cons_defs tcl_file
# tcl_file
= write_type_info com_selector_defs tcl_file
= tcl_file
write_type_info {com_type_defs,com_cons_defs,com_selector_defs} tcl_file wtis
# (tcl_file,wtis)
= write_type_info com_type_defs tcl_file wtis
# (tcl_file,wtis)
= write_type_info com_cons_defs tcl_file wtis
# (tcl_file,wtis)
= write_type_info com_selector_defs tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo SelectorDef
where
write_type_info {sd_type} tcl_file
# tcl_file
= write_type_info sd_type tcl_file
= tcl_file
write_type_info {sd_type} tcl_file wtis
# (tcl_file,wtis)
= write_type_info sd_type tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo ConsDef
where
write_type_info {cons_symb,cons_type,cons_arg_vars,cons_priority,cons_index,cons_type_index,cons_exi_vars} tcl_file
# tcl_file
= write_type_info cons_symb tcl_file
# tcl_file
= write_type_info cons_type tcl_file
# tcl_file
= write_type_info cons_arg_vars tcl_file
# tcl_file
= write_type_info cons_priority 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}
// normalize ...
# (th_vars,wtis)
= sel_type_var_heap wtis
# (_,(_,th_vars))
= mapSt normalize_type_var cons_exi_vars (wtis_n_type_vars,th_vars)
# wtis
= { wtis &
wtis_type_heaps = { wtis.wtis_type_heaps & th_vars = th_vars }
}
// ... normalize
# tcl_file
= write_type_info cons_index tcl_file
# tcl_file
= write_type_info cons_type_index tcl_file
# tcl_file
= write_type_info cons_exi_vars tcl_file
# (tcl_file,wtis)
= write_type_info cons_symb tcl_file wtis
# (tcl_file,wtis)
= write_type_info cons_type tcl_file wtis
# (tcl_file,wtis)
= 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
where
write_type_info (Prio assoc i) tcl_file
write_type_info (Prio assoc i) tcl_file wtis
# tcl_file
= fwritec PrioCode tcl_file
# tcl_file
= write_type_info assoc tcl_file
# tcl_file
= write_type_info i tcl_file
= tcl_file
write_type_info NoPrio tcl_file
# tcl_file
= fwritec NoPrioCode tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info assoc tcl_file wtis
# (tcl_file,wtis)
= write_type_info i tcl_file wtis
= (tcl_file,wtis)
write_type_info NoPrio tcl_file wtis
# tcl_file
= fwritec NoPrioCode tcl_file
= (tcl_file,wtis)
instance WriteTypeInfo Assoc
where
write_type_info LeftAssoc tcl_file
write_type_info LeftAssoc tcl_file wtis
# tcl_file
= fwritec LeftAssocCode tcl_file
= tcl_file
= fwritec LeftAssocCode tcl_file
= (tcl_file,wtis)
write_type_info RightAssoc tcl_file
write_type_info RightAssoc tcl_file wtis
# 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
= fwritec NoAssocCode tcl_file
= tcl_file
= fwritec NoAssocCode tcl_file
= (tcl_file,wtis)
*/
//1.3
instance WriteTypeInfo TypeDef TypeRhs
......@@ -132,232 +123,273 @@ instance WriteTypeInfo TypeDef TypeRhs
instance WriteTypeInfo (TypeDef TypeRhs)
0.2*/
where
write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file
#! tcl_file
= write_type_info td_name tcl_file
#! tcl_file
= write_type_info td_arity tcl_file
#! tcl_file
= write_type_info td_args tcl_file
#! tcl_file
= write_type_info td_rhs tcl_file
= tcl_file
write_type_info {td_name,td_arity,td_args,td_rhs} tcl_file wtis
// normalize ...
# (th_vars,wtis)
= sel_type_var_heap wtis
# (_,(n_type_vars,th_vars))
= mapSt normalize_type_var td_args (0,th_vars)
# wtis
= { wtis &
wtis_type_heaps = { wtis.wtis_type_heaps & th_vars = th_vars }
, 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
where
write_type_info {atv_annotation,atv_variable} tcl_file
#! tcl_file
= write_type_info atv_annotation tcl_file
#! tcl_file
= write_type_info atv_variable tcl_file
= tcl_file
write_type_info {atv_annotation,atv_variable} tcl_file wtis
# (tcl_file,wtis)
= write_type_info atv_annotation tcl_file wtis
# (tcl_file,wtis)
= write_type_info atv_variable tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo Annotation
where
write_type_info AN_Strict tcl_file
= fwritec '!' tcl_file
write_type_info AN_None tcl_file
= fwritec ' ' tcl_file
write_type_info AN_Strict tcl_file wtis
= (fwritec '!' tcl_file,wtis)
write_type_info AN_None tcl_file wtis
= (fwritec ' ' tcl_file,wtis)
instance WriteTypeInfo TypeVar
where
write_type_info {tv_name} tcl_file
// writing tv_name as number suffices
= write_type_info tv_name tcl_file
write_type_info {tv_info_ptr} tcl_file wtis
# (th_vars,wtis)
= 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
where
write_type_info (AlgType defined_symbols) tcl_file
#! tcl_file
= fwritec AlgTypeCode tcl_file;
write_type_info (AlgType defined_symbols) tcl_file wtis
# tcl_file
= fwritec AlgTypeCode tcl_file
# defined_symbols
= (sortBy (\{ds_ident={id_name=id_name1}} {ds_ident={id_name=id_name2}} -> id_name1 < id_name2) defined_symbols)
# tcl_file
= write_type_info defined_symbols tcl_file
# (tcl_file,wtis)
= write_type_info defined_symbols tcl_file wtis
= tcl_file
= (tcl_file,wtis)
write_type_info (SynType _) tcl_file
#! tcl_file
write_type_info (SynType _) tcl_file wtis
# tcl_file
= fwritec SynTypeCode tcl_file;
// 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
= 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
= fwritec AbstractTypeCode tcl_file;
// unimplemented
= tcl_file
= (tcl_file,wtis)
instance WriteTypeInfo DefinedSymbol
where
write_type_info {ds_ident,ds_arity,ds_index} tcl_file
# tcl_file
= write_type_info ds_ident tcl_file
# tcl_file
= write_type_info ds_arity tcl_file
# tcl_file
= write_type_info ds_index tcl_file
= tcl_file
write_type_info {ds_ident,ds_arity,ds_index} tcl_file wtis
# (tcl_file,wtis)
= write_type_info ds_ident tcl_file wtis
# (tcl_file,wtis)
= write_type_info ds_arity tcl_file wtis
# (tcl_file,wtis)
= write_type_info ds_index tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo Ident
where
write_type_info {id_name} tcl_file
write_type_info {id_name} tcl_file wtis
# tcl_file
= fwritei (size id_name) tcl_file
= fwrites id_name tcl_file
= (fwrites id_name tcl_file,wtis)
instance WriteTypeInfo FieldSymbol
where
write_type_info {fs_name,fs_var,fs_index} tcl_file
# tcl_file
= write_type_info fs_name tcl_file
# tcl_file
= write_type_info fs_var tcl_file
# tcl_file
= write_type_info fs_index tcl_file
= tcl_file
write_type_info {fs_name,fs_var,fs_index} tcl_file wtis
# (tcl_file,wtis)
= write_type_info fs_name tcl_file wtis
# (tcl_file,wtis)
= write_type_info fs_var tcl_file wtis
# (tcl_file,wtis)
= write_type_info fs_index tcl_file wtis
= (tcl_file,wtis)
// NEW ->
instance WriteTypeInfo SymbolType
where
write_type_info {st_vars,st_args,st_arity,st_result} tcl_file
# tcl_file
= write_type_info st_vars tcl_file
# tcl_file
= write_type_info st_args tcl_file
# tcl_file
= write_type_info st_arity tcl_file
# tcl_file
= write_type_info st_result tcl_file
= tcl_file
write_type_info {st_vars,st_args,st_arity,st_result} tcl_file wtis
# (tcl_file,wtis)
= write_type_info st_vars tcl_file wtis
# (tcl_file,wtis)
= write_type_info st_args tcl_file wtis
# (tcl_file,wtis)
= write_type_info st_arity tcl_file wtis
# (tcl_file,wtis)
= write_type_info st_result tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo AType
where
write_type_info {at_annotation,at_type} tcl_file
# tcl_file
= write_type_info at_annotation tcl_file
# tcl_file
= write_type_info at_type tcl_file
= tcl_file
write_type_info {at_annotation,at_type} tcl_file wtis
# (tcl_file,wtis)
= write_type_info at_annotation tcl_file wtis
# (tcl_file,wtis)
= write_type_info at_type tcl_file wtis
= (tcl_file,wtis)
instance WriteTypeInfo Type
where
write_type_info (TA type_symb_ident atypes) tcl_file
write_type_info (TA type_symb_ident atypes) tcl_file wtis
# tcl_file
= fwritec TypeTACode tcl_file
# tcl_file
= write_type_info type_symb_ident tcl_file
# tcl_file
= write_type_info atypes tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info type_symb_ident tcl_file wtis
# (tcl_file,wtis)
= write_type_info atypes tcl_file wtis
= (tcl_file,wtis)
write_type_info (atype1 --> atype2) tcl_file
write_type_info (atype1 --> atype2) tcl_file wtis
# tcl_file
= fwritec TypeArrowCode tcl_file
# tcl_file
= write_type_info atype1 tcl_file
# tcl_file
= write_type_info atype2 tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info atype1 tcl_file wtis
# (tcl_file,wtis)
= write_type_info atype2 tcl_file wtis
= (tcl_file,wtis)
write_type_info (cons_variable :@: atypes) tcl_file
write_type_info (cons_variable :@: atypes) tcl_file wtis
# tcl_file
= fwritec TypeConsApplyCode tcl_file
# tcl_file
= write_type_info cons_variable tcl_file
# tcl_file
= write_type_info atypes tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info cons_variable tcl_file wtis
# (tcl_file,wtis)
= write_type_info atypes tcl_file wtis
= (tcl_file,wtis)
write_type_info tb=:(TB basic_type) tcl_file
# tcl_file
write_type_info tb=:(TB basic_type) tcl_file wtis
# (tcl_file,wtis)
= case basic_type of
BT_Int -> fwritec BT_IntCode tcl_file
BT_Char -> fwritec BT_CharCode tcl_file
BT_Real -> fwritec BT_RealCode tcl_file
BT_Bool -> fwritec BT_BoolCode tcl_file
BT_Dynamic -> fwritec BT_DynamicCode tcl_file
BT_File -> fwritec BT_FileCode tcl_file
BT_World -> fwritec BT_WorldCode tcl_file
BT_Int -> (fwritec BT_IntCode tcl_file,wtis)
BT_Char -> (fwritec BT_CharCode tcl_file,wtis)
BT_Real -> (fwritec BT_RealCode tcl_file,wtis)
BT_Bool -> (fwritec BT_BoolCode tcl_file,wtis)
BT_Dynamic -> (fwritec BT_DynamicCode tcl_file,wtis)
BT_File -> (fwritec BT_FileCode tcl_file,wtis)
BT_World -> (fwritec BT_WorldCode tcl_file,wtis)
BT_String type
# tcl_file
= fwritec BT_StringCode tcl_file
# tcl_file
= write_type_info type tcl_file
-> tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info type tcl_file wtis
-> (tcl_file,wtis)
= (tcl_file,wtis)
write_type_info (GTV type_var) tcl_file
write_type_info (GTV type_var) tcl_file wtis
# tcl_file
= fwritec TypeGTVCode tcl_file
# tcl_file
= write_type_info type_var tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info type_var tcl_file wtis
= (tcl_file,wtis)
write_type_info (TV type_var) tcl_file
write_type_info (TV type_var) tcl_file wtis
# tcl_file
= fwritec TypeTVCode tcl_file
# tcl_file
= write_type_info type_var tcl_file
= tcl_file
# (tcl_file,wtis)
= write_type_info type_var tcl_file wtis
= (tcl_file,wtis)