Skip to content
GitLab
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
Hide whitespace changes
Inline Side-by-side
frontend/checktypes.icl
View file @ 4925180c
......@@ -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
......
frontend/type.icl
View file @ 4925180c
......@@ -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
......
frontend/typesupport.dcl
View file @ 4925180c
......@@ -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
......
frontend/typesupport.icl
View file @ 4925180c
......@@ -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