Skip to content

GitLab

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
Hide whitespace changes
Inline Side-by-side
frontend/convertDynamics.icl
View file @ 4453b644
......@@ -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
......
frontend/type_io.dcl
View file @ 4453b644
......@@ -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
......
frontend/type_io.icl
View file @ 4453b644
......@@ -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)
write_type_info (TQV type_var) tcl_file