diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/convertDynamics.dcl | 4 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 77 | ||||
| -rw-r--r-- | frontend/frontend.dcl | 4 | ||||
| -rw-r--r-- | frontend/frontend.icl | 39 | ||||
| -rw-r--r-- | frontend/overloading.dcl | 5 | ||||
| -rw-r--r-- | frontend/overloading.icl | 37 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 | ||||
| -rw-r--r-- | frontend/type.dcl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 10 | ||||
| -rw-r--r-- | frontend/type_io.dcl | 23 | ||||
| -rw-r--r-- | frontend/type_io.icl | 797 |
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} + + |