diff options
| -rw-r--r-- | frontend/analtypes.icl | 5 | ||||
| -rw-r--r-- | frontend/analunitypes.icl | 12 | ||||
| -rw-r--r-- | frontend/check.dcl | 2 | ||||
| -rw-r--r-- | frontend/check.icl | 38 | ||||
| -rw-r--r-- | frontend/frontend.icl | 10 | ||||
| -rw-r--r-- | frontend/overloading.icl | 2 | ||||
| -rw-r--r-- | frontend/postparse.dcl | 2 | ||||
| -rw-r--r-- | frontend/postparse.icl | 479 | ||||
| -rw-r--r-- | frontend/predef.dcl | 4 | ||||
| -rw-r--r-- | frontend/predef.icl | 5 | ||||
| -rw-r--r-- | frontend/refmark.icl | 2 | ||||
| -rw-r--r-- | frontend/type.icl | 134 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 24 |
14 files changed, 364 insertions, 357 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index 19de6f5..b143d0b 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -309,7 +309,8 @@ analTypeDef modules type_module type_index as=:{as_error,as_heaps,as_kind_heap,a | is_abs_type # (tdi, as_td_infos) = as_td_infos![type_module].[type_index] tdi = { tdi & tdi_kinds = [ KindConst \\ _ <- td_args ], tdi_group = [{glob_module = type_module, glob_object = type_index}], - tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = abs_type_properties } + tdi_group_vars = [ i \\ _ <- td_args & i <- [0..]], tdi_properties = abs_type_properties, + tdi_tmp_index = 0 } = (cMAXINT, ({con_top_var_binds = [], con_var_binds = [] }, { as & as_td_infos = { as_td_infos & [type_module].[type_index] = tdi}})) # position = newPosition td_name td_pos as_error = pushErrorAdmin position as_error @@ -429,7 +430,7 @@ where = (kind_store, kind_heap, { td_infos & [glob_module].[glob_object] = {td_info & tdi_properties = type_properties, tdi_kinds = td_kinds, tdi_group = group, tdi_group_vars = group_vars, tdi_cons_vars = cons_vars, tdi_group_nr = group_nr, tdi_tmp_index = loc_type_index } }) -// ---> ("update_type_def_info", glob_module, glob_object, group_nr) +// ---> ("update_type_def_info", glob_module, glob_object, (group_nr, loc_type_index)) where determine_type_def_info [ KindVar kind_info_ptr : kind_vars ] [ kind : kinds ] top_vars kind_store kind_heap #! kind_info = sreadPtr kind_info_ptr kind_heap diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl index 05e8994..cbe99cf 100644 --- a/frontend/analunitypes.icl +++ b/frontend/analunitypes.icl @@ -30,7 +30,7 @@ typeProperties type_index module_index hio_signs hio_props defs type_var_heap td (tsp_propagation, type_var_heap, td_infos) = determinePropClassOfTypeDef type_index module_index td_args td_info hio_props defs type_var_heap td_infos tsp_coercible = (td_info.tdi_properties bitand cIsNonCoercible) == 0 = ({tsp_sign = tsp_sign, tsp_propagation = tsp_propagation, tsp_coercible = tsp_coercible }, type_var_heap, td_infos) - ---> ("typeProperties", (td_name, type_index, module_index), tsp_sign, tsp_propagation) +// ---> ("typeProperties", (td_name, type_index, module_index), tsp_sign, tsp_propagation) signClassification :: !Index !Index ![SignClassification] !{# CommonDefs } !*TypeVarHeap !*TypeDefInfos -> (!SignClassification, !*TypeVarHeap, !*TypeDefInfos) @@ -72,6 +72,7 @@ determineSignClassOfTypeDef type_index module_index td_args {tdi_classification, No # signs_of_group_vars = foldSt (determine_signs_of_group_var tdi_cons_vars hio_signs) tdi_group_vars [] -> newSignClassOfTypeDefGroup tdi_group_nr { glob_module = module_index, glob_object = type_index} +// tdi_group (signs_of_group_vars ---> ("determine_signs_of_group_var", (module_index, type_index), signs_of_group_vars, tdi_group_vars)) ci type_var_heap td_infos tdi_group signs_of_group_vars ci type_var_heap td_infos where @@ -132,6 +133,7 @@ where collect_sign_class_of_type_def group_nr signs_of_group_vars ci {glob_module,glob_object} (sign_requirements, type_var_heap, td_infos) # ({tdi_group_vars,tdi_kinds,tdi_tmp_index},td_infos) = td_infos![glob_module].[glob_object] {td_name,td_args,td_rhs} = ci.[glob_module].com_type_defs.[glob_object] +// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, (glob_module, glob_object), tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap) (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args tdi_group_vars tdi_kinds signs_of_group_vars ([], type_var_heap) (sign_env, scs) = sign_class_of_type_def glob_module td_rhs group_nr ci {scs_type_var_heap = type_var_heap, scs_type_def_infos = td_infos, scs_rec_appls = [] } @@ -177,6 +179,8 @@ where | this_gv == gv = sign = retrieve_sign this_gv signs + retrieve_sign this_gv [ ] + = TopSignClass restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap # (TVI_SignClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap @@ -426,10 +430,12 @@ where = bind_type_vars_to_props tvs gvs tks props_of_group_vars ([prop:rev_hio_props], type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info)) = bind_type_vars_to_props tvs gvs tks props_of_group_vars (rev_hio_props, type_var_heap <:= (tv_info_ptr, TVI_PropClass gv prop var_info)) where - retrieve_prop this_gv [(gv,prop) : signs ] + retrieve_prop this_gv [(gv,prop) : props ] | this_gv == gv = prop - = retrieve_prop this_gv signs + = retrieve_prop this_gv props + retrieve_prop this_gv [ ] + = PropClass restore_binds_of_type_var {atv_variable={tv_info_ptr}} type_var_heap # (TVI_PropClass _ _ old_info, type_var_heap) = readPtr tv_info_ptr type_var_heap diff --git a/frontend/check.dcl b/frontend/check.dcl index 6f1c234..3c13324 100644 --- a/frontend/check.dcl +++ b/frontend/check.dcl @@ -4,7 +4,7 @@ import syntax, transform, checksupport, typesupport, predef cPredefinedModuleIndex :== 1 -checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File +checkModule :: !ScannedModule !IndexRange ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) retrieveGlobalDefinition :: !SymbolTableEntry !STE_Kind !Index -> (!Index, !Index) diff --git a/frontend/check.icl b/frontend/check.icl index cf25ab2..886b2bd 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -7,6 +7,10 @@ import explicitimports, comparedefimp cPredefinedModuleIndex :== 1 +isMainModule :: ModuleKind -> Bool +isMainModule MK_Main = True +isMainModule _ = False + convertIndex :: !Index !Index !(Optional ConversionTable) -> !Index convertIndex index table_index (Yes tables) = tables.[table_index].[index] @@ -2571,9 +2575,9 @@ where (<=<) state fun :== fun state -checkModule :: !ScannedModule !Int ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File +checkModule :: !ScannedModule !IndexRange ![FunDef] !ScannedModule !ScannedModule ![ScannedModule] !*PredefinedSymbols !*SymbolTable !*File -> (!Bool, !*IclModule, *{# DclModule}, *{! Group}, !(Optional {# Index}), !*Heaps, !*PredefinedSymbols, !*SymbolTable, *File) -checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} nr_of_global_funs fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file +checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs} icl_global_function_range fun_defs dcl_mod pre_def_mod scanned_modules predef_symbols symbol_table err_file # error = {ea_file = err_file, ea_loc = [], ea_ok = True } first_inst_index = length fun_defs @@ -2584,7 +2588,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs #! nr_of_functions = size icl_functions # sizes_and_local_defs = collectCommonfinitions cdefs - (icl_functions, sizes_and_local_defs) = collectGlobalFunctions cFunctionDefs 0 nr_of_global_funs icl_functions sizes_and_local_defs + (icl_functions, sizes_and_local_defs) = collectGlobalFunctions cFunctionDefs icl_global_function_range.ir_from icl_global_function_range.ir_to icl_functions sizes_and_local_defs (icl_functions, (sizes, local_defs)) = collectMacros cdefs.def_macros icl_functions sizes_and_local_defs (scanned_modules, icl_functions, cs) @@ -2635,8 +2639,9 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs ef_is_macro_fun = False } (icl_functions, e_info, heaps, cs) = checkMacros cIclModIndex cdefs.def_macros icl_functions e_info heaps cs - (icl_functions, e_info, heaps, cs) = checkFunctions cIclModIndex cGlobalScope 0 nr_of_global_funs icl_functions e_info heaps cs + (icl_functions, e_info, heaps, cs) = checkFunctions cIclModIndex cGlobalScope icl_global_function_range.ir_from icl_global_function_range.ir_to icl_functions e_info heaps cs + cs = check_start_rule mod_type icl_global_function_range cs cs = check_needed_modules_are_imported mod_name ".icl" cs (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error}) @@ -2648,7 +2653,6 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (spec_functions, dcl_modules, class_instances, icl_functions, new_nr_of_functions, dcl_icl_conversions, var_heap, th_vars, expr_heap) = collect_specialized_functions_in_dcl_module dcl_modules icl_common.com_instance_defs icl_functions nr_of_functions hp_var_heap th_vars hp_expression_heap - icl_global_function_range = {ir_from = 0, ir_to = nr_of_global_funs} icl_instances = {ir_from = first_inst_index, ir_to = nr_of_functions} icl_specials = {ir_from = nr_of_functions, ir_to = new_nr_of_functions} icl_functions = copy_instance_types instance_types { icl_fun \\ icl_fun <- [ icl_fun \\ icl_fun <-: icl_functions ] ++ spec_functions } @@ -2656,7 +2660,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (dcl_modules, class_instances, icl_functions, cs_predef_symbols) = adjust_instance_types_of_array_functions_in_std_array_icl dcl_modules class_instances icl_functions cs_predef_symbols - (untransformed_macro_funs_defs, icl_functions) = memcpy {ir_from = nr_of_global_funs, ir_to = first_inst_index } icl_functions + (untransformed_macro_funs_defs, icl_functions) = memcpy cdefs.def_macros icl_functions (groups, icl_functions, dcl_modules, var_heap, expr_heap, cs_symbol_table, cs_error) = partitionateAndLiftFunctions [icl_global_function_range, icl_instances] cIclModIndex icl_functions dcl_modules var_heap expr_heap cs_symbol_table cs_error @@ -2668,9 +2672,10 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs heaps = { heaps & hp_var_heap = var_heap, hp_expression_heap = expr_heap, hp_type_heaps = {hp_type_heaps & th_vars = th_vars}} +/* RWS (dcl_modules, icl_mod, heaps, cs_error) - = compareDefImp (nr_of_global_funs, untransformed_macro_funs_defs) dcl_modules icl_mod heaps cs_error - + = compareDefImp (cdefs.def_macros.ir_from, untransformed_macro_funs_defs) dcl_modules icl_mod heaps cs_error +*/ = (cs_error.ea_ok, icl_mod, dcl_modules, groups, dcl_icl_conversions, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) # icl_common = { icl_common & com_type_defs = e_info.ef_type_defs, com_selector_defs = e_info.ef_selector_defs, com_class_defs = e_info.ef_class_defs, com_cons_defs = e_info.ef_cons_defs, com_member_defs = e_info.ef_member_defs } @@ -2681,6 +2686,23 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs icl_declared = {dcls_local = local_defs, dcls_import = icl_imported, dcls_explicit = dcls_explicit} } = (False, icl_mod, dcl_modules, {}, No, heaps, cs_predef_symbols, cs_symbol_table, cs_error.ea_file) where + check_start_rule mod_kind {ir_from, ir_to} cs=:{cs_predef_symbols,cs_symbol_table} + # (pre_symb, cs_predef_symbols) = cs_predef_symbols![PD_Start] + ({ste_kind, ste_index}, cs_symbol_table) = readPtr pre_symb.pds_ident.id_info cs_symbol_table + cs = { cs & cs_predef_symbols = cs_predef_symbols, cs_symbol_table = cs_symbol_table } + = case ste_kind of + STE_FunctionOrMacro _ + | ir_from <= ste_index && ste_index < ir_to + -> { cs & cs_predef_symbols = { cs.cs_predef_symbols & [PD_Start] = { pre_symb & pds_def = ste_index, pds_module = cIclModIndex }}} + STE_Imported STE_DclFunction mod_index + -> { cs & cs_predef_symbols = { cs.cs_predef_symbols & [PD_Start] = { pre_symb & pds_def = ste_index, pds_module = mod_index }}} + _ + -> case mod_kind of + MK_Main + -> { cs & cs_error = checkError "Start" " function not defined" cs.cs_error } + _ + -> cs + convert_class_instances [pi=:{pi_members} : pins] next_fun_index # ins_members = sort pi_members (member_symbols, next_fun_index) = determine_indexes_of_members ins_members next_fun_index diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 6638dda..a5a9b46 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -21,16 +21,16 @@ import RWSDebug frontEndInterface :: !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree) frontEndInterface mod_ident search_paths predef_symbols hash_table files error io out # (ok, mod, hash_table, error, predef_symbols, files) - = wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) error search_paths predef_symbols files + = wantModule cWantIclFile mod_ident (hash_table -*-> ("Parsing:", mod_ident)) error search_paths predef_symbols files | not ok = (predef_symbols, hash_table, files, error, io, out, No) - # (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, error, predef_symbols, files) + # (ok, mod, global_fun_range, mod_functions, dcl_mod, predef_mod, modules, hash_table, error, predef_symbols, files) = scanModule (mod -*-> "Scanning") hash_table error search_paths predef_symbols files | not ok = (predef_symbols, hash_table, files, error, io, out, No) # symbol_table = hash_table.hte_symbol_heap (ok, icl_mod, dcl_mods, components, optional_dcl_icl_conversions, heaps, predef_symbols, symbol_table, error) - = checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table -*-> "Checking") error + = checkModule mod global_fun_range mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table -*-> "Checking") error hash_table = { hash_table & hte_symbol_heap = symbol_table} | not ok = (predef_symbols, hash_table, files, error, io, out, No) @@ -41,7 +41,7 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i | not ok = (predef_symbols, hash_table, files, error, io, out, No) - # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials] + # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials] // (components, fun_defs, error) = showTypes components 0 fun_defs error // (components, fun_defs, error) = showComponents components 0 True fun_defs error // (fun_defs, error) = showFunctions array_instances fun_defs error @@ -62,7 +62,7 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i var_heap type_heaps expression_heap (dcl_types, type_heaps, var_heap) = convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap - (components, fun_defs, out) = showComponents components 0 False fun_defs out +// (components, fun_defs, out) = showComponents components 0 False fun_defs out = (predef_symbols,hash_table,files,error,io,out, Yes { fe_icl = {icl_mod & icl_functions=fun_defs } diff --git a/frontend/overloading.icl b/frontend/overloading.icl index fa12fe9..85bb801 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -675,7 +675,7 @@ where convert_reduced_context_to_expression defs contexts {rc_class, rc_inst_module, rc_inst_members, rc_red_contexts, rc_types} dictionary_args heaps # (expressions, heaps) = convertClassApplsToExpressions defs contexts rc_red_contexts heaps context_size = length expressions - | size rc_inst_members > 1 && context_size > 0 + | False // RWS test size rc_inst_members > 1 && context_size > 0 # (let_binds, let_types, rev_dicts, hp_var_heap, hp_expression_heap) = foldSt (bind_shared_dictionary (size rc_inst_members)) expressions ([], [], [], heaps.hp_var_heap, heaps.hp_expression_heap) dictionary_args = build_class_members (size rc_inst_members) rc_inst_members rc_inst_module (reverse rev_dicts) context_size dictionary_args diff --git a/frontend/postparse.dcl b/frontend/postparse.dcl index b8778aa..9e5f2a1 100644 --- a/frontend/postparse.dcl +++ b/frontend/postparse.dcl @@ -5,4 +5,4 @@ import StdEnv import syntax, parse, predef scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files - -> (!Bool, !ScannedModule, !Int, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) + -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) diff --git a/frontend/postparse.icl b/frontend/postparse.icl index c401606..19bfb35 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -8,6 +8,15 @@ import RWSDebug **/ +:: *CollectAdmin = + { ca_error :: !*ParseErrorAdmin + , ca_fun_count :: !Int + , ca_rev_fun_defs :: ![FunDef] + , ca_predefs :: !PredefinedIdents + , ca_u_predefs :: !*PredefinedSymbols + , ca_hash_table :: !*HashTable + } + cIsAGlobalDef :== True cIsNotAGlobalDef :== False @@ -40,9 +49,7 @@ exprToRhs expr { ewl_nodes = [] , ewl_expr = expr , ewl_locals = LocalParsedDefs [] -// , ewl_locals = CollectedLocalDefs {loc_functions = {ir_from=0,ir_to=0}, loc_nodes=[] } } -// , rhs_locals = CollectedLocalDefs {loc_functions = {ir_from=0,ir_to=0}, loc_nodes=[] } , rhs_locals = LocalParsedDefs [] } @@ -96,45 +103,52 @@ where get_file_and_line_nr (LinePos filename linenr) = (filename, linenr, No) -:: *CollectAdmin = - { ca_error :: !ParseErrorAdmin - , ca_fun_count :: !Int - , ca_predefs :: !PredefinedIdents - , ca_hash_table :: !*HashTable - } - -class collectFunctions a :: a !CollectAdmin -> (a, ![FunDef], !CollectAdmin) +class collectFunctions a :: a !*CollectAdmin -> (a, !*CollectAdmin) + +addFunctionsRange :: [FunDef] *CollectAdmin -> (IndexRange, *CollectAdmin) +addFunctionsRange fun_defs ca + # (frm, ca) + = ca!ca_fun_count + ca + = foldSt add_function fun_defs ca + (to, ca) + = ca!ca_fun_count + = ({ir_from = frm, ir_to = to}, ca) + where + add_function :: FunDef !*CollectAdmin -> !*CollectAdmin + add_function fun_def ca=:{ca_fun_count, ca_rev_fun_defs} + = {ca & ca_fun_count = ca.ca_fun_count + 1 + , ca_rev_fun_defs = [fun_def : ca.ca_rev_fun_defs] + } instance collectFunctions ParsedExpr where collectFunctions (PE_List exprs) ca - # (exprs, fun_defs, ca) = collectFunctions exprs ca - = (PE_List exprs, fun_defs, ca) + # (exprs, ca) = collectFunctions exprs ca + = (PE_List exprs, ca) collectFunctions (PE_Bound bound_expr) ca - # (bound_expr, fun_defs, ca) = collectFunctions bound_expr ca - = (PE_Bound bound_expr, fun_defs, ca) + # (bound_expr, ca) = collectFunctions bound_expr ca + = (PE_Bound bound_expr, ca) collectFunctions (PE_Lambda lam_ident args res) ca - # fun_count = ca.ca_fun_count - next_fun_count = inc fun_count - ((args,res), fun_defs, ca) = collectFunctions (args,res) {ca & ca_fun_count = next_fun_count} - fun_def = transformLambda lam_ident args res - = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = { ir_from = fun_count, ir_to = next_fun_count }, loc_nodes = [] }) - (PE_Ident lam_ident), [fun_def : fun_defs], ca) + # ((args,res), ca) = collectFunctions (args,res) ca + # (range, ca) = addFunctionsRange [transformLambda lam_ident args res] ca + = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = range, loc_nodes = [] }) + (PE_Ident lam_ident), ca) collectFunctions (PE_Record rec_expr type_name fields) ca - # ((rec_expr,fields), fun_defs, ca) = collectFunctions (rec_expr,fields) ca - = (PE_Record rec_expr type_name fields, fun_defs, ca) + # ((rec_expr,fields), ca) = collectFunctions (rec_expr,fields) ca + = (PE_Record rec_expr type_name fields, ca) collectFunctions (PE_Tuple exprs) ca - # (exprs, fun_defs, ca) = collectFunctions exprs ca - = (PE_Tuple exprs, fun_defs, ca) + # (exprs, ca) = collectFunctions exprs ca + = (PE_Tuple exprs, ca) collectFunctions (PE_Selection is_unique expr selectors) ca - # ((expr, selectors), fun_defs, ca) = collectFunctions (expr, selectors) ca - = (PE_Selection is_unique expr selectors, fun_defs, ca) + # ((expr, selectors), ca) = collectFunctions (expr, selectors) ca + = (PE_Selection is_unique expr selectors, ca) collectFunctions (PE_Update expr1 updates expr2) ca - # ((expr1, (updates, expr2)), fun_defs, ca) = collectFunctions (expr1, (updates, expr2)) ca - = (PE_Update expr1 updates expr2, fun_defs, ca) + # ((expr1, (updates, expr2)), ca) = collectFunctions (expr1, (updates, expr2)) ca + = (PE_Update expr1 updates expr2, ca) collectFunctions (PE_Case case_ident pattern_expr case_alts) ca - # ((pattern_expr,case_alts), fun_defs, ca) = collectFunctions (pattern_expr,case_alts) ca - = (PE_Case case_ident pattern_expr case_alts, fun_defs, ca) + # ((pattern_expr,case_alts), ca) = collectFunctions (pattern_expr,case_alts) ca + = (PE_Case case_ident pattern_expr case_alts, ca) collectFunctions (PE_If if_ident c t e) ca # true_pattern = PE_Basic (BVB True) false_pattern = PE_WildCard // PE_Basic (BVB False) @@ -143,8 +157,8 @@ where , {calt_pattern = false_pattern, calt_rhs = exprToRhs e} ]) ca collectFunctions (PE_Let strict locals in_expr) ca - # ((node_defs,in_expr), fun_defs, ca) = collectFunctions (locals,in_expr) ca - = (PE_Let strict node_defs in_expr, fun_defs, ca) + # ((node_defs,in_expr), ca) = collectFunctions (locals,in_expr) ca + = (PE_Let strict node_defs in_expr, ca) collectFunctions (PE_Compr gen_kind expr qualifiers) ca # (compr, ca) = transformComprehension gen_kind expr qualifiers ca @@ -158,152 +172,128 @@ where collectFunctions (PE_ArrayDenot exprs) ca=:{ca_predefs} = collectFunctions (transformArrayDenot exprs ca_predefs) ca collectFunctions expr ca - = (expr, [], ca) + = (expr, ca) instance collectFunctions [a] | collectFunctions a where - collectFunctions [x:xs] ca - # (x, fun_defs_in_x, ca) = collectFunctions x ca - (xs, fun_defs_in_xs, ca) = collectFunctions xs ca - = ([x:xs], fun_defs_in_x ++ fun_defs_in_xs, ca) - collectFunctions [] ca - = ([], [], ca) + collectFunctions l ca + = mapSt collectFunctions l ca instance collectFunctions (a,b) | collectFunctions a & collectFunctions b where collectFunctions (x,y) ca - # (x, fun_defs_in_x, ca) = collectFunctions x ca - (y, fun_defs_in_y, ca) = collectFunctions y ca - = ((x,y), fun_defs_in_x ++ fun_defs_in_y, ca) + # (x, ca) = collectFunctions x ca + (y, ca) = collectFunctions y ca + = ((x,y), ca) instance collectFunctions Qualifier where collectFunctions qual=:{qual_generators, qual_filter} ca - # ((qual_generators, qual_filter), fun_defs, ca) = collectFunctions (qual_generators, qual_filter) ca - = ({ qual & qual_generators = qual_generators, qual_filter = qual_filter }, fun_defs, ca) + # ((qual_generators, qual_filter), ca) = collectFunctions (qual_generators, qual_filter) ca + = ({ qual & qual_generators = qual_generators, qual_filter = qual_filter }, ca) instance collectFunctions Generator where collectFunctions gen=:{gen_pattern,gen_expr} ca - # ((gen_pattern,gen_expr), fun_defs, ca) = collectFunctions (gen_pattern,gen_expr) ca - = ({gen & gen_pattern = gen_pattern, gen_expr = gen_expr}, fun_defs, ca) - + # ((gen_pattern,gen_expr), ca) = collectFunctions (gen_pattern,gen_expr) ca + = ({gen & gen_pattern = gen_pattern, gen_expr = gen_expr}, ca) instance collectFunctions (Optional a) | collectFunctions a where collectFunctions (Yes expr) ca - # (expr, fun_defs, ca) = collectFunctions expr ca - = (Yes expr, fun_defs, ca) + # (expr, ca) = collectFunctions expr ca + = (Yes expr, ca) collectFunctions No ca - = (No, [], ca) + = (No, ca) instance collectFunctions ParsedSelection where collectFunctions (PS_Array index_expr) ca - # (index_expr, fun_defs, ca) = collectFunctions index_expr ca - = (PS_Array index_expr, fun_defs, ca) + # (index_expr, ca) = collectFunctions index_expr ca + = (PS_Array index_expr, ca) collectFunctions expr ca - = (expr, [], ca) + = (expr, ca) instance collectFunctions CaseAlt where collectFunctions calt=:{calt_pattern,calt_rhs} ca -// MW why not # (calt_rhs, fun_defs, ca) = collectFunctions calt_rhs ca - # ((calt_pattern,calt_rhs), fun_defs, ca) = collectFunctions (calt_pattern,calt_rhs) ca - = ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, fun_defs, ca) - - -instance collectFunctions Sequence -where - collectFunctions (SQ_FromThen from_expr then_expr) ca - # ((from_expr,then_expr), fun_defs, ca) = collectFunctions (from_expr,then_expr) ca - = (SQ_FromThen from_expr then_expr, fun_defs, ca) - collectFunctions (SQ_FromThenTo from_expr then_expr to_expr) ca - # ((from_expr,(then_expr,to_expr)), fun_defs, ca) = collectFunctions (from_expr,(then_expr,to_expr)) ca - = (SQ_FromThenTo from_expr then_expr to_expr, fun_defs, ca) - collectFunctions (SQ_FromTo from_expr to_expr) ca - # ((from_expr,to_expr), fun_defs, ca) = collectFunctions (from_expr,to_expr) ca - = (SQ_FromTo from_expr to_expr, fun_defs, ca) - collectFunctions (SQ_From from_expr) ca - # (from_expr, fun_defs, ca) = collectFunctions from_expr ca - = (SQ_From from_expr, fun_defs, ca) + # ((calt_pattern,calt_rhs), ca) = collectFunctions (calt_pattern,calt_rhs) ca + = ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, ca) instance collectFunctions (Bind a b) | collectFunctions a & collectFunctions b where collectFunctions bind=:{bind_src,bind_dst} ca - # ((bind_src,bind_dst), fun_defs, ca) = collectFunctions (bind_src,bind_dst) ca - = ({ bind_src = bind_src, bind_dst = bind_dst }, fun_defs, ca) + # ((bind_src,bind_dst), ca) = collectFunctions (bind_src,bind_dst) ca + = ({bind & bind_src = bind_src, bind_dst = bind_dst }, ca) instance collectFunctions OptGuardedAlts where collectFunctions (GuardedAlts guarded_exprs (Yes def_expr)) ca - # ((guarded_exprs, def_expr), fun_defs, ca) = collectFunctions (guarded_exprs, def_expr) ca - = (GuardedAlts guarded_exprs (Yes def_expr), fun_defs, ca) + # ((guarded_exprs, def_expr), ca) = collectFunctions (guarded_exprs, def_expr) ca + = (GuardedAlts guarded_exprs (Yes def_expr), ca) collectFunctions (GuardedAlts guarded_exprs No) ca - # (guarded_exprs, fun_defs, ca) = collectFunctions guarded_exprs ca - = (GuardedAlts guarded_exprs No, fun_defs, ca) + # (guarded_exprs, ca) = collectFunctions guarded_exprs ca + = (GuardedAlts guarded_exprs No, ca) collectFunctions (UnGuardedExpr unguarded_expr) ca - # (unguarded_expr, fun_defs, ca) = collectFunctions unguarded_expr ca - = (UnGuardedExpr unguarded_expr, fun_defs, ca) + # (unguarded_expr, ca) = collectFunctions unguarded_expr ca + = (UnGuardedExpr unguarded_expr, ca) instance collectFunctions GuardedExpr where collectFunctions alt=:{alt_nodes,alt_guard,alt_expr} ca - # ((alt_nodes, (alt_guard, alt_expr)), fun_defs, ca) = + # ((alt_nodes, (alt_guard, alt_expr)), ca) = collectFunctions (alt_nodes, (alt_guard, alt_expr)) ca - = ({alt & alt_nodes = alt_nodes, alt_guard = alt_guard, alt_expr = alt_expr}, fun_defs, ca) + = ({alt & alt_nodes = alt_nodes, alt_guard = alt_guard, alt_expr = alt_expr}, ca) instance collectFunctions ExprWithLocalDefs where collectFunctions expr=:{ewl_nodes, ewl_expr,ewl_locals} ca - # ((ewl_nodes, (ewl_expr, ewl_locals)), fun_defs, ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) ca - = ({expr & ewl_nodes = ewl_nodes, ewl_expr = ewl_expr, ewl_locals = ewl_locals}, fun_defs, ca) + # ((ewl_nodes, (ewl_expr, ewl_locals)), ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) ca + = ({expr & ewl_nodes = ewl_nodes, ewl_expr = ewl_expr, ewl_locals = ewl_locals}, ca) instance collectFunctions NodeDefWithLocals where collectFunctions node_def=:{ndwl_def, ndwl_locals} ca - # (( ndwl_def, ndwl_locals), fun_defs, ca) = collectFunctions (ndwl_def, ndwl_locals) ca - = ({node_def & ndwl_def = ndwl_def, ndwl_locals = ndwl_locals}, fun_defs, ca) + # (( ndwl_def, ndwl_locals), ca) = collectFunctions (ndwl_def, ndwl_locals) ca + = ({node_def & ndwl_def = ndwl_def, ndwl_locals = ndwl_locals}, ca) instance collectFunctions Rhs where collectFunctions {rhs_alts, rhs_locals} ca - # ((rhs_alts, rhs_locals), fun_defs, ca) = collectFunctions (rhs_alts, rhs_locals) ca - = ({rhs_alts = rhs_alts, rhs_locals = rhs_locals}, fun_defs, ca) + # ((rhs_alts, rhs_locals), ca) = collectFunctions (rhs_alts, rhs_locals) ca + = ({rhs_alts = rhs_alts, rhs_locals = rhs_locals}, ca) instance collectFunctions LocalDefs where collectFunctions (LocalParsedDefs locals) ca - # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions locals ca - ir_from = ca.ca_fun_count - ir_to = ca.ca_fun_count + length fun_defs - (node_defs, fun_defs_in_node_defs, ca) = collect_functions_in_node_defs node_defs {ca & ca_fun_count = ir_to} - (fun_defs, collected_fun_defs, ca) = reorganizeLocalDefinitionsOfFunctions fun_defs ca - = (CollectedLocalDefs { loc_functions = { ir_from = ir_from, ir_to = ir_to }, loc_nodes = node_defs }, - fun_defs ++ fun_defs_in_node_defs ++ collected_fun_defs, ca) + # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions locals ca + (node_defs, ca) = collect_functions_in_node_defs node_defs ca + (fun_defs, ca) = collectFunctions fun_defs ca + (range, ca) = addFunctionsRange fun_defs ca + = (CollectedLocalDefs { loc_functions = range, loc_nodes = node_defs }, ca) where - collect_functions_in_node_defs :: [(Optional SymbolType,NodeDef ParsedExpr)] *CollectAdmin -> ([(Optional SymbolType,NodeDef ParsedExpr)],[FunDef],*CollectAdmin) + collect_functions_in_node_defs :: [(Optional SymbolType,NodeDef ParsedExpr)] *CollectAdmin -> ([(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) collect_functions_in_node_defs [ (node_def_type, bind) : node_defs ] ca - # (bind, fun_defs_in_bind, ca) = collectFunctions bind ca - (node_defs, fun_defs_in_node_defs, ca) = collect_functions_in_node_defs node_defs ca - = ([(node_def_type, bind):node_defs], fun_defs_in_bind ++ fun_defs_in_node_defs, ca) + # (bind, ca) = collectFunctions bind ca + (node_defs, ca) = collect_functions_in_node_defs node_defs ca + = ([(node_def_type, bind):node_defs], ca) collect_functions_in_node_defs [] ca - = ([], [], ca) + = ([], ca) // RWS ... +++ remove recollection collectFunctions locals ca - = (locals, [], ca) + = (locals, ca) // ... RWS instance collectFunctions (NodeDef a) | collectFunctions a where collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} ca - # ((nd_dst,(nd_alts,nd_locals)), fun_defs, ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca - = ({ node_def & nd_dst = nd_dst, nd_alts = nd_alts, nd_locals = nd_locals }, fun_defs, ca) - + # ((nd_dst,(nd_alts,nd_locals)), ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca + = ({ node_def & nd_dst = nd_dst, nd_alts = nd_alts, nd_locals = nd_locals }, ca) + instance collectFunctions Ident where collectFunctions e ca - = (e, [], ca) + = (e, ca) NoCollectedLocalDefs :== CollectedLocalDefs { loc_functions = { ir_from = 0, ir_to = 0 }, loc_nodes = [] } @@ -601,8 +591,7 @@ makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_ get_predef_id :: Int *CollectAdmin -> (Ident, *CollectAdmin) get_predef_id predef_index ca=:{ca_predefs} - #! symb = ca_predefs.[predef_index] - = (symb, ca) + = ca!ca_predefs.[predef_index] transformSequence :: Sequence -> PredefinedIdents -> ParsedExpr transformSequence (SQ_FromThen frm then) @@ -629,18 +618,18 @@ transformArrayDenot exprs pi [{bind_dst=toParsedExpr i pi, bind_src=expr} \\ expr <- exprs & i <- [0..]] pi -scanModules :: [ParsedImport] [ScannedModule] Int *HashTable *File SearchPaths *PredefinedSymbols *Files -> (Bool, [ScannedModule],[FunDef],Int, *HashTable, *File, *PredefinedSymbols, *Files) -scanModules [] parsed_modules fun_count hash_table err_file searchPaths predefs files - = (True, parsed_modules, [], fun_count, hash_table, err_file, predefs, files) -scanModules [{import_module,import_symbols} : mods] parsed_modules fun_count hash_table err_file searchPaths predefs files +scanModules :: [ParsedImport] [ScannedModule] SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) +scanModules [] parsed_modules searchPaths files ca + = (True, parsed_modules, files, ca) +scanModules [{import_module,import_symbols} : mods] parsed_modules searchPaths files ca # (found, mod) = try_to_find import_module parsed_modules | found - = scanModules mods parsed_modules fun_count hash_table err_file searchPaths predefs files - # (succ, parsed_modules, local_fun_defs, fun_count, hash_table, err_file, predefs, files) - = parseAndScanDclModule import_module parsed_modules fun_count hash_table err_file searchPaths predefs files - (mods_succ, parsed_modules, local_fun_defs_in_imports, fun_count, hash_table, err_file, predefs, files) - = scanModules mods parsed_modules fun_count hash_table err_file searchPaths predefs files - = (succ && mods_succ, parsed_modules, local_fun_defs ++ local_fun_defs_in_imports, fun_count, hash_table, err_file, predefs, files) + = scanModules mods parsed_modules searchPaths files ca + # (succ, parsed_modules, files, ca) + = parseAndScanDclModule import_module parsed_modules searchPaths files ca + (mods_succ, parsed_modules, files, ca) + = scanModules mods parsed_modules searchPaths files ca + = (succ && mods_succ, parsed_modules, files, ca) where try_to_find :: Ident [ScannedModule] -> (Bool, ScannedModule) try_to_find mod_id [] @@ -654,85 +643,95 @@ MakeEmptyModule name :== { mod_name = name, mod_type = MK_None, mod_imports = [ mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macros = { ir_from = 0, ir_to = 0 }, def_members = [], def_funtypes = [], def_instances = [] } } -parseAndScanDclModule :: !Ident ![ScannedModule] !Int !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files - -> *(!Bool, ![ScannedModule], ![FunDef], !Int, !*HashTable, !*File, !*PredefinedSymbols, !*Files) -parseAndScanDclModule dcl_module parsed_modules fun_count hash_table err_file searchPaths predefs files - # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module hash_table err_file searchPaths predefs files +parseAndScanDclModule :: !Ident ![ScannedModule] !SearchPaths !*Files !*CollectAdmin + -> *(!Bool, ![ScannedModule], !*Files, !*CollectAdmin) +parseAndScanDclModule dcl_module parsed_modules searchPaths files ca + # {ca_error, ca_fun_count, ca_rev_fun_defs, ca_predefs, ca_u_predefs, ca_hash_table} + = ca + hash_table = ca_hash_table + pea_file = ca_error.pea_file + predefs = ca_u_predefs + # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module hash_table pea_file searchPaths predefs files + # ca = {ca_hash_table=hash_table, ca_error={pea_file=err_file,pea_ok=True}, ca_u_predefs=predefs, ca_fun_count=ca_fun_count, ca_rev_fun_defs=ca_rev_fun_defs, ca_predefs=ca_predefs} | parse_ok - = scan_dcl_module mod parsed_modules fun_count hash_table err_file searchPaths predefs files - = (False, [ MakeEmptyModule mod.mod_name : parsed_modules ], [], fun_count, hash_table, err_file, predefs, files) + = scan_dcl_module mod parsed_modules searchPaths files ca + = (False, [MakeEmptyModule mod.mod_name : parsed_modules], files, ca) where - scan_dcl_module :: ParsedModule [ScannedModule] Int *HashTable *File SearchPaths *PredefinedSymbols *Files -> (Bool, [ScannedModule], [FunDef], Int, *HashTable, *File, *PredefinedSymbols, *Files) - scan_dcl_module mod=:{mod_defs = pdefs} parsed_modules fun_count hash_table err_file searchPaths predefs files - # (predefIdents, predefs) = SelectPredefinedIdents predefs - # state = {ca_error = { pea_file = err_file, pea_ok = True }, ca_fun_count = 0, ca_predefs = predefIdents, ca_hash_table = hash_table} - (_, defs, imports, imported_objects, state) = reorganizeDefinitions False pdefs 0 0 0 state - macro_count = length defs.def_macros + fun_count - (macro_defs, local_fun_defs, {ca_fun_count=new_fun_count, ca_error={pea_file,pea_ok}, ca_predefs, ca_hash_table=hash_table}) - = reorganizeLocalDefinitionsOfFunctions defs.def_macros {state & ca_fun_count = macro_count} - mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros = { ir_from = fun_count, ir_to = macro_count } }} - (import_ok, parsed_modules, imported_local_fun_defs, fun_count, hash_table, err_file, predefs, files) - = scanModules imports [mod : parsed_modules] new_fun_count hash_table pea_file searchPaths predefs files - = (pea_ok && import_ok, parsed_modules, macro_defs ++ local_fun_defs ++ imported_local_fun_defs, fun_count, hash_table, err_file, predefs, files) + scan_dcl_module :: ParsedModule [ScannedModule] !SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) + scan_dcl_module mod=:{mod_defs = pdefs} parsed_modules searchPaths files ca + # (_, defs, imports, imported_objects, ca) + = reorganiseDefinitions False pdefs 0 0 0 ca + (macro_defs, ca) + = collectFunctions defs.def_macros ca + (range, ca) + = addFunctionsRange macro_defs ca + (pea_ok,ca) + = ca!ca_error.pea_ok + mod + = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros = range }} + (import_ok, parsed_modules, files, ca) + = scanModules imports [mod : parsed_modules] searchPaths files ca + = (pea_ok && import_ok, parsed_modules, files, ca) scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files - -> (!Bool, !ScannedModule, !Int, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) + -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files) scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} hash_table err_file searchPaths predefs files # (predefIdents, predefs) = SelectPredefinedIdents predefs - # state = {ca_fun_count = 0, ca_error = { pea_file = err_file, pea_ok = True }, ca_predefs = predefIdents, ca_hash_table = hash_table} - (fun_defs, defs, imports, imported_objects, ca) = reorganizeDefinitions True pdefs 0 0 0 state - fun_count = length fun_defs - macro_count = length defs.def_macros - (fun_defs, local_defs, ca) = reorganizeLocalDefinitionsOfFunctions (fun_defs ++ defs.def_macros) {ca & ca_fun_count = fun_count + macro_count} - (def_instances, local_defs_in_insts, {ca_fun_count=tot_fun_count, ca_error = {pea_file,pea_ok}, ca_predefs, ca_hash_table=hash_table}) - = reorganizeLocalDefinitionsOfInstances defs.def_instances ca - (import_dcl_ok, parsed_modules, local_defs_in_dcl, tot_fun_count, hash_table, err_file, ca_predefs, files) - = scan_dcl_module mod_name mod_type tot_fun_count hash_table pea_file predefs files - (import_dcls_ok, parsed_modules, local_defs_in_imports, tot_fun_count, hash_table, err_file, ca_predefs, files) - = scanModules imports parsed_modules tot_fun_count hash_table err_file searchPaths ca_predefs files + # ca = { ca_error = {pea_file = err_file, pea_ok = True} + , ca_fun_count = 0 + , ca_rev_fun_defs = [] + , ca_predefs = predefIdents + , ca_u_predefs = predefs + , ca_hash_table = hash_table + } + (fun_defs, defs, imports, imported_objects, ca) = reorganiseDefinitions True pdefs 0 0 0 ca + fun_count = length fun_defs + (fun_defs, ca) = collectFunctions fun_defs ca + (fun_range, ca) = addFunctionsRange fun_defs ca + (macro_defs, ca) = collectFunctions defs.def_macros ca + (macro_range, ca) = addFunctionsRange macro_defs ca + (def_instances, ca) + = collectFunctions defs.def_instances ca + (pea_ok, ca) = ca!ca_error.pea_ok + (import_dcl_ok, parsed_modules, files, ca) + = scan_dcl_module mod_name mod_type searchPaths files ca + (import_dcls_ok, parsed_modules, files, ca) + = scanModules imports parsed_modules searchPaths files ca + { ca_error = {pea_file = err_file} + , ca_predefs = predefs + , ca_rev_fun_defs + , ca_u_predefs + , ca_hash_table = hash_table + } + = ca mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_instances = def_instances, - def_macros = { ir_from = fun_count, ir_to = fun_count + macro_count } }} + def_macros = macro_range }} [dcl_mod : modules] = reverse parsed_modules - all_local_defs = fun_defs ++ local_defs ++ local_defs_in_insts ++ local_defs_in_dcl ++ local_defs_in_imports - (pre_def_mod, ca_predefs) = buildPredefinedModule ca_predefs - = (pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_count, all_local_defs, dcl_mod, pre_def_mod, modules, hash_table, err_file, ca_predefs, files) + (pre_def_mod, ca_u_predefs) = buildPredefinedModule ca_u_predefs + = (pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_range, reverse ca_rev_fun_defs, dcl_mod, pre_def_mod, modules, hash_table, err_file, ca_u_predefs, files) where - scan_dcl_module :: Ident ModuleKind Int *HashTable *File *PredefinedSymbols *Files -> (Bool, [ScannedModule], [FunDef], Int, *HashTable, *File, *PredefinedSymbols, *Files) - scan_dcl_module mod_name MK_Main fun_count hash_table err_file predefs files - = (True, [MakeEmptyModule mod_name ], [], fun_count, hash_table, err_file, predefs, files) - scan_dcl_module mod_name MK_None fun_count hash_table err_file predefs files - = (True, [MakeEmptyModule mod_name ], [], fun_count, hash_table, err_file, predefs , files) - scan_dcl_module mod_name kind fun_count hash_table err_file predefs files - = parseAndScanDclModule mod_name [] fun_count hash_table err_file searchPaths predefs files - -reorganizeLocalDefinitionsOfInstances :: [ParsedInstance FunDef] *CollectAdmin -> ([ParsedInstance FunDef], [FunDef], *CollectAdmin) -reorganizeLocalDefinitionsOfInstances [] ca - = ([], [], ca) -reorganizeLocalDefinitionsOfInstances [inst=:{pi_members} : insts] ca - # (pi_members, local_defs, ca) = reorganizeLocalDefinitionsOfFunctions pi_members ca - (insts, local_defs_in_insts, ca) = reorganizeLocalDefinitionsOfInstances insts ca - = ([{inst & pi_members = pi_members } : insts], local_defs ++ local_defs_in_insts, ca) - -reorganizeLocalDefinitionsOfFunction :: FunDef *CollectAdmin -> (FunDef, [FunDef], *CollectAdmin) -reorganizeLocalDefinitionsOfFunction fun_def=:{fun_body = ParsedBody bodies} ca - # (bodies, rhs_fun_defs, ca) = collect_local_definitions_in_bodies bodies ca - = ({fun_def & fun_body = ParsedBody bodies}, rhs_fun_defs, ca) -where - collect_local_definitions_in_bodies :: [ParsedBody] *CollectAdmin -> ([ParsedBody], [FunDef], CollectAdmin) - collect_local_definitions_in_bodies [pb=:{pb_rhs} : bodies] ca - # (pb_rhs, rhs_fun_defs, ca) = collectFunctions pb_rhs ca - (bodies, body_fun_defs, ca) = collect_local_definitions_in_bodies bodies ca - = ([ { pb & pb_rhs = pb_rhs } : bodies], rhs_fun_defs ++ body_fun_defs, ca) - collect_local_definitions_in_bodies [] ca - = ([], [], ca) - -reorganizeLocalDefinitionsOfFunctions :: [FunDef] *CollectAdmin -> ([FunDef], [FunDef], *CollectAdmin) -reorganizeLocalDefinitionsOfFunctions [] ca - = ([], [], ca) -reorganizeLocalDefinitionsOfFunctions [fun_def : fun_defs] ca - # (fun_def, rhs_fun_defs, ca) = reorganizeLocalDefinitionsOfFunction fun_def ca - (fun_defs, rhss_fun_defs, ca) = reorganizeLocalDefinitionsOfFunctions fun_defs ca - = ([fun_def : fun_defs], rhs_fun_defs ++ rhss_fun_defs, ca) + scan_dcl_module :: Ident ModuleKind SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin) + scan_dcl_module mod_name MK_Main searchPaths files ca + = (True, [MakeEmptyModule mod_name], files, ca) + scan_dcl_module mod_name MK_None searchPaths files ca + = (True, [MakeEmptyModule mod_name], files, ca) + scan_dcl_module mod_name kind searchPaths files ca + = parseAndScanDclModule mod_name [] searchPaths files ca + +instance collectFunctions (ParsedInstance a) | collectFunctions a where + collectFunctions inst=:{pi_members} ca + # (pi_members, ca) = collectFunctions pi_members ca + = ({inst & pi_members = pi_members }, ca) + +instance collectFunctions FunDef where + collectFunctions fun_def=:{fun_body = ParsedBody bodies} ca + # (bodies, ca) = collectFunctions bodies ca + = ({fun_def & fun_body = ParsedBody bodies}, ca) + +instance collectFunctions ParsedBody where + collectFunctions pb=:{pb_rhs} ca + # (pb_rhs, ca) = collectFunctions pb_rhs ca + = ({ pb & pb_rhs = pb_rhs }, ca) MakeNewFunction name arity body kind prio opt_type pos :== { fun_symb = name, fun_arity = arity, fun_priority = prio, fun_type = opt_type, fun_kind = kind, @@ -768,37 +767,37 @@ collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Functio collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca = ([], fun_kind, defs, ca) -reorganizeDefinitions :: Bool [ParsedDefinition] Index Index Index *CollectAdmin -> ([FunDef],CollectedDefinitions (ParsedInstance FunDef) [FunDef], [ParsedImport], [ImportedObject], *CollectAdmin) -reorganizeDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count ca +reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index *CollectAdmin -> ([FunDef],CollectedDefinitions (ParsedInstance FunDef) [FunDef], [ParsedImport], [ImportedObject], *CollectAdmin) +reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count ca # prio = if is_infix (Prio NoAssoc 9) NoPrio fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] fun_kind prio No pos | fun_kind == FK_Macro = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects, ca) = ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) -reorganizeDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] cons_count sel_count mem_count ca = case defs of [PD_Function pos name is_infix args rhs fun_kind : defs] | fun_name <> name - -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos ("function alternative for "+++fun_name.id_name+++" expected") ca) + -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos ("function alternative for "+++fun_name.id_name+++" expected") ca) | not (sameFixity prio is_infix) - -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "infix of type specification and alternative should match" ca) + -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "infix of type specification and alternative should match" ca) // | belongsToTypeSpec fun_name prio name is_infix # fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos | fun_kind == FK_Macro -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects, ca) -> ([ fun : fun_defs ], c_defs, imports, imported_objects, ca) - // -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca) + // -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca) _ - -> reorganizeDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function alternative expected (2)" ca) -reorganizeDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_arity}) specials : defs] cons_count sel_count mem_count ca + -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function alternative expected (2)" ca) +reorganiseDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_arity}) specials : defs] cons_count sel_count mem_count ca # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca | isEmpty bodies # fun_type = MakeNewFunctionType name st_arity prio fun_type pos specials nilPtr c_defs = { c_defs & def_funtypes = [ fun_type : c_defs.def_funtypes ]} @@ -809,9 +808,9 @@ reorganizeDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_a | icl_module = ([fun : fun_defs], c_defs, imports, imported_objects, ca) = ([fun : fun_defs], c_defs, imports, imported_objects, postParseError pos "function body not allowed in definition module" ca) -reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs} : defs] cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs} : defs] cons_count sel_count mem_count ca # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca type_def = { type_def & td_rhs = AlgType cons_symbs } c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors } = (fun_defs, c_defs, imports, imported_objects, ca) @@ -823,9 +822,9 @@ where = ([cons : conses], next_cons_index) determine_symbols_of_conses [] next_cons_index = ([], next_cons_index) -reorganizeDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorList rec_cons_id exivars sel_defs, td_pos } : defs] cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorList rec_cons_id exivars sel_defs, td_pos } : defs] cons_count sel_count mem_count ca # (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs (inc cons_count) new_count mem_count ca + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count ca cons_arity = new_count - sel_count cons_def = { pc_cons_name = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos, pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars } @@ -843,28 +842,27 @@ where determine_symbols_of_selectors [] next_selector_index = ([], next_selector_index) -reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = TypeSpec type} : defs] cons_count sel_count mem_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = TypeSpec type} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca type_def = { type_def & td_rhs = SynType type } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } = (fun_defs, c_defs, imports, imported_objects, ca) -reorganizeDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs properties} : defs] cons_count sel_count mem_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs properties} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca type_def = { type_def & td_rhs = AbstractType properties } c_defs = { c_defs & def_types = [type_def : c_defs.def_types] } = (fun_defs, c_defs, imports, imported_objects, ca) -reorganizeDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count ca # type_context = { tc_class = {glob_module = NoIndex, glob_object = {ds_ident = class_name, ds_arity = class_arity, ds_index = NoIndex }}, tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr } (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca - (mem_symbs, mem_defs, class_size) = reorganize_member_defs mem_defs mem_count - (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count (mem_count + class_size) ca + (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count + (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count (mem_count + class_size) ca class_def = { class_def & class_members = { member \\ member <- mem_symbs }} c_defs = { c_defs & def_classes = [class_def : c_defs.def_classes], def_macros = mem_macros ++ c_defs.def_macros, def_members = mem_defs ++ c_defs.def_members } = (fun_defs, c_defs, imports, imported_objects, ca) where - check_symbols_of_class_members :: ![ParsedDefinition] !TypeContext !*CollectAdmin -> (![MemberDef], ![FunDef], !*CollectAdmin) check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca @@ -900,8 +898,8 @@ where check_symbols_of_class_members [] type_context ca = ([], [], ca) - reorganize_member_defs :: [MemberDef] Index -> ([DefinedSymbol], [MemberDef], Index) - reorganize_member_defs mem_defs first_mem_index + reorganise_member_defs :: [MemberDef] Index -> ([DefinedSymbol], [MemberDef], Index) + reorganise_member_defs mem_defs first_mem_index # mem_defs = sort mem_defs = determine_indexes_of_class_members mem_defs first_mem_index 0 @@ -913,9 +911,8 @@ where determine_indexes_of_class_members [] first_mem_index last_mem_offset = ([], [], last_mem_offset) - -reorganizeDefinitions icl_module [PD_Instance class_instance=:{pi_members,pi_pos} : defs] cons_count sel_count mem_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Instance class_instance=:{pi_members,pi_pos} : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca (mem_defs, ca) = collect_member_instances pi_members ca | icl_module || isEmpty mem_defs = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = mem_defs} : c_defs.def_instances] }, imports, imported_objects, ca) @@ -943,60 +940,50 @@ where -> collect_member_instances defs (postParseError fun_pos "function body expected" ca) collect_member_instances [] ca = ([], ca) -reorganizeDefinitions icl_module [PD_Instances class_instances : defs] cons_count sel_count mem_count ca - = reorganizeDefinitions icl_module ([PD_Instance class_instance \\ class_instance <- class_instances] ++ defs) cons_count sel_count mem_count ca -reorganizeDefinitions icl_module [PD_Import new_imports : defs] cons_count sel_count mem_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Instances class_instances : defs] cons_count sel_count mem_count ca + = reorganiseDefinitions icl_module ([PD_Instance class_instance \\ class_instance <- class_instances] ++ defs) cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_Import new_imports : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca = (fun_defs, c_defs, new_imports ++ imports, imported_objects, ca) -reorganizeDefinitions icl_module [PD_ImportedObjects new_imported_objects : defs] cons_count sel_count mem_count ca - # (fun_defs, c_defs, imports, imported_objects, ca) = reorganizeDefinitions icl_module defs cons_count sel_count mem_count ca +reorganiseDefinitions icl_module [PD_ImportedObjects new_imported_objects : defs] cons_count sel_count mem_count ca + # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca = (fun_defs, c_defs, imports, new_imported_objects ++ imported_objects, ca) -reorganizeDefinitions icl_module [def:defs] _ _ _ ca - = abort ("reorganizeDefinitions does not match" ---> def) +reorganiseDefinitions icl_module [def:defs] _ _ _ ca + = abort ("reorganiseDefinitions does not match" ---> def) -reorganizeDefinitions icl_module [] _ _ _ ca +reorganiseDefinitions icl_module [] _ _ _ ca = ([], { def_types = [], def_constructors = [], def_selectors = [], def_macros = [], def_classes = [], def_members = [], def_instances = [], def_funtypes = [] }, [], [], ca) -checkRhsOfNodeDef :: Position Rhs *CollectAdmin -> (ParsedExpr, *CollectAdmin) -checkRhsOfNodeDef pos { rhs_alts = UnGuardedExpr {ewl_expr,ewl_nodes = [],ewl_locals = LocalParsedDefs []}, rhs_locals = LocalParsedDefs []} ca - = (ewl_expr, ca) -checkRhsOfNodeDef pos rhs ca - = (PE_Empty, postParseError pos "illegal node definition" ca) - - -reorganizeLocalDefinitions :: [ParsedDefinition] *CollectAdmin -> ([FunDef],[(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) -reorganizeLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca - # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca +reorganiseLocalDefinitions :: [ParsedDefinition] *CollectAdmin -> ([FunDef],[(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin) +reorganiseLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca + # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca = (fun_defs, [(No, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca) -// = (fun_defs, [(No, { bind_dst = pattern, bind_src = rhs_expr }) : node_defs], ca) -reorganizeLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca +reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca # prio = if is_infix (Prio NoAssoc 9) NoPrio fun_arity = length args (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca - (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca + (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos = ([ fun : fun_defs ], node_defs, ca) -reorganizeLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca +reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca = case defs of [PD_Function pos name is_infix args rhs fun_kind : _] | belongsToTypeSpec name1 prio name is_infix # fun_arity = determineArity args type # (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca - (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca + (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca fun = MakeNewFunction name fun_arity bodies fun_kind prio type pos -> ([fun : fun_defs], node_defs, ca) - -> reorganizeLocalDefinitions defs (postParseError pos "function body expected" ca) + -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) [PD_NodeDef pos pattern=:(PE_Ident id) {rhs_alts,rhs_locals} : defs] | belongsToTypeSpec name1 prio id False - # (fun_defs, node_defs, ca) = reorganizeLocalDefinitions defs ca -// (rhs_expr, ca) = checkRhsOfNodeDef pos rhs ca + # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca -> (fun_defs, [(type, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca) -// -> (fun_defs, [(type, { bind_dst = pattern, bind_src = rhs_expr }) : node_defs], ca) - -> reorganizeLocalDefinitions defs (postParseError pos "function body expected" ca) + -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca) _ - -> reorganizeLocalDefinitions defs (postParseError pos1 "function body expected" ca) -reorganizeLocalDefinitions [] ca + -> reorganiseLocalDefinitions defs (postParseError pos1 "function body expected" ca) +reorganiseLocalDefinitions [] ca = ([], [], ca) diff --git a/frontend/predef.dcl b/frontend/predef.dcl index 585a764..81233b3 100644 --- a/frontend/predef.dcl +++ b/frontend/predef.dcl @@ -79,7 +79,9 @@ PD_variablePlaceholder :== 127 PD_StdDynamics :== 128 PD_undo_indirections :== 129 -PD_NrOfPredefSymbols :== 130 +PD_Start :== 130 + +PD_NrOfPredefSymbols :== 131 GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2 diff --git a/frontend/predef.icl b/frontend/predef.icl index 2ae1a83..a1e92a9 100644 --- a/frontend/predef.icl +++ b/frontend/predef.icl @@ -77,7 +77,9 @@ PD_variablePlaceholder :== 127 PD_StdDynamics :== 128 PD_undo_indirections :== 129 -PD_NrOfPredefSymbols :== 130 +PD_Start :== 130 + +PD_NrOfPredefSymbols :== 131 (<<=) infixl @@ -146,6 +148,7 @@ where <<- ("_unify", IC_Expression, PD_unify) <<- ("StdDynamics", IC_Module, PD_StdDynamics) <<- ("_undo_indirections", IC_Expression, PD_undo_indirections) + <<- ("Start", IC_Expression, PD_Start) MakeTupleConsSymbIndex arity :== arity - 2 + cArity2TupleConsSymbIndex diff --git a/frontend/refmark.icl b/frontend/refmark.icl index f528fa6..5b803ae 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -529,7 +529,7 @@ where EI_Attribute sa_attr_nr # (succ, coercion_env) = tryToMakeNonUnique sa_attr_nr coercion_env | succ - ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr) +// ---> ("make_shared_occurrence_non_unique", free_var, var_expr_ptr) -> (coercion_env, expr_heap, error) -> (coercion_env, expr_heap, uniquenessError { cp_expression = FreeVar free_var} " demanded attribute cannot be offered by shared object" error) _ diff --git a/frontend/type.icl b/frontend/type.icl index e285d3f..49905ed 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -1169,14 +1169,14 @@ InitFunEnv nr_of_fun_defs = createArray nr_of_fun_defs EmptyFunctionType //CreateInitialSymbolTypes :: ![Int] !u:{# FunDef} !{# CommonDefs } !*TypeState -> (!u:{# FunDef}, !*TypeState) -CreateInitialSymbolTypes common_defs [] defs_and_state +CreateInitialSymbolTypes start_index common_defs [] defs_and_state = defs_and_state -CreateInitialSymbolTypes common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts) +CreateInitialSymbolTypes start_index common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts) # (fd, fun_defs) = fun_defs![fun] - (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type common_defs fd (pre_def_symbols, req_cons_variables, ts) - = CreateInitialSymbolTypes common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts) + (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type (start_index == fun) common_defs fd (pre_def_symbols, req_cons_variables, ts) + = CreateInitialSymbolTypes start_index common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts) where - initial_symbol_type common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} } + initial_symbol_type is_start_rule common_defs {fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env}, fun_lifted, fun_info = {fi_dynamics} } (pre_def_symbols, req_cons_variables, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error}) # (st_args, ps) = addPropagationAttributesToATypes common_defs st_args { prop_type_heaps = ts_type_heaps, prop_td_infos = ts_td_infos, @@ -1193,8 +1193,8 @@ where { ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft lifted_args { fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted }}, ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps }) - initial_symbol_type common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts) - # (st_gen, ts) = create_general_symboltype fun_arity fun_lifted ts + initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts) + # (st_gen, ts) = create_general_symboltype is_start_rule fun_arity fun_lifted ts ts_type_heaps = ts.ts_type_heaps (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap) (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) @@ -1204,12 +1204,16 @@ where ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap}) - create_general_symboltype :: !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState) - create_general_symboltype nr_of_args nr_of_lifted_args ts - # (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts - (tst_args, ts) = fresh_attributed_type_variables nr_of_lifted_args tst_args ts - (tst_result, ts) = freshAttributedVariable ts - = ({ tst_args = tst_args, tst_arity = nr_of_args + nr_of_lifted_args, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts) + create_general_symboltype :: !Bool !Int !Int !*TypeState -> (!TempSymbolType, !*TypeState) + create_general_symboltype is_start_rule nr_of_args nr_of_lifted_args ts + | is_start_rule && nr_of_args > 0 + # (tst_args, ts) = fresh_attributed_type_variables (nr_of_args - 1) [{at_attribute = TA_Unique, at_annotation = AN_Strict, at_type = TB BT_World }] ts + (tst_result, ts) = freshAttributedVariable ts + = ({ tst_args = tst_args, tst_arity = 1, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts) + # (tst_args, ts) = fresh_attributed_type_variables nr_of_args [] ts + (tst_args, ts) = fresh_attributed_type_variables nr_of_lifted_args tst_args ts + (tst_result, ts) = freshAttributedVariable ts + = ({ tst_args = tst_args, tst_arity = nr_of_args + nr_of_lifted_args, tst_result = tst_result, tst_context = [], tst_attr_env = [], tst_lifted = 0 }, ts) fresh_attributed_type_variables :: !Int ![AType] !*TypeState -> (![AType], !*TypeState) fresh_attributed_type_variables n vars ts @@ -1321,23 +1325,23 @@ specification_error type err format = { form_properties = cAttributed, form_attr_position = No} = { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' } -cleanUpAndCheckFunctionTypes [] _ defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) +cleanUpAndCheckFunctionTypes [] _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) = (fun_defs, ts) -cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] defs type_contexts coercion_env +cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) # (fd, fun_defs) = fun_defs![fun] - # (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun defs type_contexts + # (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts req_case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts - = cleanUpAndCheckFunctionTypes funs reqs defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) + = cleanUpAndCheckFunctionTypes funs reqs start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts) where - clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun defs type_contexts case_and_let_exprs + clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts # (env_type, ts) = ts!ts_fun_env.[fun] # ts = { ts & ts_error = setErrorAdmin (newPosition fun_symb fun_pos) ts.ts_error} = case env_type of ExpandedType fun_type tmp_fun_type exp_fun_type # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error) - = cleanUpSymbolType cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env + = cleanUpSymbolType is_start_rule cSpecifiedType exp_fun_type type_contexts case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error | ts_error.ea_ok # (ts_fun_env, attr_var_env, ts_type_heaps, ts_expr_heap, ts_error) @@ -1346,7 +1350,7 @@ where -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error }) UncheckedType exp_fun_type # (clean_fun_type, type_var_env, attr_var_env, ts_type_heaps, ts_var_heap, ts_expr_heap, ts_error) - = cleanUpSymbolType cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env + = cleanUpSymbolType is_start_rule cDerivedType exp_fun_type type_contexts case_and_let_exprs coercion_env attr_partition type_var_env attr_var_env ts.ts_type_heaps ts.ts_var_heap ts.ts_expr_heap ts.ts_error ts_fun_env = { ts.ts_fun_env & [fun] = CheckedType clean_fun_type } -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error }) @@ -1401,24 +1405,17 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error } ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions } special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] } -// MW0 was # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) - (type_error, fun_defs, predef_symbols, special_instances, ts=:{ts_error}) - = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) -// MW0 was (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs - (fun_defs, ts_fun_env, ts_error=:{ea_ok=no_start_rule_error}) = update_function_types 0 comps ts.ts_fun_env fun_defs ts_error + # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts) + (fun_defs,ts_fun_env) = update_function_types 0 comps ts.ts_fun_env fun_defs (type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps}) -// MW0 was = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances, -// MW0 was { ts & ts_fun_env = ts_fun_env }) - = type_instances specials.ir_from specials.ir_to class_instances ti - (type_error || not no_start_rule_error, fun_defs, predef_symbols, special_instances, - { ts & ts_fun_env = ts_fun_env, ts_error = { ts_error & ea_ok = True }}) + = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances, + { ts & ts_fun_env = ts_fun_env }) {si_array_instances, si_next_array_member_index, si_next_TC_member_index, si_TC_instances}= special_instances (fun_defs, predef_symbols, ts_type_heaps) = convert_array_instances si_array_instances ti_common_defs fun_defs predef_symbols ts_type_heaps type_code_instances = {createArray si_next_TC_member_index GTT_Function & [gtci_index] = gtci_type \\ {gtci_index, gtci_type} <- si_TC_instances} = (not type_error, fun_defs, { ir_from = fun_env_size, ir_to = si_next_array_member_index }, type_code_instances, ti_common_defs, ti_functions, {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file) where - collect_imported_instances imports common_defs dummy error class_instances type_var_heap td_infos = foldSt (collect_imported_instance common_defs) imports (dummy, error, class_instances, type_var_heap, td_infos) @@ -1509,11 +1506,16 @@ where # ({fun_symb}, fun_defs) = fun_defs![fun_index] = ([fun_symb : names], fun_defs) - + get_index_of_start_rule predef_symbols + # ({pds_def, pds_module}, predef_symbols) = predef_symbols![PD_Start] + | pds_def <> NoIndex && pds_module == cIclModIndex + = (pds_def, predef_symbols) + = (NoIndex, predef_symbols) + type_component comp class_instances ti=:{ti_common_defs} (type_error, fun_defs, predef_symbols, special_instances, ts) - # (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes ti_common_defs comp (fun_defs, predef_symbols, [], ts) - (names, fun_defs) = show_component comp fun_defs - (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts /* (ts ---> names) */ + # (start_index, predef_symbols) = get_index_of_start_rule predef_symbols + # (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes start_index ti_common_defs comp (fun_defs, predef_symbols, [], ts) + (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts #! nr_of_type_variables = ts.ts_var_store # (subst, ts_type_heaps, ts_error) @@ -1546,7 +1548,7 @@ where (subst, ts_fun_env) = expand_function_types comp subst ts.ts_fun_env attr_var_env = createArray nr_of_attr_vars TA_None var_env = { subst & [i] = TE \\ i <- [0..dec ts_var_store]} - (fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env + (fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs start_index ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env (fun_defs, { ts & ts_error = ts_error, ts_fun_env = ts_fun_env, ts_type_heaps = ts_type_heaps, ts_td_infos = ts_td_infos, ts_var_heap = os_var_heap, ts_expr_heap = os_symbol_heap }) | not ts.ts_error.ea_ok @@ -1667,50 +1669,31 @@ where = (subst, ts_fun_env) -// MW0 was update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) - update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} !*ErrorAdmin -> (!*{#FunDef}, !*{!FunctionType}, !.ErrorAdmin) -// MW0 was update_function_types group_index comps fun_env fun_defs - update_function_types group_index comps fun_env fun_defs error_admin + update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) + update_function_types group_index comps fun_env fun_defs | group_index == size comps -// MW0 was = (fun_defs, fun_env) - = (fun_defs, fun_env, error_admin) + = (fun_defs, fun_env) #! comp = comps.[group_index] -// MW0 was # (fun_defs, fun_env) = update_function_types_in_component comp.group_members fun_env fun_defs - # (fun_defs, fun_env, error_admin) = update_function_types_in_component comp.group_members fun_env fun_defs error_admin -// MW0 was = update_function_types (inc group_index) comps fun_env fun_defs - = update_function_types (inc group_index) comps fun_env fun_defs error_admin + # (fun_defs, fun_env) = update_function_types_in_component comp.group_members fun_env fun_defs + = update_function_types (inc group_index) comps fun_env fun_defs where -// MW0 was update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) - update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} !*ErrorAdmin - -> (!*{#FunDef}, !*{!FunctionType}, !.ErrorAdmin) -// MW0 was update_function_types_in_component [ fun_index : funs ] fun_env fun_defs - update_function_types_in_component [ fun_index : funs ] fun_env fun_defs error_admin + update_function_types_in_component :: ![Index] !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType}) + update_function_types_in_component [ fun_index : funs ] fun_env fun_defs # (CheckedType checked_fun_type, fun_env) = fun_env![fun_index] # (fd, fun_defs) = fun_defs![fun_index] -// MW0.. - # is_start_rule = fd.fun_symb.id_name=="Start" && fd.fun_info.fi_def_level==1 - error_admin = case is_start_rule of - False -> error_admin - _ -> check_type_of_start_rule fd checked_fun_type error_admin -// ..MW0 = case fd.fun_type of No -// MW0 was -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }} - -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }} error_admin + -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes checked_fun_type }} Yes fun_type # nr_of_lifted_arguments = checked_fun_type.st_arity - fun_type.st_arity | nr_of_lifted_arguments > 0 # fun_type = addLiftedArgumentsToSymbolType fun_type nr_of_lifted_arguments checked_fun_type.st_args checked_fun_type.st_vars checked_fun_type.st_attr_vars checked_fun_type.st_context -// MW0 was -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} - -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} error_admin -// MW0 was -> update_function_types_in_component funs fun_env fun_defs - -> update_function_types_in_component funs fun_env fun_defs error_admin -// MW0 was update_function_types_in_component [] fun_env fun_defs -// MW0 was = (fun_defs, fun_env) - update_function_types_in_component [] fun_env fun_defs error_admin - = (fun_defs, fun_env, error_admin) + -> update_function_types_in_component funs fun_env { fun_defs & [fun_index] = { fd & fun_type = Yes fun_type }} + -> update_function_types_in_component funs fun_env fun_defs + update_function_types_in_component [] fun_env fun_defs + = (fun_defs, fun_env) type_functions group ti cons_variables fun_defs ts = mapSt (type_function ti) group (cons_variables, fun_defs, ts) // ((cons_variables, fun_defs, ts) ---> "[(") ---> ")]" @@ -1802,23 +1785,6 @@ where CheckedType _ -> ts -// MW0.. - check_type_of_start_rule fd checked_fun_type error_admin - | not (isEmpty checked_fun_type.st_context) - = checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "must not be overloaded" error_admin - | isEmpty checked_fun_type.st_args - = error_admin - | length checked_fun_type.st_args > 1 - = checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "should have arity 0 or 1" error_admin - = case checked_fun_type.st_args of - [] -> error_admin - [{at_type=TB BT_World}] - -> error_admin - [{at_type=TV _}] - -> error_admin - _ -> checkErrorWithIdentPos (newPosition fd.fun_symb fd.fun_pos) "argument must be of type World" error_admin -// ..MW0 - instance <<< AttrCoercion where (<<<) file {ac_demanded,ac_offered} = file <<< ac_demanded <<< '~' <<< ac_offered diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index de2d53d..739470b 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -32,7 +32,7 @@ extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) cSpecifiedType :== True cDerivedType :== False -cleanUpSymbolType :: !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition +cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition !*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 48b53f6..8d096e8 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -223,6 +223,10 @@ liftedError var err # err = errorHeading "Type error" err = { err & ea_file = err.ea_file <<< "type variable of type of lifted argument " <<< var <<< " appears in the specified type\n" } +startRuleError mess err + # err = errorHeading "Type error" err + = { err & ea_file = err.ea_file <<< mess } + extendSymbolType :: !SymbolType !Int !*TypeHeaps -> (!SymbolType, !*TypeHeaps) extendSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars} nr_of_extra_args type_heaps | nr_of_extra_args > 0 @@ -255,10 +259,10 @@ newAttributedVariable var_number (variables, attributes, type_heaps=:{th_vars,th cSpecifiedType :== True cDerivedType :== False -cleanUpSymbolType :: !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition +cleanUpSymbolType :: !Bool !Bool !TempSymbolType ![TypeContext] ![ExprInfoPtr] !{! CoercionTree} !AttributePartition !*VarEnv !*AttributeEnv !*TypeHeaps !*VarHeap !*ExpressionHeap !*ErrorAdmin -> (!SymbolType, !*VarEnv, !*AttributeEnv, !*TypeHeaps, !*VarHeap, !*ExpressionHeap, !*ErrorAdmin) -cleanUpSymbolType spec_type tst=:{tst_arity,tst_args,tst_result,tst_context,tst_lifted} derived_context case_and_let_exprs +cleanUpSymbolType is_start_rule spec_type tst=:{tst_arity,tst_args,tst_result,tst_context,tst_lifted} derived_context case_and_let_exprs coercions attr_part var_env attr_var_env heaps var_heap expr_heap error #! nr_of_temp_vars = size var_env #! max_attr_nr = size attr_var_env @@ -276,6 +280,7 @@ cleanUpSymbolType spec_type tst=:{tst_arity,tst_args,tst_result,tst_context,tst_ expr_heap { cus & cus_var_env = cus_var_env, cus_attr_env = cus_attr_env, cus_error = cus_error } st = { st_arity = tst_arity, st_vars = st_vars , st_args = lifted_args ++ st_args, st_result = st_result, st_context = st_context, st_attr_env = st_attr_env, st_attr_vars = st_attr_vars } + cus_error = check_type_of_start_rule is_start_rule st cus_error = (st, { cus_var_env & [i] = TE \\ i <- [0..nr_of_temp_vars - 1]}, { cus_attr_env & [i] = TA_None \\ i <- [0..max_attr_nr - 1]}, cus_heaps, var_heap, expr_heap, cus_error) // ---> ("cleanUpSymbolType", st) @@ -382,6 +387,21 @@ where # (let_type, cus) = clean_up cui let_type cus -> (expr_heap <:= (expr_ptr, EI_LetType let_type), cus) + check_type_of_start_rule is_start_rule {st_context,st_arity,st_args} cus_error + | is_start_rule + | isEmpty st_context + | st_arity > 0 + | st_arity == 1 + = case st_args of + [{at_type = TB BT_World} : _] + -> cus_error + _ + -> startRuleError "argument of Start rule should have type World.\n" cus_error + = startRuleError "Start rule has too many arguments.\n" cus_error + = cus_error + = startRuleError "Start rule cannot be overloaded.\n" cus_error + = cus_error + instance clean_up CaseType where clean_up cui ctype=:{ct_pattern_type,ct_result_type, ct_cons_types} cus |