diff options
| -rw-r--r-- | frontend/checktypes.icl | 30 | ||||
| -rw-r--r-- | frontend/type.icl | 147 | ||||
| -rw-r--r-- | frontend/typesupport.dcl | 2 | ||||
| -rw-r--r-- | frontend/typesupport.icl | 54 |
4 files changed, 129 insertions, 104 deletions
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl index 10a18ed..50079ce 100644 --- a/frontend/checktypes.icl +++ b/frontend/checktypes.icl @@ -358,8 +358,14 @@ determineAttributeVariable attr_var=:{av_name=attr_name=:{id_info}} oti=:{oti_he :: DemandedAttributeKind = DAK_Ignore | DAK_Unique | DAK_None newAttribute :: !DemandedAttributeKind {#Char} TypeAttribute !*OpenTypeInfo !*CheckState -> (!TypeAttribute, !*OpenTypeInfo, !*CheckState) -newAttribute DAK_Ignore var_name _ oti cs - = (TA_Multi, oti, cs) +newAttribute DAK_Ignore var_name attr oti cs + = case attr of + TA_Multi + -> (TA_Multi, oti, cs) + TA_None + -> (TA_Multi, oti, cs) + _ + -> (TA_Multi, oti, { cs & cs_error = checkError var_name "attribute not allowed" cs.cs_error }) newAttribute DAK_Unique var_name new_attr oti cs = case new_attr of TA_Unique @@ -515,7 +521,7 @@ where # (var, global_vars, var_heap, ste_previous) = retrieve_global_variable var ste_previous global_vars var_heap = (var, global_vars, var_heap, { entry & ste_previous = ste_previous }) // -checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute} +checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type_name=type_name=:{id_name,id_info}} types, at_attribute} (ots=:{ots_type_defs,ots_modules}, oti, cs=:{cs_symbol_table}) # (entry, cs_symbol_table) = readPtr id_info cs_symbol_table cs = { cs & cs_symbol_table = cs_symbol_table } @@ -525,27 +531,27 @@ checkOpenAType mod_index scope dem_attr type=:{ at_type=TA type_cons=:{type_name ots = { ots & ots_type_defs = ots_type_defs, ots_modules = ots_modules } | checkArityOfType type_cons.type_arity td_arity td_rhs # type_cons = { type_cons & type_index = { glob_object = type_index, glob_module = type_module }} - (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope /* dem_attr */ types td_args (ots, oti, cs) - (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr td_attribute) id_name at_attribute oti cs + (types, (ots, oti, cs)) = check_args_of_type_cons mod_index scope dem_attr_kind types td_args (ots, oti, cs) + (new_attr, oti, cs) = newAttribute (new_demanded_attribute dem_attr_kind td_attribute) id_name at_attribute oti cs = ({ type & at_type = TA type_cons types, at_attribute = new_attr } , (ots, oti, cs)) = (type, (ots, oti, {cs & cs_error = checkError type_name "used with wrong arity" cs.cs_error})) = (type, (ots, oti, {cs & cs_error = checkError type_name "undefined" cs.cs_error})) where - check_args_of_type_cons :: !Index !Int ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) + check_args_of_type_cons :: !Index !Int !DemandedAttributeKind ![AType] ![ATypeVar] !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState) -> (![AType], !(!u:OpenTypeSymbols, !*OpenTypeInfo, !*CheckState)) - check_args_of_type_cons mod_index scope [] _ cot_state + check_args_of_type_cons mod_index scope dem_attr_kind [] _ cot_state = ([], cot_state) - check_args_of_type_cons mod_index scope [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state - # (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute DAK_None atv_attribute) arg_type cot_state - (arg_types, cot_state) = check_args_of_type_cons mod_index scope arg_types td_args cot_state + check_args_of_type_cons mod_index scope dem_attr_kind [arg_type : arg_types] [ {atv_attribute} : td_args ] cot_state + # (arg_type, cot_state) = checkOpenAType mod_index scope (new_demanded_attribute dem_attr_kind /* DAK_None */ atv_attribute) arg_type cot_state + (arg_types, cot_state) = check_args_of_type_cons mod_index scope dem_attr_kind arg_types td_args cot_state = ([arg_type : arg_types], cot_state) new_demanded_attribute DAK_Ignore _ = DAK_Ignore new_demanded_attribute _ TA_Unique = DAK_Unique - new_demanded_attribute dem_attr _ - = dem_attr + new_demanded_attribute dem_attr_kind _ + = dem_attr_kind checkOpenAType mod_index scope dem_attr type=:{at_type = arg_type --> result_type, at_attribute} cot_state # (arg_type, cot_state) = checkOpenAType mod_index scope DAK_None arg_type cot_state diff --git a/frontend/type.icl b/frontend/type.icl index f56f2bd..c84bc24 100644 --- a/frontend/type.icl +++ b/frontend/type.icl @@ -487,6 +487,8 @@ where fromInt AttrMulti = TA_Multi fromInt av_number = TA_TempVar av_number + + class freshCopy a :: !a !*TypeHeaps -> (!a, !*TypeHeaps) instance freshCopy [a] | freshCopy a @@ -524,10 +526,14 @@ freshConsVariable {tv_info_ptr} type_var_heap # (tv_info, type_var_heap) = readPtr tv_info_ptr type_var_heap = (to_constructor_variable tv_info, type_var_heap) where - to_constructor_variable (TVI_Type (TempV temp_var_id)) - = TempCV temp_var_id - to_constructor_variable (TVI_Type (TempQV temp_var_id)) - = TempQCV temp_var_id + to_constructor_variable (TVI_Type fresh_type) + = case fresh_type of + TempV temp_var_id + -> TempCV temp_var_id + TempQV temp_var_id + -> TempQCV temp_var_id + TV var + -> CV var instance freshCopy AType where @@ -562,21 +568,40 @@ where = (TArrow1 arg_type, type_heaps) //..AA freshCopy (TFA vars type) type_heaps - # type_heaps = foldSt bind_var_and_attr vars type_heaps - (type, type_heaps) = freshCopy type type_heaps - # type_heaps = clearBindings vars type_heaps - = (TFA vars 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 + = freshCopyOfTFAType vars type type_heaps freshCopy type type_heaps = (type, type_heaps) +freshCopyOfTFAType vars type type_heaps + # (fresh_vars, type_heaps) = foldSt bind_var_and_attr vars ([], type_heaps) + (type, type_heaps) = freshCopy type type_heaps + type_heaps = foldSt clear_binding_of_var_and_attr fresh_vars type_heaps + = (TFA fresh_vars type, type_heaps) + where + bind_var_and_attr atv=:{atv_attribute, atv_variable = tv=:{tv_info_ptr}} (fresh_vars, type_heaps=:{th_vars,th_attrs}) + # (fresh_vars, th_attrs) = bind_attr atv_attribute atv (fresh_vars, th_attrs) + = (fresh_vars, { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_Type (TV tv)), th_attrs = th_attrs }) + + bind_attr var=:(TA_Var {av_info_ptr}) atv (fresh_vars, attr_heap) + # (av_info, attr_heap) = readPtr av_info_ptr attr_heap + = case av_info of + AVI_Empty + -> ([atv : fresh_vars], attr_heap <:= (av_info_ptr, AVI_Attr var)) + AVI_Attr (TA_TempVar _) + -> ([{ atv & atv_attribute = TA_Multi } : fresh_vars], attr_heap) + bind_attr attr atv (fresh_vars, attr_heap) + = ([atv : fresh_vars], attr_heap) + + + clear_binding_of_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_Empty), th_attrs = clear_attr atv_attribute th_attrs } + + clear_attr var=:(TA_Var {av_info_ptr}) attr_heap + = attr_heap <:= (av_info_ptr, AVI_Empty) + clear_attr attr attr_heap + = attr_heap + + freshExistentialVariables type_variables var_store attr_store type_heaps = foldSt fresh_existential_variable type_variables ([], var_store, attr_store, type_heaps) where @@ -723,21 +748,35 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con = 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) + th_attrs = clear_attributes st_attr_vars th_attrs 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); + fresh_type_variables :: [TypeVar] !(!*TypeVarHeap, !Int) -> (!*TypeVarHeap, !Int) fresh_type_variables type_variables state - = foldr (\{tv_info_ptr} (var_heap, var_store) -> (writePtr tv_info_ptr (TVI_Type (TempV var_store)) var_heap, inc var_store)) - state type_variables - - fresh_attributes :: .[AttributeVar] *(*Heap AttrVarInfo,.Int) -> (!.Heap AttrVarInfo,!Int); + = foldSt fresh_type_variable type_variables state + where + fresh_type_variable {tv_info_ptr} (var_heap, var_store) + = (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store) + + fresh_attributes :: [AttributeVar] !(!*AttrVarHeap, !Int) -> (!*AttrVarHeap, !Int) 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 + = foldSt fresh_attribute attributes state + where + fresh_attribute {av_info_ptr} (attr_heap, attr_store) + = (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store)), inc attr_store) + + + clear_attributes :: [AttributeVar] !*AttrVarHeap -> !*AttrVarHeap + clear_attributes attributes attr_heap + = foldSt clear_attribute attributes attr_heap + where + clear_attribute {av_info_ptr} attr_heap + = attr_heap <:= (av_info_ptr, AVI_Empty) + 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] @@ -763,56 +802,60 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con = [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, type_heaps) = mapSt fresh_arg_type arg_types type_heaps = (arg_types, (var_store, attr_store, exis_variables, 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 + (at_type, type_heaps) = freshCopyOfTFAType vars type { type_heaps & th_attrs = th_attrs } + = ({ at & at_attribute = fresh_attribute, at_type = at_type }, type_heaps) + fresh_arg_type at type_heaps + = freshCopy at 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 + # (var_store, attr_store, new_exis_variables, bound_attr_vars, 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 = { type_heaps & th_vars = foldSt clear_binding_of_type_var vars type_heaps.th_vars, + th_attrs = foldSt clear_binding_of_attr_var bound_attr_vars type_heaps.th_attrs } = ({ at & at_attribute = fresh_attribute, at_type = fresh_type }, (var_store, attr_store, addToExistentialVariables pos new_exis_variables exis_variables, type_heaps)) fresh_arg_type _ at (var_store, attr_store, exis_variables, type_heaps) # (fresh_at, type_heaps) = freshCopy at type_heaps = (fresh_at, (var_store, attr_store, exis_variables, type_heaps)) - 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 }) + fresh_var_and_attr {atv_attribute, atv_variable = tv=:{tv_info_ptr}} (var_store, attr_store, exis_variables, bound_attr_vars, type_heaps) + # (attr_store, exis_variables, bound_attr_vars, th_attrs) + = fresh_attr atv_attribute (attr_store, exis_variables, bound_attr_vars, type_heaps.th_attrs) + = (inc var_store, attr_store, exis_variables, bound_attr_vars, + { 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 var=:(TA_Var {av_info_ptr}) (attr_store, exis_variables, bound_attr_vars, attr_heap) + # (av_info, attr_heap) = readPtr av_info_ptr attr_heap + = case av_info of + AVI_Empty + -> (inc attr_store, [attr_store : exis_variables], [av_info_ptr : bound_attr_vars], attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store))) + AVI_Attr (TA_TempVar _) + -> (attr_store, exis_variables, bound_attr_vars, attr_heap) fresh_attr attr state = state + + clear_binding_of_type_var {atv_variable = {tv_info_ptr}} type_var_heap + = type_var_heap <:= (tv_info_ptr, TVI_Empty) + + clear_binding_of_attr_var av_info_ptr attr_var_heap + = attr_var_heap <:= (av_info_ptr, AVI_Empty) + addToExistentialVariables pos [] exis_variables = exis_variables addToExistentialVariables pos new_exis_variables exis_variables = [(pos, new_exis_variables) : exis_variables] -freshArgumentsOfSymbolType :: ![AType] !*TypeHeaps -> (![AType], !*TypeHeaps) -freshArgumentsOfSymbolType atypes type_heaps = mapSt fresh_arg_type atypes type_heaps -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 freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo); freshInequality {ai_demanded,ai_offered} attr_heap diff --git a/frontend/typesupport.dcl b/frontend/typesupport.dcl index 9509ac6..9c98af7 100644 --- a/frontend/typesupport.dcl +++ b/frontend/typesupport.dcl @@ -83,8 +83,6 @@ clearBindingsOfTypeVarsAndAttributes :: !TypeAttribute ![ATypeVar] !*TypeHeaps - instance <<< TempSymbolType -clearBindings :: ![ATypeVar] !*TypeHeaps -> !*TypeHeaps - removeInequality :: !Int !Int !*Coercions -> .Coercions flattenCoercionTree :: !u:CoercionTree -> (![Int], !u:CoercionTree) // retrieve all numbers from a coercion tree diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl index f73bec0..c7b795a 100644 --- a/frontend/typesupport.icl +++ b/frontend/typesupport.icl @@ -164,10 +164,12 @@ 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 (cv :@: types) cus + # (types, cus) = clean_up cui types cus + = (cv :@: types, cus) 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_exis_vars = add_new_variable type qv_number cus_exis_vars} = cleanUpVariable False type qv_number cus where @@ -181,30 +183,8 @@ where 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 }}) - clean_up cui (TFA vars type) cus=:{cus_heaps} - # (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 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 - (atv_attribute, th_attrs) = refresh_attr atv_attribute th_attrs - = ( { atv & atv_attribute = atv_attribute, atv_variable = { tv & tv_info_ptr = new_info_ptr }}, - { type_heaps & th_vars = th_vars <:= (tv_info_ptr, TVI_TypeVar new_info_ptr), th_attrs = th_attrs }) - where - refresh_attr (TA_Var av=:{av_info_ptr}) attr_heap - # (new_info_ptr, attr_heap) = newPtr AVI_Empty attr_heap - = (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" + clean_up cui type cus + = abort ("clean_up Type (typesupport.icl): unknown type " ---> ("clean_up Type", type)) instance clean_up [a] | clean_up a where @@ -222,17 +202,6 @@ cleanUpVariable top_level (TLifted var) tv_number cus=:{cus_error} cleanUpVariable _ type tv_number cus = (type, cus) -clearBindings :: ![ATypeVar] !*TypeHeaps -> !*TypeHeaps -clearBindings atvs type_heaps - = foldSt clear_binding_of_var_and_attr atvs type_heaps -where - clear_binding_of_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_Empty), th_attrs = clear_attr atv_attribute th_attrs } - - clear_attr var=:(TA_Var {av_info_ptr}) attr_heap - = attr_heap <:= (av_info_ptr, AVI_Empty) - clear_attr attr attr_heap - = attr_heap :: CleanUpResult :== BITVECT @@ -549,14 +518,23 @@ where = cus_error = startRuleError "Start rule cannot be overloaded.\n" cus_error = cus_error - + + instance clean_up CaseType where clean_up cui ctype=:{ct_pattern_type,ct_result_type, ct_cons_types} cus # (ct_pattern_type, cus) = clean_up cui ct_pattern_type cus (ct_result_type, cus) = clean_up cui ct_result_type cus - (ct_cons_types, cus) = clean_up cui ct_cons_types cus + (ct_cons_types, cus) = mapSt (mapSt (clean_up_arg_type cui)) ct_cons_types cus = ({ctype & ct_pattern_type = ct_pattern_type, ct_cons_types = ct_cons_types, ct_result_type = ct_result_type}, cus) + where + clean_up_arg_type cui at=:{at_type = TFA avars type, at_attribute} cus + # (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus + (type, cus) = clean_up cui type cus + = ({ at & at_type = TFA avars type, at_attribute = at_attribute}, cus) + clean_up_arg_type cui at cus + = clean_up cui at cus + /* In 'bindInstances t1 t2' type variables of t1 are bound to the corresponding subtypes of t2, provided that |