Commit 4925180c authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Ik heb helaas geen flauw idee, maar deze files weken af van wat ik zelf had.

parent dd62f07e
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment