aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/convertDynamics.dcl4
-rw-r--r--frontend/convertDynamics.icl77
-rw-r--r--frontend/frontend.dcl4
-rw-r--r--frontend/frontend.icl39
-rw-r--r--frontend/overloading.dcl5
-rw-r--r--frontend/overloading.icl37
-rw-r--r--frontend/syntax.dcl2
-rw-r--r--frontend/syntax.icl2
-rw-r--r--frontend/type.dcl2
-rw-r--r--frontend/type.icl10
-rw-r--r--frontend/type_io.dcl23
-rw-r--r--frontend/type_io.icl797
12 files changed, 952 insertions, 50 deletions
diff --git a/frontend/convertDynamics.dcl b/frontend/convertDynamics.dcl
index c87f335..dba1bc4 100644
--- a/frontend/convertDynamics.dcl
+++ b/frontend/convertDynamics.dcl
@@ -3,8 +3,8 @@ definition module convertDynamics
import syntax, transform, convertcases
-convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap
- -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
+convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap !*File {# DclModule} !IclModule
+ -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, !*File)
/*
convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !*{! Group} !*{#FunDef} !*PredefinedSymbols
diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl
index 8a2c98f..1db6161 100644
--- a/frontend/convertDynamics.icl
+++ b/frontend/convertDynamics.icl
@@ -3,6 +3,7 @@ implementation module convertDynamics
import syntax, transform, utilities, convertcases
// Optional
USE_TUPLES tuple b :== b; // change also StdDynamic.icl and recompile all applications
+import type_io;
:: *ConversionInfo =
{ ci_predef_symb :: !*PredefinedSymbols
@@ -47,11 +48,73 @@ getSymbol index symb_kind arity ci=:{ci_predef_symb}
symbol = { symb_name = pds_ident, symb_kind = symb_kind { glob_module = pds_module, glob_object = pds_def}, symb_arity = arity }
= (symbol, ci)
*/
+/*
+// | True
+// = abort (toString main_dcl_module.dcl_name.id_name)
+ | True
+ = abort (toString main_dcl_module_n);
+
+ // distinguish external/internal types
+ # dcl_conversions
+ = get_conversion_table (main_dcl_module.dcl_conversions)
+ # type_defs_conversions
+ = dcl_conversions.[cTypeDefs]
+ # s_type_defs_conversions
+ = size type_defs_conversions
+
+
+ # s_exported_com_type_defs
+ = size common_defs.com_type_defs
+ # exported_com_type_defs
+ = createArray s_exported_com_type_defs False
+
+ # exported_com_type_defs
+ = foldSt (\i exported_com_type_defs ->
+
+ { exported_com_type_defs & [type_defs_conversions.[i]] = True }
+
+
+
+ ) [0..dec s_type_defs_conversions] exported_com_type_defs;
+
+ # (s_exported_com_type_defs,exported_com_type_defs)
+ = usize exported_com_type_defs
+ | True
+ = abort (toString s_exported_com_type_defs);
+*/
+
+pl [] = ""
+pl [x:xs] = x +++ " , " +++ (pl xs)
+F :: !a .b -> .b
+F a b = b
-convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap
- -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap)
-convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap
+write_tcl_file :: !Int {#DclModule} CommonDefs !*File -> (.Bool,.File)
+write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_module} common_defs tcl_file
+/*
+ #! tcl_file
+ = write_type_info dcl_mods tcl_file
+*/
+ #! tcl_file
+ = write_type_info common_defs tcl_file
+
+// #! (ok,common_defs,tcl_file)
+// = read_type_info tcl_file
+// | True
+// = abort (toString (size common_defs.com_type_defs))
+ = (True,tcl_file)
+
+convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */!*File {# DclModule} !IclModule
+ -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ !*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 ...
+/*
+ # (ok,tcl_file)
+ = write_tcl_file main_dcl_module_n dcl_mods icl_mod.icl_common tcl_file
+ | not ok
+ = abort "convertDynamicPatternsIntoUnifyAppls: error writing tcl file"
+*/
+ // ... TD
# ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics]
#! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols)
= case (pds_module == (-1) || pds_def == (-1)) of
@@ -151,7 +214,7 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_
ci_used_tcs = [],ci_symb_ident = dynamic_temp_symb_ident , ci_sel_type_field = ci_sel_type_field, ci_sel_value_field = ci_sel_value_field })
(groups, new_fun_defs, imported_types, imported_conses, type_heaps, ci_var_heap)
= addNewFunctionsToGroups common_defs ci_fun_heap ci_new_functions main_dcl_module_n groups imported_types [] type_heaps ci_var_heap
- = (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap)
+ = (groups, { fundef \\ fundef <- [ fundef \\ fundef <-: fun_defs ] ++ new_fun_defs }, ci_predef_symb, imported_types, imported_conses, ci_var_heap, type_heaps, ci_expr_heap, tcl_file)
where
convert_groups group_nr groups global_type_instances fun_defs_and_ci
| group_nr == size groups
@@ -980,9 +1043,9 @@ get_constructor glob_type_inst index
instance toString GlobalTCType
where
- toString (GTT_Basic basic_type) = toString basic_type
- toString GTT_Function = " -> "
- toString (GTT_Constructor type_symb_indent) = type_symb_indent.type_name.id_name
+ toString (GTT_Basic basic_type) = toString basic_type
+ toString GTT_Function = " -> "
+ toString (GTT_Constructor type_symb_indent mod_name) = type_symb_indent.type_name.id_name +++ "'" +++ mod_name
instance toString BasicType
where
diff --git a/frontend/frontend.dcl b/frontend/frontend.dcl
index a8720d1..d6c6a15 100644
--- a/frontend/frontend.dcl
+++ b/frontend/frontend.dcl
@@ -22,5 +22,5 @@ import checksupport, transform, overloading
| FrontEndPhaseConvertModules
| FrontEndPhaseAll
-frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*Heaps
- -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File,!*Heaps)
+frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*File !*Heaps
+ -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !*File, !*Heaps)
diff --git a/frontend/frontend.icl b/frontend/frontend.icl
index f70ca43..c4584c3 100644
--- a/frontend/frontend.icl
+++ b/frontend/frontend.icl
@@ -57,7 +57,7 @@ instance == FrontEndPhase where
(==) a b
= equal_constructor a b
-frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions
+frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions
global_fun_range heaps
:== (Yes {
fe_icl = {icl_mod & icl_functions=fun_defs }
@@ -67,15 +67,18 @@ frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_module
, fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions
, fe_globalFunctions = global_fun_range
, fe_arrayInstances = array_instances
- },cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,heaps
+ },cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps
)
-frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*Heaps -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File,!*Heaps)
-frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out heaps
+//frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*File !*Heaps -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File !*File, !*File, !*File, !*Heaps)
+frontEndInterface :: !FrontEndPhase !Ident !SearchPaths !{#DclModule} !{#FunDef} !(Optional Bool) !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File !*File !*Heaps
+ -> ( !Optional *FrontEndSyntaxTree,!.{# FunDef },!Int,!Int,!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !*File, !*Heaps)
+
+frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_macros list_inferred_types predef_symbols hash_table files error io out tcl_file heaps
# (ok, mod, hash_table, error, predef_symbols, files)
= wantModule cWantIclFile mod_ident NoPos (hash_table /* ---> ("Parsing:", mod_ident)*/) error search_paths predef_symbols files
| not ok
- = (No,{},0,0,predef_symbols, hash_table, files, error, io, out,heaps)
+ = (No,{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
# cached_module_idents = [dcl_mod.dcl_name \\ dcl_mod<-:dcl_modules]
# (ok, mod, global_fun_range, mod_functions, optional_dcl_mod, modules, dcl_module_n_in_cache,n_functions_and_macros_in_dcl_modules,hash_table, error, predef_symbols, files)
= scanModule (mod -*-> "Scanning") cached_module_idents (size functions_and_macros) hash_table error search_paths predef_symbols files
@@ -84,14 +87,14 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
# hash_table = remove_icl_symbols_from_hash_table hash_table
/**/
| not ok
- = (No,{},0,0,predef_symbols, hash_table, files, error, io, out,heaps)
+ = (No,{},0,0,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
# symbol_table = hash_table.hte_symbol_heap
(ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions,cached_functions_and_macros,main_dcl_module_n,heaps, predef_symbols, symbol_table, error)
= checkModule mod global_fun_range mod_functions n_functions_and_macros_in_dcl_modules dcl_module_n_in_cache optional_dcl_mod modules dcl_modules functions_and_macros predef_symbols (symbol_table -*-> "Checking") error heaps
hash_table = { hash_table & hte_symbol_heap = symbol_table}
| not ok
- = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, heaps)
+ = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
#! (icl_functions,icl_mod) = select_and_remove_icl_functions_from_record icl_mod
with
@@ -116,13 +119,13 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
array_instances = {ir_from=0, ir_to=0}
| upToPhase == FrontEndPhaseCheck
- = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
+ = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out)
- = typeProgram (components -*-> "Typing") main_dcl_module_n icl_functions icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers heaps predef_symbols error out
+ = typeProgram (components -*-> "Typing") main_dcl_module_n icl_functions icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers heaps predef_symbols error out dcl_mods
| not ok
- = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out,heaps)
+ = (No,{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
# (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials]
// (components, fun_defs, error) = showTypes components 0 fun_defs error
@@ -130,15 +133,17 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
// (fun_defs, error) = showFunctions array_instances fun_defs error
| upToPhase == FrontEndPhaseTypeCheck
- = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
+ = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
- # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap)
+ # (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap, tcl_file)
= convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs main_dcl_module_n (components -*-> "convertDynamics") fun_defs predef_symbols
- heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap
+ heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap tcl_file dcl_mods icl_mod
+// # (components, fun_defs, error) = showComponents3 components 0 False fun_defs error
+// (components, fun_defs, error) = showComponents components 0 True fun_defs error
| upToPhase == FrontEndPhaseConvertDynamics
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap}
- = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
+ = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
// (components, fun_defs, error) = showComponents components 0 True fun_defs error
# (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
@@ -149,7 +154,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
| upToPhase == FrontEndPhaseTransformGroups
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap}
- = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
+ = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule main_dcl_module_n common_defs (dcl_types -*-> "Convert icl") used_conses var_heap type_heaps
# (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule main_dcl_module_n dcl_mods common_defs (dcl_types -*-> "Convert dcl") used_conses var_heap type_heaps
@@ -158,7 +163,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
| upToPhase == FrontEndPhaseConvertModules
# heaps = {hp_var_heap=var_heap, hp_type_heaps=type_heaps, hp_expression_heap=expression_heap}
- = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
+ = frontSyntaxTree cached_functions_and_macros n_functions_and_macros_in_dcl_modules main_dcl_module_n predef_symbols hash_table files error io out tcl_file icl_mod dcl_mods fun_defs components array_instances optional_dcl_icl_conversions global_fun_range heaps
// (components, fun_defs, out) = showComponents components 0 False fun_defs out
# (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
@@ -181,7 +186,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac
, fe_iclDclConversions = build_optional_icl_dcl_conversions (size fun_defs) optional_dcl_icl_conversions
, fe_arrayInstances = array_instances,fe_globalFunctions=global_fun_range
}
- = (Yes fe,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,heaps)
+ = (Yes fe,cached_functions_and_macros,n_functions_and_macros_in_dcl_modules,main_dcl_module_n,predef_symbols,hash_table,files,error,io,out,tcl_file,heaps)
where
build_optional_icl_dcl_conversions :: !Int !(Optional {# Index}) -> Optional {# Index}
build_optional_icl_dcl_conversions size No
diff --git a/frontend/overloading.dcl b/frontend/overloading.dcl
index 4719aa2..71328fd 100644
--- a/frontend/overloading.dcl
+++ b/frontend/overloading.dcl
@@ -36,13 +36,16 @@ import syntax, check, typesupport
:: LocalTypePatternVariable
:: DictionaryTypes :== [(Index, [ExprInfoPtr])]
-tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
+tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState !{# DclModule}
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
:: TypeCodeInfo =
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
+// MV ...
+ , tci_dcl_modules :: !{# DclModule}
+// ... MV
}
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int !*{#FunDef} !*{! FunctionType} !*ExpressionHeap
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index b9fe05d..b27e23a 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -83,7 +83,7 @@ where
where
compare_types (GTT_Basic bt1) (GTT_Basic bt2)
= bt1 =< bt2
- compare_types (GTT_Constructor cons1) (GTT_Constructor cons2)
+ compare_types (GTT_Constructor cons1 _) (GTT_Constructor cons2 _)
= cons1 =< cons2
compare_types _ _
= Equal
@@ -134,16 +134,16 @@ FoundObject object :== object.glob_module <> NotFound
ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound }
reduceContexts :: ![TypeContext] !Int !{# CommonDefs} !ClassInstanceInfo ![TypeContext] !*SpecialInstances ![LocalTypePatternVariable]
- !(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin
+ !(!*VarHeap, !*TypeHeaps) !*Coercions !*PredefinedSymbols !*ErrorAdmin !{# DclModule}
-> *(![ClassApplication], ![TypeContext], !*SpecialInstances, ![LocalTypePatternVariable],
!(!*VarHeap, !*TypeHeaps), !*Coercions, !*PredefinedSymbols, !*ErrorAdmin)
-reduceContexts [] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
+reduceContexts [] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
= ([], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
-reduceContexts [tc : tcs] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
+reduceContexts [tc : tcs] main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
# (appl, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
= try_to_reduce_context tc defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
(appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
- = reduceContexts tcs main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error
+ = reduceContexts tcs main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars heaps coercion_env predef_symbols error dcl_modules
= ([appl : appls], new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
where
@@ -183,7 +183,7 @@ where
= ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, new_contexts,
special_instances, type_pattern_vars, (var_heap, type_heaps), coercion_env, predef_symbols, error)
# (appls, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
- = reduceContexts contexts main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error
+ = reduceContexts contexts main_dcl_module_n defs instance_info new_contexts special_instances type_pattern_vars (var_heap, type_heaps) coercion_env predef_symbols error dcl_modules
(constraints, new_contexts, special_instances, type_pattern_vars, heaps, coercion_env, predef_symbols, error)
= reduce_contexts_in_constraints tc_types class_args class_context defs instance_info new_contexts special_instances type_pattern_vars
heaps coercion_env predef_symbols error
@@ -416,9 +416,13 @@ where
reduce_TC_context type_code_class tc_type new_contexts special_instances type_pattern_vars var_heap
= reduce_tc_context type_code_class tc_type (new_contexts, special_instances, type_pattern_vars, var_heap)
where
- reduce_tc_context type_code_class (TA cons_id cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
+ reduce_tc_context type_code_class (TA cons_id=:{type_index={glob_module}} cons_args) (new_contexts, special_instances=:{si_next_TC_member_index, si_TC_instances}, type_pattern_vars, var_heap)
+// MV ...
+ # defining_module_name
+ = dcl_modules.[glob_module].dcl_name.id_name
+// ... MV
# (inst_index, (si_next_TC_member_index, si_TC_instances))
- = addGlobalTCInstance (GTT_Constructor cons_id) (si_next_TC_member_index, si_TC_instances)
+ = addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (si_next_TC_member_index, si_TC_instances)
(rc_red_contexts, instances) = reduce_TC_contexts type_code_class cons_args
(new_contexts, { special_instances & si_next_TC_member_index = si_next_TC_member_index, si_TC_instances = si_TC_instances }, type_pattern_vars, var_heap)
= (CA_GlobalTypeCode { tci_index = inst_index, tci_contexts = rc_red_contexts }, instances)
@@ -582,9 +586,9 @@ where
:: DictionaryTypes :== [(Index, [ExprInfoPtr])]
-tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState
+tryToSolveOverloading :: ![(Optional [TypeContext], [ExprInfoPtr], IdentPos, Index)] !Int !{# CommonDefs } !ClassInstanceInfo !*Coercions !*OverloadingState !{# DclModule}
-> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], DictionaryTypes, !*OverloadingState)
-tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os
+tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os dcl_modules
# (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os)
| os.os_error.ea_ok
# (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap)
@@ -623,7 +627,7 @@ where
# (class_applications, new_contexts, os_special_instances, type_pattern_vars,
(os_var_heap, os_type_heaps), coercion_env, os_predef_symbols, os_error)
= reduceContexts oc_context main_dcl_module_n defs instance_info new_contexts os_special_instances type_pattern_vars
- (os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error
+ (os_var_heap, os_type_heaps) coercion_env os_predef_symbols os_error dcl_modules
= ([ (oc_symbol, fun_index, over_info_ptr, class_applications) : reduced_calls ], new_contexts, coercion_env, type_pattern_vars,
{ os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap,
os_special_instances = os_special_instances, os_error = os_error, os_predef_symbols = os_predef_symbols })
@@ -1085,15 +1089,22 @@ retrieve_var symb_name var_info_ptr (free_vars, var_heap, rev_variables, error)
{ tci_next_index :: !Index
, tci_instances :: ![GlobalTCInstance]
, tci_type_var_heap :: !.TypeVarHeap
+// MV ...
+ , tci_dcl_modules :: !{# DclModule}
+// ... MV
}
class toTypeCodeExpression type :: !Ident ![Ptr VarInfo] type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin) -> (!TypeCodeExpression, !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin))
instance toTypeCodeExpression Type
where
- toTypeCodeExpression symb_name rev_variables (TA cons_id type_args) (tci=:{tci_next_index,tci_instances},var_heap,error)
+ toTypeCodeExpression symb_name rev_variables (TA cons_id=:{type_index={glob_module}} type_args) (tci=:{tci_next_index,tci_instances,tci_dcl_modules},var_heap,error)
+// MV ...
+ # defining_module_name
+ = tci_dcl_modules.[glob_module].dcl_name.id_name
+// ... MV
# (inst_index, (tci_next_index, tci_instances))
- = addGlobalTCInstance (GTT_Constructor cons_id) (tci_next_index, tci_instances)
+ = addGlobalTCInstance (GTT_Constructor cons_id defining_module_name) (tci_next_index, tci_instances)
(type_code_args, tci) = mapSt (toTypeCodeExpression symb_name rev_variables) type_args ({ tci & tci_next_index = tci_next_index, tci_instances = tci_instances },var_heap,error)
= (TCE_Constructor inst_index type_code_args, tci)
toTypeCodeExpression symb_name rev_variables (TB basic_type) (tci=:{tci_next_index,tci_instances},var_heap,error)
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 3a3b559..9cd098b 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -1118,7 +1118,7 @@ cIsNotStrict :== False
//:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
-:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function
+:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function
/*
:: PatternExpression =
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index ab76d2f..5bd60c8 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -1041,7 +1041,7 @@ cIsNotStrict :== False
:: TypeCodeExpression = TCE_Empty | TCE_Var !VarInfoPtr /* MV */ | TCE_TypeTerm !VarInfoPtr | TCE_Constructor !Index ![TypeCodeExpression] | TCE_Selector ![Selection] !VarInfoPtr
-:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent | GTT_Function
+:: GlobalTCType = GTT_Basic !BasicType | GTT_Constructor !TypeSymbIdent !String | GTT_Function
:: FunctionPattern = FP_Basic !BasicValue !(Optional FreeVar)
| FP_Algebraic !(Global DefinedSymbol) ![FunctionPattern] !(Optional FreeVar)
diff --git a/frontend/type.dcl b/frontend/type.dcl
index 383bfe0..359c3a3 100644
--- a/frontend/type.dcl
+++ b/frontend/type.dcl
@@ -3,7 +3,7 @@ definition module type
import StdArray
import syntax, check
-typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File
+typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule}
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !.TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File)
addPropagationAttributesToAType :: {#CommonDefs} !AType !*PropState -> *(!AType,Int,!*PropState);
diff --git a/frontend/type.icl b/frontend/type.icl
index da6ada5..8680b19 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -1848,9 +1848,9 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con
, fe_location :: !IdentPos
}
-typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File
+typeProgram ::!{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs ![Declaration] !{# DclModule} !NumberSet !*Heaps !*PredefinedSymbols !*File !*File !{# DclModule}
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !.TypeDefInfos, !*Heaps, !*PredefinedSymbols, !*File, !*File)
-typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out
+typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_defs imports modules used_module_numbers heaps=:{hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file out dcl_modules
#! fun_env_size = size fun_defs
# ts_error = {ea_file = file, ea_loc = [], ea_ok = True }
ti_common_defs = {{dcl_common \\ {dcl_common} <-: modules } & [main_dcl_module_n] = icl_defs }
@@ -2009,7 +2009,7 @@ where
{ os_type_heaps, os_var_heap, os_symbol_heap, os_predef_symbols, os_special_instances, os_error })
= tryToSolveOverloading over_info main_dcl_module_n ti_common_defs class_instances coercion_env
{ os_type_heaps = {ts_type_heaps & th_vars = th_vars}, os_var_heap = ts_var_heap, os_symbol_heap = ts_expr_heap,
- os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances }
+ os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } modules
| not os_error.ea_ok
= (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps,
ts_error = { os_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar,
@@ -2031,7 +2031,7 @@ where
| isEmpty over_info
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
- tci_type_var_heap = ts_type_heaps.th_vars }
+ tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
= updateDynamics comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
= ( type_error || not ts_error.ea_ok,
@@ -2040,7 +2040,7 @@ where
ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env})
# ts_type_heaps = ts.ts_type_heaps
type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances,
- tci_type_var_heap = ts_type_heaps.th_vars }
+ tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules }
(fun_defs, ts_fun_env, ts_expr_heap, {tci_next_index,tci_instances,tci_type_var_heap}, ts_var_heap, ts_error, os_predef_symbols)
= removeOverloadedFunctions comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env
ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols
diff --git a/frontend/type_io.dcl b/frontend/type_io.dcl
new file mode 100644
index 0000000..4f208f6
--- /dev/null
+++ b/frontend/type_io.dcl
@@ -0,0 +1,23 @@
+definition module type_io
+
+import scanner, general, Heap, typeproperties, utilities, checksupport
+
+import StdEnv
+
+class WriteTypeInfo a
+where
+ write_type_info :: a !*File -> !*File
+
+instance WriteTypeInfo CommonDefs
+
+//1.3
+instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
+//3.1
+
+// read
+// read
+class ReadTypeInfo a
+where
+ read_type_info :: !*File -> (!Bool,a,!*File)
+
+instance ReadTypeInfo CommonDefs //,TypeDef TypeRhs, ConsDef
diff --git a/frontend/type_io.icl b/frontend/type_io.icl
new file mode 100644
index 0000000..508aa8a
--- /dev/null
+++ b/frontend/type_io.icl
@@ -0,0 +1,797 @@
+implementation module type_io
+
+
+import DebugUtilities;
+
+import StdEnv, compare_constructor // ,RWSDebug
+
+import scanner, general, Heap, typeproperties, utilities, checksupport
+
+class WriteTypeInfo a
+where
+ write_type_info :: a !*File -> !*File
+
+instance WriteTypeInfo CommonDefs
+where
+ write_type_info {com_type_defs,com_cons_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
+
+instance WriteTypeInfo ConsDef
+where
+ write_type_info {cons_symb,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_arg_vars tcl_file
+ # tcl_file
+ = write_type_info cons_priority tcl_file
+
+ # 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
+
+PrioCode =: toChar 0
+NoPrioCode =: toChar 1
+
+instance WriteTypeInfo Priority
+where
+ write_type_info (Prio assoc i) tcl_file
+ # 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
+
+LeftAssocCode =: toChar 2
+RightAssocCode =: toChar 3
+NoAssocCode =: toChar 4
+
+instance WriteTypeInfo Assoc
+where
+ write_type_info LeftAssoc tcl_file
+ # tcl_file
+ = fwritec LeftAssocCode tcl_file
+ = tcl_file
+
+ write_type_info RightAssoc tcl_file
+ # tcl_file
+ = fwritec RightAssocCode tcl_file
+ = tcl_file
+
+ write_type_info NoAssoc tcl_file
+ # tcl_file
+ = fwritec NoAssocCode tcl_file
+ = tcl_file
+
+instance WriteTypeInfo TypeDef TypeRhs
+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
+
+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
+
+instance WriteTypeInfo Annotation
+where
+ write_type_info AN_Strict tcl_file
+ = fwritec '!' tcl_file
+ write_type_info AN_None tcl_file
+ = fwritec ' ' tcl_file
+
+instance WriteTypeInfo TypeVar
+where
+ write_type_info {tv_name} tcl_file
+ = write_type_info tv_name tcl_file
+
+AlgTypeCode =: (toChar 5)
+SynTypeCode =: (toChar 6)
+RecordTypeCode =: (toChar 7)
+AbstractTypeCode =: (toChar 8)
+
+instance WriteTypeInfo TypeRhs
+where
+ write_type_info (AlgType defined_symbols) tcl_file
+ #! tcl_file
+ = fwritec AlgTypeCode tcl_file;
+
+ # tcl_file
+ = write_type_info defined_symbols tcl_file
+
+ = tcl_file
+
+ write_type_info (SynType _) tcl_file
+ #! tcl_file
+ = fwritec SynTypeCode tcl_file;
+
+ // unimplemented
+ = tcl_file
+
+ write_type_info (RecordType {rt_fields}) tcl_file
+ #! tcl_file
+ = fwritec RecordTypeCode tcl_file;
+ = write_type_info rt_fields tcl_file
+
+ write_type_info (AbstractType _) tcl_file
+ #! tcl_file
+ = fwritec AbstractTypeCode tcl_file;
+
+ // unimplemented
+ = tcl_file
+
+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
+
+instance WriteTypeInfo Ident
+where
+ write_type_info {id_name} tcl_file
+// # tcl_file
+// = fwritei (size id_name) tcl_file
+// = fwrites id_name tcl_file
+ = write_type_info id_name tcl_file;
+
+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
+
+// basic and structural write_type_info's
+instance WriteTypeInfo Int
+where
+ write_type_info i tcl_file
+ = fwritei i tcl_file
+
+instance WriteTypeInfo {#b} | select_u, size_u, WriteTypeInfo b
+where
+ write_type_info unboxed_array tcl_file
+ # s_unboxed_array
+ = size unboxed_array
+ # tcl_file
+ = fwritei s_unboxed_array tcl_file
+
+ = write_type_info_loop 0 s_unboxed_array tcl_file
+ where
+ write_type_info_loop i limit tcl_file
+ | i == limit
+ = tcl_file
+ # tcl_file
+ = write_type_info unboxed_array.[i] tcl_file
+ = write_type_info_loop (inc i) limit tcl_file
+
+instance WriteTypeInfo [a] | WriteTypeInfo a
+where
+ write_type_info l tcl_file
+ # tcl_file
+ = fwritei (length l) tcl_file
+ = write_type_info_loop l tcl_file
+ where
+ write_type_info_loop [] tcl_file
+ = tcl_file
+ write_type_info_loop [x:xs] tcl_file
+ # tcl_file
+ = write_type_info x tcl_file
+ = write_type_info_loop xs tcl_file
+
+instance WriteTypeInfo Char
+where
+ write_type_info c tcl_file
+ # tcl_file
+ = fwritec c tcl_file;
+ = tcl_file;
+
+
+// read
+class ReadTypeInfo a
+where
+ read_type_info :: !*File -> (!Bool,a,!*File)
+
+instance ReadTypeInfo CommonDefs
+where
+ read_type_info tcl_file
+ # (ok1,com_type_defs,tcl_file)
+// = (True,{},tcl_file);
+ = read_type_info tcl_file
+ # (ok2,com_cons_defs,tcl_file)
+ = (True,{},tcl_file);
+// = read_type_info tcl_file
+
+ # common_defs
+ = { CommonDefs |
+ com_type_defs = com_type_defs
+ , com_cons_defs = com_cons_defs
+ , com_selector_defs = {}
+ , com_class_defs = {}
+ , com_member_defs = {}
+ , com_instance_defs = {}
+ }
+ = (ok1&&ok2,common_defs,tcl_file)
+
+instance ReadTypeInfo TypeDef TypeRhs
+where
+ read_type_info tcl_file
+
+ // td_name
+ #! (ok1,td_name,tcl_file)
+ = read_type_info tcl_file
+ | F ("TypeDef '" +++ td_name.id_name +++ "'") not ok1
+ = (False,default_elem,tcl_file)
+
+ // td_arity
+ #! (ok2,td_arity,tcl_file)
+ = read_type_info tcl_file
+ | not ok2
+ = (False,default_elem,tcl_file)
+
+ // td_args
+ #! (ok2,td_args,tcl_file)
+ = read_type_info tcl_file
+ | not ok2
+ = (False,default_elem,tcl_file)
+
+ // td_rhs
+ #! (ok2,td_rhs,tcl_file)
+ = read_type_info tcl_file
+ | not ok2
+ = (False,default_elem,tcl_file)
+
+ # type_def
+ = { default_elem &
+ td_name = td_name
+ , td_arity = td_arity
+ , td_args = td_args
+ , td_rhs = td_rhs
+ }
+
+ = (ok1,type_def,tcl_file)
+
+instance ReadTypeInfo TypeRhs
+where
+ read_type_info tcl_file
+ # (ok1,c,tcl_file)
+ = freadc tcl_file
+ | not ok1
+ = (False,default_elem,tcl_file)
+
+ | c == AlgTypeCode
+ # (ok,defined_symbols,tcl_file)
+ = read_type_info tcl_file
+ = (ok,AlgType defined_symbols,tcl_file)
+
+ | c == SynTypeCode
+ = (True,UnknownType,tcl_file)
+ | c == RecordTypeCode
+ = (True,UnknownType,tcl_file)
+ | c == AbstractTypeCode
+ = (True,UnknownType,tcl_file)
+
+instance ReadTypeInfo Priority
+where
+ read_type_info tcl_file
+ # (ok1,p,tcl_file)
+ = freadc tcl_file
+ | not ok1
+ = (False,default_elem,tcl_file)
+
+ | p == PrioCode
+ # (ok1,assoc,tcl_file)
+ = read_type_info tcl_file
+ # (ok2,i,tcl_file)
+ = read_type_info tcl_file
+
+ # prio
+ = Prio assoc i
+ = (ok1&&ok2,prio,tcl_file)
+
+ | p == NoPrioCode
+ = (ok1,NoPrio,tcl_file)
+
+instance ReadTypeInfo Assoc
+where
+ read_type_info tcl_file
+ # (ok1,a,tcl_file)
+ = freadc tcl_file
+ | not ok1
+ = (False,default_elem,tcl_file)
+
+ | a == LeftAssocCode
+ = (ok1,LeftAssoc,tcl_file)
+ | a == RightAssocCode
+ = (ok1,RightAssoc,tcl_file)
+ | a == NoAssocCode
+ = (ok1,NoAssoc,tcl_file)
+
+instance ReadTypeInfo DefinedSymbol
+where
+ read_type_info tcl_file
+ // ds_ident
+ # (ok1,ds_ident,tcl_file)
+ = read_type_info tcl_file
+ | not ok1
+ = (False,default_elem,tcl_file)
+
+ // ds_arity
+ # (ok2,ds_arity,tcl_file)
+ = read_type_info tcl_file
+ | not ok2
+ = (False,default_elem,tcl_file)
+
+ // ds_index
+ # (ok3,ds_index,tcl_file)
+ = read_type_info tcl_file
+
+ # defined_symbol
+ = { default_elem &
+ ds_ident = ds_ident
+ , ds_arity = ds_arity
+ , ds_index = ds_index
+ }
+ = (ok3,defined_symbol,tcl_file)
+
+
+instance ReadTypeInfo ConsDef
+where
+ read_type_info tcl_file
+ # (ok1,cons_symb,tcl_file)
+ = read_type_info tcl_file
+ # (ok2,cons_arg_vars,tcl_file)
+ = read_type_info tcl_file
+ # (ok3,cons_priority,tcl_file)
+ = read_type_info tcl_file
+
+ # (ok4,cons_index,tcl_file)
+ = read_type_info tcl_file
+ # (ok5,cons_type_index,tcl_file)
+ = read_type_info tcl_file
+ # (ok6,cons_exi_vars,tcl_file)
+ = read_type_info tcl_file
+
+ # consdef
+ = { default_elem &
+ cons_symb = cons_symb
+ , cons_arg_vars = cons_arg_vars
+ , cons_priority = cons_priority
+
+ , cons_index = cons_index
+ , cons_type_index = cons_type_index
+ , cons_exi_vars = cons_exi_vars
+ }
+ = (ok1&&ok2&&ok3&&ok4&&ok5&&ok6,consdef,tcl_file)
+
+instance ReadTypeInfo Char
+where
+ read_type_info :: !*File -> (!Bool,Char,!*File)
+ read_type_info tcl_file
+ = freadc1 tcl_file
+ where
+ // Input. The boolean output parameter reports success or failure of the operations.
+
+ freadc1::!*File -> (!Bool,!Char,!*File)
+ /* Reads a character from a text file or a byte from a datafile. */
+ freadc1 f
+ = code {
+ .inline freadc
+ .d 0 2 f
+ jsr readFC
+ .o 0 4 b c f
+ .end
+ }
+/*
+ # (_,i,tcl_file)
+ = freadi tcl_file
+
+ # (q,tcl_file)
+ = freads tcl_file i;
+
+
+ | True
+ = abort ("dkskksdkdsksdkfklsklklsgfdklsdgfklgklklgklgkl " +++ toString q);
+ */
+
+instance ReadTypeInfo Ident
+where
+ read_type_info :: !*File -> (!Bool,Ident,!*File)
+ read_type_info tcl_file
+
+/*
+ # (ok1,id_name,tcl_file)
+ = read_type_info tcl_file
+*/
+ # (ok1,i,tcl_file)
+ = freadi tcl_file
+
+
+ # (id_name,tcl_file)
+ = freads tcl_file i;
+ | F ("Ident " +++ toString i +++ " - " +++ id_name) True
+
+
+
+ # ident
+ = { default_elem &
+ id_name = id_name
+ , id_info = nilPtr
+ }
+ = (ok1,ident,tcl_file)
+
+instance ReadTypeInfo ATypeVar
+where
+ read_type_info tcl_file
+ // atv_annotation
+ # (ok1,atv_annotation,tcl_file)
+ = read_type_info tcl_file
+ | not ok1
+ = (False,default_elem,tcl_file)
+
+ // atv_variable
+ # (ok2,atv_variable,tcl_file)
+ = read_type_info tcl_file
+ | not ok2
+ = (False,default_elem,tcl_file)
+
+ # atypevar
+ = { default_elem &
+ atv_annotation = atv_annotation
+ , atv_variable = atv_variable
+ }
+ = (True,atypevar,tcl_file)
+
+instance ReadTypeInfo TypeVar
+where
+ read_type_info tcl_file
+ # (ok1,tv_name,tcl_file)
+ = read_type_info tcl_file
+
+ # typevar
+ = { default_elem &
+ tv_name = tv_name
+ }
+ = (ok1,typevar,tcl_file)
+
+instance ReadTypeInfo Annotation
+where
+ read_type_info tcl_file
+ #! (ok1,c,tcl_file)
+ = freadc tcl_file
+
+ # annotation
+ = if (c == '!') AN_Strict AN_None
+ = (ok1,annotation,tcl_file)
+
+// basic and structural write_type_info's
+instance ReadTypeInfo Int
+where
+ read_type_info :: !*File -> (!Bool,Int,!*File)
+ read_type_info tcl_file
+ = freadi_new tcl_file
+ where
+ // copy from StdEnv. The only difference is the dot before the Int in the type
+ // of freadi_new.
+ freadi_new ::!*File -> (!Bool,!Int,!*File)
+ /* Reads an integer from a textfile by skipping spaces, tabs and newlines and
+ then reading digits, which may be preceeded by a plus or minus sign.
+ From a datafile freadi will just read four bytes (a Clean Int). */
+ freadi_new f
+ = code {
+ .inline freadi
+ .d 0 2 f
+ jsr readFI
+ .o 0 4 b i f
+ .end
+ }
+
+
+instance ReadTypeInfo {#b} | ReadTypeInfo b & DefaultElem b & ArrayElem b //| DefaultElem, createArray_u, select_u, size_u, update_u, ReadTypeInfo b
+where
+ read_type_info tcl_file
+
+ # (ok,s_unboxed_array,tcl_file)
+ = freadi tcl_file
+ | F ("s_unboxed_array: " +++ toString s_unboxed_array) not ok
+ = (False,{default_elem},tcl_file)
+
+ # unboxed_array
+ = { default_elem \\ i <- [1..s_unboxed_array] }
+ = read_type_info_loop 0 s_unboxed_array tcl_file unboxed_array
+
+ where
+ read_type_info_loop i limit tcl_file unboxed_array
+ | F (" " +++ toString i) i == limit
+ = (True,unboxed_array,tcl_file)
+
+ # (ok,elem,tcl_file)
+ = read_type_info tcl_file
+ | not ok
+ = (False,unboxed_array,tcl_file)
+
+ = read_type_info_loop (inc i) limit tcl_file {unboxed_array & [i] = elem}
+
+
+instance ReadTypeInfo [a] | ReadTypeInfo a
+where
+ read_type_info tcl_file
+ # (ok1,limit,tcl_file)
+ = freadi tcl_file
+ | not ok1
+ = (False,[],tcl_file)
+
+ = read_type_info_loop 0 limit tcl_file []
+ where
+ read_type_info_loop i limit tcl_file elems
+ | i == limit
+ = (True,reverse elems,tcl_file)
+
+ # (ok,elem,tcl_file)
+ = read_type_info tcl_file
+ | not ok
+ = (False,[],tcl_file)
+ = read_type_info_loop (inc i) limit tcl_file [elem:elems]
+
+
+
+
+
+// defaults
+class DefaultElem a
+where
+ default_elem :: a
+
+instance DefaultElem (TypeDef TypeRhs)
+where
+ default_elem
+ = { TypeDef |
+ td_name = default_elem
+ , td_index = default_elem
+ , td_arity = default_elem
+ , td_args = default_elem
+ , td_attrs = default_elem
+ , td_context = default_elem
+ , td_rhs = default_elem
+ , td_attribute = default_elem
+ , td_pos = default_elem
+ }
+
+// = abort "aa";
+
+instance DefaultElem Position
+where
+ default_elem
+ = NoPos
+
+instance DefaultElem TypeAttribute
+where
+ default_elem
+ = TA_None
+
+instance DefaultElem TypeRhs
+where
+ default_elem
+ = UnknownType
+
+instance DefaultElem ATypeVar
+where
+ default_elem
+ = { ATypeVar |
+ atv_attribute = TA_None
+ , atv_annotation = AN_None
+ , atv_variable = default_elem
+ }
+
+instance DefaultElem TypeVar
+where
+// default_elem :: TypeVar
+ default_elem
+ = { TypeVar |
+ tv_name = default_elem
+ , tv_info_ptr = default_elem
+ }
+
+/*
+instance DefaultElem Ptr TypeVarInfo
+where
+ default_elem
+ = nilPtr
+*/
+
+instance DefaultElem (Ptr a) // | DefaultElem a
+where
+ default_elem
+ = nilPtr //default_elem
+
+instance DefaultElem Ident
+where
+ default_elem
+ = { Ident |
+ id_name = {}
+ , id_info = default_elem
+ }
+
+
+instance DefaultElem TypeVarInfo
+where
+ default_elem
+ = TVI_Empty
+
+instance DefaultElem SymbolTableEntry
+where
+ default_elem
+ = { SymbolTableEntry |
+ ste_kind = STE_Empty
+ , ste_index = NoIndex
+ , ste_def_level = NotALevel
+ , ste_previous = abort "instance DefaultElem SymboltableEntry"
+ }
+
+instance DefaultElem [a]
+where
+ default_elem
+ = []
+
+instance DefaultElem Int
+where
+ default_elem
+ = abort "instance DefaultElem Int"
+
+instance DefaultElem DefinedSymbol
+where
+ default_elem
+ = { DefinedSymbol |
+ ds_ident = default_elem
+ , ds_arity = default_elem
+ , ds_index = default_elem
+ }
+
+instance DefaultElem ConsDef
+where
+ default_elem
+ = { ConsDef |
+ cons_symb = default_elem
+ , cons_type = default_elem
+ , cons_arg_vars = default_elem
+ , cons_priority = default_elem
+ , cons_index = default_elem
+ , cons_type_index = default_elem
+ , cons_exi_vars = default_elem
+ , cons_type_ptr = default_elem
+ , cons_pos = default_elem
+ }
+
+instance DefaultElem Priority
+where
+ default_elem
+ = NoPrio
+
+instance DefaultElem SymbolType
+where
+ default_elem
+ = { SymbolType |
+ st_vars = [] //default_elem
+ , st_args = [] //default_elem
+ , st_arity = 0 //default_elem
+ , st_result = default_elem
+ , st_context = [] //default_elem
+ , st_attr_vars = [] //default_elem
+ , st_attr_env = [] //default_elem
+ }
+
+instance DefaultElem VarInfo
+where
+ default_elem
+ = VI_Empty
+
+instance DefaultElem AType
+where
+ default_elem
+ = { AType |
+ at_attribute = default_elem
+ , at_annotation = default_elem
+ , at_type = default_elem
+ }
+
+instance DefaultElem Type
+where
+ default_elem
+ = TE
+
+instance DefaultElem Annotation
+where
+ default_elem
+ = AN_None
+
+instance DefaultElem Assoc
+where
+ default_elem
+ = NoAssoc
+
+
+/*
+instance DefaultElem CommonDefs
+where
+ default_elem
+ = { CommonDefs |
+ com_type_defs = default_elem
+ , com_cons_defs = default_elem
+ , com_selector_defs = undef //default_elem
+ , com_class_defs = undef
+ , com_member_defs = undef
+ , com_instance_defs = undef
+ }
+*/
+
+/*
+instance DefaultElem ClassInstance
+where
+ default_elem
+ = { ClassInstance |
+ ins_class = default_elem
+ , ins_ident = default_elem
+ , ins_type = default_elem
+ , ins_members = default_elem
+ , ins_specials = default_elem
+ , ins_pos = default_elem
+ }
+ */
+
+/*
+instance DefaultElem SelectorDef
+where
+ default_elem
+ = { SelectorDef |
+ sd_symb = default_elem
+ , sd_field = default_elem
+ , sd_type = default_elem
+ , sd_exi_vars = default_elem
+ , sd_field_nr = default_elem
+ , sd_type_index = default_elem
+ , sd_type_ptr = default_elem
+ , sd_pos = default_elem
+ }
+*/
+
+instance DefaultElem {#a} | ArrayElem, DefaultElem a
+where
+ default_elem
+ = {default_elem}
+
+