diff options
author | sjakie | 2000-01-17 16:40:25 +0000 |
---|---|---|
committer | sjakie | 2000-01-17 16:40:25 +0000 |
commit | 7df70be02dac26f4b4324e091a1f37b833504e96 (patch) | |
tree | 7cf2de146cd5c8c5b186c1b9bdad8badadb4d481 | |
parent | removing some abort statements in check (diff) |
Bug fixes
git-svn-id: https://svn.cs.ru.nl/repos/clean-compiler/trunk@77 1f8540f1-abd5-4d5b-9d24-4c5ce8603e2d
-rw-r--r-- | frontend/check.icl | 126 | ||||
-rw-r--r-- | frontend/general.icl | 14 | ||||
-rw-r--r-- | frontend/overloading.icl | 64 | ||||
-rw-r--r-- | frontend/refmark.icl | 3 | ||||
-rw-r--r-- | frontend/syntax.dcl | 2 | ||||
-rw-r--r-- | frontend/syntax.icl | 7 | ||||
-rw-r--r-- | frontend/transform.icl | 42 | ||||
-rw-r--r-- | frontend/type.icl | 25 | ||||
-rw-r--r-- | frontend/typesupport.icl | 6 | ||||
-rw-r--r-- | frontend/unitype.icl | 17 |
10 files changed, 113 insertions, 193 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index 8d43120..1e49d63 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -883,7 +883,6 @@ checkPattern (PE_List [exp1, exp2 : exps]) opt_var p_input var_env ps e_info cs checkPattern (PE_DynamicPattern pattern type) opt_var p_input var_env ps e_info cs # (dyn_pat, var_env, ps, e_info, cs) = checkPattern pattern No p_input var_env ps e_info cs -// MW was = (AP_Dynamic dyn_pat type opt_var, var_env, ps, e_info, cs) = (AP_Dynamic dyn_pat type opt_var, var_env, ps, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics }) checkPattern (PE_Basic basic_value) opt_var p_input var_env ps e_info cs @@ -1048,7 +1047,8 @@ where # index = { glob_object = ste_index, glob_module = cIclModIndex } | is_called_before ei_fun_index calls | fun_kind == FK_Macro - = (SK_Macro index, fun_arity, fun_priority, cIsNotAFunction, e_state, e_info, cs) +// = (SK_Macro index, fun_arity, fun_priority, cIsNotAFunction, e_state, e_info, cs) + = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) = (SK_Function index, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) # cs = { cs & cs_symbol_table = cs_symbol_table <:= (symb_info, { entry & ste_kind = STE_FunctionOrMacro [ ei_fun_index : calls ]})} e_state = { e_state & es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} @@ -1308,21 +1308,7 @@ where _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error}) -/* - = case patterns of - BasicPatterns basic_type basic_patterns - | type_symbol == basic_type - -> (BasicPatterns basic_type [pattern : basic_patterns], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) - -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, - { cs & cs_error = checkError basic_val "incompatible types of patterns" cs.cs_error }) - NoPattern - -> (BasicPatterns type_symbol [pattern], pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) - _ - -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, - { cs & cs_error = checkError basic_val "illegal combination of patterns" cs.cs_error}) -*/ transform_pattern (AP_Dynamic pattern type opt_var) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs - // # cs = { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics } // MW++ # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap pattern = { dp_var = var_arg, dp_type = dynamic_info_ptr, dp_rhs = result_expr, dp_type_patterns_vars = [], dp_type_code = TCE_Empty } @@ -1336,16 +1322,6 @@ where _ -> (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError "<dynamic pattern>" "illegal combination of patterns" cs.cs_error }) -/* - = case patterns of - DynamicPatterns dyn_patterns - -> (DynamicPatterns [pattern : dyn_patterns], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) - NoPattern - -> (DynamicPatterns [pattern], pattern_variables, defaul, var_store, expr_heap, [dynamic_info_ptr], cs) - _ - -> (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, - { cs & cs_error = checkError "<dynamic pattern>" "illegal combination of patterns" cs.cs_error }) -*/ transform_pattern (AP_Variable name var_info opt_var) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs = ( NoPattern, pattern_scheme, cons_optional opt_var pattern_variables, Yes ([{ fv_name = name, fv_info_ptr = var_info, fv_def_level = NotALevel, fv_count = 0 }], result_expr), @@ -1361,29 +1337,15 @@ where // if (!has_been_inserted) checkWarning("pattern won't match"); = (NoPattern, pattern_scheme, (cons_optional opt_var pattern_variables), Yes (cons_opt free_var vars_as_patterns, new_defaul), var_store, expr_heap, opt_dynamics, cs) -/* - transform_pattern (AP_Variable name var_info opt_var) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs - = (patterns, cons_optional opt_var pattern_variables, defaul, var_store, expr_heap, opt_dynamics, - { cs & cs_error = checkError name "illegal combination of patterns" cs.cs_error }) -*/ -// MW added the following alternative transform_pattern (AP_WildCard (Yes opt_var)) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs = transform_pattern (AP_Variable opt_var.bind_src opt_var.bind_dst No) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs transform_pattern (AP_WildCard no) NoPattern pattern_scheme pattern_variables No result_expr _ var_store expr_heap opt_dynamics cs = (NoPattern, pattern_scheme, pattern_variables, Yes ([], result_expr), var_store, expr_heap, opt_dynamics, cs) -/* - transform_pattern (AP_WildCard _) NoPattern pattern_variables No result_expr var_store expr_heap opt_dynamics cs - = (NoPattern, pattern_variables, Yes ([], result_expr), var_store, expr_heap, opt_dynamics, cs) -*/ transform_pattern (AP_WildCard _) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs # (new_info_ptr, var_store) = newPtr VI_Empty var_store = transform_pattern (AP_Variable (newVarId "wc") new_info_ptr No) patterns pattern_scheme pattern_variables defaul result_expr case_name var_store expr_heap opt_dynamics cs -/* - transform_pattern (AP_WildCard _) patterns pattern_variables defaul result_expr var_store expr_heap opt_dynamics cs - = (patterns, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, { cs & cs_error = checkError "_" "illegal combination of patterns" cs.cs_error }) -*/ transform_pattern (AP_Empty name) patterns pattern_scheme pattern_variables defaul result_expr _ var_store expr_heap opt_dynamics cs = (patterns, pattern_scheme, pattern_variables, defaul, var_store, expr_heap, opt_dynamics, cs) @@ -1406,19 +1368,6 @@ where -> (let_expression, expr_heap) No -> (EE, expr_heap) -/* - build_case NoPattern defaul expr case_ident expr_heap - = case defaul of - Yes (opt_var, result) - -> case opt_var of - Yes var - # (let_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (let_expression, expr_heap) - No - -> (result, expr_heap) - No - -> (abort "incorrect case expression in build_case", expr_heap) -*/ build_case (DynamicPatterns patterns) defaul expr case_ident expr_heap = case defaul of Yes (vars, result) @@ -1434,25 +1383,6 @@ where No # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap -> (buildTypeCase expr patterns No type_case_info_ptr, expr_heap) -/* - build_case (DynamicPatterns patterns) defaul expr case_ident expr_heap - = case defaul of - Yes (opt_var, result) - -> case opt_var of - Yes var - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap - bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr } - result = buildTypeCase (Var bound_var) patterns (Yes result) type_case_info_ptr - (case_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (case_expression, expr_heap) - No - # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (buildTypeCase expr patterns (Yes result) type_case_info_ptr, expr_heap) - No - # (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (buildTypeCase expr patterns No type_case_info_ptr, expr_heap) -*/ build_case patterns (Yes (vars,result)) expr case_ident expr_heap = case vars of [] # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap @@ -1465,31 +1395,9 @@ where case_ident = Yes case_ident, case_info_ptr = case_expr_ptr} (case_expression, expr_heap) = bind_default_variables expr (reverse vars) result expr_heap -> (case_expression, expr_heap) -/* - build_case patterns (Yes (defaul,result)) expr case_ident expr_heap - = case defaul of - Yes var - # (var_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - bound_var = { var_name = var.fv_name, var_info_ptr = var.fv_info_ptr, var_expr_ptr = var_expr_ptr } - result = Case {case_expr = Var bound_var, case_guards = patterns, case_default = Yes result, - case_ident = Yes case_ident, case_info_ptr = case_expr_ptr} - (case_expression, expr_heap) = bind_default_variable expr var result expr_heap - -> (case_expression, expr_heap) - No - # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - -> (Case {case_expr = expr, case_guards = patterns, case_default = Yes result, - case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) -*/ build_case patterns No expr case_ident expr_heap # (case_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap = (Case {case_expr = expr, case_guards = patterns, case_default = No, case_ident = Yes case_ident, case_info_ptr = case_expr_ptr }, expr_heap) - -/* - bind_default_variable bind_src bind_dst result_expr expr_heap - # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap - = (Let {let_strict = cIsNotStrict, let_binds = [{ bind_src = bind_src, bind_dst = bind_dst }], let_expr = result_expr, let_info_ptr = let_expr_ptr }, expr_heap) -*/ bind_default_variables expr vars result_expr expr_heap # (let_expr_ptr, expr_heap) = newPtr EI_Empty expr_heap (var_binds, expr_heap) = build_binds vars [] expr_heap @@ -1506,7 +1414,7 @@ where = (pattern_expr, [], expr_heap) bind_pattern_variables [{bind_src,bind_dst} : variables] this_pattern_expr expr_heap # free_var = { fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 } - (bound_var, expr_heap) = allocate_bound_var free_var expr_heap // MW + (bound_var, expr_heap) = allocate_bound_var free_var expr_heap (pattern_expr, binds, expr_heap) = bind_pattern_variables variables (Var bound_var) expr_heap = (pattern_expr, [{bind_src = this_pattern_expr, bind_dst = free_var} : binds], expr_heap) @@ -1641,7 +1549,6 @@ checkExpression free_vars (PE_Dynamic expr opt_type) e_input e_state=:{es_expres (dyn_expr, free_vars, e_state, e_info, cs) = checkExpression free_vars expr e_input {e_state & es_dynamics = [dyn_info_ptr : es_dynamics], es_expression_heap = es_expression_heap } e_info cs = (DynamicExpr { dyn_expr = dyn_expr, dyn_opt_type = opt_type, dyn_info_ptr = dyn_info_ptr, dyn_type_code = TCE_Empty, dyn_uni_vars = [] }, -// MW was free_vars, e_state, e_info, cs) free_vars, e_state, e_info, { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics }) checkExpression free_vars (PE_Basic basic_value) e_input e_state e_info cs @@ -1956,14 +1863,15 @@ where (binds, let_vars_list, rhs_expr_level, free_vars, e_state, e_info, cs) = check_sequential_lets free_vars ewl_nodes [] { e_input & ei_expr_level = this_expr_level } e_state e_info cs (expr, free_vars, e_state, e_info, cs) = checkExpression free_vars ewl_expr { e_input & ei_expr_level = rhs_expr_level } e_state e_info cs cs = { cs & cs_symbol_table = remove_seq_let_vars rhs_expr_level let_vars_list cs.cs_symbol_table } - (expr, free_vars, e_state, e_info, cs) = checkRhssAndTransformLocalDefs free_vars loc_defs expr e_input e_state e_info cs + (seq_let_expr, es_expression_heap) = build_sequential_lets binds expr e_state.es_expression_heap + (expr, free_vars, e_state, e_info, cs) + = checkRhssAndTransformLocalDefs free_vars loc_defs seq_let_expr e_input { e_state & es_expression_heap = es_expression_heap} e_info cs (es_fun_defs, e_info, heaps, cs) - = checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals e_state.es_fun_defs e_info + = checkLocalFunctions ei_mod_index rhs_expr_level ewl_locals e_state.es_fun_defs e_info { hp_var_heap = e_state.es_var_heap, hp_expression_heap = e_state.es_expression_heap, hp_type_heaps = e_state.es_type_heaps } cs (es_fun_defs, cs_symbol_table) = removeLocalsFromSymbolTable this_expr_level var_env ewl_locals es_fun_defs cs.cs_symbol_table - (seq_let_expr, es_expression_heap) = build_sequential_lets binds expr heaps.hp_expression_heap - = (seq_let_expr, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, - es_expression_heap = es_expression_heap, es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table} ) + = (expr, free_vars, {e_state & es_fun_defs = es_fun_defs, es_var_heap = heaps.hp_var_heap, + es_expression_heap = heaps.hp_expression_heap, es_type_heaps = heaps.hp_type_heaps }, e_info, { cs & cs_symbol_table = cs_symbol_table} ) remove_seq_let_vars level [] symbol_table = symbol_table @@ -2064,10 +1972,6 @@ convertSubPattern (AP_WildCard opt_var) result_expr var_store expr_heap opt_dyna = ({ fv_name = bind_src, fv_info_ptr = bind_dst, fv_def_level = NotALevel, fv_count = 0 }, result_expr, var_store, expr_heap, opt_dynamics, cs) convertSubPattern (AP_Empty _) result_expr var_store expr_heap opt_dynamics cs = convertSubPattern (AP_WildCard No) EE var_store expr_heap opt_dynamics cs -/* MW was -convertSubPattern ap result_expr var_store expr_heap opt_dynamics cs - = abort ("convertSubPattern: unknown pattern " ---> ap) -*/ typeOfBasicValue :: !BasicValue !*CheckState -> (!BasicType, !*CheckState) typeOfBasicValue (BVI _) cs = (BT_Int, cs) @@ -2197,7 +2101,6 @@ where = (Case { case_expr = act_var, case_guards = case_guards, case_default = No, case_ident = No, case_info_ptr = case_expr_ptr }, var_store, expr_heap, opt_dynamics, cs) transform_pattern_into_cases (AP_Dynamic pattern type opt_var) fun_arg result_expr var_store expr_heap opt_dynamics cs - //# cs = { cs & cs_needed_modules = cs.cs_needed_modules bitor cNeedStdDynamics } // MW++ # (var_arg, result_expr, var_store, expr_heap, opt_dynamics, cs) = convertSubPattern pattern result_expr var_store expr_heap opt_dynamics cs (type_case_info_ptr, expr_heap) = newPtr EI_Empty expr_heap (dynamic_info_ptr, expr_heap) = newPtr (EI_DynamicType type opt_dynamics) expr_heap @@ -2564,7 +2467,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (scanned_modules, icl_functions, cs) = add_modules_to_symbol_table [ dcl_mod, pre_def_mod : scanned_modules ] 0 icl_functions - { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, /*MW*/ cs_needed_modules = 0 } + { cs_symbol_table = symbol_table, cs_predef_symbols = predef_symbols, cs_error = error, cs_needed_modules = 0 } init_dcl_modules = [ initialDclModule scanned_module \\ scanned_module <- scanned_modules ] (dcl_modules, local_defs, cdefs, sizes, cs) @@ -2583,7 +2486,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (_, {ii_modules,ii_funs_and_macros = icl_functions}, heaps, cs) = checkImports mod_imports iinfo heaps cs - cs = { cs & cs_needed_modules = 0 } // MW++ + cs = { cs & cs_needed_modules = 0 } (nr_of_modules, (f_consequences, ii_modules, icl_functions, hp_expression_heap, cs)) = check_completeness_of_all_dcl_modules ii_modules icl_functions heaps.hp_expression_heap cs @@ -2614,7 +2517,7 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (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 - (e_info, cs) = check_needed_modules_are_imported mod_name ".icl" e_info cs // MW ++ + (e_info, cs) = check_needed_modules_are_imported mod_name ".icl" e_info cs (icl_functions, e_info, heaps, {cs_symbol_table, cs_predef_symbols, cs_error}) = checkInstanceBodies {ir_from = first_inst_index, ir_to = nr_of_functions} icl_functions e_info heaps cs @@ -2829,7 +2732,6 @@ checkModule {mod_type,mod_name,mod_imports,mod_imported_objects,mod_defs = cdefs (Yes symbol_type) = inst_def.fun_type = { instance_defs & [ds_index] = { inst_def & fun_type = Yes (makeElemTypeOfArrayFunctionStrict symbol_type ins_offset offset_table) } } -// MW.. check_needed_modules_are_imported mod_name extension e_info cs=:{cs_needed_modules} # (e_info, cs) = case cs_needed_modules bitand cNeedStdDynamics of 0 -> (e_info, cs) @@ -2852,7 +2754,6 @@ check_needed_modules_are_imported mod_name extension e_info cs=:{cs_needed_modul cs_error = checkError pds_ident "not imported" cs_error cs_error = popErrorAdmin cs_error = (e_info, { cs & cs_error = cs_error }) -// ..MW arrayFunOffsetToPD_IndexTable member_defs predef_symbols # nr_of_array_functions = size member_defs @@ -2963,7 +2864,6 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h dcl_common = createCommonDefinitions mod_defs dcl_macros = mod_defs.def_macros -// MW was (imports, modules, cs) = collect_imported_symbols mod_imports [] modules cs (imports, modules, cs) = collect_imported_symbols mod_imports [] modules { cs & cs_needed_modules = 0 } // imports :: [(Index,Declarations)] @@ -2997,7 +2897,7 @@ checkDclModule {mod_name,mod_imports,mod_defs} mod_index modules icl_functions h (icl_functions, e_info, heaps, cs) = checkMacros mod_index dcl_macros icl_functions e_info heaps { cs & cs_error = cs_error } - (e_info, cs) = check_needed_modules_are_imported mod_name ".dcl" e_info cs // MW ++ + (e_info, cs) = check_needed_modules_are_imported mod_name ".dcl" e_info cs com_instance_defs = dcl_common.com_instance_defs com_instance_defs = { inst_def \\ inst_def <- [ inst_def \\ inst_def <-: com_instance_defs ] ++ new_class_instances } diff --git a/frontend/general.icl b/frontend/general.icl index 83f854e..4db7f96 100644 --- a/frontend/general.icl +++ b/frontend/general.icl @@ -49,15 +49,17 @@ where (--->) infix :: .a !b -> .a | <<< b (--->) val message - | file_to_true (stderr <<< message <<< '\n') - = val - = abort "Internal error in --->" + | file_to_true (stderr <<< message <<< '\n') + = val + = abort "Internal error in --->" (-?->) infix :: .a !(!Bool, !b) -> .a | <<< b (-?->) val (cond, message) - | cond && file_to_true (stderr <<< message <<< '\n') - = val - = abort "Internal error in --->" + | cond + | file_to_true (stderr <<< message <<< '\n') + = val + = abort "Internal error in --->" + = val file_to_true :: !File -> Bool file_to_true file = code { diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 6b839b4..0e51e27 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -2,7 +2,7 @@ implementation module overloading import StdEnv -import syntax, check, type, typesupport, utilities, unitype, predef // , RWSDebug +import syntax, check, type, typesupport, utilities, unitype, predef, RWSDebug :: InstanceTree = IT_Node !(Global Index) !InstanceTree !InstanceTree | IT_Empty @@ -178,8 +178,8 @@ where # {ins_members, ins_class} = defs.[glob_module].com_instance_defs.[glob_object] | is_predefined_symbol ins_class.glob_module ins_class.glob_object.ds_index PD_ArrayClass predef_symbols && is_unboxed_array tc_types predef_symbols - # (rcs_class_context, special_instances, predef_symbols, error) - = check_unboxed_type glob_module ins_class ins_members tc_types class_members defs special_instances predef_symbols error + # (rcs_class_context, special_instances, (predef_symbols, type_heaps), error) + = check_unboxed_type glob_module ins_class ins_members tc_types class_members defs special_instances (predef_symbols, type_heaps) error = ({ rcs_class_context = rcs_class_context, rcs_constraints_contexts = []}, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) # (appls, special_instances, type_pattern_vars, type_heaps, coercion_env, predef_symbols, error) @@ -293,39 +293,40 @@ where is_unboxed_array _ predef_symbols = False - - check_unboxed_type ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols error - # (unboxable, opt_record, predef_symbols) = try_to_unbox elem_type defs predef_symbols + check_unboxed_type ins_module ins_class ins_members types=:[ _, elem_type :_] class_members defs special_instances predef_symbols_type_heaps error + # (unboxable, opt_record, predef_symbols_type_heaps) = try_to_unbox elem_type defs predef_symbols_type_heaps | unboxable = case opt_record of Yes record # (ins_members, special_instances) = add_record_to_array_instances record class_members special_instances -> ({ rc_class = ins_class, rc_inst_module = cIclModIndex, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, - special_instances, predef_symbols, error) + special_instances, predef_symbols_type_heaps, error) No -> ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, - special_instances, predef_symbols, error) + special_instances, predef_symbols_type_heaps, error) = ({ rc_class = ins_class, rc_inst_module = ins_module, rc_inst_members = ins_members, rc_red_contexts = [], rc_types = types }, - special_instances, predef_symbols, unboxError elem_type error) + special_instances, predef_symbols_type_heaps, unboxError elem_type error) where - try_to_unbox (TB _) _ predef_symbols - = (True, No, predef_symbols) - try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} _) defs predef_symbols - # {td_arity,td_rhs} = defs.[glob_module].com_type_defs.[glob_object] + try_to_unbox (TB _) _ predef_symbols_type_heaps + = (True, No, predef_symbols_type_heaps) + try_to_unbox (TA type_symb=:{type_index={glob_module,glob_object},type_arity} type_args) defs (predef_symbols, type_heaps) + # {td_arity,td_rhs, td_args} = defs.[glob_module].com_type_defs.[glob_object] = case td_rhs of RecordType _ - -> (True, (Yes type_symb), predef_symbols) + -> (True, (Yes type_symb), (predef_symbols, type_heaps)) AbstractType _ #! unboxable = is_predefined_symbol glob_module glob_object PD_LazyArrayType predef_symbols || is_predefined_symbol glob_module glob_object PD_StrictArrayType predef_symbols || is_predefined_symbol glob_module glob_object PD_UnboxedArrayType predef_symbols - -> (unboxable, No, predef_symbols) + -> (unboxable, No, (predef_symbols, type_heaps)) + SynType {at_type} + # (expanded_type, type_heaps) = expandTypeSyn td_args type_args at_type type_heaps + -> try_to_unbox expanded_type defs (predef_symbols, type_heaps) _ - -> (False, No, predef_symbols) - - try_to_unbox type _ predef_symbols - = (True, No, predef_symbols) + -> (False, No, (predef_symbols, type_heaps)) + try_to_unbox type _ predef_symbols_type_heaps + = (True, No, predef_symbols_type_heaps) add_record_to_array_instances :: !TypeSymbIdent !{# DefinedSymbol} !*SpecialInstances -> (!{#DefinedSymbol},!*SpecialInstances) add_record_to_array_instances record members special_instances=:{si_next_array_member_index,si_array_instances} @@ -411,18 +412,23 @@ addGlobalTCInstance type_of_TC (next_member_index, []) tryToExpandTypeSyn defs cons_id=:{type_name,type_index={glob_object,glob_module}} type_args type_heaps # {td_name,td_rhs,td_args} = defs.[glob_module].com_type_defs.[glob_object] - | is_synonym_type td_rhs - # (SynType {at_type}) = td_rhs - type_heaps = fold2St bind_var td_args type_args type_heaps - (expanded_type, type_heaps) = substitute at_type type_heaps - = (True, expanded_type, type_heaps) - = (False, TA cons_id type_args, type_heaps) + = case td_rhs of + SynType {at_type} + # (expanded_type, type_heaps) = expandTypeSyn td_args type_args at_type type_heaps + -> (True, expanded_type, type_heaps) + _ + -> (False, TA cons_id type_args, type_heaps) where is_synonym_type (SynType _) = True is_synonym_type type_rhs = False +expandTypeSyn td_args type_args td_rhs type_heaps + # type_heaps = fold2St bind_var td_args type_args type_heaps + (expanded_type, type_heaps) = substitute td_rhs type_heaps + = (expanded_type, type_heaps) +where bind_var {atv_attribute = TA_Var {av_info_ptr}, atv_variable={tv_info_ptr}} {at_attribute, at_type} type_heaps=:{th_vars,th_attrs} = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type at_type), th_attrs = th_attrs <:= (av_info_ptr, AVI_Attr at_attribute) } bind_var {atv_variable={tv_info_ptr}} {at_type} type_heaps=:{th_vars} @@ -529,6 +535,7 @@ where | isEmpty call_ptrs = (contexts, coercion_env, type_pattern_vars, os) # os = { os & os_error = setErrorAdmin location os_error } +// ---> ("try_to_solve_overloading", call_ptrs) = case fun_context of Yes specified_context # (_, coercion_env, type_pattern_vars, os) @@ -542,7 +549,10 @@ where reduce_and_simplify_contexts :: ![ExprInfoPtr] !{# CommonDefs } !ClassInstanceInfo !Bool ![TypeContext] !*Coercions ![LocalTypePatternVariable] !*OverloadingState -> (![TypeContext], !*Coercions, ![LocalTypePatternVariable], !*OverloadingState) reduce_and_simplify_contexts [over_info_ptr : ocs] defs instance_info has_context contexts coercion_env type_pattern_vars os=:{os_symbol_heap, os_type_heaps} - # (EI_Overloaded {oc_symbol, oc_context, oc_specials}, os_symbol_heap) = readPtr over_info_ptr os_symbol_heap + # (expr_info, os_symbol_heap) = readPtr over_info_ptr os_symbol_heap + {oc_symbol, oc_context, oc_specials} = case expr_info of + EI_Overloaded over_info -> over_info + _ -> abort ("reduce_and_simplify_contexts" <<- expr_info) (glob_fun, os_type_heaps) = trySpecializedInstances oc_context oc_specials os_type_heaps | FoundObject glob_fun # os_symbol_heap = os_symbol_heap <:= (over_info_ptr, EI_Instance {glob_module = glob_fun.glob_module, glob_object = @@ -1199,7 +1209,7 @@ where instance <<< (Ptr x) where - (<<<) file _ = file + (<<<) file ptr = file <<< '<' <<< ptrToInt ptr <<< '>' instance <<< TypeCodeExpression where diff --git a/frontend/refmark.icl b/frontend/refmark.icl index e78eb9e..a450ca2 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -130,7 +130,8 @@ where bind_variable {bind_src,bind_dst={fv_info_ptr}} var_heap # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap - = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src }) +// = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_bind = OB_OpenLet bind_src }) + = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet bind_src }) refMark free_vars sel (Case {case_expr,case_guards,case_default}) var_heap = refMarkOfCase free_vars sel case_expr case_guards case_default var_heap diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 613107a..7273de5 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -259,7 +259,7 @@ cIsNotAFunction :== False :: Import from_symbol = { import_module :: !Ident , import_symbols :: ![from_symbol] - , import_file_position:: !(!FileName, !Int) // for error messages // MW++ + , import_file_position:: !(!FileName, !Int) // for error messages } instance toString (Import from_symbol), AttributeVar, TypeAttribute, Annotation diff --git a/frontend/syntax.icl b/frontend/syntax.icl index ec091e6..72c7ca5 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -253,7 +253,7 @@ cIsNotAFunction :== False :: Import from_symbol = { import_module :: !Ident , import_symbols :: ![from_symbol] - , import_file_position:: !(!FileName, !Int) // for error messages // MW++ + , import_file_position:: !(!FileName, !Int) // for error messages } :: ParsedImport :== Import ImportDeclaration @@ -1328,8 +1328,9 @@ where instance <<< Expression where (<<<) file (Var ident) = file <<< ident - (<<<) file (App {app_symb, app_args}) - = file <<< app_symb <<< ' ' <<< app_args + (<<<) file (App {app_symb, app_args, app_info_ptr}) +// = file <<< app_symb <<< ' ' <<< app_args + = file <<< app_symb <<< " <" <<< ptrToInt app_info_ptr <<< "> " <<< app_args (<<<) file (f_exp @ a_exp) = file <<< '(' <<< f_exp <<< " @ " <<< a_exp <<< ')' (<<<) file (Let {let_info_ptr, let_binds, let_expr}) = write_binds (file <<< "let" <<< '\n') let_binds <<< "in\n" <<< let_expr where diff --git a/frontend/transform.icl b/frontend/transform.icl index 917e08c..75e0487 100644 --- a/frontend/transform.icl +++ b/frontend/transform.icl @@ -267,24 +267,28 @@ where unfold expr us = (expr, us) +/* Sjaak ... */ instance unfold Selection where - unfold (ArraySelection array_select expr_ptr index_expr) us - # (index_expr, us) = unfold index_expr us - = (ArraySelection array_select expr_ptr index_expr, us) - unfold (DictionarySelection var selectors expr_ptr index_expr) us - # (index_expr, us) = unfold index_expr us + unfold (ArraySelection array_select expr_ptr index_expr) us=:{us_symbol_heap} + # (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap + (index_expr, us) = unfold index_expr { us & us_symbol_heap = us_symbol_heap} + = (ArraySelection array_select new_ptr index_expr, us) + unfold (DictionarySelection var selectors expr_ptr index_expr) us=:{us_symbol_heap} + # (new_ptr, us_symbol_heap) = newPtr EI_Empty us_symbol_heap + (index_expr, us) = unfold index_expr { us & us_symbol_heap = us_symbol_heap} (var_expr, us) = unfoldVariable var us = case var_expr of App {app_symb={symb_kind= SK_Constructor _ }, app_args} # [RecordSelection _ field_index:_] = selectors (App { app_symb = {symb_name, symb_kind = SK_Function array_select}}) = app_args !! field_index -> (ArraySelection { array_select & glob_object = { ds_ident = symb_name, ds_arity = 2, ds_index = array_select.glob_object}} - expr_ptr index_expr, us) + new_ptr index_expr, us) Var var - -> (DictionarySelection var selectors expr_ptr index_expr, us) + -> (DictionarySelection var selectors new_ptr index_expr, us) unfold record_selection ls = (record_selection, ls) +/* ... Sjaak */ instance unfold FreeVar where @@ -308,20 +312,6 @@ where _ -> (nilPtr, us) (app_args, us) = unfold app_args us = ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us) -/* - unfold app=:{app_symb, app_args, app_info_ptr} us=:{us_symbol_heap} - # (new_info_ptr, us_symbol_heap) - = case is_function_or_macro app_symb.symb_kind of - True -> newPtr EI_Empty us_symbol_heap - _ -> case (app_symb.symb_kind, isNilPtr app_info_ptr) of - (SK_Constructor _, False) - # (app_info, us_symbol_heap) = readPtr app_info_ptr us_symbol_heap - -> newPtr app_info us_symbol_heap - _ -> (nilPtr, us_symbol_heap) - us = { us & us_symbol_heap = us_symbol_heap } - (app_args, us) = unfold app_args us - = ({ app & app_args = app_args, app_info_ptr = new_info_ptr}, us) -*/ where is_function_or_macro (SK_Function _) = True @@ -331,6 +321,7 @@ where = True is_function_or_macro _ = False + substitute_EI_ClassTypes (EI_ClassTypes class_types) (Yes type_heaps) # (new_class_types, type_heaps) = substitute class_types type_heaps = (EI_ClassTypes new_class_types, Yes type_heaps) @@ -694,7 +685,8 @@ where = expandMacrosInBody fun_info.fi_calls body fun_and_macro_defs mod_index modules { es & es_error = setErrorAdmin identPos es.es_error } fun_def = { fun_def & fun_body = TransformedBody { tb_args = tb_args, tb_rhs = tb_rhs}, fun_info = { fun_info & fi_calls = fi_calls, fi_local_vars = fi_local_vars }} - = ({ fun_and_macro_defs & [fun_index] = fun_def }, modules, es) + = ({ fun_and_macro_defs & [fun_index] = fun_def }, modules, es) +// ---> ("expand_macros", fun_symb, tb_args, tb_rhs) addFunctionCallsToSymbolTable calls fun_defs symbol_table = foldSt add_function_call_to_symbol_table calls ([], fun_defs, symbol_table) @@ -721,12 +713,12 @@ expandMacrosInBody fi_calls {cb_args,cb_rhs} fun_defs mod_index modules es=:{es_ ([rhs:rhss], fun_defs, modules, (all_calls, es)) = expand cb_rhs fun_defs mod_index modules (prev_calls, { es & es_symbol_table = es_symbol_table }) (fun_defs, es_symbol_table) = removeFunctionCallsFromSymbolTable all_calls fun_defs es.es_symbol_table (merge_rhs, es_var_heap, es_symbol_heap, es_error) = mergeCases rhs rhss es.es_var_heap es.es_symbol_heap es.es_error - (merge_rhs, cb_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) = determineVariablesAndRefCounts cb_args merge_rhs // (merge_rhs ---> (cb_args, merge_rhs)) + (merge_rhs, new_args, local_vars, {cos_error, cos_var_heap, cos_symbol_heap}) = determineVariablesAndRefCounts cb_args merge_rhs { cos_error = es_error, cos_var_heap = es_var_heap, cos_symbol_heap = es_symbol_heap } - = (cb_args, merge_rhs, local_vars, all_calls, fun_defs, modules, + = (new_args, merge_rhs, local_vars, all_calls, fun_defs, modules, { es & es_error = cos_error, es_var_heap = cos_var_heap, es_symbol_heap = cos_symbol_heap, es_symbol_table = es_symbol_table }) -// ---> (cb_args, local_vars, merge_rhs) +// ---> (cb_args, cb_rhs, new_args, local_vars, merge_rhs) cContainsFreeVars :== True cContainsNoFreeVars :== False diff --git a/frontend/type.icl b/frontend/type.icl index 030773d..8ad360d 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -809,9 +809,14 @@ class requirements a :: !TypeInput !a !(!u:Requirements, !*TypeState) -> (!AType instance requirements BoundVar where - requirements ti {var_info_ptr,var_expr_ptr} (reqs, ts) - # (VI_Type type, ts_var_heap) = readPtr var_info_ptr ts.ts_var_heap - = (type, Yes var_expr_ptr, (reqs, { ts & ts_var_heap = ts_var_heap })) + requirements ti {var_name,var_info_ptr,var_expr_ptr} (reqs, ts) + # (var_info, ts_var_heap) = readPtr var_info_ptr ts.ts_var_heap + ts = { ts & ts_var_heap = ts_var_heap } + = case var_info of + VI_Type type + -> (type, Yes var_expr_ptr, (reqs, ts)) + _ + -> abort ("requirements BoundVar" ---> (var_name <<- var_info)) instance requirements App where @@ -1480,10 +1485,20 @@ where # funs_and_state = type_component comp.group_members class_instances ti funs_and_state = type_components (inc group_index) comps class_instances ti funs_and_state + show_component comp fun_defs + = foldSt show_fun comp ([], fun_defs) + where + show_fun fun_index (names, fun_defs) + # ({fun_symb}, fun_defs) = fun_defs![fun_index] + = ([fun_symb : names], fun_defs) + + 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) - (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs 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 ---> names) #! nr_of_type_variables = ts.ts_var_store + # (subst, ts_type_heaps, ts_error) = unify_requirements_of_functions fun_reqs ti (createArray nr_of_type_variables TE) ts.ts_type_heaps ts.ts_error | not ts_error.ea_ok @@ -1680,7 +1695,7 @@ where = ({fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No, fe_requirements = { rhs_reqs & req_type_coercions = req_type_coercions, req_cons_variables = [] }}, (rhs_reqs.req_cons_variables, fun_defs, { ts & ts_expr_heap = ts_expr_heap })) - // ---> ("type_function", fun_symb) +// ---> ("type_function", fun_symb, tb_args, tb_rhs, fun_info.fi_local_vars) where has_option (Yes _) = True has_option No = False diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 7fdac81..84e5344 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -136,7 +136,7 @@ instance cleanUpClosed AType where cleanUpClosed atype=:{at_type} env # (ok, at_type, env) = cleanUpClosed at_type env - = (ok, { atype & at_type = at_type}, env) + = (ok, { atype & at_attribute = TA_Multi, at_type = at_type}, env) instance cleanUpClosed Type where @@ -310,8 +310,8 @@ where update_expression_types :: !CleanUpInput ![ExprInfoPtr] !*ExpressionHeap !*CleanUpState -> (!*ExpressionHeap,!*CleanUpState); update_expression_types cui expr_ptrs expr_heap cus - = (expr_heap, cus) -// = foldSt (update_expression_type cui) expr_ptrs (expr_heap, cus) +// = (expr_heap, cus) + = foldSt (update_expression_type cui) expr_ptrs (expr_heap, cus) update_expression_type cui expr_ptr (expr_heap, cus) # (info, expr_heap) = readPtr expr_ptr expr_heap diff --git a/frontend/unitype.icl b/frontend/unitype.icl index cf204be..bb9302b 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -14,7 +14,7 @@ AttrUni :== 0 AttrMulti :== 1 FirstAttrVar :== 2 -:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique /* | CT_Existential !Int */ +:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique :: Coercions = { coer_demanded :: !.{! .CoercionTree}, coer_offered :: !.{! .CoercionTree }} @@ -74,6 +74,7 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions -> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error) -> undef */ + NotChecked :== -1 DummyAttrNumber :== -1 :: AttributeGroups :== {! [Int]} @@ -152,9 +153,7 @@ where combine_coercion_trees group_index [ attr : attrs ] partition merged_tree coer_offered coer_demanded | isNonUnique coer_offered.[attr] = (CT_NonUnique, coer_demanded) -/* | isExistential coer_offered.[attr] - = (CT_Existential DummyAttrNumber, coer_demanded) -*/ # (next_tree, coer_demanded) = replace coer_demanded attr CT_Empty + # (next_tree, coer_demanded) = replace coer_demanded attr CT_Empty | isUnique next_tree = (CT_Unique, coer_demanded) # merged_tree = rebuild_tree group_index partition next_tree merged_tree @@ -206,7 +205,7 @@ adjustSignClass :: !SignClassification !Int -> SignClassification adjustSignClass {sc_pos_vect,sc_neg_vect} arity = { sc_pos_vect = sc_pos_vect >> arity, sc_neg_vect = sc_neg_vect >> arity } -// adjustPropClass :: !PropClassification !Int -> PropClassification +//adjustPropClass :: !PropClassification !Int -> PropClassification adjustPropClass prop_class arity :== prop_class >> arity :: LiftState = @@ -372,7 +371,6 @@ instance toInt TypeAttribute where toInt TA_Unique = AttrUni toInt (TA_TempVar av_number) = av_number -// toInt (TA_TempExVar av_number) = av_number toInt TA_Multi = AttrMulti toInt TA_None = AttrMulti @@ -526,7 +524,7 @@ where tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions) tryToMakeUnique attr coercions=:{coer_offered} - | isNonUnique coer_offered.[attr] // || isExistential coer_offered.[attr] + | isNonUnique coer_offered.[attr] = (False, coercions) = (True, makeUnique attr coercions) @@ -547,7 +545,9 @@ where tryToMakeNonUnique :: !Int !*Coercions -> (!Bool, !*Coercions) tryToMakeNonUnique attr coercions=:{coer_demanded} - | isUnique coer_demanded.[attr] // || isExistential coer_demanded.[attr] + #! s = size coer_demanded + | isUnique coer_demanded.[attr + -?-> (s <= attr, ("tryToMakeNonUnique", s, attr))] = (False, coercions) = (True, makeNonUnique attr coercions) // ---> ("tryToMakeNonUnique", attr) @@ -697,7 +697,6 @@ where (<<<) file (CT_Node attr left right) = file <<< left <<< ' ' <<< attr <<< ' ' <<< right (<<<) file CT_Unique = file <<< "CT_Unique" (<<<) file CT_NonUnique = file <<< "CT_NonUnique" -// (<<<) file (CT_Existential int) = file <<< "CT_Existential:" <<< int (<<<) file CT_Empty = file <<< "##" instance <<< CoercionPosition |