diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/analtypes.icl | 6 | ||||
| -rw-r--r-- | frontend/checktypes.icl | 53 | ||||
| -rw-r--r-- | frontend/parse.icl | 44 | ||||
| -rw-r--r-- | frontend/type.icl | 114 |
4 files changed, 132 insertions, 85 deletions
diff --git a/frontend/analtypes.icl b/frontend/analtypes.icl index b7e2281..55f05f2 100644 --- a/frontend/analtypes.icl +++ b/frontend/analtypes.icl @@ -51,9 +51,9 @@ partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{ = (reverse pi_groups, common_defs, pi_type_def_infos, {icl_common & com_type_defs = icl_type_defs}, dcl_modules, type_heaps, error) where copy_type_defs_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod nr_of_modules (icl_type_defs, dcl_modules) - # type_defs = { {} \\ module_nr <- [0..nr_of_modules] } - marks = { {} \\ module_nr <- [0..nr_of_modules] } - type_def_infos = { {} \\ module_nr <- [0..nr_of_modules] } + # type_defs = { {} \\ module_nr <- [1..nr_of_modules] } + marks = { {} \\ module_nr <- [1..nr_of_modules] } + type_def_infos = { {} \\ module_nr <- [1..nr_of_modules] } = iFoldSt (copy_type_def_and_create_marks_and_infos used_module_numbers main_dcl_module_index nr_of_types_in_icl_mod) 0 nr_of_modules (icl_type_defs, dcl_modules, type_defs, marks, type_def_infos) where diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 1780233..62ba41c 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -279,6 +279,7 @@ where = ({ ts & ts_cons_defs = { ts.ts_cons_defs & [ds_index] = { cons_def & cons_type = cons_type, cons_index = cons_index, cons_type_index = cti.cti_type_index, cons_exi_vars = exi_vars, cons_type_ptr = new_type_ptr, cons_arg_vars = cons_arg_vars }}}, { ti & ti_var_heap = ti_var_heap }, cs) +// ---> ("bind_types_of_constructors", cons_def.cons_symb, exi_vars, cons_type) where bind_types_of_cons :: ![AType] !CurrentTypeInfo ![TypeVar] ![AttrInequality] !(!*TypeSymbols, !*TypeInfo, !*CheckState) -> !(![AType], ![[ATypeVar]], ![AttrInequality], !(!*TypeSymbols, !*TypeInfo, !*CheckState)) @@ -1056,28 +1057,32 @@ where = (TA_Unique, attr_vars, attr_var_heap, cs) check_attribute is_rank_two attr name attr_vars attr_var_heap cs | is_rank_two - = check_rank_two_attribute attr name attr_vars attr_var_heap cs + = check_rank_two_attribute attr attr_vars attr_var_heap cs = check_global_attribute attr name attr_vars attr_var_heap cs where check_global_attribute TA_Multi name attr_vars attr_var_heap cs - # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap - new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} - = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) check_global_attribute TA_None name attr_vars attr_var_heap cs - # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap - new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} - = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) check_global_attribute _ name attr_vars attr_var_heap cs = (TA_Multi, attr_vars, attr_var_heap, checkError name "specified attribute variable not allowed" cs) - check_rank_two_attribute TA_Anonymous name attr_vars attr_var_heap cs + check_rank_two_attribute (TA_Var var) attr_vars attr_var_heap cs # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + new_var = { var & av_info_ptr = attr_info_ptr} + = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) + check_rank_two_attribute TA_Anonymous attr_vars attr_var_heap cs + = abort "check_rank_two_attribute (TA_Anonymous, check_types.icl)" +/* # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr} = (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs) - check_rank_two_attribute attr name attr_vars attr_var_heap cs +*/ check_rank_two_attribute attr attr_vars attr_var_heap cs = (attr, attr_vars, attr_var_heap, cs) - addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState -> (![ATypeVar], !(!*TypeHeaps, !*CheckState)) addExistentionalTypeVariablesToSymbolTable root_attr type_vars heaps cs @@ -1092,15 +1097,15 @@ where | entry.ste_def_level < cGlobalScope // cOuterMostLevel # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } - (atv_attribute, cs_error) = check_attribute atv_attribute root_attr tv_name.id_name cs_error + (atv_attribute, th_attrs, cs_error) = check_attribute atv_attribute root_attr tv_name.id_name th_attrs cs_error cs_symbol_table = cs_symbol_table <:= (tv_info, {ste_index = NoIndex, ste_kind = STE_BoundTypeVariable {stv_attribute = atv_attribute, stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cGlobalScope /* cOuterMostLevel */, ste_previous = entry }) - heaps = { heaps & th_vars = th_vars } + heaps = { heaps & th_vars = th_vars, th_attrs = th_attrs } = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error})) = (atv, ({ heaps & th_vars = th_vars }, { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name "type variable already defined" cs_error})) - +/* check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin -> (!TypeAttribute, !*ErrorAdmin) check_attribute TA_Multi root_attr name error @@ -1117,6 +1122,28 @@ where -> (PA_BUG (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error) check_attribute attr root_attr name error = (TA_Multi, checkError name "specified attribute not allowed" error) +*/ + + + check_attribute :: !TypeAttribute !TypeAttribute !String !*AttrVarHeap !*ErrorAdmin + -> (!TypeAttribute, !*AttrVarHeap, !*ErrorAdmin) + check_attribute TA_Multi root_attr name attr_var_heap error + = (TA_Multi, attr_var_heap, error) + check_attribute TA_None root_attr name attr_var_heap error + = (TA_Multi, attr_var_heap, error) + check_attribute TA_Unique root_attr name attr_var_heap error + = (TA_Unique, attr_var_heap, error) + check_attribute (TA_Var var) root_attr name attr_var_heap error + = case root_attr of + TA_Var root_var + -> (TA_RootVar root_var, attr_var_heap, error) + TA_Unique + # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap + -> (TA_Var { var & av_info_ptr = attr_info_ptr}, attr_var_heap, error) +// -> (PA_BUG (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error) + check_attribute attr root_attr name attr_var_heap error + = (TA_Multi, attr_var_heap, checkError name "specified attribute not allowed" error) + retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap) retrieveKinds type_vars var_heap = mapSt retrieve_kind type_vars var_heap diff --git a/frontend/parse.icl b/frontend/parse.icl index 76e28b1..157512b 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -2034,9 +2034,11 @@ optionalExistentialQuantifiedVariables pState # (token, pState) = nextToken TypeContext pState = case token of ExistsToken - # (vars, pState) = wantList "existential quantified variable(s)" try_existential_type_var pState + # (vars, pState) = wantList "existential quantified variable(s)" tryQuantifiedTypeVar pState -> (vars, wantToken TypeContext "Existential Quantified Variables" ColonToken pState) _ -> ([], tokenBack pState) + +/* Sjaak 041001 where try_existential_type_var :: !ParseState -> (Bool,ATypeVar,ParseState) try_existential_type_var pState @@ -2053,34 +2055,34 @@ where # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} -> (True,atypevar,pState) -> (False,abort "no ATypeVar",pState) - -// Sjaak 210801 .... +*/ +// Sjaak 041001 .... optionalUniversalQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState) optionalUniversalQuantifiedVariables pState # (token, pState) = nextToken TypeContext pState = case token of ForAllToken - # (vars, pState) = wantList "universal quantified variable(s)" try_universal_type_var pState + # (vars, pState) = wantList "universal quantified variable(s)" tryQuantifiedTypeVar pState -> (vars, wantToken TypeContext "Universal Quantified Variables" ColonToken pState) _ -> ([], tokenBack pState) -where - try_universal_type_var :: !ParseState -> (Bool, ATypeVar, ParseState) - try_universal_type_var pState - # (token, pState) = nextToken TypeContext pState - (succ, attr, pState) = try_universal_attribute token pState - | succ - # (typevar, pState) = wantTypeVar pState - (attr, pState) = adjustAttributeOfTypeVariable attr typevar.tv_name pState - = (True, {atv_attribute = attr, atv_annotation = AN_None, atv_variable = typevar}, pState) - # (succ, typevar, pState) = tryTypeVarT token pState - | succ - = (True, {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}, pState) - = (False, abort "no ATypeVar", pState) - - try_universal_attribute DotToken pState = (True, TA_Anonymous, pState) - try_universal_attribute AsteriskToken pState = (True, TA_Unique, pState) - try_universal_attribute token pState = (False, TA_None, pState) + +tryQuantifiedTypeVar :: !ParseState -> (Bool, ATypeVar, ParseState) +tryQuantifiedTypeVar pState + # (token, pState) = nextToken TypeContext pState + (succ, attr, pState) = try_attribute token pState + | succ + # (typevar, pState) = wantTypeVar pState + (attr, pState) = adjustAttributeOfTypeVariable attr typevar.tv_name pState + = (True, {atv_attribute = attr, atv_annotation = AN_None, atv_variable = typevar}, pState) + # (succ, typevar, pState) = tryTypeVarT token pState + | succ + = (True, {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}, pState) + = (False, abort "no ATypeVar", pState) +where + try_attribute DotToken pState = (True, TA_Anonymous, pState) + try_attribute AsteriskToken pState = (True, TA_Unique, pState) + try_attribute token pState = (False, TA_None, pState) // ... Sjaak diff --git a/frontend/type.icl b/frontend/type.icl index f48142c..8159d1b 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -504,12 +504,8 @@ freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap freshCopyOfTypeAttribute (TA_Var avar) attr_var_heap = freshCopyOfAttributeVar avar attr_var_heap - -/* A temporary hack to handle the new Object IO lib */ -/* Should be removed !!!!!!!!!! */ - freshCopyOfTypeAttribute (TA_RootVar avar) attr_var_heap - = PA_BUG (TA_PA_BUG, attr_var_heap) (freshCopyOfAttributeVar avar attr_var_heap) + = freshCopyOfAttributeVar avar attr_var_heap freshCopyOfTypeAttribute TA_None attr_var_heap = (TA_Multi, attr_var_heap) freshCopyOfTypeAttribute TA_Unique attr_var_heap @@ -517,7 +513,6 @@ freshCopyOfTypeAttribute TA_Unique attr_var_heap freshCopyOfTypeAttribute attr attr_var_heap = (attr, attr_var_heap) - cIsExistential :== True cIsNotExistential :== False @@ -582,12 +577,20 @@ where freshCopy type type_heaps = (type, type_heaps) -freshExistentialVariables type_variables state - = foldSt fresh_existential_variable type_variables state +freshExistentialVariables type_variables var_store attr_store type_heaps + = foldSt fresh_existential_variable type_variables ([], var_store, attr_store, type_heaps) where - fresh_existential_variable {atv_variable={tv_info_ptr}} (var_heap, var_store) - = (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store) - + fresh_existential_variable {atv_variable={tv_info_ptr},atv_attribute} (exi_attr_vars, var_store, attr_store, type_heaps =: {th_vars, th_attrs}) + # th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TempQV var_store)) + # var_store = inc var_store + # (exi_attr_vars, attr_store, th_attrs) = fresh_existential_attribute atv_attribute (exi_attr_vars, attr_store, th_attrs) + = (exi_attr_vars, var_store, attr_store, { type_heaps & th_vars = th_vars, th_attrs = th_attrs }) + + fresh_existential_attribute (TA_Var {av_info_ptr}) (exi_attr_vars, attr_store, attr_heap) + = ([ attr_store : exi_attr_vars ], inc attr_store, attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store))) + fresh_existential_attribute attr state + = state + fresh_type_variables :: [ATypeVar] *(*Heap TypeVarInfo,Int) -> *(!*Heap TypeVarInfo,!Int); fresh_type_variables type_variables state = foldSt (\{atv_variable={tv_info_ptr}} (var_heap, var_store) -> (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store)) @@ -622,21 +625,6 @@ fresh_environment inequalities attr_env attr_heap is_new_ineqality dem_attr_var off_attr_var [] = True -fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store type_heaps - # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (th_vars, var_store) = freshExistentialVariables cons_exi_vars (type_heaps.th_vars, var_store) - (attr_env, th_attrs) = fresh_environment st_attr_env [] type_heaps.th_attrs - (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs, th_vars = th_vars } - (fresh_args, type_heaps) = freshCopy st_args type_heaps - = ([fresh_args], result_type, var_store, attr_env, type_heaps) -fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store type_heaps - # (cons_types, result_type, var_store, attr_env, type_heaps) - = fresh_symbol_types patterns cons_defs var_store type_heaps - {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] - (th_vars, var_store) = freshExistentialVariables cons_exi_vars (type_heaps.th_vars, var_store) - (attr_env, th_attrs) = fresh_environment st_attr_env attr_env type_heaps.th_attrs - (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs, th_vars = th_vars } - = ([fresh_args : cons_types], result_type, var_store, attr_env, type_heaps) freshUniversalVariables type_variables state = foldSt fresh_universal_variable type_variables state @@ -645,15 +633,39 @@ where = (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store) freshAlgebraicType :: !(Global Int) ![AlgebraicPattern] !{#CommonDefs} !*TypeState -> (![[AType]],!AType,![AttrCoercion],!*TypeState) -freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos} +freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos,ts_exis_variables} # {td_rhs,td_args,td_attrs,td_name,td_attribute} = common_defs.[glob_module].com_type_defs.[glob_object] # (th_vars, ts_var_store) = fresh_type_variables td_args (ts_type_heaps.th_vars, ts_var_store) (th_attrs, ts_attr_store) = fresh_attributes td_attrs (ts_type_heaps.th_attrs, ts_attr_store) - type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } - (cons_types, alg_type, ts_var_store, attr_env, type_heaps) - = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store type_heaps - = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = type_heaps }) + ts_type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } + (cons_types, alg_type, attr_env, ts_var_store, ts_attr_store, ts_type_heaps, ts_exis_variables) + = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store ts_attr_store ts_type_heaps ts_exis_variables + = (cons_types, alg_type, attr_env, + { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = ts_type_heaps, ts_exis_variables = ts_exis_variables }) // ---> ("freshAlgebraicType", alg_type, cons_types) +where + fresh_symbol_types [{ap_symbol={glob_object},ap_expr}] cons_defs var_store attr_store type_heaps all_exis_variables + # {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] + (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env [] type_heaps.th_attrs + (result_type, type_heaps) = freshCopy st_result { type_heaps & th_attrs = th_attrs } + (fresh_args, type_heaps) = freshCopy st_args type_heaps + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + = ([fresh_args], result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) + fresh_symbol_types [{ap_symbol={glob_object},ap_expr} : patterns] cons_defs var_store attr_store type_heaps all_exis_variables + # (cons_types, result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) + = fresh_symbol_types patterns cons_defs var_store attr_store type_heaps all_exis_variables + {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars} = cons_defs.[glob_object.ds_index] + (exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps + (attr_env, th_attrs) = fresh_environment st_attr_env attr_env type_heaps.th_attrs + (fresh_args, type_heaps) = freshCopy st_args { type_heaps & th_attrs = th_attrs } + all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables + = ([fresh_args : cons_types], result_type, attr_env, var_store, attr_store, type_heaps, all_exis_variables) + + add_exis_variables expr [] exis_variables + = exis_variables + add_exis_variables expr new_exis_variables exis_variables + = [(CP_Expression expr, new_exis_variables) : exis_variables] fresh_overloaded_list_type [{ap_symbol}:patterns] pd_cons_symbol pd_nil_symbol decons_u_index nil_u_index stdStrictLists_index pos functions common_defs ts | ap_symbol.glob_module==cPredefinedModuleIndex @@ -760,7 +772,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con (fresh_type, type_heaps) = freshCopy type type_heaps type_heaps = clearBindings vars type_heaps = ({ at & at_attribute = fresh_attribute, at_type = fresh_type }, - (var_store, attr_store, add_exis_variables pos new_exis_variables exis_variables, type_heaps)) + (var_store, attr_store, addToExistentialVariables pos new_exis_variables exis_variables, type_heaps)) fresh_arg_type _ at (var_store, attr_store, exis_variables, type_heaps) # (fresh_at, type_heaps) = freshCopy at type_heaps = (fresh_at, (var_store, attr_store, exis_variables, type_heaps)) @@ -774,10 +786,10 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con fresh_attr attr state = state - add_exis_variables pos [] exis_variables - = exis_variables - add_exis_variables pos new_exis_variables exis_variables - = [(pos, new_exis_variables) : exis_variables] +addToExistentialVariables pos [] exis_variables + = exis_variables +addToExistentialVariables pos new_exis_variables exis_variables + = [(pos, new_exis_variables) : exis_variables] freshArgumentsOfSymbolType :: ![AType] !*TypeHeaps -> (![AType], !*TypeHeaps) freshArgumentsOfSymbolType atypes type_heaps = mapSt fresh_arg_type atypes type_heaps @@ -1024,10 +1036,12 @@ determineSymbolTypeOfFunction pos ident act_arity st=:{st_args,st_result,st_attr ts_var_heap = ts.ts_var_heap <:= (type_ptr, VI_PropagationType st) } -> currySymbolType copy_symb_type act_arity ts -standardFieldSelectorType pos {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} - #! {sd_type,sd_exi_vars} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] - # (th_vars, ts_var_store) = freshExistentialVariables sd_exi_vars (ts_type_heaps.th_vars, ts_var_store) - = freshSymbolType (Yes pos) cWithFreshContextVars sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } +standardFieldSelectorType pos {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_exis_variables} + # {sd_type,sd_exi_vars} = ti_common_defs.[glob_module].com_selector_defs.[ds_index] + (new_exis_variables, ts_var_store, ts_attr_store, ts_type_heaps) = freshExistentialVariables sd_exi_vars ts_var_store ts_attr_store ts_type_heaps + ts_exis_variables = addToExistentialVariables pos new_exis_variables ts_exis_variables + ts = { ts & ts_type_heaps = ts_type_heaps, ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_exis_variables = ts_exis_variables } + = freshSymbolType (Yes pos) cWithFreshContextVars sd_type ti_common_defs ts // ---> ("standardFieldSelectorType", ds_ident, inst) standardTupleSelectorType pos {ds_index} arg_nr {ti_common_defs} ts @@ -1041,10 +1055,12 @@ standardRhsConstructorType pos index mod arity {ti_common_defs} ts = currySymbolType fresh_type arity ts // ---> ("standardRhsConstructorType", cons_symb, fresh_type) -standardLhsConstructorType index mod arity {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} - #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] - # (th_vars, ts_var_store) = freshExistentialVariables cons_exi_vars (ts_type_heaps.th_vars, ts_var_store) - = freshSymbolType No cWithFreshContextVars cons_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } +standardLhsConstructorType pos index mod arity {ti_common_defs} ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_exis_variables} + # {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] + (new_exis_variables, ts_var_store, ts_attr_store, ts_type_heaps) = freshExistentialVariables cons_exi_vars ts_var_store ts_attr_store ts_type_heaps + ts_exis_variables = addToExistentialVariables pos new_exis_variables ts_exis_variables + ts = { ts & ts_type_heaps = ts_type_heaps, ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_exis_variables = ts_exis_variables } + = freshSymbolType No cWithFreshContextVars cons_type ti_common_defs ts // ---> ("standardLhsConstructorType", cons_symb, fresh_type) :: ReferenceMarking :== Bool @@ -1464,8 +1480,9 @@ where = (composite_expr_type, opt_composite_expr_ptr, (reqs, ts)) requirements ti (RecordUpdate {glob_module,glob_object={ds_index,ds_arity}} expression expressions) (reqs, ts) - # (lhs, ts) = standardLhsConstructorType ds_index glob_module ds_arity ti ts - (rhs, ts) = standardRhsConstructorType (CP_Expression expression) ds_index glob_module ds_arity ti ts + # cp = CP_Expression expression + (lhs, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts + (rhs, ts) = standardRhsConstructorType cp ds_index glob_module ds_arity ti ts (expression_type, opt_expr_ptr, reqs_ts) = requirements ti expression (reqs, ts) (reqs, ts) = requirements_of_fields ti expression expressions rhs.tst_args lhs.tst_args reqs_ts ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs.tst_result.at_attribute ts.ts_expr_heap } @@ -1504,10 +1521,11 @@ where requirements ti (MatchExpr opt_tuple_type {glob_object={ds_arity, ds_index},glob_module} expr) (reqs, ts) - # ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType ds_index glob_module ds_arity ti ts + # cp = CP_Expression expr + ({tst_result,tst_args,tst_attr_env}, ts) = standardLhsConstructorType cp ds_index glob_module ds_arity ti ts (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr (reqs, ts) reqs = { reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, - req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = CP_Expression expr, tc_coercible = True } : reqs.req_type_coercions ] } + req_type_coercions = [{ tc_demanded = tst_result, tc_offered = e_type, tc_position = cp, tc_coercible = True } : reqs.req_type_coercions ] } ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr tst_result.at_attribute ts.ts_expr_heap } = case opt_tuple_type of Yes {glob_object={ds_ident,ds_index,ds_arity}, glob_module} |