diff options
| -rw-r--r-- | frontend/check.icl | 56 | ||||
| -rw-r--r-- | frontend/checkFunctionBodies.icl | 6 | ||||
| -rw-r--r-- | frontend/checksupport.icl | 2 | ||||
| -rw-r--r-- | frontend/checktypes.dcl | 9 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 187 | ||||
| -rw-r--r-- | frontend/comparedefimp.icl | 3 | ||||
| -rw-r--r-- | frontend/convertDynamics.icl | 2 | ||||
| -rw-r--r-- | frontend/convertcases.icl | 26 | ||||
| -rw-r--r-- | frontend/frontend.icl | 2 | ||||
| -rw-r--r-- | frontend/generics.icl | 3 | ||||
| -rw-r--r-- | frontend/overloading.icl | 32 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 21 | ||||
| -rw-r--r-- | frontend/syntax.icl | 10 | ||||
| -rw-r--r-- | frontend/trans.dcl | 2 | ||||
| -rw-r--r-- | frontend/trans.icl | 106 | ||||
| -rw-r--r-- | frontend/type.icl | 3 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 3 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 64 |
18 files changed, 333 insertions, 204 deletions
diff --git a/frontend/check.icl b/frontend/check.icl index a7b5538..bdbb68b 100644 --- a/frontend/check.icl +++ b/frontend/check.icl @@ -32,9 +32,10 @@ checkGenerics # cs = {cs & cs_error = cs_error, cs_symbol_table = cs_symbol_table } # type_heaps = {type_heaps & th_vars = th_vars} +/* # (gen_type, specials, type_defs, class_defs, modules, type_heaps, cs) = checkSymbolType module_index gen_type SP_None type_defs class_defs modules type_heaps cs - +*/ # cs = {cs & cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope gen_args cs.cs_symbol_table} # generic_defs = {generic_defs & [gen_index] = {gen_def & gen_type = gen_type, gen_args = gen_args}} @@ -57,41 +58,17 @@ where checkTypeClasses :: !Index !Index !*{#ClassDef} !*{#MemberDef} !*{#CheckedTypeDef} !*{#DclModule} !*TypeHeaps !*CheckState -> (!*{#ClassDef}, !*{#MemberDef}, !*{#CheckedTypeDef}, !*{#DclModule}, !*TypeHeaps, !*CheckState) -checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps=:{th_vars} cs=:{cs_symbol_table,cs_error} +checkTypeClasses class_index module_index class_defs member_defs type_defs modules type_heaps cs=:{cs_symbol_table,cs_error} | class_index == size class_defs = (class_defs, member_defs, type_defs, modules, type_heaps, cs) # (class_def=:{class_name,class_pos,class_args,class_context,class_members}, class_defs) = class_defs![class_index] - position = newPosition class_name class_pos - cs_error = setErrorAdmin position cs_error - (rev_class_args, cs_symbol_table, th_vars, cs_error) - = add_variables_to_symbol_table cGlobalScope class_args [] cs_symbol_table th_vars cs_error - cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } - (class_context, type_defs, class_defs, modules, type_heaps, cs) - = checkTypeContexts class_context module_index type_defs class_defs modules { type_heaps & th_vars = th_vars } cs - (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table + cs = {cs & cs_error = setErrorAdmin (newPosition class_name class_pos) cs_error } + (class_args, class_context, type_defs, class_defs, modules, type_heaps, cs) + = checkSuperClasses class_args class_context module_index type_defs class_defs modules type_heaps cs class_defs = { class_defs & [class_index] = { class_def & class_context = class_context, class_args = class_args }} member_defs = set_classes_in_member_defs 0 class_members {glob_object = class_index, glob_module = module_index} member_defs - = checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps { cs & cs_symbol_table = cs_symbol_table } + = checkTypeClasses (inc class_index) module_index class_defs member_defs type_defs modules type_heaps cs where - add_variables_to_symbol_table :: !Level ![TypeVar] ![TypeVar] !*SymbolTable !*TypeVarHeap !*ErrorAdmin - -> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin) - add_variables_to_symbol_table level [] rev_class_args symbol_table th_vars error - = (rev_class_args, symbol_table, th_vars, error) - add_variables_to_symbol_table level [var=:{tv_name={id_name,id_info}} : vars] rev_class_args symbol_table th_vars error - # (entry, symbol_table) = readPtr id_info symbol_table - | entry.ste_kind == STE_Empty || entry.ste_def_level < level - # (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars - # symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex level entry - = add_variables_to_symbol_table level vars [{ var & tv_info_ptr = new_var_ptr} : rev_class_args] symbol_table th_vars error - = add_variables_to_symbol_table level vars rev_class_args symbol_table th_vars (checkError id_name "(variable) already defined" error) - - retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable) - retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table - # (entry, symbol_table) = readPtr id_info symbol_table - = retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous)) - retrieve_variables_from_symbol_table [] class_args symbol_table - = (class_args, symbol_table) - set_classes_in_member_defs mem_offset class_members glob_class_index member_defs | mem_offset == size class_members = member_defs @@ -99,7 +76,6 @@ where # (member_def, member_defs) = member_defs![ds_index] = set_classes_in_member_defs (inc mem_offset) class_members glob_class_index { member_defs & [ds_index] = { member_def & me_class = glob_class_index }} - checkSpecial :: !Index !FunType !Index !SpecialSubstitution (!Index, ![FunType], !*Heaps, !*ErrorAdmin) -> (!Special, (!Index, ![FunType], !*Heaps, !*ErrorAdmin)) checkSpecial mod_index fun_type=:{ft_type} fun_index subst (next_inst_index, special_types, heaps, error) @@ -131,7 +107,7 @@ where # position = newPosition ft_symb ft_pos cs = { cs & cs_error = setErrorAdmin position cs.cs_error } (ft_type, ft_specials, type_defs, class_defs, modules, hp_type_heaps, cs) - = checkSymbolType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs + = checkFunctionType module_index ft_type ft_specials type_defs class_defs modules heaps.hp_type_heaps cs (spec_types, next_inst_index, collected_instances, heaps, cs_error) = check_specials module_index { fun_type & ft_type = ft_type } fun_index ft_specials next_inst_index collected_instances { heaps & hp_type_heaps = hp_type_heaps } cs.cs_error @@ -198,13 +174,13 @@ where # (member_def=:{me_symb,me_type,me_pos}, member_defs) = member_defs![member_index] position = newPosition me_symb me_pos cs = { cs & cs_error = setErrorAdmin position cs.cs_error } - (me_type, _, type_defs, class_defs, modules, type_heaps, cs) - = checkSymbolType module_index me_type SP_None type_defs class_defs modules type_heaps cs - me_class_vars = map (\(TV type_var) -> type_var) (hd me_type.st_context).tc_types + (me_type, type_defs, class_defs, modules, type_heaps, cs) + = checkMemberType module_index me_type type_defs class_defs modules type_heaps cs + me_class_vars = [ type_var \\ (TV type_var) <- (hd me_type.st_context).tc_types ] (me_type_ptr, var_heap) = newPtr VI_Empty var_heap = ({ member_defs & [member_index] = { member_def & me_type = me_type, me_class_vars = me_class_vars, me_type_ptr = me_type_ptr }}, type_defs, class_defs, modules, type_heaps, var_heap, cs) - + :: InstanceSymbols = { is_type_defs :: !.{# CheckedTypeDef} , is_class_defs :: !.{# ClassDef} @@ -696,8 +672,9 @@ checkFunction mod_index fun_index def_level fun_defs (ef_type_defs, ef_modules, es_type_heaps, es_expr_heap, cs) = checkDynamicTypes mod_index es_dynamics fun_type e_info.ef_type_defs e_info.ef_modules es_type_heaps es_expr_heap cs cs = { cs & cs_error = popErrorAdmin cs.cs_error } + fi_properties = (if ef_is_macro_fun FI_IsMacroFun 0) bitor (has_type fun_type) fun_info = { fun_def.fun_info & fi_calls = es_calls, fi_def_level = def_level, fi_free_vars = free_vars, fi_dynamics = es_dynamics, - fi_is_macro_fun = ef_is_macro_fun } + fi_properties = fi_properties } fun_defs = { es_fun_defs & [fun_index] = { fun_def & fun_body = fun_body, fun_index = fun_index, fun_info = fun_info, fun_type = fun_type}} (fun_defs, cs_symbol_table) = remove_calls_from_symbol_table fun_index def_level es_calls fun_defs cs.cs_symbol_table = (fun_defs, @@ -706,8 +683,11 @@ checkFunction mod_index fun_index def_level fun_defs { cs & cs_symbol_table = cs_symbol_table }) where + has_type (Yes _) = FI_HasTypeSpec + has_type no = 0 + check_function_type (Yes ft) module_index type_defs class_defs modules var_heap type_heaps cs - # (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkSymbolType module_index ft SP_None type_defs class_defs modules type_heaps cs + # (ft, _, type_defs, class_defs, modules, type_heaps, cs) = checkFunctionType module_index ft SP_None type_defs class_defs modules type_heaps cs (st_context, var_heap) = initializeContextVariables ft.st_context var_heap = (Yes { ft & st_context = st_context } , type_defs, class_defs, modules, var_heap, type_heaps, cs) diff --git a/frontend/checkFunctionBodies.icl b/frontend/checkFunctionBodies.icl index 8c4840a..cb54608 100644 --- a/frontend/checkFunctionBodies.icl +++ b/frontend/checkFunctionBodies.icl @@ -959,12 +959,12 @@ where -> (!SymbKind, !Int, !Priority, !Bool, !*ExpressionState, !u:ExpressionInfo,!*CheckState) determine_info_of_symbol entry=:{ste_kind=STE_FunctionOrMacro calls,ste_index,ste_def_level} symb_info e_input=:{ei_fun_index, ei_mod_index} e_state=:{es_fun_defs,es_calls} e_info cs=:{cs_symbol_table,cs_x} - # ({fun_symb,fun_arity,fun_kind,fun_priority,fun_info}, es_fun_defs) = es_fun_defs![ste_index] + # ({fun_symb,fun_arity,fun_kind,fun_priority,fun_info={fi_properties}}, es_fun_defs) = es_fun_defs![ste_index] # index = { glob_object = ste_index, glob_module = cs_x.x_main_dcl_module_n } | is_called_before ei_fun_index calls | case fun_kind of FK_DefMacro->True ; FK_ImpMacro->True; _ -> False = (SK_Macro index, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, e_info, cs) - # symbol_kind = if fun_info.fi_is_macro_fun (SK_LocalMacroFunction ste_index) (SK_Function index) + # symbol_kind = if (fi_properties bitand FI_IsMacroFun <> 0) (SK_LocalMacroFunction ste_index) (SK_Function index) = (symbol_kind, fun_arity, fun_priority, cIsAFunction, { e_state & es_fun_defs = es_fun_defs }, 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_fun_defs = es_fun_defs, es_calls = [{ fc_index = ste_index, fc_level = ste_def_level} : es_calls ]} @@ -974,7 +974,7 @@ where FK_ImpMacro -> SK_Macro index; _ - | fun_info.fi_is_macro_fun + | fi_properties bitand FI_IsMacroFun <> 0 -> SK_LocalMacroFunction ste_index -> SK_Function index = (symbol_kind, fun_arity, fun_priority, cIsAFunction, e_state, e_info, cs) diff --git a/frontend/checksupport.icl b/frontend/checksupport.icl index 1a90e9f..a45c9e4 100644 --- a/frontend/checksupport.icl +++ b/frontend/checksupport.icl @@ -308,7 +308,7 @@ addLocalFunctionDefsToSymbolTable level from_index to_index is_macro_fun fun_def # (fun_def, fun_defs) = fun_defs![from_index] # (symbol_table, error) = addDefToSymbolTable level from_index fun_def.fun_symb (STE_FunctionOrMacro []) symbol_table error | is_macro_fun - # fun_defs = {fun_defs & [from_index].fun_info.fi_is_macro_fun=is_macro_fun} + # fun_defs = {fun_defs & [from_index].fun_info.fi_properties = fun_def.fun_info.fi_properties bitor FI_IsMacroFun } = addLocalFunctionDefsToSymbolTable level (inc from_index) to_index is_macro_fun fun_defs symbol_table error = addLocalFunctionDefsToSymbolTable level (inc from_index) to_index is_macro_fun fun_defs symbol_table error diff --git a/frontend/checktypes.dcl b/frontend/checktypes.dcl index 2f45848..475b8a1 100644 --- a/frontend/checktypes.dcl +++ b/frontend/checktypes.dcl @@ -5,15 +5,18 @@ import checksupport, typesupport checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) -checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState +checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) -checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState - -> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) checkInstanceType :: !Index !(Global DefinedSymbol) !InstanceType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState -> (!InstanceType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) + checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 9996352..cfa64cf 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -674,15 +674,16 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de = check_fully_polymorphity it_types it_context cs.cs_error ots = { ots_type_defs = type_defs, ots_modules = modules } oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] } - (it_types, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error }) - (it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs - cs_error - = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error + (it_types, (ots, oti=:{oti_all_vars = it_vars, oti_all_attrs = it_attr_vars}, cs)) + = checkOpenTypes mod_index cGlobalScope DAK_None it_types (ots, oti, { cs & cs_error = cs_error }) + oti = { oti & oti_all_vars = [], oti_all_attrs = [] } + (it_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts it_context mod_index class_defs ots oti cs + cs_error = foldSt (compare_context_and_instance_types ins_class it_types) it_context cs.cs_error (specials, cs) = checkSpecialTypeVars specials { cs & cs_error = cs_error } - cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table - cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope it_vars cs.cs_symbol_table + cs_symbol_table = removeAttributesFromSymbolTable it_attr_vars cs_symbol_table (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table } - = ({it & it_vars = oti_all_vars, it_types = it_types, it_attr_vars = oti_all_attrs, it_context = it_context }, + = ({it & it_vars = it_vars, it_types = it_types, it_attr_vars = it_attr_vars, it_context = it_context }, specials, type_defs, class_defs, modules, heaps, cs) where check_fully_polymorphity it_types it_context cs_error @@ -715,32 +716,37 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de compare_context_and_instance_type _ _ are_equal_accu = False +checkFunctionType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkFunctionType mod_index st specials type_defs class_defs modules heaps cs + = checkSymbolType True mod_index st specials type_defs class_defs modules heaps cs + +checkMemberType :: !Index !SymbolType !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (!SymbolType, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkMemberType mod_index st type_defs class_defs modules heaps cs + # (checked_st, specials, type_defs, class_defs, modules, heaps, cs) + = checkSymbolType False mod_index st SP_None type_defs class_defs modules heaps cs + = (checked_st, type_defs, class_defs, modules, heaps, cs) -checkSymbolType :: !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState +checkSymbolType :: !Bool !Index !SymbolType !Specials !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState -> (!SymbolType, !Specials, !u:{# CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) -checkSymbolType mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs +checkSymbolType is_function mod_index st=:{st_args,st_result,st_context,st_attr_env} specials type_defs class_defs modules heaps cs # ots = { ots_type_defs = type_defs, ots_modules = modules } oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars= [] } (st_args, cot_state) = checkOpenATypes mod_index cGlobalScope st_args (ots, oti, cs) - (st_result, (ots, {oti_heaps,oti_all_vars,oti_all_attrs}, cs)) = checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state - (st_context, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts st_context mod_index ots.ots_type_defs class_defs ots.ots_modules oti_heaps cs - (st_attr_env, cs) = check_attr_inequalities st_attr_env cs + (st_result, (ots, oti=:{oti_all_vars = st_vars,oti_all_attrs = st_attr_vars}, cs)) + = checkOpenAType mod_index cGlobalScope DAK_None st_result cot_state + oti = { oti & oti_all_vars = [], oti_all_attrs = [] } + (st_context, type_defs, class_defs, modules, heaps, cs) = check_type_contexts is_function st_context mod_index class_defs ots oti cs + (st_attr_env, cs) = mapSt check_attr_inequality st_attr_env cs (specials, cs) = checkSpecialTypeVars specials cs - cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope oti_all_vars cs.cs_symbol_table - cs_symbol_table = removeAttributesFromSymbolTable oti_all_attrs cs_symbol_table + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope st_vars cs.cs_symbol_table + cs_symbol_table = removeAttributesFromSymbolTable st_attr_vars cs_symbol_table (specials, type_defs, modules, heaps, cs) = checkSpecialTypes mod_index specials type_defs modules heaps { cs & cs_symbol_table = cs_symbol_table } - checked_st = {st & st_vars = oti_all_vars, st_args = st_args, st_result = st_result, st_context = st_context, - st_attr_vars = oti_all_attrs, st_attr_env = st_attr_env } + checked_st = {st & st_vars = st_vars, st_args = st_args, st_result = st_result, st_context = st_context, + st_attr_vars = st_attr_vars, st_attr_env = st_attr_env } = (checked_st, specials, type_defs, class_defs, modules, heaps, cs) - // ---> ("checkSymbolType", st, checked_st) where - check_attr_inequalities [ineq : ineqs] cs - # (ineq, cs) = check_attr_inequality ineq cs - (ineqs, cs) = check_attr_inequalities ineqs cs - = ([ineq : ineqs], cs) - check_attr_inequalities [] cs - = ([], cs) - check_attr_inequality ineq=:{ai_demanded=ai_demanded=:{av_name=dem_name},ai_offered=ai_offered=:{av_name=off_name}} cs=:{cs_symbol_table,cs_error} # (dem_entry, cs_symbol_table) = readPtr dem_name.id_info cs_symbol_table # (found_dem_attr, dem_attr_ptr) = retrieve_attribute dem_entry @@ -752,46 +758,75 @@ where { cs & cs_symbol_table = cs_symbol_table }) = (ineq, { cs & cs_error = checkError off_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table }) = (ineq, { cs & cs_error = checkError dem_name "attribute variable undefined" cs_error, cs_symbol_table = cs_symbol_table }) - - retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index} - | ste_def_level == cGlobalScope - = (True, attr_ptr) - retrieve_attribute entry - = (False, abort "no attribute") - -checkTypeContexts :: ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState - -> (![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) -checkTypeContexts [tc : tcs] mod_index type_defs class_defs modules heaps cs - # (tc, type_defs, class_defs, modules, heaps, cs) = check_type_context tc mod_index type_defs class_defs modules heaps cs - (tcs, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts tcs mod_index type_defs class_defs modules heaps cs - = ([tc : tcs], type_defs, class_defs, modules, heaps, cs) + where + retrieve_attribute {ste_kind = STE_TypeAttribute attr_ptr, ste_def_level, ste_index} + | ste_def_level == cGlobalScope + = (True, attr_ptr) + retrieve_attribute entry + = (False, abort "no attribute") + + check_type_contexts is_function st_context mod_index class_defs ots oti cs + | is_function + = checkTypeContexts st_context mod_index class_defs ots oti cs + = check_member_contexts st_context mod_index class_defs ots oti cs + + check_member_contexts [tc : tcs] mod_index class_defs ots oti cs + # (tc, (class_defs, ots, oti, cs)) = checkTypeContext mod_index tc (class_defs, ots, oti, cs) + cs_symbol_table = removeVariablesFromSymbolTable cGlobalScope [ tv \\ (TV tv) <- tc.tc_types] cs.cs_symbol_table + (tcs, type_defs, class_defs, modules, heaps, cs) = checkTypeContexts tcs mod_index class_defs ots oti { cs & cs_symbol_table = cs_symbol_table } + = ([tc : tcs], type_defs, class_defs, modules, heaps, cs) + +NewEntry symbol_table symb_ptr def_kind def_index level previous :== + symbol_table <:= (symb_ptr,{ ste_kind = def_kind, ste_index = def_index, ste_def_level = level, ste_previous = previous }) + +checkSuperClasses :: ![TypeVar] ![TypeContext] !Index !u:{# CheckedTypeDef} !v:{# ClassDef} !u:{# DclModule} !*TypeHeaps !*CheckState + -> (![TypeVar], ![TypeContext], !u:{#CheckedTypeDef}, !v:{# ClassDef}, !u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkSuperClasses class_args class_contexts mod_index type_defs class_defs modules heaps=:{th_vars} cs=:{cs_symbol_table,cs_error} + # (rev_class_args, cs_symbol_table, th_vars, cs_error) + = foldSt add_variable_to_symbol_table class_args ([], cs_symbol_table, th_vars, cs_error) + cs = {cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error } + ots = { ots_modules = modules, ots_type_defs = type_defs } + oti = { oti_heaps = { heaps & th_vars = th_vars }, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] } + (class_contexts, type_defs, class_defs, modules, type_heaps, cs) + = checkTypeContexts class_contexts mod_index class_defs ots oti cs + (class_args, cs_symbol_table) = retrieve_variables_from_symbol_table rev_class_args [] cs.cs_symbol_table + = (class_args, class_contexts, type_defs, class_defs, modules, type_heaps, {cs & cs_symbol_table = cs_symbol_table}) where - - check_type_context :: !TypeContext !Index v:{#CheckedTypeDef} !x:{#ClassDef} !u:{#.DclModule} !*TypeHeaps !*CheckState - -> (!TypeContext,!z:{#CheckedTypeDef},!x:{#ClassDef},!w:{#DclModule},!*TypeHeaps,!*CheckState), [u v <= w, v u <= z] - check_type_context tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} - mod_index type_defs class_defs modules heaps cs=:{cs_symbol_table, cs_predef_symbols} - # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table - cs = { cs & cs_symbol_table = cs_symbol_table } - # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index - | class_index <> NotFound - # (class_def, class_index, class_defs, modules) = getClassDef class_index class_module mod_index class_defs modules - ots = { ots_modules = modules, ots_type_defs = type_defs } - oti = { oti_heaps = heaps, oti_all_vars = [], oti_all_attrs = [], oti_global_vars = [] } - (tc_types, (ots, {oti_all_vars,oti_all_attrs,oti_heaps}, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) - cs = check_context_types class_def.class_name tc_types cs - cs = foldr (\ {tv_name} cs=:{cs_symbol_table,cs_error} -> - { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table, - cs_error = checkError tv_name " undefined" cs_error}) cs oti_all_vars - cs = foldr (\ {av_name} cs=:{cs_symbol_table,cs_error} -> - { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table, - cs_error = checkError av_name " undefined" cs_error}) cs oti_all_attrs - tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} - | class_def.class_arity == ds_arity - = (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, cs) - = (tc, ots.ots_type_defs, class_defs, ots.ots_modules, oti_heaps, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error }) - = (tc, type_defs, class_defs, modules, heaps, { cs & cs_error = checkError id_name "undefined" cs.cs_error }) - + add_variable_to_symbol_table :: !TypeVar !(![TypeVar], !*SymbolTable, !*TypeVarHeap, !*ErrorAdmin) + -> (![TypeVar],!*SymbolTable,!*TypeVarHeap,!*ErrorAdmin) + add_variable_to_symbol_table tv=:{tv_name={id_name,id_info}} (rev_class_args, symbol_table, th_vars, error) + # (entry, symbol_table) = readPtr id_info symbol_table + | entry.ste_kind == STE_Empty || entry.ste_def_level < cGlobalScope + # (new_var_ptr, th_vars) = newPtr TVI_Empty th_vars + # symbol_table = NewEntry symbol_table id_info (STE_TypeVariable new_var_ptr) NoIndex cGlobalScope entry + = ([{ tv & tv_info_ptr = new_var_ptr} : rev_class_args], symbol_table, th_vars, error) + = (rev_class_args, symbol_table, th_vars, checkError id_name "(variable) already defined" error) + + retrieve_variables_from_symbol_table :: ![TypeVar] ![TypeVar] !*SymbolTable -> (![TypeVar],!*SymbolTable) + retrieve_variables_from_symbol_table [var=:{tv_name={id_name,id_info}} : vars] class_args symbol_table + # (entry, symbol_table) = readPtr id_info symbol_table + = retrieve_variables_from_symbol_table vars [var : class_args] (symbol_table <:= (id_info,entry.ste_previous)) + retrieve_variables_from_symbol_table [] class_args symbol_table + = (class_args, symbol_table) + +checkTypeContext :: !Index !TypeContext !(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) + -> (!TypeContext,!(!v:{# ClassDef}, !u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) +checkTypeContext mod_index tc=:{tc_class=tc_class=:{glob_object=class_name=:{ds_ident=ds_ident=:{id_name,id_info},ds_arity}},tc_types} + (class_defs, ots, oti, cs=:{cs_symbol_table, cs_predef_symbols}) + # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table + cs = { cs & cs_symbol_table = cs_symbol_table } + # (class_index, class_module) = retrieveGlobalDefinition entry STE_Class mod_index + | class_index <> NotFound + # (class_def, class_index, class_defs, ots_modules) = getClassDef class_index class_module mod_index class_defs ots.ots_modules + ots = { ots & ots_modules = ots_modules } + (tc_types, (ots, oti, cs)) = checkOpenTypes mod_index cGlobalScope DAK_Ignore tc_types (ots, oti, cs) + cs = check_context_types class_def.class_name tc_types cs + tc = { tc & tc_class = { tc_class & glob_object = { class_name & ds_index = class_index }, glob_module = class_module }, tc_types = tc_types} + | class_def.class_arity == ds_arity + = (tc, (class_defs, ots, oti, cs)) + = (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "used with wrong arity" cs.cs_error })) + = (tc, (class_defs, ots, oti, { cs & cs_error = checkError id_name "undefined" cs.cs_error })) +where check_context_types tc_class [] cs=:{cs_error} = { cs & cs_error = checkError tc_class " type context should contain one or more type variables" cs_error} check_context_types tc_class [TV _ : types] cs @@ -799,8 +834,28 @@ where check_context_types tc_class [type : types] cs = check_context_types tc_class types cs -checkTypeContexts [] _ type_defs class_defs modules heaps cs - = ([], type_defs, class_defs, modules, heaps, cs) +checkTypeContexts :: ![TypeContext] !Index !v:{# ClassDef} !u:OpenTypeSymbols !*OpenTypeInfo !*CheckState + -> (![TypeContext], !u:{# CheckedTypeDef}, !v:{# ClassDef}, u:{# DclModule}, !*TypeHeaps, !*CheckState) +checkTypeContexts tcs mod_index class_defs ots oti cs + # (tcs, (class_defs, { ots_modules, ots_type_defs}, oti, cs)) = mapSt (checkTypeContext mod_index) tcs (class_defs, ots, oti, cs) + cs = check_class_variables oti.oti_all_vars cs + cs = check_class_attributes oti.oti_all_attrs cs + = (tcs, ots_type_defs, class_defs, ots_modules, oti.oti_heaps, cs) +where + check_class_variables class_variables cs + = foldSt check_class_variable class_variables cs + where + check_class_variable {tv_name} cs=:{cs_symbol_table,cs_error} + = { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope tv_name cs_symbol_table, + cs_error = checkError tv_name " not defined or defined as class variable" cs_error} + + check_class_attributes class_attributes cs + = foldSt check_class_attribute class_attributes cs + where + check_class_attribute {av_name} cs=:{cs_symbol_table,cs_error} + = { cs & cs_symbol_table = removeDefinitionFromSymbolTable cGlobalScope av_name cs_symbol_table, + cs_error = checkError av_name " undefined" cs_error} + checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedTypeDef} !u:{# DclModule} !*TypeHeaps !*ExpressionHeap !*CheckState -> (!u:{# CheckedTypeDef}, !u:{# DclModule}, !*TypeHeaps, !*ExpressionHeap, !*CheckState) @@ -831,6 +886,8 @@ where | entry.ste_kind == STE_Empty = symbol_table = symbol_table <:= (id_info, entry.ste_previous) + + checkDynamicTypes mod_index dyn_type_ptrs (Yes {st_vars}) type_defs modules type_heaps expr_heap cs=:{cs_symbol_table} # (th_vars, cs_symbol_table) = foldSt add_type_variable_to_symbol_table st_vars (type_heaps.th_vars, cs_symbol_table) diff --git a/frontend/comparedefimp.icl b/frontend/comparedefimp.icl index 449f6cd..44374a4 100644 --- a/frontend/comparedefimp.icl +++ b/frontend/comparedefimp.icl @@ -252,7 +252,8 @@ compareTwoMacroFuns dclIndex iclIndex ident_pos = getIdentPos dcl_function ec_error_admin = pushErrorAdmin ident_pos ec_state.ec_error_admin ec_state = { ec_state & ec_error_admin = ec_error_admin } - | dcl_function.fun_info.fi_is_macro_fun<>icl_function.fun_info.fi_is_macro_fun || +// Sjaak : | dcl_function.fun_info.fi_is_macro_fun<>icl_function.fun_info.fi_is_macro_fun || + | dcl_function.fun_info.fi_properties bitand FI_IsMacroFun <> icl_function.fun_info.fi_properties bitand FI_IsMacroFun || dcl_function.fun_priority<>icl_function.fun_priority # ec_state = give_error dcl_function.fun_symb ec_state = { ec_state & ec_error_admin = popErrorAdmin ec_state.ec_error_admin } diff --git a/frontend/convertDynamics.icl b/frontend/convertDynamics.icl index 44daff5..6d485cd 100644 --- a/frontend/convertDynamics.icl +++ b/frontend/convertDynamics.icl @@ -68,7 +68,6 @@ write_tcl_file main_dcl_module_n dcl_mods=:{[main_dcl_module_n] = main_dcl_modul convertDynamicPatternsIntoUnifyAppls :: {! GlobalTCType} !{# CommonDefs} !Int !*{! Group} !*{#FunDef} !*PredefinedSymbols !*VarHeap !*TypeHeaps !*ExpressionHeap /* TD */ (Optional !*File) {# DclModule} !IclModule /* TD */ [String] -> (!*{! Group}, !*{#FunDef}, !*PredefinedSymbols, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*VarHeap, !*TypeHeaps, !*ExpressionHeap, /* TD */ (Optional !*File)) convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_module_n groups fun_defs predefined_symbols var_heap type_heaps expr_heap /* TD */ tcl_file dcl_mods icl_mod /* TD */ directly_imported_dcl_modules - // TD ... # tcl_file = case tcl_file of @@ -83,7 +82,6 @@ convertDynamicPatternsIntoUnifyAppls global_type_instances common_defs main_dcl_ // ... TD - # ({pds_module, pds_def} , predefined_symbols) = predefined_symbols![PD_StdDynamics] #! (dynamic_temp_symb_ident,ci_sel_value_field,ci_sel_type_field,predefined_symbols) = case (pds_module == (-1) || pds_def == (-1)) of diff --git a/frontend/convertcases.icl b/frontend/convertcases.icl index 9b5050a..5c2d6ff 100644 --- a/frontend/convertcases.icl +++ b/frontend/convertcases.icl @@ -468,6 +468,8 @@ toOptionalFreeVar No var_heap :: ImportedFunctions :== [Global Index] +cDontRemoveAnnatations :== False + addNewFunctionsToGroups :: !{#.CommonDefs} FunctionHeap ![FunctionInfoPtr] !Int !*{! Group} !*{#{# CheckedTypeDef}} !ImportedFunctions !*TypeHeaps !*VarHeap -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) addNewFunctionsToGroups common_defs fun_heap new_functions main_dcl_module_n groups imported_types imported_conses type_heaps var_heap @@ -479,11 +481,13 @@ where -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) add_new_function_to_group fun_heap common_defs fun_ptr (groups, fun_defs, imported_types, imported_conses, type_heaps, var_heap) # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr fun_heap - group_index = gf_fun_def.fun_info.fi_group_index + {fun_type = Yes ft, fun_info = {fi_group_index, fi_properties}} = gf_fun_def (Yes ft) = gf_fun_def.fun_type - (ft, imported_types, imported_conses, type_heaps, var_heap) = convertSymbolType common_defs ft main_dcl_module_n imported_types imported_conses type_heaps var_heap - # (group, groups) = groups![group_index] - = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, + (ft, imported_types, imported_conses, type_heaps, var_heap) + = convertSymbolType (fi_properties bitand FI_HasTypeSpec == 0) common_defs ft main_dcl_module_n + imported_types imported_conses type_heaps var_heap + # (group, groups) = groups![fi_group_index] + = ({ groups & [fi_group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, [ { gf_fun_def & fun_type = Yes ft }: fun_defs], imported_types, imported_conses, type_heaps, var_heap) convertCasesOfFunctionsIntoPatterns :: !*{! Group} !Int !{# {# FunType} } !{# CommonDefs} !*{#FunDef} !*{#{# CheckedTypeDef}} @@ -572,7 +576,7 @@ where convert_dcl_function dcl_functions common_defs dcl_index (imported_types, imported_conses, var_heap, type_heaps) # {ft_type, ft_type_ptr} = dcl_functions.[dcl_index] (ft_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap + = convertSymbolType cDontRemoveAnnatations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type), type_heaps) convertConstructorTypes cons_defs main_dcl_module_n common_defs types_and_heaps @@ -581,7 +585,7 @@ where convert_constructor_type common_defs cons_defs cons_index (imported_types, imported_conses, var_heap, type_heaps) # {cons_type_ptr, cons_type} = cons_defs.[cons_index] (cons_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap + = convertSymbolType cDontRemoveAnnatations common_defs cons_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type), type_heaps) @@ -591,7 +595,7 @@ where convert_selector_type common_defs selector_defs sel_index (imported_types, imported_conses, var_heap, type_heaps) # {sd_type_ptr, sd_type} = selector_defs.[sel_index] (sd_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap + = convertSymbolType cDontRemoveAnnatations common_defs sd_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type), type_heaps) convertIclModule :: !Int !{# CommonDefs} !*{#{# CheckedTypeDef}} !ImportedConstructors !*VarHeap !*TypeHeaps @@ -641,7 +645,7 @@ where convert_imported_function dcl_functions common_defs {glob_object,glob_module} (imported_types, imported_conses, type_heaps, var_heap) # {ft_type_ptr,ft_type} = dcl_functions.[glob_module].[glob_object] (ft_type, imported_types, imported_conses, type_heaps, var_heap) - = convertSymbolType common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap + = convertSymbolType cDontRemoveAnnatations common_defs ft_type main_dcl_module_n imported_types imported_conses type_heaps var_heap = (imported_types, imported_conses, type_heaps, var_heap <:= (ft_type_ptr, VI_ExpandedType ft_type)) convert_imported_constructors common_defs [] imported_types type_heaps var_heap @@ -649,7 +653,8 @@ where convert_imported_constructors common_defs [ {glob_module, glob_object} : conses ] imported_types type_heaps var_heap # {com_cons_defs,com_selector_defs} = common_defs.[glob_module] {cons_type_ptr,cons_type,cons_type_index,cons_symb} = common_defs.[glob_module].com_cons_defs.[glob_object] - (cons_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs cons_type main_dcl_module_n imported_types conses type_heaps var_heap + (cons_type, imported_types, conses, type_heaps, var_heap) + = convertSymbolType cDontRemoveAnnatations common_defs cons_type main_dcl_module_n imported_types conses type_heaps var_heap var_heap = var_heap <:= (cons_type_ptr, VI_ExpandedType cons_type) ({td_rhs}, imported_types) = imported_types![glob_module].[cons_type_index] // ---> ("convert_imported_constructors", cons_symb, cons_type) @@ -665,7 +670,8 @@ where convert_type_of_imported_field module_index selector_defs fields field_index (imported_types, conses, type_heaps, var_heap) # field_index = fields.[field_index].fs_index {sd_type_ptr,sd_type} = selector_defs.[field_index] - (sd_type, imported_types, conses, type_heaps, var_heap) = convertSymbolType common_defs sd_type main_dcl_module_n imported_types conses type_heaps var_heap + (sd_type, imported_types, conses, type_heaps, var_heap) + = convertSymbolType cDontRemoveAnnatations common_defs sd_type main_dcl_module_n imported_types conses type_heaps var_heap = (imported_types, conses, type_heaps, var_heap <:= (sd_type_ptr, VI_ExpandedType sd_type)) convertRootExpression bound_vars group_index common_defs default_ptr (Let lad=:{let_strict_binds,let_lazy_binds,let_expr,let_info_ptr}) ci=:{ci_expr_heap} diff --git a/frontend/frontend.icl b/frontend/frontend.icl index 8b34bbd..54a3e43 100644 --- a/frontend/frontend.icl +++ b/frontend/frontend.icl @@ -151,7 +151,7 @@ frontEndInterface upToPhase mod_ident search_paths dcl_modules functions_and_mac # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ global_fun_range, icl_instances, icl_specials, generic_range] // (components, fun_defs, error) = showTypes components 0 fun_defs error -// (components, fun_defs, error) = showComponents components 0 True fun_defs error + (components, fun_defs, error) = showComponents components 0 True fun_defs error // (fun_defs, error) = showFunctions array_instances fun_defs error | upToPhase == FrontEndPhaseTypeCheck diff --git a/frontend/generics.icl b/frontend/generics.icl index 6be0cae..4e3fb21 100644 --- a/frontend/generics.icl +++ b/frontend/generics.icl @@ -1817,7 +1817,8 @@ makeFunction {ds_index, ds_arity, ds_ident} group_index arg_vars body_expr opt_s fi_free_vars = [], fi_local_vars = local_vars, fi_dynamics = [], - fi_is_macro_fun = False +// Sjaak fi_is_macro_fun = False + fi_properties = 0 } } diff --git a/frontend/overloading.icl b/frontend/overloading.icl index 3df8017..7f673b9 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -593,7 +593,7 @@ tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os d # (reduced_contexts, contexts, coercion_env, type_pattern_vars, os) = foldSt (reduce_contexts defs instance_info) ocs ([], [], coercion_env, [], os) | os.os_error.ea_ok # (contexts, os_var_heap) = foldSt add_spec_contexts ocs (contexts, os.os_var_heap) - (contexts, os_type_heaps) = remove_sub_classes contexts os.os_type_heaps + (contexts, os_type_heaps) = remove_super_classes contexts os.os_type_heaps ({ hp_var_heap, hp_expression_heap, hp_type_heaps}, dict_types) = foldSt (convert_dictionaries defs contexts) reduced_contexts ({ hp_var_heap = os_var_heap, hp_expression_heap = os.os_symbol_heap, hp_type_heaps = os_type_heaps}, []) = (contexts, coercion_env, type_pattern_vars, dict_types, { os & os_type_heaps = hp_type_heaps, os_symbol_heap = hp_expression_heap, os_var_heap = hp_var_heap} ) @@ -633,21 +633,24 @@ where { os & os_type_heaps = os_type_heaps, os_symbol_heap = os_symbol_heap, os_var_heap = os_var_heap, os_special_instances = os_special_instances, os_error = os_error, os_predef_symbols = os_predef_symbols }) - remove_sub_classes contexts type_heaps - # (sub_classes, type_heaps) = foldSt generate_subclasses contexts ([], type_heaps) - = (foldSt (remove_doubles sub_classes) contexts [], type_heaps) - - generate_subclasses {tc_class={glob_object={ds_index},glob_module},tc_types} (sub_classes, type_heaps) + remove_super_classes contexts type_heaps + # (super_classes, type_heaps) = foldSt generate_super_classes contexts ([], type_heaps) + sub_classes = foldSt (remove_doubles super_classes) contexts [] + = (sub_classes, type_heaps) + + generate_super_classes {tc_class={glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps) # {class_args,class_members,class_context,class_dictionary} = defs.[glob_module].com_class_defs.[ds_index] th_vars = fold2St set_type class_args tc_types type_heaps.th_vars - = foldSt subst_context class_context (sub_classes, { type_heaps & th_vars = th_vars }) + = foldSt subst_context_and_generate_super_classes class_context (super_classes, { type_heaps & th_vars = th_vars }) where set_type {tv_info_ptr} type type_var_heap = type_var_heap <:= (tv_info_ptr, TVI_Type type) - subst_context class_context (sub_classes, type_heaps) - # (sub_class, type_heaps) = substitute class_context type_heaps - = ([sub_class : sub_classes], type_heaps) + subst_context_and_generate_super_classes class_context (super_classes, type_heaps) + # (super_class, type_heaps) = substitute class_context type_heaps + | containsContext super_class super_classes + = (super_classes, type_heaps) + = generate_super_classes super_class ([super_class : super_classes], type_heaps) remove_doubles sub_classes tc context | containsContext tc sub_classes @@ -921,7 +924,7 @@ removeOverloadedFunctions group type_pattern_vars main_dcl_module_n fun_defs fun where remove_overloaded_function type_pattern_vars fun_index (fun_defs, fun_env, symbol_heap, type_code_info, var_heap, error, predef_symbols) # (fun_def, fun_defs) = fun_defs![fun_index] - (CheckedType {st_context}, fun_env) = fun_env![fun_index] + (CheckedType st=:{st_context}, fun_env) = fun_env![fun_index] {fun_body = TransformedBody {tb_args,tb_rhs},fun_info,fun_arity,fun_symb,fun_pos} = fun_def (rev_variables, var_heap) = foldSt determine_class_argument st_context ([], var_heap) @@ -943,9 +946,6 @@ where = case var_info of VI_ForwardClassVar var_info_ptr # (var_info, var_heap) = readPtr var_info_ptr var_heap -// (new_info_ptr, var_heap) = newPtr VI_Empty var_heap -// -> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0 var_info)) - -> case var_info of VI_Empty # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap @@ -1199,7 +1199,7 @@ where { ui & ui_var_heap = ui_var_heap, ui_error = ui_error }) where - build_context_arg symb {tc_var} (var_heap, error) + build_context_arg symb tc=:{tc_var} (var_heap, error) # (var_info, var_heap) = readPtr tc_var var_heap = case var_info of VI_ForwardClassVar var_info_ptr @@ -1209,7 +1209,7 @@ where -> (Var { var_name = var_name, var_info_ptr = new_info_ptr, var_expr_ptr = nilPtr }, (var_heap <:= (tc_var, VI_ClassVar var_name new_info_ptr (inc count)), error)) _ - -> abort "build_context_arg (overloading.icl)" + -> abort "build_context_arg (overloading.icl)" // ---> (tc <<- var_info)) get_recursive_fun_index :: !Index !SymbKind Int !{# FunDef} -> Index get_recursive_fun_index group_index (SK_Function {glob_module,glob_object}) main_dcl_module_n fun_defs diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 3d5eb75..c9427dc 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -427,6 +427,11 @@ cIsNonCoercible :== 2 , fc_index :: !Index } +/* Sjaak 19-3-2001 ... */ + +FI_IsMacroFun :== 1 // whether the function is a local function of a macro +FI_HasTypeSpec :== 2 // whether the function has u user defined type + :: FunInfo = { fi_calls :: ![FunCall] , fi_group_index :: !Index @@ -434,8 +439,9 @@ cIsNonCoercible :== 2 , fi_free_vars :: ![FreeVar] , fi_local_vars :: ![FreeVar] , fi_dynamics :: ![ExprInfoPtr] - , fi_is_macro_fun :: !Bool // whether the function is a local function of a macro + , fi_properties :: !BITVECT } +/* ... Sjaak 19-3-2001 */ :: ParsedBody = { pb_args :: ![ParsedExpr] @@ -486,7 +492,6 @@ cIsNonCoercible :== 2 , fun_index :: !Int , fun_kind :: !DefOrImpFunKind , fun_lifted :: !Int -// , fun_type_ptr :: !TypeVarInfoPtr , fun_info :: !FunInfo } @@ -909,14 +914,12 @@ cNonRecursiveAppl :== False :: BasicValue = BVI !String | BVC !String | BVB !Bool | BVR !String | BVS !String - -//:: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow !Int :: TypeKind = KindVar !KindInfoPtr | KindConst | KindArrow ![TypeKind] -instance toString TypeKind -instance <<< TypeKind -instance == TypeKind -instance toString KindInfo +instance toString TypeKind +instance <<< TypeKind +instance == TypeKind +instance toString KindInfo /* A few obscure type definitions */ @@ -1267,7 +1270,7 @@ MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, a MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var } EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel, - fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_is_macro_fun=False } + fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_properties=0 } BottomSignClass :== { sc_pos_vect = 0, sc_neg_vect = 0 } PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } diff --git a/frontend/syntax.icl b/frontend/syntax.icl index d9dbea4..42f11f5 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -400,6 +400,11 @@ cMayBeNonCoercible :== 4 , fc_index :: !Index } +/* Sjaak 19-3-2001 ... */ + +FI_IsMacroFun :== 1 // whether the function is a local function of a macro +FI_HasTypeSpec :== 2 // whether the function has u user defined type + :: FunInfo = { fi_calls :: ![FunCall] , fi_group_index :: !Index @@ -407,8 +412,9 @@ cMayBeNonCoercible :== 4 , fi_free_vars :: ![FreeVar] , fi_local_vars :: ![FreeVar] , fi_dynamics :: ![ExprInfoPtr] - , fi_is_macro_fun :: !Bool // whether the function is a local function of a macro + , fi_properties :: !BITVECT } +/* ... Sjaak 19-3-2001 */ :: ParsedBody = { pb_args :: ![ParsedExpr] @@ -2022,7 +2028,7 @@ MakeAttributedType type :== { at_attribute = TA_None, at_annotation = AN_None, a MakeAttributedTypeVar type_var :== { atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = type_var } EmptyFunInfo :== { fi_calls = [], fi_group_index = NoIndex, fi_def_level = NotALevel, - fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_is_macro_fun=False } + fi_free_vars = [], fi_local_vars = [], fi_dynamics = [], fi_properties=0 } BottomSignClass :== { sc_pos_vect = 0, sc_neg_vect = 0 } PostiveSignClass :== { sc_pos_vect = bitnot 0, sc_neg_vect = 0 } diff --git a/frontend/trans.dcl b/frontend/trans.dcl index 5eff949..44930ff 100644 --- a/frontend/trans.dcl +++ b/frontend/trans.dcl @@ -21,7 +21,7 @@ partitionateFunctions :: !*{# FunDef} ![IndexRange] -> (!*{! Group}, !*{# FunDef :: ImportedConstructors :== [Global Index] -convertSymbolType :: !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap +convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) addTypesOfDictionaries :: !{#CommonDefs} ![TypeContext] ![AType] -> [AType] diff --git a/frontend/trans.icl b/frontend/trans.icl index be07c6d..d683e36 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -1012,7 +1012,8 @@ possibly_generate_case_function kees=:{case_info_ptr} aci=:{aci_free_vars} ro ti , fi_free_vars = [] , fi_local_vars = [] , fi_dynamics = [] - , fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun +// Sjaak: , fi_is_macro_fun = outer_fun_def.fun_info.fi_is_macro_fun + , fi_properties = outer_fun_def.fun_info.fi_properties } } cc_args_from_outer_fun = [ cons_arg \\ cons_arg <- outer_cons_args.cc_args & used <- used_mask | used ] @@ -1820,12 +1821,17 @@ where get_producer_type {symb_kind=SK_Function {glob_module, glob_object}} ro fun_defs fun_heap | glob_module == ro.ro_main_dcl_module_n - # ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object] - = (symbol_type, fun_defs, fun_heap) - # {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] - st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context ft_type.st_args - = ({ft_type & st_args = st_args, st_arity = length st_args, st_context = [] }, - fun_defs, fun_heap) +// Sjaak ... + # ({fun_type=Yes symbol_type, fun_info={fi_properties}}, fun_defs) = fun_defs![glob_object] + | fi_properties bitand FI_HasTypeSpec <> 0 + # (_, symbol_type) = removeAnnotations symbol_type + = (symbol_type, fun_defs, fun_heap) + = (symbol_type, fun_defs, fun_heap) + # {ft_type} = ro.ro_imported_funs.[glob_module].[glob_object] + (_, ft_type) = removeAnnotations ft_type + st_args = addTypesOfDictionaries ro.ro_common_defs ft_type.st_context ft_type.st_args + = ({ft_type & st_args = st_args, st_arity = length st_args, st_context = [] }, fun_defs, fun_heap) +// ... Sjaak get_producer_type {symb_kind=SK_LocalMacroFunction glob_object} ro fun_defs fun_heap # ({fun_type=Yes symbol_type}, fun_defs) = fun_defs![glob_object] = (symbol_type, fun_defs, fun_heap) @@ -2008,7 +2014,8 @@ allocate_fresh_type_var i (accu, th_vars) transformFunctionApplication fun_def instances cc=:{cc_size, cc_args, cc_linear_bits} app=:{app_symb,app_args} extra_args ro ti # (app_symb, app_args, extra_args) = complete_application app_symb fun_def.fun_arity app_args extra_args | cc_size > 0 - # (producers, new_args, ti) = determineProducers fun_def.fun_info.fi_is_macro_fun cc_linear_bits cc_args app_args +// Sjaak: # (producers, new_args, ti) = determineProducers fun_def.fun_info.fi_is_macro_fun cc_linear_bits cc_args app_args + # (producers, new_args, ti) = determineProducers (fun_def.fun_info.fi_properties bitand FI_IsMacroFun <> 0) cc_linear_bits cc_args app_args 0 (createArray cc_size PR_Empty) ro ti | containsProducer cc_size producers // | False--->("determineProducers",(cc_linear_bits,cc_args,app_symb.symb_name, app_args),("\nresults in",II_Node producers nilPtr II_Empty II_Empty)) @@ -2331,20 +2338,21 @@ transformGroups cleanup_info main_dcl_module_n groups fun_defs cons_args common_ -> (!*{! Group}, ![FunDef], !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) add_new_function_to_group common_defs ti_fun_heap fun_ptr (groups, fun_defs, imported_types, collected_imports, type_heaps, var_heap) # (FI_Function {gf_fun_def,gf_fun_index}) = sreadPtr fun_ptr ti_fun_heap - group_index = gf_fun_def.fun_info.fi_group_index - # (Yes ft=:{st_args,st_result}) = gf_fun_def.fun_type - ((st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes common_defs (st_result,st_args) - { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap, - ets_main_dcl_module_n=main_dcl_module_n } - # (group, groups) = groups![group_index] - = ({ groups & [group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, +// Sjaak + {fun_type = Yes ft=:{st_args,st_result}, fun_info = {fi_group_index,fi_properties}} = gf_fun_def + ((st_result,st_args), {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) + = expandSynTypes (fi_properties bitand FI_HasTypeSpec == 0) common_defs (st_result,st_args) + { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps = type_heaps, ets_var_heap = var_heap, + ets_main_dcl_module_n=main_dcl_module_n } + # (group, groups) = groups![fi_group_index] + = ({ groups & [fi_group_index] = { group & group_members = [gf_fun_index : group.group_members]} }, [ { gf_fun_def & fun_type = Yes { ft & st_result = st_result, st_args = st_args }} : fun_defs], ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) convert_function_type common_defs fun_index (fun_defs, imported_types, collected_imports, type_heaps, var_heap) - # (fun_def=:{fun_type = Yes fun_type}, fun_defs) = fun_defs![fun_index] + # (fun_def=:{fun_type = Yes fun_type, fun_info = {fi_properties}}, fun_defs) = fun_defs![fun_index] (fun_type, imported_types, collected_imports, type_heaps, var_heap) - = convertSymbolType common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap + = convertSymbolType (fi_properties bitand FI_HasTypeSpec == 0) common_defs fun_type main_dcl_module_n imported_types collected_imports type_heaps var_heap = ({ fun_defs & [fun_index] = { fun_def & fun_type = Yes fun_type }}, imported_types, collected_imports, type_heaps, var_heap) cleanup_attributes expr_info_ptr symbol_heap @@ -2360,10 +2368,10 @@ set_extended_expr_info expr_info_ptr extension expr_info_heap -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei) ei -> expr_info_heap <:= (expr_info_ptr, EI_Extended extension ei) -convertSymbolType :: !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap +convertSymbolType :: !Bool !{# CommonDefs} !SymbolType !Int !*{#{# CheckedTypeDef}} !ImportedConstructors !*TypeHeaps !*VarHeap -> (!SymbolType, !*{#{# CheckedTypeDef}}, !ImportedConstructors, !*TypeHeaps, !*VarHeap) -convertSymbolType common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap - # (st, {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes common_defs st +convertSymbolType rem_annots common_defs st main_dcl_module_n imported_types collected_imports type_heaps var_heap + # (st, {ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap}) = expandSynTypes rem_annots common_defs st { ets_type_defs = imported_types, ets_collected_conses = collected_imports, ets_type_heaps= type_heaps, ets_var_heap = var_heap, ets_main_dcl_module_n=main_dcl_module_n } = (st, ets_type_defs, ets_collected_conses, ets_type_heaps, ets_var_heap) @@ -2395,56 +2403,53 @@ where tc_types class_cons_vars))} -class expandSynTypes a :: !{# CommonDefs} !a !*ExpandTypeState -> (!a, !*ExpandTypeState) +class expandSynTypes a :: !Bool !{# CommonDefs} !a !*ExpandTypeState -> (!a, !*ExpandTypeState) -/* -class expandSynTypes a :: !a (!*{#{#CheckedTypeDef}}, !*TypeHeaps) -> (!a, (!*{#{#CheckedTypeDef}}, !*TypeHeaps)) -*/ instance expandSynTypes SymbolType where - expandSynTypes common_defs st=:{st_args,st_result,st_context} ets - # ((st_args,st_result), ets) = expandSynTypes common_defs (st_args,st_result) ets + expandSynTypes rem_annots common_defs st=:{st_args,st_result,st_context} ets + # ((st_args,st_result), ets) = expandSynTypes rem_annots common_defs (st_args,st_result) ets st_args = addTypesOfDictionaries common_defs st_context st_args = ({st & st_args = st_args, st_result = st_result, st_arity = length st_args, st_context = [] }, ets) instance expandSynTypes Type where - expandSynTypes common_defs (arg_type --> res_type) ets - # ((arg_type, res_type), ets) = expandSynTypes common_defs (arg_type, res_type) ets + expandSynTypes rem_annots common_defs (arg_type --> res_type) ets + # ((arg_type, res_type), ets) = expandSynTypes rem_annots common_defs (arg_type, res_type) ets = (arg_type --> res_type, ets) - expandSynTypes common_defs type=:(TB _) ets + expandSynTypes rem_annots common_defs type=:(TB _) ets = (type, ets) - expandSynTypes common_defs (cons_var :@: types) ets - # (types, ets) = expandSynTypes common_defs types ets + expandSynTypes rem_annots common_defs (cons_var :@: types) ets + # (types, ets) = expandSynTypes rem_annots common_defs types ets = (cons_var :@: types, ets) - expandSynTypes common_defs type=:(TA type_symb types) ets - = expand_syn_types_in_TA common_defs type_symb types TA_Multi ets - expandSynTypes common_defs type ets + expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets + = expand_syn_types_in_TA rem_annots common_defs type_symb types TA_Multi ets + expandSynTypes rem_annots common_defs type ets = (type, ets) instance expandSynTypes [a] | expandSynTypes a where - expandSynTypes common_defs list ets - = mapSt (expandSynTypes common_defs) list ets + expandSynTypes rem_annots common_defs list ets + = mapSt (expandSynTypes rem_annots common_defs) list ets instance expandSynTypes (a,b) | expandSynTypes a & expandSynTypes b where - expandSynTypes common_defs tuple ets - = app2St (expandSynTypes common_defs, expandSynTypes common_defs) tuple ets + expandSynTypes rem_annots common_defs tuple ets + = app2St (expandSynTypes rem_annots common_defs, expandSynTypes rem_annots common_defs) tuple ets -expand_syn_types_in_TA common_defs type_symb=:{type_index={glob_object,glob_module},type_name} types attribute ets=:{ets_type_defs} +expand_syn_types_in_TA rem_annots common_defs type_symb=:{type_index={glob_object,glob_module},type_name} types attribute ets=:{ets_type_defs} # ({td_rhs,td_name,td_args,td_attribute},ets_type_defs) = ets_type_defs![glob_module].[glob_object] ets = { ets & ets_type_defs = ets_type_defs } = case td_rhs of SynType rhs_type # ets_type_heaps = bind_attr td_attribute attribute ets.ets_type_heaps ets_type_heaps = (fold2St bind_var_and_attr td_args types ets_type_heaps) - (type, ets_type_heaps) = substitute rhs_type.at_type ets_type_heaps - -> expandSynTypes common_defs type { ets & ets_type_heaps = ets_type_heaps } + (type, ets_type_heaps) = substitute_rhs rem_annots rhs_type.at_type ets_type_heaps + -> expandSynTypes rem_annots common_defs type { ets & ets_type_heaps = ets_type_heaps } _ - # (types, ets) = expandSynTypes common_defs types ets + # (types, ets) = expandSynTypes rem_annots common_defs types ets | glob_module == ets.ets_main_dcl_module_n -> ( TA type_symb types, ets) -> ( TA type_symb types, collect_imported_constructors common_defs glob_module td_rhs ets) @@ -2481,17 +2486,22 @@ where has_been_collected (VI_ExpandedType _) = True has_been_collected _ = False + substitute_rhs rem_annots rhs_type type_heaps + | rem_annots + # (_, rhs_type) = removeAnnotations rhs_type + = substitute rhs_type type_heaps + = substitute rhs_type type_heaps instance expandSynTypes AType where - expandSynTypes common_defs atype ets - = expand_syn_types_in_a_type common_defs atype ets + expandSynTypes rem_annots common_defs atype ets + = expand_syn_types_in_a_type rem_annots common_defs atype ets where - expand_syn_types_in_a_type common_defs atype=:{at_type = TA type_symb types, at_attribute} ets - # (at_type, ets) = expand_syn_types_in_TA common_defs type_symb types at_attribute ets + expand_syn_types_in_a_type rem_annots common_defs atype=:{at_type = TA type_symb types, at_attribute} ets + # (at_type, ets) = expand_syn_types_in_TA rem_annots common_defs type_symb types at_attribute ets = ({ atype & at_type = at_type }, ets) - expand_syn_types_in_a_type common_defs atype ets - # (at_type, ets) = expandSynTypes common_defs atype.at_type ets + expand_syn_types_in_a_type rem_annots common_defs atype ets + # (at_type, ets) = expandSynTypes rem_annots common_defs atype.at_type ets = ({ atype & at_type = at_type }, ets) :: FreeVarInfo = diff --git a/frontend/type.icl b/frontend/type.icl index d7c1c73..048ceb0 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -875,7 +875,6 @@ addPropagationAttributesToAType modules type=:{at_type = TA cons_id=:{type_index = unsafeFold2St (check_kind type_name modules) tdi_kinds cons_args (1, error_admin) -> Yes error_admin = ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute }, prop_class, { ps & prop_attr_vars = prop_attr_vars, -// MW probably = ({ type & at_type = TA cons_id cons_args, at_attribute = at_attribute, at_annotation = AN_None }, prop_class, { ps & prop_attr_vars = prop_attr_vars, prop_td_infos = prop_td_infos, prop_attr_env = prop_attr_env, prop_type_heaps = { prop_type_heaps & th_vars = th_vars, th_attrs = th_attrs}, prop_error = prop_error }) where @@ -2044,7 +2043,7 @@ where #! 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 //---> (("begin\n" ---> subst.[2]) ---> "\nend") + | not ts_error.ea_ok = (True, fun_defs, predef_symbols, special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = ts_type_heaps, ts_error = { ts_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar}) # {ts_attr_store,ts_var_heap,ts_var_store,ts_expr_heap,ts_td_infos} = ts diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index b36113b..5505b3b 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -132,3 +132,6 @@ appTypeVarHeap f type_heaps :== let th_vars = f type_heaps.th_vars in { type_hea accTypeVarHeap f type_heaps :== let (r, th_vars) = f type_heaps.th_vars in (r, { type_heaps & th_vars = th_vars }) accAttrVarHeap f type_heaps :== let (r, th_attrs) = f type_heaps.th_attrs in (r, { type_heaps & th_attrs = th_attrs }) +class removeAnnotations a :: !a -> (!Bool, !a) + +instance removeAnnotations Type, SymbolType diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 3da8390..0ebdfdd 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -56,7 +56,7 @@ where clean_up cui atype=:{at_attribute,at_type} cus # (at_attribute, cus) = clean_up cui at_attribute cus (at_type, cus) = clean_up cui at_type cus - = ({atype & at_attribute = at_attribute, at_type = at_type}, cus) + = ({atype & at_attribute = at_attribute, at_type = at_type, at_annotation = AN_None}, cus) attrIsUndefined TA_None = True attrIsUndefined _ = False @@ -589,6 +589,68 @@ where (ct_cons_types, heaps) = substitute ct_cons_types heaps = ({ct_pattern_type = ct_pattern_type, ct_result_type = ct_result_type, ct_cons_types = ct_cons_types}, heaps) + +class removeAnnotations a :: !a -> (!Bool, !a) + +instance removeAnnotations (a,b) | removeAnnotations a & removeAnnotations b +where + removeAnnotations t=:(x,y) + # (rem_x, x) = removeAnnotations x + (rem_y, y) = removeAnnotations y + | rem_x || rem_y + = (True, (x,y)) + = (False, t) + +instance removeAnnotations [a] | removeAnnotations a +where + removeAnnotations l=:[x:xs] + # (rem_x, x) = removeAnnotations x + (rem_xs, xs) = removeAnnotations xs + | rem_x || rem_xs + = (True, [x:xs]) + = (False, l) + removeAnnotations el + = (False, el) + +instance removeAnnotations Type +where + removeAnnotations t=:(arg_type --> res_type) + # (rem, (arg_type, res_type)) = removeAnnotations (arg_type, res_type) + | rem + = (True, arg_type --> res_type) + = (False, t) + removeAnnotations t=:(TA cons_id cons_args) + # (rem, cons_args) = removeAnnotations cons_args + | rem + = (True, TA cons_id cons_args) + = (False, t) + removeAnnotations t=:(cv :@: types) + # (rem, types) = removeAnnotations types + | rem + = (True, cv :@: types) + = (False, t) + removeAnnotations type + = (False, type) + + +instance removeAnnotations AType +where + removeAnnotations atype=:{at_annotation,at_type} + # (rem, at_type) = removeAnnotations at_type + | rem + = (True, { atype & at_annotation = AN_None, at_type = at_type }) + | at_annotation == AN_None + = (False, atype) + = (True, { atype & at_annotation = AN_None }) + +instance removeAnnotations SymbolType +where + removeAnnotations st=:{st_args,st_result} + # (rem, (st_args,st_result)) = removeAnnotations (st_args,st_result) + | rem + = (True, { st & st_args = st_args, st_result = st_result }) + = (False, st) + expandTypeApplication :: ![ATypeVar] !TypeAttribute !Type ![AType] !TypeAttribute !*TypeHeaps -> (!Type, !*TypeHeaps) expandTypeApplication type_args form_attr type_rhs arg_types act_attr type_heaps=:{th_attrs} # type_heaps = bindTypeVarsAndAttributes form_attr act_attr type_args arg_types type_heaps |