aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/Heap.icl18
-rw-r--r--frontend/analunitypes.icl2
-rw-r--r--frontend/checktypes.icl7
-rw-r--r--frontend/frontend.icl6
-rw-r--r--frontend/main.icl61
-rw-r--r--frontend/syntax.dcl4
-rw-r--r--frontend/syntax.icl13
-rw-r--r--frontend/type.icl55
-rw-r--r--frontend/typesupport.icl2
-rw-r--r--frontend/unitype.dcl5
-rw-r--r--frontend/unitype.icl128
11 files changed, 140 insertions, 161 deletions
diff --git a/frontend/Heap.icl b/frontend/Heap.icl
index a50b10a..3a99c89 100644
--- a/frontend/Heap.icl
+++ b/frontend/Heap.icl
@@ -1,6 +1,6 @@
implementation module Heap;
-import StdOverloaded;
+import StdOverloaded,StdMisc;
:: Heap v = {heap::!.(HeapN v)};
:: HeapN v = Heap !Int;
@@ -78,7 +78,13 @@ sreadPtr p h = code {
};
writePtr :: !(Ptr v) !v !*(Heap v) -> .Heap v;
-writePtr p v h = code {
+writePtr p v h
+ | isNilPtr p
+ = abort "writePtr: Nil pointer encountered\n";
+ = writePtr2 p v h;
+
+writePtr2 :: !(Ptr v) !v !*(Heap v) -> .Heap v;
+writePtr2 p v h = code {
push_a_b 2
push_r_args_b 0 1 1 1 1
eqI
@@ -101,7 +107,13 @@ writePtr p v h = code {
}
ptrToInt :: !(Ptr v) -> Int;
-ptrToInt p = code {
+ptrToInt p
+ | isNilPtr p
+ = 0;
+ = ptrToInt2 p;
+
+ptrToInt2 :: !(Ptr v) -> Int;
+ptrToInt2 p = code {
push_a_b 0
pop_a 1
build _Nil 0 _hnf
diff --git a/frontend/analunitypes.icl b/frontend/analunitypes.icl
index 08cb748..fec92d1 100644
--- a/frontend/analunitypes.icl
+++ b/frontend/analunitypes.icl
@@ -246,7 +246,7 @@ determinePropClassOfTypeDef type_index module_index td_args {tdi_classification,
(ts_type_prop, type_var_heap, td_infos) = newPropClassOfTypeDefGroup type_index module_index tdi_group hio_props
tdi_group_nr ci type_var_heap td_infos
-> (ts_type_prop, foldSt restore_binds_of_type_var td_args type_var_heap, td_infos)
-// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop)
+// ---> ("determinePropClassOfTypeDef", ci.[module_index].com_type_defs.[type_index].td_name, ts_type_prop, hio_props)
where
bind_type_vars_to_props [{atv_variable={tv_info_ptr}} : tvs] [gv : gvs] cons_vars hio_props type_var_heap
#! old_info = sreadPtr tv_info_ptr type_var_heap
diff --git a/frontend/checktypes.icl b/frontend/checktypes.icl
index 5fb1791..49651fb 100644
--- a/frontend/checktypes.icl
+++ b/frontend/checktypes.icl
@@ -1015,8 +1015,13 @@ where
TA_Var var
-> (TA_RootVar var, error)
_
+ -> (TA_RootVar undef, error)
+/* = case root_attr of
+ TA_Var var
+ -> (TA_RootVar var, error)
+ _
-> (root_attr, error)
- check_attribute attr root_attr name error
+*/ check_attribute attr root_attr name error
= (TA_Multi, checkError name "specified attribute not allowed" error)
retrieveKinds :: ![ATypeVar] *TypeVarHeap -> (![TypeKind], !*TypeVarHeap)
diff --git a/frontend/frontend.icl b/frontend/frontend.icl
index 2786862..267d59b 100644
--- a/frontend/frontend.icl
+++ b/frontend/frontend.icl
@@ -16,7 +16,7 @@ import RWSDebug
// trace macro
(-*->) infixl
(-*->) value trace
- :== value // ---> trace
+ :== value ---> trace
frontEndInterface :: !Ident !SearchPaths !*PredefinedSymbols !*HashTable !*Files !*File !*File !*File -> (!*PredefinedSymbols, !*HashTable, !*Files, !*File, !*File, !*File, !Optional *FrontEndSyntaxTree)
frontEndInterface mod_ident search_paths predef_symbols hash_table files error io out
@@ -41,8 +41,8 @@ frontEndInterface mod_ident search_paths predef_symbols hash_table files error i
| not ok
= (predef_symbols, hash_table, files, error, io, out, No)
- # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
-// (components, fun_defs, io) = showTypes components 0 fun_defs io
+ # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
+ (components, fun_defs, io) = showTypes components 0 fun_defs io
// (components, fun_defs, out) = showComponents components 0 True fun_defs out
diff --git a/frontend/main.icl b/frontend/main.icl
index b561d53..5f4c7d0 100644
--- a/frontend/main.icl
+++ b/frontend/main.icl
@@ -154,67 +154,6 @@ loadModule mod_ident predef_symbols hash_table ms=:{ms_files,ms_error,ms_io,ms_o
-> (Yes (buildInterMod mod_ident fe_dcls icl_functions fe_dclIclConversions fe_iclDclConversions), predef_symbols, hash_table, ms)
No
-> (No, predef_symbols, hash_table, ms)
-/* RWS
- # (ok, mod, hash_table, ms_error, predef_symbols, ms_files)
- = wantModule cWantIclFile mod_ident (hash_table ---> ("Parsing:", mod_ident)) ms_error ms_paths predef_symbols ms_files
- | not ok
- = (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
- # (ok, mod, nr_of_global_funs, mod_functions, dcl_mod, predef_mod, modules, hash_table, ms_error, predef_symbols, ms_files)
- = scanModule (mod ---> "Scanning") hash_table ms_error ms_paths predef_symbols ms_files
- | not ok
- = (No, predef_symbols, hash_table, { ms & ms_files = ms_files, ms_io = ms_io, ms_error = ms_error })
- # symbol_table = hash_table.hte_symbol_heap
- (ok, icl_mod, dcl_mods, components, dcl_icl_conversions, heaps, predef_symbols, symbol_table, ms_error)
- = checkModule mod nr_of_global_funs mod_functions dcl_mod predef_mod modules predef_symbols (symbol_table ---> "Checking") ms_error
- | not ok
- = (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io })
- # {icl_functions,icl_instances,icl_specials,icl_common,icl_declared={dcls_import}} = icl_mod
- (components, icl_functions, ms_error) = showComponents components 0 True icl_functions ms_error
- (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, heaps, predef_symbols, ms_error)
- = typeProgram (components ---> "Typing") icl_functions icl_specials icl_common dcls_import dcl_mods heaps predef_symbols ms_error
- | not ok
- = (No, predef_symbols, { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
-
- # (components, fun_defs) = partitionateFunctions (fun_defs ---> "partitionateFunctions") [ { ir_from = 0, ir_to = nr_of_global_funs }, icl_instances, icl_specials]
- (components, fun_defs, ms_io) = showTypes components 0 fun_defs ms_io
- (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
-
-
- (components, fun_defs, predef_symbols, dcl_types, used_conses_in_dynamics, var_heap, type_heaps, expression_heap)
- = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
- heaps.hp_var_heap heaps.hp_type_heaps heaps.hp_expression_heap
-
- (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
- (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
- = analyseGroups common_defs (components ---> "Transform") fun_defs var_heap expression_heap
- (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
- = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs dcl_types used_conses_in_dynamics var_heap type_heaps expression_heap
-/*
-
- (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
- = analyseGroups common_defs (components ---> "Transform") fun_defs heaps.hp_var_heap heaps.hp_expression_heap
- (components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
- = transformGroups cleanup_info components fun_defs acc_args common_defs imported_funs var_heap heaps.hp_type_heaps expression_heap
- (components, fun_defs, ms_error) = showComponents components 0 True fun_defs ms_error
-
-*/
- (dcl_types, used_conses, var_heap, type_heaps) = convertIclModule common_defs dcl_types used_conses var_heap type_heaps
- (dcl_types, used_conses, var_heap, type_heaps) = convertDclModule dcl_mods common_defs dcl_types used_conses var_heap type_heaps
-/*
- (components, fun_defs, predef_symbols, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
- = convertDynamicPatternsIntoUnifyAppls type_code_instances common_defs (components ---> "convertDynamics") fun_defs predef_symbols
- dcl_types used_conses var_heap type_heaps expression_heap
- (components, fun_defs, ms_out) = showComponents components 0 True fun_defs ms_out
-*/
- (used_funs, components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap)
- = convertCasesOfFunctionsIntoPatterns components imported_funs common_defs fun_defs dcl_types used_conses
- var_heap type_heaps expression_heap
- (dcl_types, var_heap, type_heaps)
- = convertImportedTypeSpecifications dcl_mods imported_funs common_defs used_conses used_funs dcl_types type_heaps var_heap
- (components, fun_defs, ms_out) = showComponents components 0 False fun_defs ms_out
- = (Yes (buildInterMod mod_ident dcl_mods fun_defs dcl_icl_conversions), predef_symbols,
- { hash_table & hte_symbol_heap = symbol_table}, { ms & ms_files = ms_files, ms_error = ms_error, ms_io = ms_io, ms_out = ms_out })
-*/
makeProject (Yes proj=:{proj_main_module,proj_hash_table,proj_predef_symbols}) ms
# (main_mod, proj_predef_symbols, proj_hash_table, ms) = loadModule proj_main_module proj_predef_symbols proj_hash_table ms
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index a2ec1ba..3ac7259 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -833,8 +833,8 @@ cNonRecursiveAppl :== False
, atv_variable :: !TypeVar
}
-:: 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_Omega
+:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar
+ | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute
:: AttributeVar =
{ av_name :: !Ident
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index a7f9d7b..667eb07 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -772,8 +772,8 @@ cNotVarNumber :== -1
, atv_variable :: !TypeVar
}
-:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar !AttributeVar | TA_TempVar !Int
- | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute | TA_Omega
+:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar
+ | TA_Anonymous | TA_None | TA_List !Int !TypeAttribute
:: AttributeVar =
{ av_name :: !Ident
@@ -1152,11 +1152,8 @@ where
= "u" + toString tav_number + ": "
toString (TA_Var avar)
= toString avar + ": "
-/* toString (TA_TempExVar tav_number)
- = "e" + toString tav_number + ": "
- toString (TA_ExVar avar)
- = toString avar + "': "
-*/
+ toString TA_TempExVar
+ = "E"
toString (TA_RootVar avar)
= toString avar + ": "
toString (TA_Anonymous)
@@ -1165,8 +1162,6 @@ where
= ""
toString TA_Multi
= "o "
- toString TA_Omega
- = "w "
toString (TA_List _ _)
= "??? "
diff --git a/frontend/type.icl b/frontend/type.icl
index 5b28349..b0d2c31 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -32,7 +32,7 @@ import RWSDebug
}
:: SharedAttribute =
- { sa_attr_nr :: !Int
+ { sa_attr_nr :: !Int
, sa_position :: !Expression
}
@@ -316,7 +316,7 @@ unifyTypeApplications cons_var type_args type modules subst heaps
:: CopyState =
- { copy_heaps :: !.TypeHeaps
+ { copy_heaps :: !.TypeHeaps
}
instance fromInt TypeAttribute
@@ -352,10 +352,16 @@ freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap
_
-> abort ("freshCopyOfAttributeVar (type,icl)" ---> av_name)
+
freshCopyOfTypeAttribute (TA_Var avar) attr_var_heap
= freshCopyOfAttributeVar avar attr_var_heap
+
+/* A temporary hack to handle the new Object IO lib */
+/* Should be removed !!!!!!!!!! */
+
freshCopyOfTypeAttribute (TA_RootVar avar) attr_var_heap
- = freshCopyOfAttributeVar avar attr_var_heap
+// = freshCopyOfAttributeVar avar attr_var_heap
+ = (TA_TempExVar, attr_var_heap)
freshCopyOfTypeAttribute TA_None attr_var_heap
= (TA_Multi, attr_var_heap)
freshCopyOfTypeAttribute TA_Unique attr_var_heap
@@ -363,6 +369,7 @@ freshCopyOfTypeAttribute TA_Unique attr_var_heap
freshCopyOfTypeAttribute attr attr_var_heap
= (attr, attr_var_heap)
+
cIsExistential :== True
cIsNotExistential :== False
@@ -418,30 +425,27 @@ freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_s
# {td_rhs,td_args,td_attrs,td_name,td_attribute} = common_defs.[glob_module].com_type_defs.[glob_object]
# (th_vars, ts_var_store) = fresh_type_variables td_args (ts_type_heaps.th_vars, ts_var_store)
(th_attrs, ts_attr_store) = fresh_attributes td_attrs (ts_type_heaps.th_attrs, ts_attr_store)
- cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }}
- (cons_types, alg_type, ts_var_store, ts_attr_store, attr_env, cs)
- = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store ts_attr_store cs
- = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = cs.copy_heaps })
+ copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }
+ (cons_types, alg_type, ts_var_store, attr_env, copy_heaps)
+ = fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store copy_heaps
+ = (cons_types, alg_type, attr_env, { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps })
// ---> ("freshAlgebraicType", alg_type, cons_types)
where
- fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store attr_store cs=:{copy_heaps}
+ fresh_symbol_types [{ap_symbol={glob_object}}] cons_defs var_store copy_heaps
# {cons_type = {st_args,st_attr_env,st_result}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index]
(th_vars, var_store) = freshExistentialVariables cons_exi_vars (copy_heaps.th_vars, var_store)
-// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store)
(attr_env, th_attrs) = fresh_environment st_attr_env ([], copy_heaps.th_attrs)
- (result_type, cs) = freshCopy st_result { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars } }
+ (result_type, cs) = freshCopy st_result { copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars } }
(fresh_args, cs) = freshCopy st_args cs
- = ([fresh_args], result_type, var_store, attr_store, attr_env, cs)
- fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store attr_store cs
- # (cons_types, result_type, var_store, attr_store, attr_env, cs=:{copy_heaps})
- = fresh_symbol_types patterns cons_defs var_store attr_store cs
-// {cons_type = {st_args,st_attr_env}, cons_index, cons_exi_vars, cons_exi_attrs} = cons_defs.[glob_object.ds_index]
+ = ([fresh_args], result_type, var_store, attr_env, cs.copy_heaps)
+ fresh_symbol_types [{ap_symbol={glob_object}} : patterns] cons_defs var_store copy_heaps
+ # (cons_types, result_type, var_store, attr_env, copy_heaps)
+ = fresh_symbol_types patterns cons_defs var_store copy_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 (copy_heaps.th_vars, var_store)
-// (th_attrs, attr_store) = fresh_existential_attributes cons_exi_attrs (copy_heaps.th_attrs, attr_store)
(attr_env, th_attrs) = fresh_environment st_attr_env (attr_env, copy_heaps.th_attrs)
- (fresh_args, cs) = freshCopy st_args { cs & copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }}
- = ([fresh_args : cons_types], result_type, var_store, attr_store, attr_env, cs)
+ (fresh_args, cs) = freshCopy st_args { copy_heaps = { copy_heaps & th_attrs = th_attrs, th_vars = th_vars }}
+ = ([fresh_args : cons_types], result_type, var_store, attr_env, cs.copy_heaps)
fresh_type_variables type_variables state
@@ -450,11 +454,6 @@ where
fresh_attributes attributes state
= foldSt (\{av_info_ptr} (attr_heap, attr_store) -> (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store)), inc attr_store))
attributes state
-/*
- fresh_existential_attributes attributes state
- = foldSt (\{av_info_ptr} (attr_heap, attr_store) -> (attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempExVar attr_store)), inc attr_store))
- attributes state
-*/
fresh_environment inequalities (attr_env, attr_heap)
= foldSt fresh_inequality inequalities (attr_env, attr_heap)
@@ -480,8 +479,8 @@ where
freshSymbolType 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}
- # (th_vars, var_store) = fresh_type_variables st_vars (ts_type_heaps.th_vars, ts_var_store)
- (th_attrs, attr_store) = fresh_attributes st_attr_vars (ts_type_heaps.th_attrs, ts_attr_store)
+ # (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
cs = { copy_heaps = { ts_type_heaps & th_vars = th_vars, th_attrs = th_attrs }}
(tst_args, cs) = freshCopy st_args cs
@@ -489,7 +488,7 @@ freshSymbolType st=:{st_vars,st_args,st_result,st_context,st_attr_vars,st_attr_e
(tst_context, {copy_heaps}) = freshTypeContexts st_context cs
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 = var_store, ts_attr_store = attr_store, ts_type_heaps = copy_heaps})
+ { ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = copy_heaps})
// ---> ("freshSymbolType", tst_args, tst_result)
where
fresh_type_variables type_variables state
@@ -1507,7 +1506,8 @@ where
= (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
- (subst, nr_of_attr_vars, th_vars, ts_td_infos) = liftSubstitution subst ti_common_defs ts_attr_store ts_type_heaps.th_vars ts_td_infos
+ (cons_var_vects, subst) = determine_cons_variables cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst)
+ (subst, nr_of_attr_vars, th_vars, ts_td_infos) = liftSubstitution subst ti_common_defs cons_var_vects ts_attr_store ts_type_heaps.th_vars 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 }
coercion_env = build_initial_coercion_env fun_reqs {coer_demanded = coer_demanded, coer_offered = coer_offered }
@@ -1524,7 +1524,6 @@ where
ts_td_infos = ts_td_infos, ts_expr_heap = os_symbol_heap, ts_var_heap = os_var_heap })
# (fun_defs, coercion_env, subst, os_var_heap, os_symbol_heap, os_error)
= makeSharedReferencesNonUnique comp fun_defs coercion_env subst ti_common_defs os_var_heap os_symbol_heap os_error
- (cons_var_vects, subst) = determine_cons_variables cons_variables (createArray (inc (BITINDEX nr_of_type_variables)) 0, subst)
(subst, {coer_offered,coer_demanded}, ts_td_infos, ts_type_heaps, ts_error)
= build_coercion_env fun_reqs subst coercion_env ti_common_defs cons_var_vects ts_td_infos os_type_heaps os_error
(attr_partition, coer_demanded) = partitionateAttributes coer_offered coer_demanded
diff --git a/frontend/typesupport.icl b/frontend/typesupport.icl
index 84e5344..3f4c904 100644
--- a/frontend/typesupport.icl
+++ b/frontend/typesupport.icl
@@ -66,6 +66,8 @@ varIsDefined _ = True
instance clean_up TypeAttribute
where
+ clean_up cui TA_TempExVar cus
+ = (TA_Multi, cus)
clean_up cui TA_Unique cus
= (TA_Unique, cus)
clean_up cui TA_Multi cus
diff --git a/frontend/unitype.dcl b/frontend/unitype.dcl
index 83065d1..197dec5 100644
--- a/frontend/unitype.dcl
+++ b/frontend/unitype.dcl
@@ -9,7 +9,8 @@ import syntax, analunitypes
AttrUni :== 0
AttrMulti :== 1
-FirstAttrVar :== 2
+AttrExi :== 2
+FirstAttrVar :== 3
instance toInt TypeAttribute
@@ -44,7 +45,7 @@ tryToMakeUnique :: !Int !*Coercions -> (!Bool, !*Coercions)
uniquenessError :: !CoercionPosition !String !*ErrorAdmin -> *ErrorAdmin
-liftSubstitution :: !*{! Type} !{# CommonDefs } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
+liftSubstitution :: !*{! Type} !{# CommonDefs }!{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
instance <<< CoercionPosition
diff --git a/frontend/unitype.icl b/frontend/unitype.icl
index bb9302b..5665d83 100644
--- a/frontend/unitype.icl
+++ b/frontend/unitype.icl
@@ -12,7 +12,11 @@ import cheat
AttrUni :== 0
AttrMulti :== 1
+/*
FirstAttrVar :== 2
+*/
+AttrExi :== 2
+FirstAttrVar :== 3
:: CoercionTree = CT_Node !Int !CoercionTree !CoercionTree | CT_Empty | CT_Unique | CT_NonUnique
@@ -65,8 +69,6 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions
-> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error)
/*
- No
-
# (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions
format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) }
| file_to_true (stderr <:: (format, exp_off_type) <:: (format, exp_dem_type) <<< '\n')
@@ -189,16 +191,16 @@ where
:: CoercionTreeRecord = { tree :: !.CoercionTree }
-liftSubstitution :: !*{! Type} !{# CommonDefs } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
-liftSubstitution subst modules attr_store type_var_heap td_infos
+liftSubstitution :: !*{! Type} !{# CommonDefs } !{# BOOLVECT } !Int !*TypeVarHeap !*TypeDefInfos -> (*{! Type}, !Int, !*TypeVarHeap, !*TypeDefInfos)
+liftSubstitution subst modules cons_vars attr_store type_var_heap td_infos
# ls = { ls_next_attr = attr_store, ls_td_infos = td_infos, ls_type_var_heap = type_var_heap}
- = lift_substitution 0 modules subst ls
+ = lift_substitution 0 modules cons_vars subst ls
where
- lift_substitution var_index modules subst ls
+ lift_substitution var_index modules cons_vars subst ls
| var_index < size subst
#! type = subst.[var_index]
- # (type, _, _, subst, ls) = lift modules type subst ls
- = lift_substitution (inc var_index) modules { subst & [var_index] = type } ls
+ # (type, subst, ls) = lift modules cons_vars type subst ls
+ = lift_substitution (inc var_index) modules cons_vars { subst & [var_index] = type } ls
= (subst, ls.ls_next_attr, ls.ls_type_var_heap, ls.ls_td_infos)
adjustSignClass :: !SignClassification !Int -> SignClassification
@@ -215,55 +217,78 @@ adjustPropClass prop_class arity :== prop_class >> arity
}
-liftTempTypeVariable :: !{# CommonDefs } !TempVarId !*{! Type} !*LiftState
- -> (!Type, !SignClassification, !PropClassification, !*{! Type}, !*LiftState)
-liftTempTypeVariable modules tv_number subst ls
+liftTempTypeVariable :: !{# CommonDefs } !{# BOOLVECT } !TempVarId !*{! Type} !*LiftState
+ -> (!Type, !*{! Type}, !*LiftState)
+liftTempTypeVariable modules cons_vars tv_number subst ls
#! type = subst.[tv_number]
= case type of
- TE -> (TempV tv_number, TopSignClass, PropClass, subst, ls)
- _ -> lift modules type subst ls
+ TE -> (TempV tv_number, subst, ls)
+ _ -> lift modules cons_vars type subst ls
-class lift a :: !{# CommonDefs } !a !*{! Type} !*LiftState
- -> (!a, !SignClassification, !PropClassification, !*{! Type}, !*LiftState)
+class lift a :: !{# CommonDefs } !{# BOOLVECT } !a !*{! Type} !*LiftState
+ -> (!a, !*{! Type}, !*LiftState)
instance lift Type
where
- lift modules (TempV tv_number) subst ls
- = liftTempTypeVariable modules tv_number subst ls
- lift modules (arg_type --> res_type) subst ls
- # (arg_type, _, _, subst, ls) = lift modules arg_type subst ls
- (res_type, _, _, subst, ls) = lift modules res_type subst ls
- = (arg_type --> res_type, BottomSignClass, NoPropClass, subst, ls)
- lift modules (TA cons_id=:{type_index={glob_object,glob_module},type_arity} cons_args) subst ls
- # (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_args subst ls
+ lift modules cons_vars (TempV tv_number) subst ls
+ = liftTempTypeVariable modules cons_vars tv_number subst ls
+ lift modules cons_vars (arg_type --> res_type) subst ls
+ # (arg_type, subst, ls) = lift modules cons_vars arg_type subst ls
+ (res_type, subst, ls) = lift modules cons_vars res_type subst ls
+ = (arg_type --> res_type, subst, ls)
+ lift modules cons_vars (TA cons_id=:{type_name,type_index={glob_object,glob_module},type_arity} cons_args) subst ls
+ # (cons_args, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars cons_args subst ls
(type_prop, ls_type_var_heap, ls_td_infos) = typeProperties glob_object glob_module sign_classes prop_classes modules ls.ls_type_var_heap ls.ls_td_infos
- = (TA { cons_id & type_prop = type_prop } cons_args,
- adjustSignClass type_prop.tsp_sign type_arity, adjustPropClass type_prop.tsp_propagation type_arity,
- subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap})
- lift modules (TempCV temp_var :@: types) subst ls
- # (type, sign_class, prop_class, subst, ls) = liftTempTypeVariable modules temp_var subst ls
- (types, _, _, subst, ls) = lift_list modules types subst ls
+ = (TA { cons_id & type_prop = type_prop } cons_args, subst, { ls & ls_td_infos = ls_td_infos, ls_type_var_heap = ls_type_var_heap})
+ where
+ lift_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] !*{!Type} !*LiftState
+ -> (![AType], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState)
+ lift_list modules cons_vars [] subst ls
+ = ([], [], [], subst, ls)
+ lift_list modules cons_vars [t:ts] subst ls
+ # (t, subst, ls) = lift modules cons_vars t subst ls
+ (ts, sign_classes, prop_classes, subst, ls) = lift_list modules cons_vars ts subst ls
+ = case t.at_type of
+ TA {type_arity,type_prop} _
+ -> ([t:ts], [adjustSignClass type_prop.tsp_sign type_arity : sign_classes],
+ [adjustPropClass type_prop.tsp_propagation type_arity : prop_classes], subst, ls)
+ TempV tmp_var_id
+ | isPositive tmp_var_id cons_vars
+ -> ([t:ts], [PosSignClass : sign_classes], [PropClass : prop_classes], subst, ls)
+ -> ([t:ts], [TopSignClass : sign_classes], [NoPropClass : prop_classes], subst, ls)
+ _
+ -> ([t:ts], [TopSignClass : sign_classes], [PropClass : prop_classes], subst, ls)
+
+ lift modules cons_vars (TempCV temp_var :@: types) subst ls
+ # (type, subst, ls) = liftTempTypeVariable modules cons_vars temp_var subst ls
+ (types, subst, ls) = lift_list modules cons_vars types subst ls
= case type of
TA type_cons cons_args
# nr_of_new_args = length types
- -> (TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types),
- adjustSignClass sign_class nr_of_new_args, adjustPropClass prop_class nr_of_new_args, subst, ls)
+ -> (TA { type_cons & type_arity = type_cons.type_arity + nr_of_new_args } (cons_args ++ types), subst, ls)
TempV tv_number
- -> (TempCV tv_number :@: types, TopSignClass, PropClass, subst, ls)
+ -> (TempCV tv_number :@: types, subst, ls)
cons_var :@: cv_types
- -> (cons_var :@: (cv_types ++ types), TopSignClass, PropClass, subst, ls)
- lift modules type subst ls
- = (type, BottomSignClass, NoPropClass, subst, ls)
+ -> (cons_var :@: (cv_types ++ types), subst, ls)
+ where
+ lift_list :: !{#CommonDefs} !{# BOOLVECT } ![a] !*{!Type} !*LiftState -> (![a], !*{!Type}, !*LiftState) | lift a
+ lift_list modules cons_vars [] subst ls
+ = ([], subst, ls)
+ lift_list modules cons_vars [t:ts] subst ls
+ # (t, subst, ls) = lift modules cons_vars t subst ls
+ (ts, subst, ls) = lift_list modules cons_vars ts subst ls
+ = ([t:ts], subst, ls)
+ lift modules cons_vars type subst ls
+ = (type, subst, ls)
instance lift AType
where
- lift modules attr_type=:{at_attribute,at_type} subst ls
- # (at_type, sign_class, prop_class, subst, ls) = lift modules at_type subst ls
+ lift modules cons_vars attr_type=:{at_attribute,at_type} subst ls
+ # (at_type, subst, ls) = lift modules cons_vars at_type subst ls
| type_is_non_coercible at_type
- = ({attr_type & at_type = at_type}, sign_class, prop_class, subst, ls)
- = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type},
- sign_class, prop_class, subst, {ls & ls_next_attr = inc ls.ls_next_attr})
+ = ({attr_type & at_type = at_type },subst, ls)
+ = ({attr_type & at_attribute = TA_TempVar ls.ls_next_attr, at_type = at_type}, subst, {ls & ls_next_attr = inc ls.ls_next_attr})
where
type_is_non_coercible (TempV _)
= True
@@ -277,15 +302,6 @@ where
= False
-lift_list :: !{#CommonDefs} ![a] !*{!Type} !*LiftState
- -> (![a], ![SignClassification], ![PropClassification], !*{!Type}, !*LiftState) | lift a
-lift_list modules [] subst ls
- = ([], [], [], subst, ls)
-lift_list modules [t:ts] subst ls
- # (t, sign_class, prop_class, subst, ls) = lift modules t subst ls
- (ts, sign_classes, prop_classes, subst, ls) = lift_list modules ts subst ls
- = ([t:ts], [sign_class : sign_classes], [prop_class : prop_classes], subst, ls)
-
:: ExpansionState =
{ es_type_heaps :: !.TypeHeaps
, es_td_infos :: !.TypeDefInfos
@@ -324,12 +340,13 @@ where
# (arg_type, es) = expandType modules cons_vars arg_type es
(res_type, es) = expandType modules cons_vars res_type es
= (arg_type --> res_type, es)
- expandType modules cons_vars (TA cons_id=:{type_index={glob_object,glob_module}} cons_args) es
+ expandType modules cons_vars (TA cons_id=:{type_name, type_index={glob_object,glob_module}} cons_args) es
# (cons_args, sign_classes, prop_classes, (subst,es=:{es_td_infos,es_type_heaps})) = expand_type_list modules cons_vars cons_args es
(type_prop, th_vars, es_td_infos)
= typeProperties glob_object glob_module sign_classes prop_classes modules es_type_heaps.th_vars es_td_infos
= (TA { cons_id & type_prop = type_prop } cons_args,
(subst, { es & es_td_infos = es_td_infos, es_type_heaps = { es_type_heaps & th_vars = th_vars }}))
+// ---> ("expandType", type_name, type_prop.tsp_propagation)
where
expand_type_list :: !{#CommonDefs} !{# BOOLVECT } ![AType] !*(!u:{!Type}, !*ExpansionState)
-> (![AType], ![SignClassification], ![PropClassification], !*(!u:{!Type}, !*ExpansionState))
@@ -373,6 +390,7 @@ where
toInt (TA_TempVar av_number) = av_number
toInt TA_Multi = AttrMulti
toInt TA_None = AttrMulti
+ toInt TA_TempExVar = AttrExi
instance * Bool
@@ -400,6 +418,14 @@ offered_attribute according to sign. Failure is indicated by returning False as
*/
+/* Just Temporary */
+
+coerceAttributes TA_TempExVar dem_attr _ coercions
+ = (True, coercions)
+coerceAttributes _ TA_TempExVar _ coercions
+ = (True, coercions)
+/* ... remove this !!!! */
+
coerceAttributes TA_Unique dem_attr {neg_sign} coercions
| not neg_sign
= (True, coercions)
@@ -595,7 +621,7 @@ where
adjust_sign sign _ cons_vars
= sign
- add_propagation_inequalities attr (TA {type_prop={tsp_propagation}} cons_args) coercions
+ add_propagation_inequalities attr (TA {type_name,type_prop={tsp_propagation}} cons_args) coercions
= add_inequalities tsp_propagation attr cons_args coercions
where
add_inequalities prop_class attr [] coercions