diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/checktypes.icl | 264 | ||||
| -rw-r--r-- | frontend/overloading.icl | 11 | ||||
| -rw-r--r-- | frontend/parse.icl | 114 | ||||
| -rw-r--r-- | frontend/refmark.icl | 116 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 8 | ||||
| -rw-r--r-- | frontend/syntax.icl | 10 | ||||
| -rw-r--r-- | frontend/trans.icl | 5 | ||||
| -rw-r--r-- | frontend/type.icl | 315 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 238 | ||||
| -rw-r--r-- | frontend/unitype.dcl | 9 | ||||
| -rw-r--r-- | frontend/unitype.icl | 43 |
11 files changed, 717 insertions, 416 deletions
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 3d26a06..2c3c5bb 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -71,13 +71,13 @@ where instance bindTypes TypeVar where - bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table /* TD ... */, cs_x={x_type_var_position,x_is_dcl_module} /* ... TD */ }) + bindTypes cti tv=:{tv_name=var_id=:{id_info}} (ts, ti, cs=:{cs_symbol_table}) # (var_def, cs_symbol_table) = readPtr id_info cs_symbol_table cs = { cs & cs_symbol_table = cs_symbol_table } = case var_def.ste_kind of - STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD */, stv_position} + STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count} # cs = { cs & cs_symbol_table = cs.cs_symbol_table <:= (id_info, { var_def & ste_kind = STE_BoundTypeVariable { bv & stv_count = inc stv_count }})} - -> ({ tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, stv_attribute, (ts, ti, cs)) + -> ({ tv & tv_info_ptr = stv_info_ptr}, stv_attribute, (ts, ti, cs)) _ -> (tv, TA_Multi, (ts, ti, { cs & cs_error = checkError var_id "undefined" cs.cs_error })) @@ -129,6 +129,13 @@ where # (tv, type_attr, ts_ti_cs) = bindTypes cti tv ts_ti_cs (types, _, ts_ti_cs) = bindTypes cti types ts_ti_cs = (CV tv :@: types, type_attr, ts_ti_cs) +// Sjaak 16-08-01 + bindTypes cti (TFA vars type) (ts, ti=:{ti_type_heaps}, cs) + # (type_vars, (_, ti_type_heaps, cs)) = addTypeVariablesToSymbolTable cRankTwoScope vars [] ti_type_heaps cs + (type, _, (ts, ti, cs)) = bindTypes cti type (ts, {ti & ti_type_heaps = ti_type_heaps}, cs) + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cRankTwoScope type_vars cs.cs_symbol_table + = (TFA type_vars type, TA_Multi, (ts, ti, { cs & cs_symbol_table = cs_symbol_table })) +// ... Sjaak bindTypes cti type ts_ti_cs = (type, TA_Multi, ts_ti_cs) @@ -158,7 +165,7 @@ bindTypesOfConstructors cti=:{cti_lhs_attribute} cons_index free_vars free_attrs (st_args, cons_arg_vars, st_attr_env, (ts, ti, cs)) = bind_types_of_cons cons_def.cons_type.st_args cti free_vars [] ({ ts & ts_cons_defs = ts_cons_defs }, { ti & ti_type_heaps = ti_type_heaps }, cs) - cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel exi_vars cs.cs_symbol_table + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ exi_vars cs.cs_symbol_table (ts, ti, cs) = bindTypesOfConstructors cti (inc cons_index) free_vars free_attrs type_lhs conses (ts, ti, { cs & cs_symbol_table = cs_symbol_table }) cons_type = { cons_def.cons_type & st_vars = free_vars, st_args = st_args, st_result = type_lhs, st_attr_vars = free_attrs, st_attr_env = st_attr_env } @@ -175,17 +182,17 @@ where # (types, local_vars_list, attr_env, ts_ti_cs) = bind_types_of_cons types cti free_vars attr_env ts_ti_cs (type, type_attr, (ts, ti, cs)) = bindTypes cti type ts_ti_cs - (local_vars, cs_symbol_table /* TD ... */, _ /* ... TD */ ) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table /* TD ...*/, cs.cs_x /* ... TD */ ) + (local_vars, cs_symbol_table) = foldSt retrieve_local_vars free_vars ([], cs.cs_symbol_table) (attr_env, cs_error) = addToAttributeEnviron type_attr cti.cti_lhs_attribute attr_env cs.cs_error = ([type : types], [local_vars : local_vars_list], attr_env, (ts, ti , { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) where - retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table /* TD ... */, cs_x=:{x_is_dcl_module} /* ... TD */ ) - # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count /* TD ... */,stv_position /* ... TD */ }}, symbol_table) = readPtr id_info symbol_table + retrieve_local_vars tv=:{tv_name={id_info}} (local_vars, symbol_table) + # (ste=:{ste_kind = STE_BoundTypeVariable bv=:{stv_attribute, stv_info_ptr, stv_count }}, symbol_table) = readPtr id_info symbol_table | stv_count == 0 - = (local_vars, symbol_table /* TD ... */, cs_x /* ... TD */) + = (local_vars, symbol_table) - = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr /* TD ... */, tv_name = if x_is_dcl_module tv.tv_name { tv.tv_name & id_name = toString stv_position } /* ... TD */ }, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], - symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})/* TD ... */, cs_x /* ... TD */) + = ([{ atv_variable = { tv & tv_info_ptr = stv_info_ptr}, atv_attribute = stv_attribute, atv_annotation = AN_None } : local_vars], + symbol_table <:= (id_info, { ste & ste_kind = STE_BoundTypeVariable { bv & stv_count = 0}})) // checkRhsOfTypeDef :: !CheckedTypeDef ![AttributeVar] !CurrentTypeInfo !(!*TypeSymbols, !*TypeInfo, !*CheckState) @@ -220,7 +227,8 @@ where | field_nr < size fields # {fs_index} = fields.[field_nr] # (sel_def, selector_defs) = selector_defs![fs_index] - # [sel_type:sel_types] = sel_types + [sel_type : sel_types] = sel_types + # (sel_type, (st_vars, st_attr_vars)) = lift_quantifier sel_type (st_vars, st_attr_vars) # (st_attr_env, error) = addToAttributeEnviron sel_type.at_attribute rec_type.at_attribute [] error # (new_type_ptr, var_heap) = newPtr VI_Empty var_heap sd_type = { sel_def.sd_type & st_arity = 1, st_args = [rec_type], st_result = sel_type, st_vars = st_vars, @@ -229,6 +237,20 @@ where sd_type_ptr = new_type_ptr, sd_exi_vars = exi_vars } } = check_selectors (inc field_nr) fields rec_type_index sel_types rec_type st_vars st_attr_vars exi_vars selector_defs var_heap error = (selector_defs, var_heap, error) + where + lift_quantifier at=:{at_type = TFA vars type} (type_vars, attr_vars) + = ({ at & at_type = type}, foldSt add_var_and_attr vars (type_vars, attr_vars)) + lift_quantifier at (type_vars, attr_vars) + = (at, (type_vars, attr_vars)) + + add_var_and_attr {atv_variable, atv_attribute} (type_vars, attr_vars) + = ([atv_variable : type_vars], add_attr_var atv_attribute attr_vars) + + add_attr_var (TA_Var av) attr_vars + = [av : attr_vars] + add_attr_var attr attr_vars + = attr_vars + checkRhsOfTypeDef {td_rhs = SynType type} _ cti ts_ti_cs # (type, type_attr, ts_ti_cs) = bindTypes cti type ts_ti_cs = (SynType type, ts_ti_cs) @@ -241,35 +263,22 @@ isATopConsVar cv :== cv < 0 encodeTopConsVar cv :== dec (~cv) decodeTopConsVar cv :== ~(inc cv) -checkTypeDef :: /* TD */ !Bool !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); -checkTypeDef /* TD */ is_dcl_module type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} +checkTypeDef :: !Index !Index !*TypeSymbols !*TypeInfo !*CheckState -> (!*TypeSymbols, !*TypeInfo, !*CheckState); +checkTypeDef type_index module_index ts=:{ts_type_defs} ti=:{ti_type_heaps} cs=:{cs_error} # (type_def, ts_type_defs) = ts_type_defs![type_index] # {td_name,td_pos,td_args,td_attribute} = type_def - - // TD ... - // in case of an icl-module, the arguments i.e. the type variables of type constructors are normalized which makes - // comparison by the static linker easier. - # (cs=:{cs_error}) - = { cs & cs_x = { cs.cs_x & x_is_dcl_module = /*is_dcl_module*/ True, x_type_var_position = 0 } } -// | FB (not is_dcl_module) ("checkTypeDef: " +++ td_name.id_name) True - # - // ... TD - position = newPosition td_name td_pos cs_error = pushErrorAdmin position cs_error (td_attribute, attr_vars, th_attrs) = determine_root_attribute td_attribute td_name.id_name ti_type_heaps.th_attrs (type_vars, (attr_vars, ti_type_heaps, cs)) - = addTypeVariablesToSymbolTable td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } + = addTypeVariablesToSymbolTable cGlobalScope td_args attr_vars { ti_type_heaps & th_attrs = th_attrs } { cs & cs_error = cs_error } type_def = { type_def & td_args = type_vars, td_index = type_index, td_attrs = attr_vars, td_attribute = td_attribute } (td_rhs, (ts, ti, cs)) = checkRhsOfTypeDef type_def attr_vars { cti_module_index = module_index, cti_type_index = type_index, cti_lhs_attribute = td_attribute } ({ ts & ts_type_defs = ts_type_defs },{ ti & ti_type_heaps = ti_type_heaps}, cs) = ({ ts & ts_type_defs = { ts.ts_type_defs & [type_index] = { type_def & td_rhs = td_rhs }}}, ti, { cs & cs_error = popErrorAdmin cs.cs_error, - cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cOuterMostLevel type_vars cs.cs_symbol_table - // TD ... - , cs_x = { cs.cs_x & x_is_dcl_module = False} }) - // ... TD + cs_symbol_table = removeAttributedTypeVarsFromSymbolTable cGlobalScope /* cOuterMostLevel */ type_vars cs.cs_symbol_table}) where determine_root_attribute TA_None name attr_var_heap # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap @@ -330,18 +339,25 @@ where # (type, expst) = expand module_index type expst = (TArrow1 type, expst) // ..AA - expand module_index (CV tv :@: types) expst + expand module_index (CV tv=:{tv_name} :@: types) expst # (type, expst) = expandTypeVariable tv expst (types, expst) = expand module_index types expst - = (simplify_type_appl type types, expst) + (combined_type, exp_error) = simplify_type_appl tv_name type types expst.exp_error + = (combined_type, { expst & exp_error = exp_error }) where - simplify_type_appl :: !Type ![AType] -> Type - simplify_type_appl (TA type_cons=:{type_arity} cons_args) type_args - = TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args) - simplify_type_appl (TV tv) type_args - = CV tv :@: type_args - simplify_type_appl TE t2 - = TE + simplify_type_appl :: !Ident !Type ![AType] !*ErrorAdmin -> (!Type, *ErrorAdmin) + simplify_type_appl cv (TA type_cons=:{type_arity} cons_args) type_args error + = (TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args), error) + simplify_type_appl cv (TV tv) type_args error + = (CV tv :@: type_args, error) + simplify_type_appl cv TE t2 error + = (TE, error) + simplify_type_appl cv t1 t2 error + = (TE, checkError cv "kind conflict in argument of type synonym" error) + + expand module_index (TFA vars type) expst + # (type, expst) = expand module_index type expst + = (TFA vars type, expst) expand module_index type expst = (type, expst) @@ -360,6 +376,24 @@ where # (at_attribute, expst) = expandTypeAttribute at_attribute expst (at_type, expst) = expand module_index at_type expst = ({ atype & at_type = at_type, at_attribute = at_attribute }, expst) +/* +expandTypeApplication (CV tv={tv_name}) types expst + # (type, expst) = expandTypeVariable tv expst + (types, expst) = expand module_index types expst + (combined_type, exp_error) = simplify_type_appl tv_name type types expst.exp_error + = (simplify_type_appl type types, { expst & exp_error = exp_error }) + where + simplify_type_appl :: !Ident !Type ![AType] !*ErrorAdmin -> (!Type, *ErrorAdmin) + simplify_type_appl cv (TA type_cons=:{type_arity} cons_args) type_args error + = (TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args), error) + simplify_type_appl cv (TV tv) type_args error + = (CV tv :@: type_args, error) + simplify_type_appl cv TE t2 error + = (TE, error) + simplify_type_appl cv t1 t2 error + = (TE, checkError cv "kind conflict in argument of type synonym" error) +*/ + class look_for_cycles a :: !Index !a !*ExpandState -> *ExpandState @@ -418,6 +452,7 @@ expandSynType mod_index type_index expst=:{exp_type_defs} exp_marks = { expst.exp_marks & [type_index] = CS_Checked }, exp_type_heaps = clearBindingsOfTypeVarsAndAttributes td_attribute td_args expst.exp_type_heaps, exp_error = popErrorAdmin expst.exp_error } +// ---> ("SynType", rhs_type, exp_type) _ # exp_marks = { expst.exp_marks & [type_index] = CS_Checking } @@ -427,9 +462,9 @@ expandSynType mod_index type_index expst=:{exp_type_defs} _ -> { expst & exp_marks = { expst.exp_marks & [type_index] = CS_Checked }} -checkTypeDefs :: /* TD */ !Bool !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState +checkTypeDefs :: !Bool !*{# CheckedTypeDef} !Index !*{# ConsDef} !*{# SelectorDef} !*{# DclModule} !*VarHeap !*TypeHeaps !*CheckState -> (!*{# CheckedTypeDef}, !*{# ConsDef}, !*{# SelectorDef}, !*{# DclModule}, !*VarHeap, !*TypeHeaps, !*CheckState) -checkTypeDefs /* TD */ is_dcl_module is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs +checkTypeDefs is_main_dcl type_defs module_index cons_defs selector_defs modules var_heap type_heaps cs #! nr_of_types = size type_defs # ts = { ts_type_defs = type_defs, ts_cons_defs = cons_defs, ts_selector_defs = selector_defs, ts_modules = modules } ti = { ti_type_heaps = type_heaps, ti_var_heap = var_heap } @@ -438,16 +473,9 @@ where check_type_defs is_main_dcl type_index nr_of_types module_index ts ti=:{ti_type_heaps,ti_var_heap} cs | type_index == nr_of_types = (ts.ts_type_defs, ts.ts_cons_defs, ts.ts_selector_defs, ts.ts_modules, ti_var_heap, ti_type_heaps, cs) - # (ts, ti, cs) = checkTypeDef /* TD */ is_dcl_module type_index module_index ts ti cs + # (ts, ti, cs) = checkTypeDef type_index module_index ts ti cs = check_type_defs is_main_dcl (inc type_index) nr_of_types module_index ts ti cs -expand_syn_types module_index type_index nr_of_types expst - | type_index == nr_of_types - = expst - | expst.exp_marks.[type_index] == CS_NotChecked - # expst = expandSynType module_index type_index expst - = expand_syn_types module_index (inc type_index) nr_of_types expst - = expand_syn_types module_index (inc type_index) nr_of_types expst /* Tracea_tn a # s=size a @@ -481,7 +509,15 @@ expandSynonymTypes module_index exp_type_defs exp_modules exp_type_heaps exp_err { exp_type_defs = exp_type_defs, exp_modules = exp_modules, exp_marks = marks, exp_type_heaps = exp_type_heaps, exp_error = exp_error } = (exp_type_defs,exp_modules,exp_type_heaps,exp_error) - +where + expand_syn_types module_index type_index nr_of_types expst + | type_index == nr_of_types + = expst + | expst.exp_marks.[type_index] == CS_NotChecked + # expst = expandSynType module_index type_index expst + = expand_syn_types module_index (inc type_index) nr_of_types expst + = expand_syn_types module_index (inc type_index) nr_of_types expst + :: OpenTypeInfo = { oti_heaps :: !.TypeHeaps , oti_all_vars :: ![TypeVar] @@ -519,7 +555,7 @@ newAttribute DAK_Unique var_name new_attr oti cs TA_None -> (TA_Unique, oti, cs) _ - -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error }) + -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed (2)" cs.cs_error }) newAttribute DAK_None var_name (TA_Var attr_var) oti cs=:{cs_symbol_table} # (attr_var, oti, cs_symbol_table) = determineAttributeVariable attr_var oti cs_symbol_table = (TA_Var attr_var, oti, { cs & cs_symbol_table = cs_symbol_table }) @@ -599,7 +635,7 @@ where | old_var.av_info_ptr == new_var.av_info_ptr = (TA_Var old_var, oti, { cs & cs_symbol_table = cs_symbol_table }) = (TA_Var old_var, oti, { cs & cs_symbol_table = cs_symbol_table, - cs_error = checkError new_var.av_name "inconsistently attributed" cs_error }) + cs_error = checkError new_var.av_name "inconsistently attributed (3)" cs_error }) check_var_attribute var_attr=:(TA_Var old_var) TA_Anonymous oti cs = (var_attr, oti, cs) check_var_attribute TA_Unique new_attr oti cs @@ -607,7 +643,7 @@ where TA_Unique -> (TA_Unique, oti, cs) _ - -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error }) + -> (TA_Unique, oti, { cs & cs_error = checkError var_name "inconsistently attributed (4)" cs.cs_error }) check_var_attribute TA_Multi new_attr oti cs = case new_attr of TA_Multi @@ -615,9 +651,9 @@ where TA_None -> (TA_Multi, oti, cs) _ - -> (TA_Multi, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error }) + -> (TA_Multi, oti, { cs & cs_error = checkError var_name "inconsistently attributed (5)" cs.cs_error }) check_var_attribute var_attr new_attr oti cs - = (var_attr, oti, { cs & cs_error = checkError var_name "inconsistently attributed" cs.cs_error })// ---> (var_attr, new_attr) + = (var_attr, oti, { cs & cs_error = checkError var_name "inconsistently attributed (6)" cs.cs_error })// ---> (var_attr, new_attr) determine_attribute var_name DAK_Unique new_attr error @@ -629,7 +665,7 @@ where TA_Unique -> (TA_Unique, error) _ - -> (TA_Unique, checkError var_name "inconsistently attributed" error) + -> (TA_Unique, checkError var_name "inconsistently attributed (1)" error) determine_attribute var_name dem_attr TA_None error = (TA_Multi, error) determine_attribute var_name dem_attr new_attr error @@ -641,7 +677,7 @@ where checkOpenAType :: !Index !Int !DemandedAttributeKind !AType !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) -> (!AType, !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) checkOpenAType mod_index scope dem_attr type=:{at_type = TV tv, at_attribute} (ots, oti, cs) - # (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) + # (tv, at_attribute, (oti, cs)) = checkTypeVar scope dem_attr tv at_attribute (oti, cs) = ({ type & at_type = TV tv, at_attribute = at_attribute }, (ots, oti, cs)) checkOpenAType mod_index scope dem_attr type=:{at_type = GTV var_id=:{tv_name={id_info}}} (ots, oti=:{oti_heaps,oti_global_vars}, cs=:{cs_symbol_table}) # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table @@ -716,6 +752,28 @@ checkOpenAType mod_index scope dem_attr type=:{at_type = CV tv :@: types, at_att (types, (ots, oti, cs)) = mapSt (checkOpenAType mod_index scope DAK_None) types (ots, oti, cs) (new_attr, oti, cs) = newAttribute dem_attr ":@:" at_attribute oti cs = ({ type & at_type = CV cons_var :@: types, at_attribute = new_attr }, (ots, oti, cs)) +checkOpenAType mod_index scope dem_attr atype=:{at_type = TFA vars type, at_attribute} (ots, oti, cs) + # (vars, (oti, cs)) = mapSt add_universal_var vars (oti, cs) + (checked_type, (ots, oti, cs)) = checkOpenAType mod_index cRankTwoScope dem_attr { atype & at_type = type } (ots, oti, cs) + cs = { cs & cs_symbol_table = foldSt remove_universal_var vars cs.cs_symbol_table } + = ( { checked_type & at_type = TFA vars checked_type.at_type }, (ots, oti, cs)) +where + add_universal_var atv=:{atv_variable = tv=:{tv_name={id_name,id_info}}, atv_attribute} (oti, cs=:{cs_symbol_table,cs_error}) + # (entry=:{ste_kind,ste_def_level},cs_symbol_table) = readPtr id_info cs_symbol_table + | ste_kind == STE_Empty || ste_def_level < cRankTwoScope + # (new_attr, oti=:{oti_heaps}, cs) = newAttribute DAK_None id_name atv_attribute oti { cs & cs_symbol_table = cs_symbol_table } + (new_var_ptr, th_vars) = newPtr (TVI_Attribute new_attr) oti_heaps.th_vars + = ({atv & atv_variable = { tv & tv_info_ptr = new_var_ptr}, atv_attribute = new_attr }, + ({ oti & oti_heaps = { oti_heaps & th_vars = th_vars }}, { cs & cs_symbol_table = + cs.cs_symbol_table <:= (id_info, {ste_index = NoIndex, ste_kind = STE_TypeVariable new_var_ptr, + ste_def_level = cRankTwoScope, ste_previous = entry })})) + = (atv, (oti, { cs & cs_error = checkError id_name "type variable already undefined" cs_error, cs_symbol_table = cs_symbol_table })) + + remove_universal_var {atv_variable = {tv_name}, atv_attribute = TA_Var {av_name}} cs_symbol_table + = removeDefinitionFromSymbolTable cGlobalScope av_name (removeDefinitionFromSymbolTable cRankTwoScope tv_name cs_symbol_table) + remove_universal_var {atv_variable = {tv_name}} cs_symbol_table + = removeDefinitionFromSymbolTable cRankTwoScope tv_name cs_symbol_table + checkOpenAType mod_index scope dem_attr type=:{at_attribute} (ots, oti, cs) # (new_attr, oti, cs) = newAttribute dem_attr "." at_attribute oti cs = ({ type & at_attribute = new_attr}, (ots, oti, cs)) @@ -803,6 +861,7 @@ checkSymbolType is_function mod_index st=:{st_args,st_result,st_context,st_attr_ # 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) +// ---> ("checkSymbolType", st_args)) (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 = [] } @@ -1159,74 +1218,57 @@ where checkSpecialTypes mod_index SP_None type_defs modules heaps cs = (SP_None, type_defs, modules, heaps, cs) +/* cOuterMostLevel :== 0 */ -cOuterMostLevel :== 0 - -addTypeVariablesToSymbolTable :: ![ATypeVar] ![AttributeVar] !*TypeHeaps !*CheckState +addTypeVariablesToSymbolTable :: !Level ![ATypeVar] ![AttributeVar] !*TypeHeaps !*CheckState -> (![ATypeVar], !(![AttributeVar], !*TypeHeaps, !*CheckState)) -addTypeVariablesToSymbolTable type_vars attr_vars heaps cs /* TD */ =:{cs_x={x_type_var_position,x_is_dcl_module}} -// TD ... - | x_type_var_position <> 0 = abort "addTypeVariablesToSymbolTable: x_type_var_position must be zero-initialized" - - # ((a_type_vars,t=:(attribute_vars, type_heaps, check_state))) - = mapSt (add_type_variable_to_symbol_table) type_vars (attr_vars, heaps, cs) - | x_is_dcl_module - = (a_type_vars,t) - - // in case of an icl-module, the type variables of the type definition need to be normalized by storing its - // argument number for later use. To avoid incomprehensible error messages the constructor's type variables - // are changed below. - # (a_type_vars,check_state) - = mapSt change_type_variables_into_their_type_constructor_position a_type_vars check_state - = (a_type_vars,(attribute_vars, type_heaps, check_state)) -// ... TD +addTypeVariablesToSymbolTable scope type_vars attr_vars heaps cs + = mapSt (add_type_variable_to_symbol_table scope) type_vars (attr_vars, heaps, cs) where -// TD ... - change_type_variables_into_their_type_constructor_position :: !ATypeVar !*CheckState -> (!ATypeVar, !*CheckState) - change_type_variables_into_their_type_constructor_position atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} cs=:{cs_symbol_table} - # tv_info = tv_name.id_info - (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table - # stv_position - = case entry.ste_kind of - STE_BoundTypeVariable {stv_position} - -> stv_position - # atv - = { atv & atv_variable.tv_name.id_name = toString stv_position } - = (atv,{cs & cs_symbol_table = cs_symbol_table}) -// ... TD - - add_type_variable_to_symbol_table :: !ATypeVar !(![AttributeVar], !*TypeHeaps, !*CheckState) + add_type_variable_to_symbol_table :: !Level !ATypeVar !(![AttributeVar], !*TypeHeaps, !*CheckState) -> (!ATypeVar, !(![AttributeVar], !*TypeHeaps, !*CheckState)) - add_type_variable_to_symbol_table atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} - (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */}) + add_type_variable_to_symbol_table scope atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} + (attr_vars, heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error }) # tv_info = tv_name.id_info (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table - | entry.ste_def_level < cOuterMostLevel + | entry.ste_def_level < scope // cOuterMostLevel # (tv_info_ptr, th_vars) = newPtr TVI_Empty th_vars atv_variable = { atv_variable & tv_info_ptr = tv_info_ptr } - (atv_attribute, attr_vars, th_attrs, cs_error) = check_attribute atv_attribute tv_name.id_name attr_vars th_attrs cs_error + (atv_attribute, attr_vars, th_attrs, cs_error) = check_attribute (scope == cRankTwoScope) atv_attribute tv_name.id_name attr_vars 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 /* TD */, stv_position = x_type_var_position}, ste_def_level = cOuterMostLevel, ste_previous = entry }) + stv_info_ptr = tv_info_ptr, stv_count = 0}, ste_def_level = scope /* cOuterMostLevel */, ste_previous = entry }) heaps = { heaps & th_vars = th_vars, th_attrs = th_attrs } = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, - (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) + (attr_vars, heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error })) = (atv, (attr_vars, { 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 /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) + { cs & cs_symbol_table = cs_symbol_table, cs_error = checkError tv_name.id_name "type variable already defined" cs_error })) - check_attribute :: !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin + check_attribute :: !Bool !TypeAttribute !String ![AttributeVar] !*AttrVarHeap !*ErrorAdmin -> (!TypeAttribute, ![AttributeVar], !*AttrVarHeap, !*ErrorAdmin) - check_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) - check_attribute TA_None name attr_vars attr_var_heap cs + check_attribute _ TA_Unique name attr_vars attr_var_heap cs + = (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_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) + 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) + 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 # (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_attribute TA_Unique name attr_vars attr_var_heap cs - = (TA_Unique, attr_vars, attr_var_heap, cs) - check_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 attr name attr_vars attr_var_heap cs + = (attr, attr_vars, attr_var_heap, cs) addExistentionalTypeVariablesToSymbolTable :: !TypeAttribute ![ATypeVar] !*TypeHeaps !*CheckState @@ -1237,20 +1279,20 @@ where add_exi_variable_to_symbol_table :: !TypeAttribute !ATypeVar !(!*TypeHeaps, !*CheckState) -> (!ATypeVar, !(!*TypeHeaps, !*CheckState)) add_exi_variable_to_symbol_table root_attr atv=:{atv_variable=atv_variable=:{tv_name}, atv_attribute} - (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error /* TD ... */, cs_x={x_type_var_position} /* ... TD */}) + (heaps=:{th_vars,th_attrs}, cs=:{ cs_symbol_table, cs_error}) # tv_info = tv_name.id_info (entry, cs_symbol_table) = readPtr tv_info cs_symbol_table - | entry.ste_def_level < cOuterMostLevel + | 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 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 /* TD */, stv_position = x_type_var_position }, ste_def_level = cOuterMostLevel, ste_previous = entry }) + stv_info_ptr = tv_info_ptr, stv_count = 0 }, ste_def_level = cGlobalScope /* cOuterMostLevel */, ste_previous = entry }) heaps = { heaps & th_vars = th_vars } = ({atv & atv_variable = atv_variable, atv_attribute = atv_attribute}, - (heaps, { cs & cs_symbol_table = cs_symbol_table, cs_error = cs_error /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */ })) + (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 /* TD ... */, cs_x = {cs.cs_x & x_type_var_position = inc x_type_var_position} /* ... TD */})) + { 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) diff --git a/frontend/overloading.icl b/frontend/overloading.icl index a4def34..1ecf6ca 100644 --- a/frontend/overloading.icl +++ b/frontend/overloading.icl @@ -442,10 +442,7 @@ where # (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap) = (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap)) reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap) -// MV ... -// was: # (tc_var, var_heap) = newPtr VI_Empty var_heap - # (tc_var, var_heap) = newPtr VI_FreeTypeVarAtRuntime var_heap -// ... MV + # (tc_var, var_heap) = newPtr VI_Empty var_heap tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var } | containsContext tc new_contexts = (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap)) @@ -920,7 +917,7 @@ where fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}, fun_info = { fun_info & fi_local_vars = ui_local_vars}} = update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def }) ui_fun_env ui_symbol_heap x_type_code_info ui_var_heap ui_error predef_symbols - + removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int!*{#FunDef} !*{! FunctionType} !*ExpressionHeap !*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol} -> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol}) @@ -966,7 +963,7 @@ where -> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) // ---> ("determine_class_argument (VI_ForwardClassVar)", ptrToInt tc_var, ptrToInt var_info_ptr) _ - -> abort "determine_class_argument (overloading.icl)" + -> abort ("determine_class_argument 1 (overloading.icl)")// <<- var_info) VI_Empty # (new_info_ptr, var_heap) = newPtr VI_Empty var_heap @@ -974,7 +971,7 @@ where -> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0)) // ---> ("determine_class_argument (VI_Empty)", ptrToInt tc_var) _ - -> abort "determine_class_argument (overloading.icl)" + -> abort ("determine_class_argument 2 (overloading.icl)") // <<- var_info) build_var_name id_name = { id_name = "_v" +++ id_name, id_info = nilPtr } diff --git a/frontend/parse.icl b/frontend/parse.icl index d6107a6..f13ca65 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1539,24 +1539,28 @@ optionalAnnotAndAttr pState # (token, pState) = nextToken TypeContext pState | token == ExclamationToken # (token, pState) = nextToken TypeContext pState - (_ , attr, pState) = optional_attribute token pState +// Sjaak (_ , attr, pState) = optional_attribute token pState + (_ , attr, pState) = tryAttribute token pState = (True, AN_Strict, attr, pState) | otherwise // token <> ExclamationToken - # (succ, attr, pState) = optional_attribute token pState + # (succ, attr, pState) = tryAttribute token pState = (succ, AN_None, attr, pState) -where - optional_attribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState) - optional_attribute DotToken pState = (True, TA_Anonymous, pState) - optional_attribute AsteriskToken pState = (True, TA_Unique, pState) - optional_attribute (IdentToken id) pState - | isLowerCaseName id - # (token, pState) = nextToken TypeContext pState - | ColonToken == token - # (ident, pState) = stringToIdent id IC_TypeAttr pState - = (True, TA_Var (makeAttributeVar ident), pState) - = (False, TA_None, tokenBack (tokenBack pState)) - optional_attribute _ pState = (False, TA_None, tokenBack pState) + +// Sjaak 210801 ... + +tryAttribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState) +tryAttribute DotToken pState = (True, TA_Anonymous, pState) +tryAttribute AsteriskToken pState = (True, TA_Unique, pState) +tryAttribute (IdentToken id) pState + | isLowerCaseName id + # (token, pState) = nextToken TypeContext pState + | ColonToken == token + # (ident, pState) = stringToIdent id IC_TypeAttr pState + = (True, TA_Var (makeAttributeVar ident), pState) + = (False, TA_None, tokenBack (tokenBack pState)) +tryAttribute _ pState = (False, TA_None, tokenBack pState) +// ... Sjaak cIsInfix :== True cIsNotInfix :== False @@ -1649,16 +1653,25 @@ where _ -> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState) -adjustAttribute :: !TypeAttribute Type *ParseState -> (TypeAttribute,*ParseState) -adjustAttribute TA_Anonymous (TV {tv_name={id_name}}) pState - # (ident, pState) = stringToIdent id_name IC_TypeAttr pState - = (TA_Var (makeAttributeVar ident), pState) -adjustAttribute TA_Anonymous (GTV {tv_name={id_name}}) pState +// Sjaak 210801 ... + +adjustAttribute :: !TypeAttribute Type *ParseState -> (!TypeAttribute, !*ParseState) +adjustAttribute attr (TV {tv_name}) pState + = adjustAttributeOfTypeVariable attr tv_name pState +adjustAttribute attr (GTV {tv_name}) pState + = adjustAttributeOfTypeVariable attr tv_name pState +adjustAttribute attr type pState + = (attr, pState) + +adjustAttributeOfTypeVariable :: !TypeAttribute !Ident !*ParseState -> (!TypeAttribute, !*ParseState) +adjustAttributeOfTypeVariable TA_Anonymous {id_name} pState # (ident, pState) = stringToIdent id_name IC_TypeAttr pState = (TA_Var (makeAttributeVar ident), pState) -adjustAttribute attr type pState +adjustAttributeOfTypeVariable attr _ pState = (attr, pState) +// ... Sjaak 210801 + stringToType :: !String !ParseState -> (!Type, !ParseState) stringToType name pState | isLowerCaseName name @@ -1937,6 +1950,7 @@ wantDynamicType pState # (type_vars, pState) = optionalUniversalQuantifiedVariables pState (type, pState) = want pState = ({ dt_uni_vars = type_vars, dt_type = type, dt_global_vars = [] }, pState) + /* PK :: QuantifierKind = UniversalQuantifier | ExistentialQuantifier @@ -1970,38 +1984,56 @@ optionalExistentialQuantifiedVariables pState # (token, pState) = nextToken TypeContext pState = case token of ExistsToken - # (vars, pState) = wantList "existential quantified variable(s)" tryAttributedFreeTypeVar pState + # (vars, pState) = wantList "existential quantified variable(s)" try_existential_type_var pState -> (vars, wantToken TypeContext "Existential Quantified Variables" ColonToken pState) _ -> ([], tokenBack pState) +where + try_existential_type_var :: !ParseState -> (Bool,ATypeVar,ParseState) + try_existential_type_var pState + # (token, pState) = nextToken TypeContext pState + = case token of + DotToken + // Sjaak 210801 ... + # (typevar, pState) = wantTypeVar pState + -> (True, {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar}, pState) + // ... Sjaak + _ + # (succ, typevar, pState) = tryTypeVarT token pState + | succ + # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} + -> (True,atypevar,pState) + -> (False,abort "no ATypeVar",pState) + +// Sjaak 210801 .... optionalUniversalQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState) optionalUniversalQuantifiedVariables pState # (token, pState) = nextToken TypeContext pState = case token of ForAllToken - # (vars, pState) = wantList "universal quantified variable(s)" tryAttributedFreeTypeVar pState + # (vars, pState) = wantList "universal quantified variable(s)" try_universal_type_var 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) + +// ... Sjaak -tryAttributedFreeTypeVar :: !ParseState -> (Bool,ATypeVar,ParseState) -tryAttributedFreeTypeVar pState - # (token, pState) = nextToken TypeContext pState - = case token of - DotToken -// RWS ... - # (token, pState) = nextToken TypeContext pState -// ... RWS - # (succ,typevar, pState) = tryTypeVarT token pState - | succ - # atypevar = {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar} - -> (True,atypevar,pState) - -> (False,abort "no ATypeVar",pState) - _ - # (succ,typevar, pState) = tryTypeVarT token pState - | succ - # atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar} - -> (True,atypevar,pState) - -> (False,abort "no ATypeVar",pState) /* PK optionalQuantifiedVariables :: !QuantifierKind !*ParseState -> *(![ATypeVar],!*ParseState) diff --git a/frontend/refmark.icl b/frontend/refmark.icl index 6c2ef7d..bc9d78b 100644 --- a/frontend/refmark.icl +++ b/frontend/refmark.icl @@ -6,7 +6,7 @@ import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWS NotASelector :== -1 -class refMark expr :: ![[FreeVar]] !Int !(Optional Expression) !expr !*VarHeap -> *VarHeap +class refMark expr :: ![[FreeVar]] !Int !(Optional [(FreeVar,ReferenceCount)]) !expr !*VarHeap -> *VarHeap instance refMark [a] | refMark a @@ -141,8 +141,8 @@ where # (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src }) - refMark free_vars sel def (Case {case_expr,case_guards,case_default,case_explicit}) var_heap - = refMarkOfCase free_vars sel case_expr case_guards case_explicit (combineDefaults def case_default case_explicit) var_heap + refMark free_vars sel def (Case kees) var_heap + = refMarkOfCase free_vars sel def kees var_heap refMark free_vars sel _ (Selection _ expr selectors) var_heap = refMark free_vars (field_number selectors) No expr var_heap where @@ -257,28 +257,28 @@ where _ -> var_heap -refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) explicit defaul var_heap - = ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap +refMarkOfCase free_vars sel def {case_expr, case_guards=AlgebraicPatterns type patterns, case_explicit, case_default} var_heap + = ref_mark_of_algebraic_case free_vars sel def case_expr patterns case_explicit case_default var_heap where - ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap + ref_mark_of_algebraic_case free_vars sel def (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap # (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap = case occ_bind of OB_Empty - -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap + -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap OB_OpenLet let_expr # var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr }) var_heap = refMark free_vars sel No let_expr var_heap - -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap + -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap OB_LockedLet _ - -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap + -> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap OB_Pattern vars ob - -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap - ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap - = ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns explicit defaul var_heap + -> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap + ref_mark_of_algebraic_case free_vars sel def expr patterns explicit defaul var_heap + = ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns explicit defaul var_heap ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused} - free_vars sel patterns case_explicit case_default var_heap - # var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap + free_vars sel def patterns case_explicit case_default var_heap + # var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap (VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap = case var_occ.occ_ref_count of RC_Unused @@ -288,22 +288,25 @@ where -> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }}) ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr - var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_explicit case_default var_heap + var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel def patterns case_explicit case_default var_heap # var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]), rcu_uniquely = [], rcu_selectively = [] }} var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ ) - = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap + = ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap - ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_explicit case_default var_heap + ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns case_explicit case_default var_heap # var_heap = refMark free_vars NotASelector No expr var_heap - = ref_mark_of_patterns True free_vars sel No patterns case_explicit case_default var_heap + = ref_mark_of_patterns True free_vars sel def No patterns case_explicit case_default var_heap - ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_explicit case_default var_heap + ref_mark_of_patterns with_composite_pattern free_vars sel def opt_pattern_var patterns case_explicit case_default var_heap # (local_lets, var_heap) = collectLocalLetVars free_vars var_heap + (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap (with_pattern_bindings, pattern_depth, used_lets, var_heap) - = foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets (propagateDefault case_explicit case_default)) - patterns (False, 0, [], var_heap) - = refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap + = foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def) patterns (False, 0, used_lets, var_heap) + = addRefMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars def used_lets var_heap + +// = refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap + ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def {ap_vars,ap_expr} (with_pattern_bindings, pattern_depth, used_lets, var_heap) @@ -311,7 +314,7 @@ where var_heap = saveOccurrences free_vars var_heap used_pattern_vars = collectPatternsVariables ap_vars var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap - var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap + var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap // (var_heap ---> ("ref_mark_of_algebraic_pattern", ap_expr)) var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) var_heap = clear_local_vars used_pattern_vars var_heap @@ -342,13 +345,15 @@ where // ---> ("restore_binding_of_pattern_variable", occ_ref_count) restore_binding_of_pattern_variable _ used_pattern_vars var_heap = var_heap - -refMarkOfCase free_vars sel expr (BasicPatterns type patterns) explicit defaul var_heap - # var_heap = refMark free_vars NotASelector No expr var_heap + +refMarkOfCase free_vars sel def {case_expr,case_guards=BasicPatterns type patterns,case_default,case_explicit} var_heap + # var_heap = refMark free_vars NotASelector No case_expr var_heap (local_lets, var_heap) = collectLocalLetVars free_vars var_heap - (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets (propagateDefault explicit defaul)) - patterns (0, [], var_heap) - = refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap + (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap + (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap) + = addRefMarkOfDefault False pattern_depth free_vars def used_lets var_heap + +// = refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap // ---> ("refMarkOfCase", expr, [ (bp_value, bp_expr) \\ {bp_value, bp_expr} <- patterns]) where ref_mark_of_basic_pattern free_vars sel local_lets def {bp_expr} (pattern_depth, used_lets, var_heap) @@ -358,14 +363,16 @@ where (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) = (pattern_depth, used_lets, var_heap) -refMarkOfCase free_vars sel expr (DynamicPatterns patterns) explicit defaul var_heap +refMarkOfCase free_vars sel def {case_expr,case_guards=DynamicPatterns patterns,case_default,case_explicit} var_heap # var_heap = saveOccurrences free_vars var_heap - var_heap = refMark free_vars NotASelector No expr var_heap + var_heap = refMark free_vars NotASelector No case_expr var_heap (used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap var_heap = parCombine free_vars var_heap (local_lets, var_heap) = collectLocalLetVars free_vars var_heap - (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets (propagateDefault explicit defaul)) patterns (0, [], var_heap) - = refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap + (def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap + (pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap) + = addRefMarkOfDefault True pattern_depth free_vars def used_lets var_heap +// = refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap where ref_mark_of_dynamic_pattern free_vars sel local_lets def {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap) # pattern_depth = inc pattern_depth @@ -375,20 +382,55 @@ where (used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap) = (pattern_depth, used_lets, var_heap) -propagateDefault case_explicit case_default + +refMarkOfDefault case_explicit free_vars sel def (Yes expr) local_lets var_heap + # var_heap = saveOccurrences free_vars var_heap + var_heap = refMark free_vars sel No expr var_heap + (used_lets, var_heap) = collectUsedLetVars local_lets ([], var_heap) + (occurrences, var_heap) = restore_occurrences free_vars var_heap + = (Yes occurrences, used_lets, var_heap) +where + restore_occurrences free_vars var_heap + = foldSt (foldSt restore_occurrence) free_vars ([], var_heap) + where + restore_occurrence fv=:{fv_name,fv_info_ptr} (occurrences, var_heap) + # (VI_Occurrence old_occ=:{occ_ref_count,occ_previous = [prev_ref_count : occ_previous]}, var_heap) = readPtr fv_info_ptr var_heap + var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous }) + = case occ_ref_count of + RC_Unused + -> (occurrences, var_heap) + _ + -> ([(fv,occ_ref_count) : occurrences ], var_heap) +refMarkOfDefault case_explicit free_vars sel def No local_lets var_heap | case_explicit - = No - = case_default + = (No, [], var_heap) + = (def, [], var_heap) + + +addRefMarkOfDefault do_par_combine pattern_depth free_vars (Yes occurrences) used_lets var_heap + # var_heap = saveOccurrences free_vars var_heap + var_heap = foldSt set_occurrence occurrences var_heap + var_heap = setUsedLetVars used_lets var_heap + = caseCombine do_par_combine free_vars var_heap (inc pattern_depth) +where + set_occurrence (fv=:{fv_name,fv_info_ptr}, ref_count) var_heap + # (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap + = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = ref_count } ) +addRefMarkOfDefault do_par_combine pattern_depth free_vars No used_lets var_heap + # var_heap = setUsedLetVars used_lets var_heap + = caseCombine do_par_combine free_vars var_heap pattern_depth +/* refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap # pattern_depth = inc pattern_depth var_heap = saveOccurrences free_vars var_heap - var_heap = refMark free_vars sel No expr var_heap + var_heap = refMark free_vars sel No (expr ---> ("refMarkOfDefault", (expr, free_vars))) var_heap var_heap = setUsedLetVars used_lets var_heap = caseCombine do_par_combine free_vars var_heap pattern_depth refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap # var_heap = setUsedLetVars used_lets var_heap = caseCombine do_par_combine free_vars var_heap pattern_depth +*/ parCombine free_vars var_heap = foldSt (foldSt (par_combine)) free_vars var_heap diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index e4ffdd9..dfc980d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -26,7 +26,7 @@ instance toString Ident , ste_previous :: SymbolTableEntry } -:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int } +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr } :: STE_Kind = STE_FunctionOrMacro ![Index] | STE_Type @@ -540,7 +540,6 @@ cIsALocalVar :== False // ... MdM | VI_Labelled_Empty {#Char} // RWS debugging | VI_LocalLetVar // RWS, mark Let vars during case transformation - | VI_FreeTypeVarAtRuntime // MV (dynamics), mark type variables which continue to exist at run-time. :: ExtendedVarInfo = EVI_VarType !AType @@ -862,7 +861,7 @@ cNonRecursiveAppl :== False :: TypeVarInfo = TVI_Empty | TVI_Type !Type - | TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect universally quantified type variables + | TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect and check universally quantified type variables | TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr | TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo | TVI_Attribute TypeAttribute @@ -907,10 +906,11 @@ cNonRecursiveAppl :== False , atv_variable :: !TypeVar } -:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar +:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int // | TA_TempExVar !Int | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute | TA_Locked !TypeAttribute | TA_MultiOfPropagatingConsVar // only filled in after type checking, semantically equal to TA_Multi + | TA_PA_BUG :: AttributeVar = { av_name :: !Ident diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 1d74e24..cc7bd47 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -30,7 +30,7 @@ where toString {import_module} = toString import_module , ste_previous :: SymbolTableEntry } -:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int } +:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr } :: STE_Kind = STE_FunctionOrMacro ![Index] | STE_Type @@ -525,7 +525,6 @@ cIsALocalVar :== False // ... MdM | VI_Labelled_Empty {#Char} // RWS debugging | VI_LocalLetVar // RWS, mark Let vars during case transformation - | VI_FreeTypeVarAtRuntime // MV (dynamics), mark type variables which continue to exist at run-time. :: ExtendedVarInfo = EVI_VarType !AType @@ -881,10 +880,11 @@ cNotVarNumber :== -1 , atv_variable :: !TypeVar } -:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar +:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int // | TA_TempExVar !Int | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute | TA_Locked !TypeAttribute | TA_MultiOfPropagatingConsVar + | TA_PA_BUG :: AttributeVar = { av_name :: !Ident @@ -1312,8 +1312,8 @@ where = "@@ " toString (TA_List _ _) = "??? " - toString TA_TempExVar - = PA_BUG "(E)" (abort "toString TA_TempExVar") + toString TA_PA_BUG + = PA_BUG "(E)" (abort "toString TA_PA_BUG") instance <<< Annotation where diff --git a/frontend/trans.icl b/frontend/trans.icl index 395d8ba..db0681e 100644 --- a/frontend/trans.icl +++ b/frontend/trans.icl @@ -2428,6 +2428,11 @@ where = (cons_var :@: types, 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 +// Sjaak 240801 ... + expandSynTypes rem_annots common_defs (TFA vars type) ets + # (type, ets) = expandSynTypes rem_annots common_defs type ets + = (TFA vars type, ets) +// ... Sjaak expandSynTypes rem_annots common_defs type ets = (type, ets) diff --git a/frontend/type.icl b/frontend/type.icl index c05e780..af17996 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -12,15 +12,17 @@ import generics // AA } :: TypeState = - { ts_fun_env :: !.{! FunctionType} - , ts_var_store :: !Int - , ts_attr_store :: !Int - , ts_var_heap :: !.VarHeap - , ts_type_heaps :: !.TypeHeaps - , ts_expr_heap :: !.ExpressionHeap - , ts_td_infos :: !.TypeDefInfos - , ts_error :: !.ErrorAdmin - , ts_out :: !.File + { ts_fun_env :: !.{! FunctionType} + , ts_var_store :: !TempVarId + , ts_attr_store :: !TempAttrId + , ts_var_heap :: !.VarHeap + , ts_type_heaps :: !.TypeHeaps + , ts_expr_heap :: !.ExpressionHeap + , ts_td_infos :: !.TypeDefInfos + , ts_cons_variables :: ![TempVarId] + , ts_exis_variables :: ![(CoercionPosition, [TempAttrId])] + , ts_error :: !.ErrorAdmin + , ts_out :: !.File } :: TypeCoercion = @@ -40,7 +42,6 @@ import generics // AA , req_type_coercions :: ![TypeCoercion] , req_type_coercion_groups:: ![TypeCoercionGroup] , req_attr_coercions :: ![AttrCoercion] - , req_cons_variables :: ![[TempVarId]] , req_case_and_let_exprs :: ![ExprInfoPtr] } @@ -233,6 +234,19 @@ cannot_unify t1 t2 position err -> ea_file <<< " near " <<< position = { err & ea_file = ea_file <<< '\n' } + +existentialError position=:(CP_Expression expr) err=:{ea_loc=[ip:_]} + = case tryToOptimizePosition expr of + Yes (id_name, line) + # err = pushErrorAdmin { ip & ip_ident.id_name = id_name, ip_line = line } err + err = errorHeading type_error err + err = popErrorAdmin err + -> { err & ea_file = err.ea_file <<< " attribute variable could not be universally quantified"<<< '\n' } + _ + # err = errorHeading type_error err + -> { err & ea_file = err.ea_file <<< " attribute variable could not be universally quantified"<<< '\n' } + + tryToOptimizePosition (Case {case_ident=Yes {id_name}}) = optBeautifulizeIdent id_name tryToOptimizePosition (App {app_symb={symb_name}}) @@ -477,7 +491,7 @@ freshCopyOfTypeAttribute (TA_Var avar) attr_var_heap /* Should be removed !!!!!!!!!! */ freshCopyOfTypeAttribute (TA_RootVar avar) attr_var_heap - = PA_BUG (TA_TempExVar, attr_var_heap) (freshCopyOfAttributeVar avar attr_var_heap) + = PA_BUG (TA_PA_BUG, 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 @@ -574,15 +588,15 @@ where (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, type_heaps) = freshArgumentsOfSymbolType 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 } + (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) = freshArgumentsOfSymbolType st_args { type_heaps & th_attrs = th_attrs, th_vars = th_vars } = ([fresh_args : cons_types], result_type, var_store, attr_env, type_heaps) @@ -618,19 +632,42 @@ where cWithFreshContextVars :== True cWithoutFreshContextVars :== False -freshSymbolType :: !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType,![Int],!*TypeState) -freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs - ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos,ts_var_heap} +freshArgumentsOfSymbolType :: ![AType] !*TypeHeaps -> (![AType], !*TypeHeaps) +freshArgumentsOfSymbolType atypes type_heaps = mapSt fresh_arg_type atypes type_heaps +where + fresh_arg_type at=:{at_attribute, at_type = TFA vars type} type_heaps + # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute type_heaps.th_attrs + # type_heaps = foldSt bind_var_and_attr vars { type_heaps & th_attrs = th_attrs } + (fresh_type, type_heaps) = freshCopy type type_heaps + type_heaps = clearBindings vars type_heaps + = ({ at & at_attribute = fresh_attribute, at_type = TFA vars fresh_type }, type_heaps) + where + bind_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} + = { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv)), th_attrs = bind_attr atv_attribute th_attrs } + where + bind_attr var=:(TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Attr var) + bind_attr attr attr_heap + = attr_heap + fresh_arg_type at type_heaps + = freshCopy at type_heaps + + +freshSymbolType :: !(Optional CoercionPosition) !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType, !*TypeState) +freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_env,st_arity} common_defs + ts=:{ts_var_store,ts_attr_store,ts_type_heaps,ts_td_infos,ts_var_heap,ts_cons_variables,ts_exis_variables} # (th_vars, ts_var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store) (th_attrs, ts_attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store) (attr_env, th_attrs) = freshEnvironment st_attr_env th_attrs type_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs } - (tst_args, type_heaps) = freshCopy st_args type_heaps - (tst_result, type_heaps) = freshCopy st_result type_heaps + (tst_args, (ts_var_store, ts_attr_store, ts_exis_variables, type_heaps)) + = fresh_arg_types is_appl st_args (ts_var_store, ts_attr_store, ts_exis_variables, type_heaps) + (tst_result, type_heaps) = freshCopy st_result type_heaps (tst_context, (type_heaps, ts_var_heap)) = freshTypeContexts fresh_context_vars st_context (type_heaps, ts_var_heap) - cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context [] - = ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, cons_variables, - { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = type_heaps, ts_var_heap = ts_var_heap}) + cons_variables = foldSt (collect_cons_variables_in_tc common_defs) tst_context [] + = ({ tst_args = tst_args, tst_result = tst_result, tst_context = tst_context, tst_attr_env = attr_env, tst_arity = st_arity, tst_lifted = 0 }, + { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = type_heaps, ts_var_heap = ts_var_heap, + ts_cons_variables = cons_variables ++ ts_cons_variables, ts_exis_variables = ts_exis_variables }) //---> ("freshSymbolType", st, tst_args, tst_result, tst_context) where fresh_type_variables :: .[TypeVar] *(*Heap TypeVarInfo,.Int) -> (!.Heap TypeVarInfo,!Int); @@ -642,7 +679,7 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_ fresh_attributes attributes state = foldr (\{av_info_ptr} (attr_heap, attr_store) -> (writePtr av_info_ptr (AVI_Attr (TA_TempVar attr_store)) attr_heap, inc attr_store)) state attributes - + collect_cons_variables_in_tc common_defs tc=:{tc_class={glob_module,glob_object={ds_index}}, tc_types} collected_cons_vars # {class_cons_vars} = common_defs.[glob_module].com_class_defs.[ds_index] = collect_cons_variables tc_types class_cons_vars collected_cons_vars @@ -665,6 +702,39 @@ freshSymbolType fresh_context_vars st=:{st_vars,st_args,st_result,st_context,st_ | new_var_id == var_id = vars = [var_id : add_variable new_var_id var_ids] + + fresh_arg_types No arg_types (var_store, attr_store, exis_variables, type_heaps) + # (arg_types, type_heaps) = freshArgumentsOfSymbolType arg_types type_heaps + = (arg_types, (var_store, attr_store, exis_variables, type_heaps)) + fresh_arg_types (Yes pos) arg_types (var_store, attr_store, exis_variables, type_heaps) + = mapSt (fresh_arg_type pos) arg_types (var_store, attr_store, exis_variables, type_heaps) + where + fresh_arg_type pos at=:{at_attribute, at_type = TFA vars type} (var_store, attr_store, exis_variables, type_heaps) + # (fresh_attribute, th_attrs) = freshCopyOfTypeAttribute at_attribute type_heaps.th_attrs + # (var_store, attr_store, new_exis_variables, type_heaps) + = foldSt fresh_var_and_attr vars (var_store, attr_store, [], { type_heaps & th_attrs = th_attrs }) + (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)) + 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)) + + fresh_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} (var_store, attr_store, exis_variables, type_heaps) + # (attr_store, exis_variables, th_attrs) = fresh_attr atv_attribute (attr_store, exis_variables, type_heaps.th_attrs) + = (inc var_store, attr_store, exis_variables, { type_heaps & th_vars = type_heaps.th_vars <:= (tv_info_ptr, TVI_Type (TempQV var_store)), th_attrs = th_attrs }) + where + fresh_attr var=:(TA_Var {av_info_ptr}) (attr_store, exis_variables, attr_heap) + = (inc attr_store, [attr_store : exis_variables], attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store))) + 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] + freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo); freshInequality {ai_demanded,ai_offered} attr_heap @@ -871,14 +941,13 @@ where combine_attributes _ cum_attr attr_env attr_store = (cum_attr, attr_env, attr_store) -determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_vars,st_attr_env} type_ptr common_defs ts=:{ts_var_heap} +determineSymbolTypeOfFunction pos ident act_arity st=:{st_args,st_result,st_attr_vars,st_attr_env} type_ptr common_defs ts=:{ts_var_heap} # (type_info, ts_var_heap) = readPtr type_ptr ts_var_heap ts = { ts & ts_var_heap = ts_var_heap } = case type_info of VI_PropagationType symb_type - # (copy_symb_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars symb_type common_defs ts - (curried_st, ts) = currySymbolType copy_symb_type act_arity ts - -> (curried_st, cons_variables, ts) + # (copy_symb_type, ts) = freshSymbolType (Yes pos) cWithFreshContextVars symb_type common_defs ts + -> currySymbolType copy_symb_type act_arity ts _ # (st_args, ps) = addPropagationAttributesToATypes common_defs st_args { prop_type_heaps = ts.ts_type_heaps, prop_td_infos = ts.ts_td_infos, @@ -886,36 +955,32 @@ determineSymbolTypeOfFunction ident act_arity st=:{st_args,st_result,st_attr_var (st_result, _, {prop_type_heaps,prop_td_infos,prop_attr_vars,prop_error = Yes ts_error,prop_attr_env}) = addPropagationAttributesToAType common_defs st_result ps st = { st & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } - # (copy_symb_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars st common_defs { ts & + # (copy_symb_type, ts) = freshSymbolType (Yes pos) cWithFreshContextVars st common_defs { ts & ts_type_heaps = prop_type_heaps, ts_td_infos = prop_td_infos, ts_error = ts_error, ts_var_heap = ts.ts_var_heap <:= (type_ptr, VI_PropagationType st) } - (curried_st, ts) = currySymbolType copy_symb_type act_arity ts - -> (curried_st, cons_variables, ts) + -> currySymbolType copy_symb_type act_arity ts -standardFieldSelectorType {glob_object={ds_ident,ds_index},glob_module} {ti_common_defs} ts=:{ts_var_store,ts_type_heaps} +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) - (inst, cons_variables, ts) = freshSymbolType cWithFreshContextVars sd_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } - = (inst, ts) + = 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", ds_ident, inst) -standardTupleSelectorType {ds_index} arg_nr {ti_common_defs} ts +standardTupleSelectorType pos {ds_index} arg_nr {ti_common_defs} ts #! {cons_type} = ti_common_defs.[cPredefinedModuleIndex].com_cons_defs.[ds_index] - (fresh_type, cons_variables, ts) = freshSymbolType cWithFreshContextVars { cons_type & st_args = [cons_type.st_result], st_result = cons_type.st_args !! arg_nr } ti_common_defs ts - = (fresh_type, ts) + = freshSymbolType (Yes pos) cWithFreshContextVars { cons_type & st_args = [cons_type.st_result], st_result = cons_type.st_args !! arg_nr } ti_common_defs ts -standardRhsConstructorType index mod arity {ti_common_defs} ts +standardRhsConstructorType pos index mod arity {ti_common_defs} ts #! {cons_symb, cons_type, cons_exi_vars } = ti_common_defs.[mod].com_cons_defs.[index] # cons_type = { cons_type & st_vars = mapAppend (\{atv_variable} -> atv_variable) cons_exi_vars cons_type.st_vars } - (fresh_type, _, ts) = freshSymbolType cWithFreshContextVars cons_type ti_common_defs ts + (fresh_type, ts) = freshSymbolType (Yes pos) cWithFreshContextVars cons_type 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) - (fresh_type, _, ts) = freshSymbolType cWithFreshContextVars cons_type ti_common_defs { ts & ts_type_heaps = { ts_type_heaps & th_vars = th_vars }, ts_var_store = ts_var_store } - = (fresh_type, ts) + = 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", cons_symb, fresh_type) :: ReferenceMarking :== Bool @@ -928,7 +993,7 @@ storeAttribute (Yes expt_ptr) type_attribute symbol_heap storeAttribute No type_attribute symbol_heap = symbol_heap -getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name} ts +getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_Function {glob_module,glob_object}, symb_arity, symb_name} ts | glob_module == ti_main_dcl_module_n | glob_object>=size ts.ts_fun_env = abort symb_name.id_name; @@ -936,60 +1001,60 @@ getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = case fun_type of UncheckedType fun_type # (fun_type_copy, ts) = currySymbolType fun_type symb_arity ts - -> (fun_type_copy, [], [], ts) + -> (fun_type_copy, [], ts) SpecifiedType fun_type lifted_arg_types _ - # (fun_type_copy=:{tst_args,tst_arity}, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars fun_type ti_common_defs ts + # (fun_type_copy=:{tst_args,tst_arity}, ts) = freshSymbolType (Yes pos) cWithoutFreshContextVars fun_type ti_common_defs ts (fun_type_copy, ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args, tst_arity = tst_arity + length lifted_arg_types } symb_arity ts - -> (fun_type_copy, cons_variables, [], ts) + -> (fun_type_copy, [], ts) CheckedType fun_type - # (fun_type_copy, cons_variables, ts) = freshSymbolType cWithFreshContextVars fun_type ti_common_defs ts + # (fun_type_copy, ts) = freshSymbolType (Yes pos) cWithFreshContextVars fun_type ti_common_defs ts (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts - -> (fun_type_copy, cons_variables, [], ts) + -> (fun_type_copy, [], ts) _ -> abort ("getSymbolType: SK_Function "+++toString symb_name+++" "+++toString glob_object) // -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) # {ft_type,ft_type_ptr,ft_specials} = ti_functions.[glob_module].[glob_object] | glob_module>=size ti_functions || glob_object>=size ti_functions.[glob_module] = abort (toString glob_module+++" "+++toString glob_object+++" "+++toString ti_main_dcl_module_n+++" "+++symb_name.id_name); - # (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction symb_name symb_arity ft_type ft_type_ptr ti_common_defs ts - = (fun_type_copy, cons_variables, get_specials ft_specials, ts) + # (fun_type_copy, ts) = determineSymbolTypeOfFunction pos symb_name symb_arity ft_type ft_type_ptr ti_common_defs ts + = (fun_type_copy, get_specials ft_specials, ts) where get_specials (SP_ContextTypes specials) = specials get_specials SP_None = [] -getSymbolType ti {symb_kind = SK_Constructor {glob_module,glob_object}, symb_arity} ts - # (fresh_cons_type, ts) = standardRhsConstructorType glob_object glob_module symb_arity ti ts - = (fresh_cons_type, [], [], ts) -getSymbolType ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_arity, symb_name} ts +getSymbolType pos ti {symb_kind = SK_Constructor {glob_module,glob_object}, symb_arity} ts + # (fresh_cons_type, ts) = standardRhsConstructorType pos glob_object glob_module symb_arity ti ts + = (fresh_cons_type, [], ts) +getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_kind = SK_LocalMacroFunction glob_object, symb_arity, symb_name} ts | glob_object>=size ts.ts_fun_env = abort symb_name.id_name; # (fun_type, ts) = ts!ts_fun_env.[glob_object] = case fun_type of UncheckedType fun_type # (fun_type_copy, ts) = currySymbolType fun_type symb_arity ts - -> (fun_type_copy, [], [], ts) + -> (fun_type_copy, [], ts) SpecifiedType fun_type lifted_arg_types _ - # (fun_type_copy=:{tst_args,tst_arity}, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars fun_type ti_common_defs ts + # (fun_type_copy=:{tst_args,tst_arity}, ts) = freshSymbolType (Yes pos) cWithoutFreshContextVars fun_type ti_common_defs ts (fun_type_copy, ts) = currySymbolType { fun_type_copy & tst_args = lifted_arg_types ++ fun_type_copy.tst_args, tst_arity = tst_arity + length lifted_arg_types } symb_arity ts - -> (fun_type_copy, cons_variables, [], ts) + -> (fun_type_copy, [], ts) CheckedType fun_type - # (fun_type_copy, cons_variables, ts) = freshSymbolType cWithFreshContextVars fun_type ti_common_defs ts + # (fun_type_copy, ts) = freshSymbolType (Yes pos) cWithFreshContextVars fun_type ti_common_defs ts (fun_type_copy,ts) = currySymbolType fun_type_copy symb_arity ts - -> (fun_type_copy, cons_variables, [], ts) + -> (fun_type_copy, [], ts) _ -> abort ("getSymbolType SK_LocalMacroFunction: "+++toString symb_name+++" " +++toString glob_object) // -> abort "getSymbolType (type.icl)" ---> (symb_name, glob_object, fun_type) -getSymbolType ti=:{ti_common_defs} {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} ts +getSymbolType pos ti=:{ti_common_defs} {symb_kind = SK_OverloadedFunction {glob_module,glob_object}, symb_arity} ts # {me_symb, me_type,me_type_ptr} = ti_common_defs.[glob_module].com_member_defs.[glob_object] - (fun_type_copy, cons_variables, ts) = determineSymbolTypeOfFunction me_symb symb_arity me_type me_type_ptr ti_common_defs ts - = (fun_type_copy, cons_variables, [], ts) + (fun_type_copy, ts) = determineSymbolTypeOfFunction pos me_symb symb_arity me_type me_type_ptr ti_common_defs ts + = (fun_type_copy, [], ts) // AA.. -getSymbolType ti=:{ti_common_defs} symbol=:{symb_kind = SK_Generic gen_glob kind} ts +getSymbolType pos ti=:{ti_common_defs} symbol=:{symb_kind = SK_Generic gen_glob kind} ts # (found, member_glob) = getGenericMember gen_glob kind ti_common_defs | not found = abort "getSymbolType: no class for kind" - = getSymbolType ti {symbol & symb_kind = SK_OverloadedFunction member_glob} ts + = getSymbolType pos ti {symbol & symb_kind = SK_OverloadedFunction member_glob} ts // ..AA class requirements a :: !TypeInput !a !(!u:Requirements, !*TypeState) -> (!AType, !Optional ExprInfoPtr, !(!u:Requirements, !*TypeState)) @@ -1009,21 +1074,22 @@ where _ -> abort "requirements BoundVar " // ---> (var_name <<- var_info)) where - bind_var_and_attr {atv_attribute, atv_variable = {tv_info_ptr}} ts=:{ts_var_store, ts_type_heaps} - = { ts & ts_var_store = inc ts_var_store, ts_type_heaps = + bind_var_and_attr {atv_attribute, atv_variable = {tv_info_ptr}} ts=:{ts_var_store, ts_attr_store, ts_type_heaps} + # (ts_attr_store, th_attrs) = bind_attr atv_attribute (ts_attr_store, ts_type_heaps.th_attrs) + = { ts & ts_var_store = inc ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = { ts_type_heaps & th_vars = ts_type_heaps.th_vars <:= (tv_info_ptr, TVI_Type (TempV ts_var_store)), - th_attrs = bind_attr atv_attribute ts_type_heaps.th_attrs }} + th_attrs = th_attrs }} where - bind_attr (TA_Var {av_info_ptr}) attr_heap - = attr_heap <:= (av_info_ptr, AVI_Attr TA_TempExVar) + bind_attr (TA_Var {av_info_ptr}) (attr_store, attr_heap) + = (inc attr_store, attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store))) bind_attr attr attr_heap = attr_heap instance requirements App where - requirements ti {app_symb,app_args,app_info_ptr} (reqs=:{req_cons_variables, req_attr_coercions}, ts) - # (tst=:{tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, specials, ts) = getSymbolType ti app_symb ts - reqs = { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions, req_cons_variables = [cons_variables : req_cons_variables] } + requirements ti app=:{app_symb,app_args,app_info_ptr} (reqs=:{req_attr_coercions}, ts) + # (tst=:{tst_attr_env,tst_args,tst_result,tst_context}, specials, ts) = getSymbolType (CP_Expression (App app)) ti app_symb ts + reqs = { reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions } (reqs, ts) = requirements_of_args ti app_symb.symb_name 1 app_args tst_args (reqs, ts) | isEmpty tst_context = (tst_result, No, (reqs, ts)) @@ -1322,7 +1388,7 @@ where 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 ds_index glob_module ds_arity ti ts + (rhs, ts) = standardRhsConstructorType (CP_Expression expression) 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 } @@ -1347,12 +1413,12 @@ where = ({ reqs & req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts) requirements ti (TupleSelect tuple_symbol arg_nr expr) (reqs=:{req_attr_coercions}, ts) - # ({tst_args = [argtype:_], tst_result, tst_attr_env}, ts) = standardTupleSelectorType tuple_symbol arg_nr ti ts + # (position, ts_var_heap) = getPositionOfExpr expr ts.ts_var_heap + ({tst_args = [argtype:_], tst_result, tst_attr_env}, ts) = standardTupleSelectorType position tuple_symbol arg_nr ti { ts & ts_var_heap = ts_var_heap } (e_type, opt_expr_ptr, (reqs, ts)) = requirements ti expr ({ reqs & req_attr_coercions = tst_attr_env ++ req_attr_coercions }, ts) - (position, ts_var_heap) = getPositionOfExpr expr ts.ts_var_heap req_type_coercions = [{ tc_demanded = argtype, tc_offered = e_type, tc_position = position, tc_coercible = True } : reqs.req_type_coercions ] ts_expr_heap = storeAttribute opt_expr_ptr argtype.at_attribute ts.ts_expr_heap - = (tst_result, No, ({ reqs & req_type_coercions = req_type_coercions }, { ts & ts_expr_heap = ts_expr_heap, ts_var_heap = ts_var_heap })) + = (tst_result, No, ({ reqs & req_type_coercions = req_type_coercions }, { ts & ts_expr_heap = ts_expr_heap })) requirements _ (BasicExpr basic_val basic_type) (reqs, ts) @@ -1392,15 +1458,15 @@ requirementsOfSelectors ti opt_expr expr [selector : selectors] tc_coercible sel = (has_array_selection || have_array_selection, result_type, reqs_ts) requirementsOfSelector ti _ expr (RecordSelection field _) tc_coercible sel_expr_type sel_expr (reqs, ts ) - # ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType field ti ts + # ({tst_args, tst_result, tst_attr_env}, ts) = standardFieldSelectorType (CP_Expression sel_expr) field ti ts req_type_coercions = [{ tc_demanded = hd tst_args, tc_offered = sel_expr_type, tc_position = CP_Expression sel_expr, tc_coercible = tc_coercible } : reqs.req_type_coercions ] = (False, tst_result, ({ reqs & req_type_coercions = req_type_coercions }, ts)) requirementsOfSelector ti opt_expr expr (ArraySelection {glob_object = {ds_ident,ds_index,ds_arity},glob_module} expr_ptr index_expr) tc_coercible sel_expr_type sel_expr (reqs, ts) # {me_type} = ti.ti_common_defs.[glob_module].com_member_defs.[ds_index] - ({tst_attr_env,tst_args,tst_result,tst_context}, cons_variables, ts) = freshSymbolType cWithFreshContextVars me_type ti.ti_common_defs ts + ({tst_attr_env,tst_args,tst_result,tst_context}, ts) = freshSymbolType (Yes (CP_Expression expr)) cWithFreshContextVars me_type ti.ti_common_defs ts (dem_array_type, dem_index_type, rest_type) = array_and_index_type tst_args - reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions, req_cons_variables = [ cons_variables : reqs.req_cons_variables ]} + reqs ={ reqs & req_attr_coercions = tst_attr_env ++ reqs.req_attr_coercions} (index_type, opt_expr_ptr, (reqs, ts)) = requirements ti index_expr (reqs, ts) ts_expr_heap = storeAttribute opt_expr_ptr dem_index_type.at_attribute ts.ts_expr_heap reqs = { reqs & req_type_coercions = [{ tc_demanded = dem_index_type, tc_offered = index_type, tc_position = CP_Expression expr, tc_coercible = True }, @@ -1477,15 +1543,15 @@ InitFunEnv nr_of_fun_defs CreateInitialSymbolTypes start_index common_defs [] defs_and_state = defs_and_state -CreateInitialSymbolTypes start_index common_defs [fun : funs] (fun_defs, pre_def_symbols, req_cons_variables, ts) +CreateInitialSymbolTypes start_index common_defs [fun : funs] (fun_defs, pre_def_symbols, ts) # (fd, fun_defs) = fun_defs![fun] - (pre_def_symbols, req_cons_variables, ts) = initial_symbol_type (start_index == fun) common_defs fd (pre_def_symbols, req_cons_variables, ts) - = CreateInitialSymbolTypes start_index common_defs funs (fun_defs, pre_def_symbols, req_cons_variables, ts) + (pre_def_symbols, ts) = initial_symbol_type (start_index == fun) common_defs fd (pre_def_symbols, ts) + = CreateInitialSymbolTypes start_index common_defs funs (fun_defs, pre_def_symbols, ts) where initial_symbol_type is_start_rule common_defs {fun_symb, fun_type = Yes ft=:{st_arity,st_args,st_result,st_attr_vars,st_attr_env},fun_lifted, fun_info = {fi_dynamics}, fun_pos } - (pre_def_symbols, req_cons_variables, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error}) + (pre_def_symbols, ts=:{ts_type_heaps,ts_expr_heap,ts_td_infos,ts_error}) # fe_location = newPosition fun_symb fun_pos ts_error = setErrorAdmin fe_location ts_error (st_args, ps) = addPropagationAttributesToATypes common_defs st_args @@ -1495,23 +1561,23 @@ where = addPropagationAttributesToAType common_defs st_result ps ft_with_prop = { ft & st_args = st_args, st_result = st_result, st_attr_vars = prop_attr_vars, st_attr_env = prop_attr_env } (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (prop_type_heaps.th_vars, ts.ts_expr_heap) - (fresh_fun_type, cons_variables, ts) = freshSymbolType cWithoutFreshContextVars ft_with_prop common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap, + (fresh_fun_type, ts) = freshSymbolType No cWithoutFreshContextVars ft_with_prop common_defs { ts & ts_type_heaps = { prop_type_heaps & th_vars = th_vars }, ts_expr_heap = ts_expr_heap, ts_td_infos = prop_td_infos, ts_error = ts_error } (lifted_args, ts) = fresh_non_unique_type_variables fun_lifted [] ts (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) = fresh_dynamics fi_dynamics (ts.ts_var_store, ts.ts_type_heaps, ts.ts_var_heap, ts.ts_expr_heap, pre_def_symbols) - = (pre_def_symbols, [ cons_variables : req_cons_variables], + = (pre_def_symbols, { ts & ts_fun_env = { ts.ts_fun_env & [fun] = SpecifiedType ft_with_prop lifted_args { fresh_fun_type & tst_arity = st_arity + fun_lifted, tst_args = lifted_args ++ fresh_fun_type.tst_args, tst_lifted = fun_lifted }}, ts_var_heap = ts_var_heap, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps }) - initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, req_cons_variables, ts) + initial_symbol_type is_start_rule common_defs {fun_arity, fun_lifted, fun_info = {fi_dynamics}} (pre_def_symbols, ts) # (st_gen, ts) = create_general_symboltype is_start_rule fun_arity fun_lifted ts ts_type_heaps = ts.ts_type_heaps (th_vars, ts_expr_heap) = clear_dynamics fi_dynamics (ts_type_heaps.th_vars, ts.ts_expr_heap) (ts_var_store, ts_type_heaps, ts_var_heap, ts_expr_heap, pre_def_symbols) = fresh_dynamics fi_dynamics (ts.ts_var_store, { ts_type_heaps & th_vars = th_vars }, ts.ts_var_heap, ts_expr_heap, pre_def_symbols) - = (pre_def_symbols, req_cons_variables, { ts & ts_fun_env = { ts.ts_fun_env & [fun] = UncheckedType st_gen }, ts_var_store = ts_var_store, + = (pre_def_symbols, { ts & ts_fun_env = { ts.ts_fun_env & [fun] = UncheckedType st_gen }, ts_var_store = ts_var_store, ts_expr_heap = ts_expr_heap, ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap}) @@ -1641,7 +1707,7 @@ specification_error type type1 err format = { form_properties = cAttributed, form_attr_position = No} = { err & ea_file = err.ea_file <<< " specified type " <:: (format, type1, Yes initialTypeVarBeautifulizer) - <<< "conflicts with derived type " + <<< " conflicts with derived type " <:: (format, type, Yes initialTypeVarBeautifulizer) <<< '\n' } @@ -1788,7 +1854,7 @@ typeProgram comps main_dcl_module_n fun_defs specials list_inferred_types icl_de state = collect_imported_instances imports ti_common_defs {} ts_error class_instances hp_type_heaps.th_vars td_infos (_, ts_error, class_instances, th_vars, td_infos) = collect_and_check_instances (size icl_defs.com_instance_defs) ti_common_defs state - ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, + ts = { ts_fun_env = InitFunEnv fun_env_size, ts_var_heap = hp_var_heap, ts_expr_heap = hp_expression_heap, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error, ts_out = out } ti = { ti_common_defs = ti_common_defs, ti_functions = ti_functions,ti_main_dcl_module_n=main_dcl_module_n } special_instances = { si_next_array_member_index = fun_env_size, si_array_instances = [], si_next_TC_member_index = 0, si_TC_instances = [] } @@ -1918,19 +1984,21 @@ where type_component list_inferred_types comp class_instances ti=:{ti_common_defs} (type_error, fun_defs, predef_symbols, special_instances, ts) # (start_index, predef_symbols) = get_index_of_start_rule predef_symbols // # (functions, fun_defs) = show_component comp fun_defs - # (fun_defs, predef_symbols, cons_variables, ts) = CreateInitialSymbolTypes start_index ti_common_defs comp (fun_defs, predef_symbols, [], ts) + # (fun_defs, predef_symbols, ts) = CreateInitialSymbolTypes start_index ti_common_defs comp (fun_defs, predef_symbols, ts) | not ts.ts_error.ea_ok // ---> ("typing", functions) = (True, fun_defs, predef_symbols, special_instances, create_erroneous_function_types comp - { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_error = { ts.ts_error & ea_ok = True } }) - # (fun_reqs, (cons_variables, fun_defs, ts)) = type_functions comp ti cons_variables fun_defs ts + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], + ts_error = { ts.ts_error & ea_ok = True } }) + # (fun_reqs, (fun_defs, ts)) = type_functions comp ti fun_defs ts #! 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 = (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 - (cons_var_vects, subst) = determine_cons_variables cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst) + { ts & ts_type_heaps = ts_type_heaps, ts_error = { ts_error & ea_ok = True }, + ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = []}) + # {ts_attr_store,ts_var_heap,ts_var_store,ts_expr_heap,ts_td_infos,ts_cons_variables,ts_exis_variables} = ts + (cons_var_vects, subst) = determine_cons_variables ts_cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst) (subst, nr_of_attr_vars, ts_type_heaps, ts_td_infos) = liftSubstitution subst ti_common_defs cons_var_vects ts_attr_store ts_type_heaps ts_td_infos coer_demanded ={{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrUni] = CT_Unique } coer_offered = {{ CT_Empty \\ i <- [0 .. nr_of_attr_vars - 1] } & [AttrMulti] = CT_NonUnique } @@ -1943,7 +2011,7 @@ where os_predef_symbols = predef_symbols, os_error = ts_error, os_special_instances = special_instances } modules | not os_error.ea_ok = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp { ts & ts_type_heaps = os_type_heaps, - ts_error = { os_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar, + ts_error = { os_error & ea_ok = True }, ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_td_infos = ts_td_infos, ts_expr_heap = os_symbol_heap, ts_var_heap = os_var_heap }) # (fun_defs, coercion_env, subst, ts_td_infos, os_var_heap, os_symbol_heap, os_error) = makeSharedReferencesNonUnique comp fun_defs coercion_env subst ts_td_infos os_var_heap os_symbol_heap os_error @@ -1954,6 +2022,7 @@ where = foldSt (add_unicity_of_essentially_unique_types_for_function ti_common_defs) comp (ts_fun_env, coercions) (attr_partition, coer_demanded) = partitionateAttributes coer_offered coer_demanded + (coer_demanded, ts_error) = check_existential_attributes ts_exis_variables attr_partition coer_demanded ts_error attr_var_env = createArray nr_of_attr_vars TA_None var_env = { subst & [i] = TE \\ i <- [0..dec ts_var_store]} (fun_defs, ts) = cleanUpAndCheckFunctionTypes comp fun_reqs dict_types start_index list_inferred_types ti_common_defs contexts coer_demanded attr_partition var_env attr_var_env @@ -1961,7 +2030,7 @@ where ts_td_infos = ts_td_infos, ts_var_heap = os_var_heap, ts_expr_heap = os_symbol_heap }) | not ts.ts_error.ea_ok = (True, fun_defs, os_predef_symbols, os_special_instances, create_erroneous_function_types comp - { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_error = { ts.ts_error & ea_ok = True } }) + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], ts_error = { ts.ts_error & ea_ok = True } }) | isEmpty over_info # ts_type_heaps = ts.ts_type_heaps type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, @@ -1970,8 +2039,9 @@ where = updateDynamics comp local_pattern_variables main_dcl_module_n fun_defs ts.ts_fun_env ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, - { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, - ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env}) + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], + ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, + ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env}) # ts_type_heaps = ts.ts_type_heaps type_code_info = { tci_next_index = os_special_instances.si_next_TC_member_index, tci_instances = os_special_instances.si_TC_instances, tci_type_var_heap = ts_type_heaps.th_vars, tci_dcl_modules = dcl_modules } @@ -1980,8 +2050,9 @@ where ts.ts_expr_heap type_code_info ts.ts_var_heap ts.ts_error os_predef_symbols = ( type_error || not ts_error.ea_ok, fun_defs, os_predef_symbols, { os_special_instances & si_next_TC_member_index = tci_next_index, si_TC_instances = tci_instances }, - { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, - ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env}) + { ts & ts_var_store = 0, ts_attr_store = FirstAttrVar, ts_cons_variables = [], ts_exis_variables = [], + ts_expr_heap = ts_expr_heap, ts_error = { ts_error & ea_ok = True }, + ts_var_heap = ts_var_heap, ts_type_heaps = { ts_type_heaps & th_vars = tci_type_var_heap }, ts_fun_env = ts_fun_env}) add_unicity_of_essentially_unique_types_for_function ti_common_defs fun (ts_fun_env, coercions) # (env_type, ts_fun_env) = ts_fun_env![fun] @@ -2032,17 +2103,17 @@ where = coercion_env determine_cons_variables variables vect_and_subst - = foldSt (foldSt determine_cons_variable) variables vect_and_subst - - determine_cons_variable tv_number (bitvects, subst) - # (type, subst) = subst![tv_number] - = case type of - TE - -> (set_bit tv_number bitvects, subst) // ---> ("determine_cons_variable1", tv_number) - TempV var_number - -> (set_bit var_number bitvects, subst) // ---> ("determine_cons_variable2", var_number) - _ - -> (bitvects, subst) + = foldSt determine_cons_variable variables vect_and_subst + where + determine_cons_variable tv_number (bitvects, subst) + # (type, subst) = subst![tv_number] + = case type of + TE + -> (set_bit tv_number bitvects, subst) // ---> ("determine_cons_variable1", tv_number) + TempV var_number + -> (set_bit var_number bitvects, subst) // ---> ("determine_cons_variable2", var_number) + _ + -> (bitvects, subst) build_coercion_env :: [.FunctionRequirements] v:{!Type} *Coercions {#CommonDefs} {#Int} *{#*{#TypeDefInfo}} *TypeHeaps !*ErrorAdmin -> (!w:{!Type},!.Coercions,!u:{#u:{#TypeDefInfo}},!.TypeHeaps,!.ErrorAdmin), [v <= w]; build_coercion_env [{fe_requirements={req_type_coercion_groups},fe_location={ip_ident}} : reqs_list] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error @@ -2089,6 +2160,15 @@ where add_to_coercion_env [] subst coercion_env common_defs cons_var_vects type_signs type_var_heap error = (subst, coercion_env, type_signs, type_var_heap, error) + check_existential_attributes ts_exis_variables partition coercions ts_error + = foldSt (check_existential_attributes_at_pos partition) ts_exis_variables (coercions, ts_error) + where + check_existential_attributes_at_pos partition (pos, attr_vars) (coercions, ts_error) + # (ok, coercions) = checkExistentionalAttributeVars attr_vars partition coercions + | ok + = (coercions, ts_error) + = (coercions, existentialError pos ts_error) + collect_and_expand_overloaded_calls [] calls subst_and_heap = (calls, subst_and_heap) @@ -2135,6 +2215,7 @@ where SpecifiedType ft _ tst # (_, exp_tst, subst) = arraySubst tst subst -> expand_function_types funs subst { ts_fun_env & [fun] = ExpandedType ft tst exp_tst} +// ---> ("expand_function_types", tst, exp_tst) expand_function_types [] subst ts_fun_env = (subst, ts_fun_env) @@ -2165,10 +2246,10 @@ where update_function_types_in_component [] fun_env fun_defs = (fun_defs, fun_env) - type_functions group ti cons_variables fun_defs ts - = mapSt (type_function ti) group (cons_variables, fun_defs, ts) // ((cons_variables, fun_defs, ts) ---> "[(") ---> ")]" + type_functions group ti fun_defs ts + = mapSt (type_function ti) group (fun_defs, ts) - type_function ti fun_index (cons_variables, fun_defs, ts=:{ts_fun_env, ts_var_heap, ts_expr_heap, ts_error}) + type_function ti fun_index (fun_defs, ts=:{ts_fun_env, ts_var_heap, ts_expr_heap, ts_error}) # (fd, fun_defs) = fun_defs![fun_index] (type, ts_fun_env) = ts_fun_env![fun_index] {fun_symb,fun_arity,fun_body=TransformedBody {tb_args,tb_rhs},fun_pos, fun_info, fun_type} = fd @@ -2177,7 +2258,7 @@ where fe_location = newPosition fun_symb fun_pos ts_error = setErrorAdmin fe_location ts_error reqs = { req_overloaded_calls = [], req_type_coercion_groups = [], req_type_coercions = [], - req_attr_coercions = [], req_case_and_let_exprs = [], req_cons_variables = cons_variables } + req_attr_coercions = [], req_case_and_let_exprs = [] } ( rhs_type, rhs_expr_ptr, (rhs_reqs, ts)) = requirements ti tb_rhs (reqs, { ts & ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_error = ts_error, ts_fun_env = ts_fun_env }) req_type_coercions = [{tc_demanded = temp_fun_type.tst_result,tc_offered = rhs_type, tc_position = CP_Expression tb_rhs, tc_coercible = True} : @@ -2186,9 +2267,9 @@ where type_coercion_group_from_accu = { tcg_type_coercions = req_type_coercions, tcg_position = fun_pos } req_type_coercion_groups = [type_coercion_group_from_accu:rhs_reqs.req_type_coercion_groups] = ( { fe_location = fe_location, fe_context = if (has_option fun_type) (Yes temp_fun_type.tst_context) No, fe_index = fun_index, - fe_requirements = { rhs_reqs & req_type_coercions = [], req_type_coercion_groups = req_type_coercion_groups, req_cons_variables = [] } + fe_requirements = { rhs_reqs & req_type_coercions = [], req_type_coercion_groups = req_type_coercion_groups } }, - (rhs_reqs.req_cons_variables, fun_defs, { ts & ts_expr_heap = ts_expr_heap })) + (fun_defs, { ts & ts_expr_heap = ts_expr_heap })) // ---> ("type_function", fun_symb, tb_args, tb_rhs, fun_info.fi_local_vars) where has_option (Yes _) = True diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index 7a1a282..53601e9 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -49,19 +49,20 @@ simplifyTypeApplication (TArrow1 _) _ :: VarEnv :== {! Type } :: CleanUpState = - { cus_var_env :: !.VarEnv - , cus_attr_env :: !.AttributeEnv + { cus_var_env :: !.VarEnv + , cus_attr_env :: !.AttributeEnv , cus_appears_in_lifted_part :: !.LargeBitvect - , cus_heaps :: !.TypeHeaps - , cus_var_store :: !Int - , cus_attr_store :: !Int - , cus_error :: !.ErrorAdmin + , cus_heaps :: !.TypeHeaps + , cus_var_store :: !Int + , cus_attr_store :: !Int + , cus_exis_vars :: ![(Int,TypeAttribute)] + , cus_error :: !.ErrorAdmin } :: CleanUpInput = - { cui_coercions :: !{! CoercionTree} - , cui_attr_part :: !AttributePartition - , cui_top_level :: !Bool + { cui_coercions :: !{! CoercionTree} + , cui_attr_part :: !AttributePartition + , cui_top_level :: !Bool , cui_is_lifted_part :: !Bool } @@ -69,8 +70,20 @@ class clean_up a :: !CleanUpInput !a !*CleanUpState -> (!a, !*CleanUpState) instance clean_up AType where + clean_up cui atype=:{at_attribute, at_type = TempQV qv_number} cus + | cui.cui_top_level + # (at_attribute, cus) = cleanUpTypeAttribute True cui at_attribute cus + # (type, cus) = cus!cus_var_env.[qv_number] + (var, cus) = cleanUpVariable True type qv_number cus + = ({atype & at_attribute = at_attribute, at_type = var, at_annotation = AN_None}, + {cus & cus_exis_vars = add_new_variable type qv_number at_attribute cus.cus_exis_vars}) + where + add_new_variable TE ev_number ev_attr cus_exis_vars + = [(ev_number, ev_attr) : cus_exis_vars] + add_new_variable type ev_number ev_attr cus_exis_vars + = cus_exis_vars clean_up cui atype=:{at_attribute,at_type} cus - # (at_attribute, cus) = clean_up cui at_attribute cus + # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus (at_type, cus) = clean_up cui at_type cus = ({atype & at_attribute = at_attribute, at_type = at_type, at_annotation = AN_None}, cus) @@ -78,51 +91,49 @@ where attrIsUndefined TA_None = True attrIsUndefined _ = False -instance clean_up TypeAttribute -where - clean_up cui TA_Unique cus - = (TA_Unique, cus) - clean_up cui TA_Multi cus - = (TA_Multi, cus) - clean_up cui tv=:(TA_TempVar av_number) cus=:{cus_attr_env,cus_appears_in_lifted_part,cus_heaps,cus_attr_store,cus_error} - | cui.cui_top_level - # av_group_nr = cui.cui_attr_part.[av_number] - coercion_tree = cui.cui_coercions.[av_group_nr] - | isNonUnique coercion_tree - = (TA_Multi, cus) - | isUnique coercion_tree - = (TA_Unique, cus) - #! attr = cus_attr_env.[av_group_nr] - # (cus_appears_in_lifted_part, cus_error) - = case cui.cui_is_lifted_part of - True - -> (cus_appears_in_lifted_part, cus_error) - _ - | bitvectSelect av_group_nr cus_appears_in_lifted_part - -> ( bitvectResetAll cus_appears_in_lifted_part // to prevent repetition of error message - , checkError "attribute variable of lifted argument appears in the specified type" "" cus_error) - -> (cus_appears_in_lifted_part, cus_error) - | attrIsUndefined attr - # (av_info_ptr, th_attrs) = newPtr AVI_Empty cus_heaps.th_attrs - new_attr_var = TA_Var { av_name = NewAttrVarId cus_attr_store, av_info_ptr = av_info_ptr } - cus_appears_in_lifted_part - = case cui.cui_is_lifted_part of - False - -> cus_appears_in_lifted_part - _ - -> bitvectSet av_group_nr cus_appears_in_lifted_part - = (new_attr_var, { cus & cus_attr_env = { cus_attr_env & [av_group_nr] = new_attr_var}, - cus_appears_in_lifted_part = cus_appears_in_lifted_part, - cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store, - cus_error = cus_error}) - = (attr, { cus & cus_appears_in_lifted_part = cus_appears_in_lifted_part, - cus_error = cus_error }) +cleanUpTypeAttribute :: !Bool !CleanUpInput TypeAttribute !*CleanUpState -> (!TypeAttribute, !*CleanUpState) +cleanUpTypeAttribute _ cui TA_Unique cus + = (TA_Unique, cus) +cleanUpTypeAttribute _ cui TA_Multi cus + = (TA_Multi, cus) +cleanUpTypeAttribute may_be_existential cui tv=:(TA_TempVar av_number) cus + | cui.cui_top_level + # av_group_nr = cui.cui_attr_part.[av_number] + coercion_tree = cui.cui_coercions.[av_group_nr] + | isNonUnique coercion_tree = (TA_Multi, cus) - clean_up cui (TA_Var av=:{av_info_ptr}) cus=:{cus_heaps} - # (AVI_AttrVar new_info_ptr, th_attrs) = readPtr av_info_ptr cus_heaps.th_attrs - = (TA_Var { av & av_info_ptr = new_info_ptr }, { cus & cus_heaps = { cus_heaps & th_attrs = th_attrs }}) - clean_up cui TA_TempExVar cus - = PA_BUG (TA_Multi, cus) (abort "clean_up cui (TA_TempExVar)") + | isUnique coercion_tree + = (TA_Unique, cus) + # cus = check_appearance cui.cui_is_lifted_part av_group_nr cus + # (attr, cus) = clean_up_attribute_variable av_group_nr (cus!cus_attr_env.[av_group_nr]) + | isExistential coercion_tree + | may_be_existential + = (attr, { cus & cus_error = checkError "attribute variable could not be universally quantified" "" cus.cus_error}) + = (attr, cus) + = (attr, cus) + = (TA_Multi, cus) +where + check_appearance is_lifted_part group_nr cus=:{cus_appears_in_lifted_part, cus_error} + | is_lifted_part + = { cus & cus_appears_in_lifted_part = bitvectSet group_nr cus_appears_in_lifted_part} + | bitvectSelect group_nr cus_appears_in_lifted_part + = { cus & cus_appears_in_lifted_part = bitvectReset group_nr cus_appears_in_lifted_part, + cus_error = checkError "attribute variable of lifted argument appears in the specified type" "" cus_error} + = cus + + clean_up_attribute_variable av_group_nr (TA_None, cus=:{cus_heaps,cus_attr_store,cus_attr_env}) + # (av_info_ptr, th_attrs) = newPtr AVI_Empty cus_heaps.th_attrs + new_attr_var = TA_Var { av_name = NewAttrVarId cus_attr_store, av_info_ptr = av_info_ptr } + = (new_attr_var, { cus & cus_attr_env = { cus_attr_env & [av_group_nr] = new_attr_var}, + cus_heaps = { cus_heaps & th_attrs = th_attrs }, cus_attr_store = inc cus_attr_store}) + clean_up_attribute_variable av_group_nr attr_and_cus + = attr_and_cus + +cleanUpTypeAttribute _ cui av=:(TA_Var _) cus + = (av, cus) +cleanUpTypeAttribute _ cui TA_PA_BUG cus + = PA_BUG (TA_Multi, cus) (abort "clean_up cui (TA_PA_BUG)") + instance clean_up Type where @@ -153,11 +164,24 @@ where # (TV tv, cus) = cleanUpVariable cui.cui_top_level type tempvar cus (types, cus) = clean_up cui types cus = (CV tv :@: types, cus) - clean_up cui (TempQV qv_number) cus=:{cus_error} + clean_up cui (TempQV qv_number) cus=:{cus_error,cus_exis_vars} # (type, cus) = cus!cus_var_env.[qv_number] | cui.cui_top_level - = cleanUpVariable True type qv_number {cus & cus_error = existentialError cus_error} +// = cleanUpVariable True type qv_number {cus & cus_error = existentialError cus_error} + = cleanUpVariable True type qv_number {cus & cus_exis_vars = add_new_variable type qv_number cus_exis_vars} = cleanUpVariable False type qv_number cus + where + add_new_variable TE qv_number cus_exis_vars + = [(qv_number, TA_None) : cus_exis_vars] + add_new_variable type qv_number cus_exis_vars + = cus_exis_vars + + clean_up cui tv=:(TV _) cus + = (tv, cus) + clean_up cui (TFA vars type) cus=:{cus_heaps} + # (type, cus) = clean_up cui type cus + = (TFA vars type, cus) +/* clean_up cui (TV tv=:{tv_info_ptr}) cus=:{cus_heaps} # (TVI_TypeVar new_info_ptr, th_vars) = readPtr tv_info_ptr cus_heaps.th_vars = (TV { tv & tv_info_ptr = new_info_ptr }, { cus & cus_heaps = { cus_heaps & th_vars = th_vars }}) @@ -165,7 +189,7 @@ where # (new_vars, cus_heaps) = mapSt refresh_var_and_attr vars cus_heaps (type, cus) = clean_up cui type { cus & cus_heaps = cus_heaps } cus_heaps = clearBindings vars cus.cus_heaps - = (TFA vars type, { cus & cus_heaps = cus_heaps }) + = (TFA new_vars type, { cus & cus_heaps = cus_heaps }) where refresh_var_and_attr atv=:{atv_attribute, atv_variable = tv=:{tv_info_ptr}} type_heaps=:{th_vars,th_attrs} # (new_info_ptr, th_vars) = newPtr TVI_Empty th_vars @@ -178,6 +202,7 @@ where = (TA_Var {av & av_info_ptr = new_info_ptr}, attr_heap <:= (av_info_ptr, AVI_AttrVar new_info_ptr)) refresh_attr attr attr_heap = (attr, attr_heap) +*/ clean_up cui TE cus = abort "unknown pattern in function clean_up" @@ -344,13 +369,13 @@ cleanUpSymbolType is_start_rule spec_type tst=:{tst_arity,tst_args,tst_result,ts #! nr_of_temp_vars = size var_env #! max_attr_nr = size attr_var_env # cus = { cus_var_env = var_env, cus_attr_env = attr_var_env, cus_appears_in_lifted_part = bitvectCreate max_attr_nr, - cus_heaps = heaps, cus_var_store = 0, cus_attr_store = 0, cus_error = error } + cus_heaps = heaps, cus_var_store = 0, cus_attr_store = 0, cus_error = error, cus_exis_vars = [] } cui = { cui_coercions = coercions, cui_attr_part = attr_part, cui_top_level = True, cui_is_lifted_part = True } (lifted_args, cus=:{cus_var_env}) = clean_up cui (take tst_lifted tst_args) cus cui = { cui & cui_is_lifted_part = False } (lifted_vars, cus_var_env) = determine_type_vars nr_of_temp_vars [] cus_var_env - (st_args, cus) = clean_up cui (drop tst_lifted tst_args) { cus & cus_var_env = cus_var_env } - (st_result, cus) = clean_up cui tst_result cus + (st_args, (_, cus)) = mapSt (clean_up_arg_type cui) (drop tst_lifted tst_args) ([], { cus & cus_var_env = cus_var_env }) + (st_result, cus) = clean_up_result_type cui tst_result cus (st_context, cus_var_env, var_heap, cus_error) = clean_up_type_contexts spec_type tst_context derived_context cus.cus_var_env var_heap cus.cus_error (st_vars, cus_var_env) = determine_type_vars nr_of_temp_vars lifted_vars cus_var_env (cus_attr_env, st_attr_vars, st_attr_env, cus_error) @@ -377,13 +402,38 @@ where _ -> (all_vars, var_env) - determine_type_var var_index (all_vars, var_env) - #! type = var_env.[var_index] - = case type of - TV var - -> ([var : all_vars], var_env) - _ - -> (all_vars, var_env) + clean_up_arg_type cui at=:{at_type = TFA avars type, at_attribute} (all_exi_vars, cus) + # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus + (type, cus) = clean_up cui type cus + | isEmpty cus.cus_exis_vars + = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, (all_exi_vars, cus)) + = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, + (all_exi_vars, { cus & cus_error = existentialError cus.cus_error, cus_exis_vars = [] })) + clean_up_arg_type cui at (all_exi_vars, cus) + # (at, cus) = clean_up cui at cus + (cus_exis_vars, cus) = cus!cus_exis_vars + | isEmpty cus_exis_vars + = (at, (all_exi_vars, cus)) + # (new_exi_vars, all_exi_vars, cus) = foldSt check_existential_var cus_exis_vars ([], all_exi_vars, cus) + = ({ at & at_type = TFA new_exi_vars at.at_type }, (all_exi_vars, { cus & cus_exis_vars = [] })) + where + check_existential_var (var_number,var_attr) (exi_vars, all_vars, cus) + | isMember var_number all_vars + # (type, cus) = cus!cus_var_env.[var_number] + = case type of + TE + -> (exi_vars, all_vars, cus) + _ + -> (exi_vars, all_vars, { cus & cus_var_env = { cus.cus_var_env & [var_number] = TE }, cus_error = existentialError cus.cus_error }) + # (TV var, cus) = cus!cus_var_env.[var_number] + = ([{atv_attribute = var_attr, atv_variable = var, atv_annotation = AN_None } : exi_vars ], + [var_number : all_vars], { cus & cus_var_env = { cus.cus_var_env & [var_number] = TE }}) + + clean_up_result_type cui at cus + # (at, cus=:{cus_exis_vars}) = clean_up cui at cus + | isEmpty cus_exis_vars + = (at, cus) + = (at, { cus & cus_error = existentialError cus.cus_error }) clean_up_type_contexts spec_type spec_context derived_context env var_heap error | spec_type @@ -525,10 +575,25 @@ updateExpressionTypes :: !SymbolType !SymbolType ![ExprInfoPtr] !*TypeHeaps !*Ex updateExpressionTypes {st_args,st_vars,st_result,st_attr_vars} st_copy type_ptrs heaps=:{th_vars,th_attrs} expr_heap # th_vars = foldSt (\{tv_info_ptr} var_heap -> var_heap <:= (tv_info_ptr, TVI_Empty)) st_vars th_vars th_attrs = foldSt (\{av_info_ptr} attr_heap -> attr_heap <:= (av_info_ptr, AVI_Empty)) st_attr_vars th_attrs - th_vars = bindInstances st_args st_copy.st_args th_vars - th_vars = bindInstances st_result st_copy.st_result th_vars - = foldSt update_expression_type type_ptrs ({heaps & th_vars = th_vars, th_attrs = th_attrs}, expr_heap) + heaps = fold2St bind_instances_in_arg_type st_args st_copy.st_args {heaps & th_vars = th_vars, th_attrs = th_attrs} + th_vars = bindInstances st_result st_copy.st_result heaps.th_vars + = foldSt update_expression_type type_ptrs ({heaps & th_vars = th_vars}, expr_heap) where + bind_instances_in_arg_type { at_type = TFA vars type1 } { at_type = TFA _ type2 } heaps + # heaps = foldSt clear_atype_var vars heaps + = { heaps & th_vars = bindInstances type1 type2 heaps.th_vars } + where + clear_atype_var {atv_variable={tv_info_ptr},atv_attribute} heaps=:{th_vars,th_attrs} + = { heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Empty), th_attrs = clear_attribute atv_attribute th_attrs } + where + clear_attribute (TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Empty) + clear_attribute _ attr_heap + = attr_heap + bind_instances_in_arg_type { at_type } atype2 heaps=:{th_vars} + = { heaps & th_vars = bindInstances at_type atype2.at_type th_vars } + + update_expression_type expr_ptr (type_heaps, expr_heap) # (info, expr_heap) = readPtr expr_ptr expr_heap = case info of @@ -564,6 +629,8 @@ instance bindInstances Type //..AA bindInstances (TB _) (TB _) type_var_heap = type_var_heap + bindInstances (TFA _ type1) (TFA _ type2) type_var_heap + = bindInstances type1 type2 type_var_heap bindInstances (CV l1 :@: r1) (CV l2 :@: r2) type_var_heap = bindInstances r1 r2 (bindInstances (TV l1) (TV l2) type_var_heap) @@ -802,8 +869,10 @@ where -> (forw_var_number == av_number, attr_var_heap) _ -> (True, writePtr av_info_ptr (AVI_Forward av_number) attr_var_heap) - equi_attrs attr1 attr2 attr_env - = (attr1 == attr2, attr_env) + equi_attrs (TA_Var _) (TA_Var _) attr_var_heap + = (True, attr_var_heap) + equi_attrs attr1 attr2 attr_var_heap + = (attr1 == attr2, attr_var_heap) equivTypeVars :: !TypeVar !TempVarId !*TypeHeaps -> (!Bool, !*TypeHeaps) equivTypeVars {tv_info_ptr} var_number heaps=:{th_vars} @@ -819,12 +888,12 @@ instance equiv Type where equiv (TV tv) (TempV var_number) heaps = equivTypeVars tv var_number heaps + equiv (TV tv1) (TV tv2) heaps + = (True, heaps) equiv (arg_type1 --> restype1) (arg_type2 --> restype2) heaps = equiv (arg_type1,restype1) (arg_type2,restype2) heaps -//AA.. equiv (TArrow1 arg_type1) (TArrow1 arg_type2) heaps = equiv arg_type1 arg_type2 heaps -//..AA equiv (TA tc1 types1) (TA tc2 types2) heaps | tc1 == tc2 = equiv types1 types2 heaps @@ -836,13 +905,8 @@ where | equi_vars = equiv types1 types2 heaps = (False, heaps) -/* equiv (TFA vars type1) type2 heaps + equiv (TFA vars1 type1) (TFA vars2 type2) heaps = equiv type1 type2 heaps - equiv type1 (TFA vars type2) heaps - = equiv type1 type2 heaps - equiv (TQV _) (TV _) heaps - = (True, heaps) -*/ equiv type1 type2 heaps = (False, heaps) @@ -1114,8 +1178,8 @@ instance writeType TypeAttribute = writeBeautifulAttrVarAndColon file beautifulizer ta writeType file yes_beautifulizer=:(Yes _) (form, TA_Multi) = (file, yes_beautifulizer) - writeType file opt_beautifulizer (form, TA_TempExVar) - = PA_BUG (file <<< "(E)", opt_beautifulizer) (abort "writeType (TypeAttribute) TA_TempExVar") + writeType file opt_beautifulizer (form, TA_PA_BUG) + = PA_BUG (file <<< "(E)", opt_beautifulizer) (abort "writeType (TypeAttribute) TA_PA_BUG") writeType file opt_beautifulizer (_, ta) = (file <<< ta, opt_beautifulizer) @@ -1168,7 +1232,6 @@ where is_unboxed_array {id_name} = id_name == "_#array" is_string_type {id_name} = id_name == "_string" -// MW4 was: writeType file (form, arg_type --> res_type) writeType file opt_beautifulizer (form, arg_type --> res_type) | checkProperty form cBrackets = writeWithinBrackets "(" ")" file opt_beautifulizer @@ -1197,6 +1260,10 @@ where # file = file <<< ")" = (file, opt_beautifulizer) //..AA + writeType file opt_beautifulizer (form, TFA vars type) + # (file, opt_beautifulizer) = writeType (file <<< "(A.") opt_beautifulizer (form, vars) + # (file, opt_beautifulizer) = writeType (file <<< ":") opt_beautifulizer (clearProperty form cBrackets, type) + = (file <<< ")", opt_beautifulizer) writeType file opt_beautifulizer (form, TQV varid) = (file <<< "E." <<< varid, opt_beautifulizer) writeType file opt_beautifulizer (form, TempQV tv_number) @@ -1212,6 +1279,11 @@ where writeType file _ (form, type) = abort ("<:: (Type) (typesupport.icl)" ---> type) +instance writeType ATypeVar +where + writeType file beautifulizer (form, {atv_attribute,atv_annotation,atv_variable}) + = writeType file beautifulizer (form, { at_attribute = atv_attribute, at_annotation = atv_annotation, at_type = TV atv_variable }) + writeWithinBrackets br_open br_close file opt_beautifulizer (form, types) # (file, opt_beautifulizer) = writeType (file <<< br_open) opt_beautifulizer (form, types) diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl index a5716d4..5b7e0ff 100644 --- a/frontend/unitype.dcl +++ b/frontend/unitype.dcl @@ -22,12 +22,13 @@ FirstAttrVar :== 3 instance toInt TypeAttribute -:: 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 | CT_Existential :: Coercions = { coer_demanded :: !.{! .CoercionTree}, coer_offered :: !.{! .CoercionTree }} isNonUnique :: !CoercionTree -> Bool isUnique :: !CoercionTree -> Bool +isExistential :: !CoercionTree -> Bool isNonUniqueAttribute :: !Int !Coercions -> Bool isUniqueAttribute :: !Int !Coercions -> Bool @@ -44,7 +45,7 @@ determineAttributeCoercions :: !AType !AType !Bool !u:{! Type} !*Coercions !{# C :: AttributePartition :== {# Int} -partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !{! CoercionTree}) +partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !*{! CoercionTree}) newInequality :: !Int !Int !*Coercions -> *Coercions @@ -62,7 +63,7 @@ liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeHeaps ! } class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!Bool, !a, !*(!u:{! Type}, !*ExpansionState)) -//class expandType a :: !{# CommonDefs } !{# BOOLVECT } !a !*(!u:{! Type}, !*ExpansionState) -> (!a, !*(!u:{! Type}, !*ExpansionState)) - instance expandType AType + +checkExistentionalAttributeVars :: [TempAttrId] !AttributePartition !*{! CoercionTree} -> (!Bool,!*{! CoercionTree}) diff --git a/frontend/unitype.icl b/frontend/unitype.icl index aa77fad..c6d5561 100644 --- a/frontend/unitype.icl +++ b/frontend/unitype.icl @@ -15,7 +15,7 @@ FirstAttrVar :== 2 AttrExi :== 2 FirstAttrVar :== 3 -:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique +:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique | CT_Existential :: Coercions = { coer_demanded :: !.{! .CoercionTree}, coer_offered :: !.{! .CoercionTree }} @@ -93,7 +93,7 @@ NotChecked :== -1 DummyAttrNumber :== -1 :: AttributeGroups :== {! [Int]} -partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !{! CoercionTree}) +partitionateAttributes :: !{! CoercionTree} !{! *CoercionTree} -> (!AttributePartition, !*{! CoercionTree}) partitionateAttributes coer_offered coer_demanded #! max_attr_nr = size coer_offered # partitioning_info = { pi_marks = createArray max_attr_nr NotChecked, pi_deps = [], pi_next_num = 0, pi_groups = [] } @@ -344,6 +344,8 @@ where -> (True, TA { type_cons & type_arity = type_cons.type_arity + length types } (cons_args ++ types), subst, ls) TempV tv_number -> (True, TempCV tv_number :@: types, subst, ls) + TempQV tv_number + -> (True, TempQCV tv_number :@: types, subst, ls) cons_var :@: cv_types -> (True, cons_var :@: (cv_types ++ types), subst, ls) // AA.. @@ -514,6 +516,8 @@ where -> (True, TA { type_cons & type_arity = type_arity + nr_of_new_args } (cons_args ++ types), es) TempV tv_number -> (True, TempCV tv_number :@: types, es) + TempQV tv_number + -> (True, TempQCV tv_number :@: types, es) cons_var :@: cv_types -> (True, cons_var :@: (cv_types ++ types), es) // AA.. @@ -551,7 +555,7 @@ where toInt (TA_TempVar av_number) = av_number toInt TA_Multi = AttrMulti toInt TA_None = AttrMulti - toInt TA_TempExVar = PA_BUG AttrExi (abort "toInt TA_TempExVar") + toInt TA_PA_BUG = PA_BUG AttrExi (abort "toInt TA_PA_BUG") :: CoercionState = @@ -573,10 +577,11 @@ coerceAttributes :: !.TypeAttribute !.TypeAttribute !.Sign *Coercions -> (!Bool, /* Just Temporary */ -coerceAttributes TA_TempExVar dem_attr _ coercions - = PA_BUG (True, coercions) (abort "coerceAttributes TA_TempExVar") -coerceAttributes _ TA_TempExVar _ coercions - = PA_BUG (True, coercions) (abort "coerceAttributes TA_TempExVar") +coerceAttributes TA_PA_BUG dem_attr _ coercions + = PA_BUG (True, coercions) (abort "coerceAttributes TA_PA_BUG") +coerceAttributes _ TA_PA_BUG _ coercions + = PA_BUG (True, coercions) (abort "coerceAttributes TA_PA_BUG") + /* ... remove this !!!! */ coerceAttributes TA_Unique dem_attr {neg_sign} coercions @@ -679,6 +684,10 @@ isUnique :: !CoercionTree -> Bool isUnique CT_Unique = True isUnique _ = False +isExistential :: !CoercionTree -> Bool +isExistential CT_Existential = True +isExistential _ = False + isUniqueAttribute :: !Int !Coercions -> Bool isUniqueAttribute attr_number {coer_demanded} = isUnique coer_demanded.[attr_number] @@ -898,3 +907,23 @@ set_bit var_number bitvects # bit_index = BITINDEX var_number (prev_vect, bitvects) = bitvects![bit_index] = { bitvects & [bit_index] = prev_vect bitor (1 << BITNUMBER var_number) } + +checkExistentionalAttributeVars :: [TempAttrId] !AttributePartition !*{! CoercionTree} -> (!Bool,!*{! CoercionTree}) +checkExistentionalAttributeVars tmp_attr_vars partition coercions + = foldSt (check_existentional_attribute_var partition) tmp_attr_vars (True, coercions) +where + check_existentional_attribute_var partition tmp_attr (ok, coercions) + # av_group_nr = partition.[tmp_attr] + (coercion_tree,coercions) = coercions![av_group_nr] + = check_demanded_attribute_vars av_group_nr coercion_tree partition (ok, coercions) + + check_demanded_attribute_vars av_group_nr (CT_Node dem_attr left right) partition (ok, coercions) + # (ok, coercions) = check_existentional_attribute_var partition dem_attr (ok, { coercions & [av_group_nr] = CT_Existential }) + | ok + # ok_coercions = check_demanded_attribute_vars av_group_nr left partition (True, coercions) + = check_demanded_attribute_vars av_group_nr right partition ok_coercions + = (False, coercions) + check_demanded_attribute_vars av_group_nr CT_Empty partition ok_coercions + = ok_coercions + check_demanded_attribute_vars av_group_nr _ partition (ok, coercions) + = (False, coercions) |