aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--backend/backendconvert.icl8
-rw-r--r--frontend/overloading.icl78
-rw-r--r--frontend/syntax.dcl6
-rw-r--r--frontend/syntax.icl6
-rw-r--r--frontend/type.icl419
5 files changed, 248 insertions, 269 deletions
diff --git a/backend/backendconvert.icl b/backend/backendconvert.icl
index 52f2c77..962fabf 100644
--- a/backend/backendconvert.icl
+++ b/backend/backendconvert.icl
@@ -1390,10 +1390,12 @@ convertTypeNode (TAS typeSymbolIdent typeArgs strictness)
= beNormalTypeNode (convertTypeSymbolIdent typeSymbolIdent) (convertAnnotatedTypeArgs typeArgs strictness)
convertTypeNode (TV {tv_ident})
= beVarTypeNode tv_ident.id_name
-convertTypeNode (TempQV n)
- = beVarTypeNode ("_tqv" +++ toString n)
convertTypeNode (TempV n)
= beVarTypeNode ("_tv" +++ toString n)
+convertTypeNode (TempQV n)
+ = beVarTypeNode ("_tqv" +++ toString n)
+convertTypeNode (TempQDV n)
+ = beVarTypeNode ("_tqv" +++ toString n)
convertTypeNode (a --> b)
= beNormalTypeNode (beBasicSymbol BEFunType) (convertTypeArgs [a, b])
convertTypeNode (TArrow1 a)
@@ -1418,6 +1420,8 @@ consVariableToType (TempCV varId)
= TempV varId
consVariableToType (TempQCV varId)
= TempQV varId
+consVariableToType (TempQCDV varId)
+ = TempQDV varId
convertTypeArgs :: [AType] -> BEMonad BETypeArgP
convertTypeArgs args
diff --git a/frontend/overloading.icl b/frontend/overloading.icl
index 52574ac..5d764fe 100644
--- a/frontend/overloading.icl
+++ b/frontend/overloading.icl
@@ -3,7 +3,7 @@ implementation module overloading
import StdEnv
import syntax, check, type, typesupport, utilities, unitype, predef, checktypes, convertDynamics
-import genericsupport, compilerSwitches, type_io_common
+import genericsupport, type_io_common
:: LocalTypePatternVariable =
{ ltpv_var :: !Int
@@ -84,7 +84,7 @@ containsContext new_tc []
= False
containsContext new_tc [tc : tcs]
= new_tc == tc || containsContext new_tc tcs
-
+
FoundObject object :== object.glob_module <> NotFound
ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound }
@@ -115,15 +115,13 @@ ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound }
reduceContexts :: !ReduceInfo ![TypeContext] !*ReduceState -> (![ClassApplication], !*ReduceState)
reduceContexts info tcs rs_state
- = mapSt (try_to_reduce_context info) tcs rs_state
+ = mapSt (try_to_reduce_context info) tcs rs_state
where
try_to_reduce_context :: !ReduceInfo !TypeContext !*ReduceState -> *(!ClassApplication, !*ReduceState)
try_to_reduce_context info tc rs_state=:{rs_predef_symbols, rs_new_contexts}
| context_is_reducible tc rs_predef_symbols
= reduce_any_context info tc rs_state
-// ---> ("try_to_reduce_context (Yes)", tc)
| containsContext tc rs_new_contexts
-// ---> ("try_to_reduce_context (No)", tc)
= (CA_Context tc, rs_state)
# {rs_var_heap, rs_new_contexts} = rs_state
# (tc_var, rs_var_heap) = newPtr VI_Empty rs_var_heap
@@ -330,11 +328,15 @@ where
context_is_reducible tc=:{tc_class=TCGeneric {gtc_class}, tc_types = [type : types]} predef_symbols
= type_is_reducible type gtc_class predef_symbols && types_are_reducible types type gtc_class predef_symbols
- type_is_reducible :: Type a PredefinedSymbols -> Bool
+ type_is_reducible :: Type (Global DefinedSymbol) PredefinedSymbols -> Bool
type_is_reducible (TempV _) tc_class predef_symbols
= False // is_predefined_symbol tc_class.glob_module tc_class.glob_object.ds_index PD_TypeCodeClass predef_symbols
type_is_reducible (_ :@: _) tc_class predef_symbols
= False
+ type_is_reducible (TempQV _) tc_class predef_symbols
+ = False
+ type_is_reducible (TempQDV _) {glob_object={ds_index},glob_module} predef_symbols
+ = is_predefined_symbol glob_module ds_index PD_TypeCodeClass predef_symbols
type_is_reducible _ tc_class predef_symbols
= True
@@ -539,13 +541,13 @@ where
reduce_tc_context defs type_code_class type=:(TA cons_id=:{type_index} cons_args) rtcs_state=:{rtcs_error,rtcs_type_heaps}
# rtcs_error
= disallow_abstract_types_in_dynamics defs type_index rtcs_error
-
+
# (expanded, type, rtcs_type_heaps)
= tryToExpandTypeSyn defs type cons_id cons_args rtcs_type_heaps
# rtcs_state = {rtcs_state & rtcs_error=rtcs_error, rtcs_type_heaps=rtcs_type_heaps}
| expanded
= reduce_tc_context defs type_code_class type rtcs_state
-
+
# type_constructor = toTypeCodeConstructor type_index defs
(rc_red_contexts, rtcs_state) = reduce_TC_contexts defs type_code_class cons_args rtcs_state
= (CA_GlobalTypeCode { tci_constructor = type_constructor, tci_contexts = rc_red_contexts }, rtcs_state)
@@ -556,7 +558,14 @@ where
reduce_tc_context defs type_code_class (arg_type --> result_type) rtcs_state
# (rc_red_contexts, rtcs_state) = reduce_TC_contexts defs type_code_class [arg_type, result_type] rtcs_state
= (CA_GlobalTypeCode { tci_constructor = GTT_Function, tci_contexts = rc_red_contexts }, rtcs_state)
- reduce_tc_context defs type_code_class (TempQV var_number) rtcs_state=:{rtcs_type_pattern_vars, rtcs_var_heap}
+ reduce_tc_context defs type_code_class (TempQV var_number) rtcs_state=:{rtcs_var_heap,rtcs_new_contexts}
+ # (tc_var, rtcs_var_heap) = newPtr VI_Empty rtcs_var_heap
+ # rtcs_state={rtcs_state & rtcs_var_heap=rtcs_var_heap}
+ # tc = { tc_class = type_code_class, tc_types = [TempQV var_number], tc_var = tc_var }
+ | containsContext tc rtcs_new_contexts
+ = (CA_Context tc, rtcs_state)
+ = (CA_Context tc, {rtcs_state & rtcs_new_contexts = [tc : rtcs_new_contexts]})
+ reduce_tc_context defs type_code_class (TempQDV var_number) rtcs_state=:{rtcs_type_pattern_vars, rtcs_var_heap}
# (inst_var, (rtcs_type_pattern_vars, rtcs_var_heap)) = addLocalTCInstance var_number (rtcs_type_pattern_vars, rtcs_var_heap)
# rtcs_state = {rtcs_state & rtcs_type_pattern_vars=rtcs_type_pattern_vars, rtcs_var_heap=rtcs_var_heap}
= (CA_LocalTypeCode inst_var, rtcs_state)
@@ -630,7 +639,7 @@ expand_and_match cons_id1 cons_args1 cons_id2 cons_args2 defs type1 type2 type_h
= (False, type_heaps)
instance match Type
-where
+where
match defs (TV {tv_info_ptr}) type type_heaps=:{th_vars}
= (True, { type_heaps & th_vars = th_vars <:= (tv_info_ptr,TVI_Type type)})
match defs type1=:(TA cons_id1 cons_args1) type2=:(TA cons_id2 cons_args2) type_heaps
@@ -663,17 +672,12 @@ where
| diff >= 0
= match defs (TV tv, types) (TA { type_cons & type_arity = diff } (take diff cons_args), drop diff cons_args) type_heaps
= (False, type_heaps)
-//AA..
+ match defs (TB tb1) (TB tb2) type_heaps
+ = (tb1 == tb2, type_heaps)
match defs TArrow TArrow type_heaps
= (True, type_heaps)
match defs (TArrow1 t1) (TArrow1 t2) type_heaps
= match defs t1 t2 type_heaps
-//..AA
- match defs (TB tb1) (TB tb2) type_heaps
- = (tb1 == tb2, type_heaps)
-/* match defs type (TB (BT_String array_type)) type_heaps
- = match defs type array_type type_heaps
-*/
match defs type1=:(TA cons_id cons_args) type2 type_heaps
# (succ, type1, type_heaps) = tryToExpandTypeSyn defs type1 cons_id cons_args type_heaps
| succ
@@ -721,6 +725,8 @@ consVariableToType (TempCV temp_var_id)
= TempV temp_var_id
consVariableToType (TempQCV temp_var_id)
= TempQV temp_var_id
+consVariableToType (TempQCDV temp_var_id)
+ = TempQDV temp_var_id
trySpecializedInstances :: [TypeContext] [Special] *TypeHeaps -> (!Global Index,!*TypeHeaps)
trySpecializedInstances type_contexts [] type_heaps
@@ -828,8 +834,7 @@ where
# (super_classes, type_heaps) = foldSt generate_super_classes contexts ([], type_heaps)
sub_classes = foldSt (remove_doubles super_classes) contexts []
= (sub_classes, type_heaps)
-
-
+
generate_super_classes tc=:{tc_class=TCGeneric {gtc_class}} st
= generate_super_classes {tc & tc_class=TCClass gtc_class} st
generate_super_classes {tc_class=TCClass {glob_object={ds_index},glob_module},tc_types} (super_classes, type_heaps)
@@ -870,6 +875,7 @@ selectFromDictionary dict_mod dict_index member_index defs
{ fs_ident, fs_index } = rt_fields.[member_index]
= { glob_module = dict_mod, glob_object = { ds_ident = fs_ident, ds_index = fs_index, ds_arity = 1 }}
+getDictionaryTypeAndConstructor :: !(Global DefinedSymbol) !{#CommonDefs} -> (!DefinedSymbol,!DefinedSymbol)
getDictionaryTypeAndConstructor {glob_module, glob_object = {ds_ident,ds_index}} defs
# {class_dictionary} = defs.[glob_module].com_class_defs.[ds_index]
(RecordType {rt_constructor}) = defs.[glob_module].com_type_defs.[class_dictionary.ds_index].td_rhs
@@ -921,7 +927,7 @@ convertOverloadedCall defs contexts symbol=:{symb_ident, symb_kind = SK_Generic
= case opt_member_glob of
No
# error = checkError ("no generic instances of " +++ toString symb_ident +++ " for kind") kind error
- -> (heaps, expr_info_ptrs, error)
+ -> (heaps, expr_info_ptrs, error)
Yes member_glob -> convertOverloadedCall defs contexts {symbol & symb_kind = SK_OverloadedFunction member_glob} expr_ptr class_appls (heaps, expr_info_ptrs, error)
convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_TypeCode} expr_info_ptr class_appls (heaps, ptrs, error)
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts class_appls (heaps, ptrs)
@@ -930,7 +936,6 @@ convertOverloadedCall defs contexts {symb_ident} expr_info_ptr appls (heaps,ptrs
# (class_expressions, (heaps, ptrs)) = convertClassApplsToExpressions defs contexts appls (heaps,ptrs)
= ({ heaps & hp_expression_heap = heaps.hp_expression_heap <:= (expr_info_ptr, EI_Context class_expressions)}, ptrs, error)
-
expressionToTypeCodeExpression (TypeCodeExpression texpr)
= texpr
expressionToTypeCodeExpression (ClassVariable var_info_ptr)
@@ -952,6 +957,8 @@ where
toString (CA_LocalTypeCode _) = abort "CA_LocalTypeCode"
toString (CA_GlobalTypeCode _) = abort "CA_GlobalTypeCode"
+convertClassApplsToExpressions :: {#CommonDefs} [TypeContext] [ClassApplication] *( *Heaps, [ExprInfoPtr])
+ -> *(![Expression], !*(!*Heaps,![ExprInfoPtr]))
convertClassApplsToExpressions defs contexts cl_appls heaps_and_ptrs
= mapSt (convert_class_appl_to_expression defs contexts) cl_appls heaps_and_ptrs
where
@@ -1051,7 +1058,7 @@ determineContextAddress contexts defs this_context type_heaps
= look_up_context_and_address this_context contexts defs type_heaps
where
look_up_context_and_address :: !TypeContext ![TypeContext] !{#CommonDefs} !*TypeHeaps -> (TypeContext, [(Int, Global DefinedSymbol)], !*TypeHeaps)
- look_up_context_and_address this_context [] defs type_heaps
+ look_up_context_and_address this_context [] defs type_heaps
= abort "look_up_context_and_address (overloading.icl)"
look_up_context_and_address this_context [tc : tcs] defs type_heaps
#! (may_be_addres, type_heaps) = determine_address this_context tc [] defs type_heaps
@@ -1239,7 +1246,6 @@ where
add_universal_vars_to_type uni_vars at=:{at_type}
= { at & at_type = TFA uni_vars at_type }
-
convert_local_dynamics loc_dynamics state
= foldSt update_dynamic loc_dynamics state
@@ -1280,10 +1286,8 @@ toTypeCodeConstructor type=:{glob_object=type_index, glob_module=module_index} c
| module_index == cPredefinedModuleIndex
= GTT_PredefTypeConstructor type
// otherwise
- # type
- = common_defs.[module_index].com_type_defs.[type_index]
- # td_fun_index
- = type.td_fun_index
+ # type = common_defs.[module_index].com_type_defs.[type_index]
+ # td_fun_index = type.td_fun_index
// sanity check ...
| td_fun_index == NoIndex
= fatal "toTypeCodeConstructor" ("no function (" +++ type.td_ident.id_name +++ ")")
@@ -1302,16 +1306,13 @@ class toTypeCodeExpression type :: type !(!*TypeCodeInfo,!*VarHeap,!*ErrorAdmin)
instance toTypeCodeExpression Type where
toTypeCodeExpression type=:(TA cons_id=:{type_index} type_args) (tci=:{tci_dcl_modules,tci_common_defs},var_heap,error)
- # type_heaps
- = {th_vars = tci.tci_type_var_heap, th_attrs = tci.tci_attr_var_heap}
+ # type_heaps = {th_vars = tci.tci_type_var_heap, th_attrs = tci.tci_attr_var_heap}
# (expanded, type, type_heaps)
= tryToExpandTypeSyn tci_common_defs type cons_id type_args type_heaps
- # tci
- = {tci & tci_type_var_heap = type_heaps.th_vars, tci_attr_var_heap = type_heaps.th_attrs}
+ # tci = {tci & tci_type_var_heap = type_heaps.th_vars, tci_attr_var_heap = type_heaps.th_attrs}
| expanded
= toTypeCodeExpression type (tci,var_heap,error)
- # type_constructor
- = toTypeCodeConstructor type_index tci_common_defs
+ # type_constructor = toTypeCodeConstructor type_index tci_common_defs
(type_code_args, tci)
= mapSt (toTypeCodeExpression) type_args (tci,var_heap,error)
= (TCE_Constructor type_constructor type_code_args, tci)
@@ -1335,7 +1336,6 @@ instance toTypeCodeExpression Type where
= mapSt (toTypeCodeExpression) args st
= (foldl TCE_App type_code_var type_code_args, st)
-
instance toTypeCodeExpression TypeVar where
toTypeCodeExpression {tv_ident,tv_info_ptr} (tci=:{tci_type_var_heap}, var_heap, error)
# (type_info, tci_type_var_heap) = readPtr tv_info_ptr tci_type_var_heap
@@ -1822,12 +1822,6 @@ where
= equalTypeVars tv var_number type_var_heap
equalTypes (arg_type1 --> restype1) (arg_type2 --> restype2) type_var_heap
= equalTypes (arg_type1,restype1) (arg_type2,restype2) type_var_heap
-// AA ..
- equalTypes TArrow TArrow type_var_heap
- = (True, type_var_heap)
- equalTypes (TArrow1 x) (TArrow1 y) type_var_heap
- = equalTypes x y type_var_heap
-// .. AA
equalTypes (TA tc1 types1) (TA tc2 types2) type_var_heap
| tc1 == tc2
= equalTypes types1 types2 type_var_heap
@@ -1846,6 +1840,10 @@ where
= (False, type_var_heap)
equalTypes (TB basic1) (TB basic2) type_var_heap
= (basic1 == basic2, type_var_heap)
+ equalTypes TArrow TArrow type_var_heap
+ = (True, type_var_heap)
+ equalTypes (TArrow1 x) (TArrow1 y) type_var_heap
+ = equalTypes x y type_var_heap
equalTypes (CV tv :@: types1) (TempCV var_number :@: types2) type_var_heap
# (eq, type_var_heap) = equalTypeVars tv var_number type_var_heap
| eq
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 0e01bde..b8b2c97 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -314,7 +314,6 @@ cNameLocationDependent :== True
to store the index of the function that has been specialized.
*/
-
:: Specials
= SP_ParsedSubstitutions ![Env Type TypeVar]
| SP_Substitutions ![SpecialSubstitution]
@@ -433,9 +432,6 @@ cNameLocationDependent :== True
, gt_arity :: !Int // number of generic arguments
}
-//getGenericClassForKind :: !GenericDef !TypeKind -> (!Bool, DefinedSymbol)
-//addGenericKind :: !GenericDef !TypeKind -> !GenericDef
-
:: InstanceType =
{ it_vars :: [TypeVar]
, it_types :: ![Type]
@@ -987,6 +983,7 @@ cNonRecursiveAppl :== False
| TQV TypeVar
| TempQV !TempVarId /* Auxiliary, used during type checking */
+ | TempQDV !TempVarId // Auxiliary, used during type checking, existential type variable in dynamic pattern
| TLifted !TypeVar /* Auxiliary, used during type checking of lifted arguments */
| TQualifiedIdent !Ident !String ![AType]
@@ -998,6 +995,7 @@ cNonRecursiveAppl :== False
:: ConsVariable = CV !TypeVar
| TempCV !TempVarId
| TempQCV !TempVarId
+ | TempQCDV !TempVarId // existential type variable in dynamic pattern
:: DynamicType =
{ dt_uni_vars :: ![ATypeVar]
diff --git a/frontend/syntax.icl b/frontend/syntax.icl
index 73b5fad..a05ef5e 100644
--- a/frontend/syntax.icl
+++ b/frontend/syntax.icl
@@ -161,6 +161,8 @@ where
= file <<< "v" <<< tv <<< ' '
(<<<) file (TempQCV tv)
= file <<< "E." <<< tv <<< ' '
+ (<<<) file (TempQCDV tv)
+ = file <<< "E." <<< tv <<< ' '
instance <<< StrictnessList
where
@@ -196,7 +198,9 @@ where
(<<<) file (TQV varid)
= file <<< "E." <<< varid
(<<<) file (TempQV tv_number)
- = file <<< "E." <<< tv_number <<< ' '
+ = file <<< "E.#" <<< tv_number <<< ' '
+ (<<<) file (TempQDV tv_number)
+ = file <<< "E.#" <<< tv_number <<< ' '
(<<<) file TE
= file <<< "### EMPTY ###"
/*
diff --git a/frontend/type.icl b/frontend/type.icl
index 7ab1a25..f83bef6 100644
--- a/frontend/type.icl
+++ b/frontend/type.icl
@@ -2,7 +2,6 @@ implementation module type
import StdEnv
import syntax, typesupport, check, analtypes, overloading, unitype, refmark, predef, utilities, compare_constructor
-import compilerSwitches
import genericsupport
:: TypeInput =
@@ -355,6 +354,12 @@ unifyTypes (TempQV qv_number) attr1 type attr2 modules subst heaps
= (False, subst, heaps)
unifyTypes type attr1 (TempQV qv_number1) attr2 modules subst heaps
= (False, subst, heaps)
+unifyTypes t1=:(TempQDV qv_number1) attr1 t2=:(TempQDV qv_number2) attr2 modules subst heaps
+ = (qv_number1 == qv_number2, subst, heaps)
+unifyTypes (TempQDV qv_number) attr1 type attr2 modules subst heaps
+ = (False, subst, heaps)
+unifyTypes type attr1 (TempQDV qv_number1) attr2 modules subst heaps
+ = (False, subst, heaps)
unifyTypes type1 attr1 type2 attr2 modules subst heaps
# (succ1, type1, heaps) = tryToExpandInUnify type1 attr1 modules heaps
(succ2, type2, heaps) = tryToExpandInUnify type2 attr2 modules heaps
@@ -419,16 +424,6 @@ tryToExpand type=:(TAS {type_index={glob_object,glob_module}} type_args _) type_
tryToExpand type type_attr modules type_heaps
= (False, type, type_heaps)
-toTV is_exist temp_var_id
- | is_exist
- = TempQV temp_var_id
- = TempV temp_var_id
-
-toCV is_exist temp_var_id
- | is_exist
- = TempQCV temp_var_id
- = TempCV temp_var_id
-
simplifyTypeApplication :: !Type ![AType] -> (!Bool, !Type)
simplifyTypeApplication (TA type_cons=:{type_arity} cons_args) type_args
= (True, TA { type_cons & type_arity = type_arity + length type_args } (cons_args ++ type_args))
@@ -440,6 +435,8 @@ simplifyTypeApplication (TempV tv_number) type_args
= (True, TempCV tv_number :@: type_args)
simplifyTypeApplication (TempQV tv_number) type_args
= (True, TempQCV tv_number :@: type_args)
+simplifyTypeApplication (TempQDV tv_number) type_args
+ = (True, TempQCDV tv_number :@: type_args)
simplifyTypeApplication TArrow [type1, type2]
= (True, type1 --> type2)
simplifyTypeApplication TArrow [type]
@@ -449,108 +446,134 @@ simplifyTypeApplication (TArrow1 type1) [type2]
simplifyTypeApplication type type_args
= (False, type)
-unifyTypeApplications (TempCV tv_number) attr1 type_args type2 attr2 modules subst heaps
+unifyTypeApplications cv=:(TempCV tv_number) attr1 type_args type2 attr2 modules subst heaps
# (type1, subst) = subst![tv_number]
| isIndirection type1
# (ok, simplified_type) = simplifyTypeApplication type1 type_args
| ok
= unifyTypes simplified_type attr1 type2 attr2 modules subst heaps
= (False, subst, heaps)
- = unifyCVwithType False tv_number type_args type2 modules subst heaps
-unifyTypeApplications (TempQCV tv_number) attr1 type_args type2 attr2 modules subst heaps
- = unifyCVwithType True tv_number type_args type2 modules subst heaps
-
-unifyCVwithType is_exist tv_number1 type_args1 type=:(cv :@: type_args2) modules subst heaps
- = case cv of
+ = unifyCVwithType cv type_args type2 modules subst heaps
+unifyTypeApplications cv=:(TempQCV tv_number) attr1 type_args type2 attr2 modules subst heaps
+ = unifyCVwithType cv type_args type2 modules subst heaps
+unifyTypeApplications cv=:(TempQCDV tv_number) attr1 type_args type2 attr2 modules subst heaps
+ = unifyCVwithType cv type_args type2 modules subst heaps
+
+unifyCVwithType cv1 type_args1 type=:(cv2 :@: type_args2) modules subst heaps
+ = case cv2 of
TempCV tv_number2
# (type2, subst) = subst![tv_number2]
| isIndirection type2
# (ok, simplified_type) = simplifyTypeApplication type2 type_args2
| ok
- -> unifyCVwithType is_exist tv_number1 type_args1 simplified_type modules subst heaps
+ -> unifyCVwithType cv1 type_args1 simplified_type modules subst heaps
-> (False, subst, heaps)
- -> unifyCVApplicationwithCVApplication is_exist tv_number1 type_args1 False tv_number2 type_args2 modules subst heaps
+ -> unifyCVApplicationwithCVApplication cv1 type_args1 cv2 type_args2 modules subst heaps
TempQCV tv_number2
- -> unifyCVApplicationwithCVApplication is_exist tv_number1 type_args1 True tv_number2 type_args2 modules subst heaps
-
-unifyCVwithType is_exist tv_number type_args type=:(TA type_cons cons_args) modules subst heaps
+ -> unifyCVApplicationwithCVApplication cv1 type_args1 cv2 type_args2 modules subst heaps
+ TempQCDV tv_number2
+ -> unifyCVApplicationwithCVApplication cv1 type_args1 cv2 type_args2 modules subst heaps
+unifyCVwithType cv type_args type=:(TA type_cons cons_args) modules subst heaps
# diff = type_cons.type_arity - length type_args
| diff >= 0
# (succ, subst, heaps) = unify type_args (drop diff cons_args) modules subst heaps
| succ
- = unifyTypes (toTV is_exist tv_number) TA_Multi (TA { type_cons & type_arity = diff } (take diff cons_args)) TA_Multi modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi (TA { type_cons & type_arity = diff } (take diff cons_args)) TA_Multi modules subst heaps
= (False, subst, heaps)
= (False, subst, heaps)
-
-unifyCVwithType is_exist tv_number type_args type=:(TAS type_cons cons_args strictness) modules subst heaps
+unifyCVwithType cv type_args type=:(TAS type_cons cons_args strictness) modules subst heaps
# diff = type_cons.type_arity - length type_args
| diff >= 0
# (succ, subst, heaps) = unify type_args (drop diff cons_args) modules subst heaps
| succ
- = unifyTypes (toTV is_exist tv_number) TA_Multi (TAS { type_cons & type_arity = diff } (take diff cons_args) strictness) TA_Multi modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi (TAS { type_cons & type_arity = diff } (take diff cons_args) strictness) TA_Multi modules subst heaps
= (False, subst, heaps)
= (False, subst, heaps)
-
-unifyCVwithType is_exist tv_number [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps
+unifyCVwithType cv [type_arg1, type_arg2] type=:(atype1 --> atype2) modules subst heaps
# (succ, subst, heaps) = unify (type_arg1, type_arg2) (atype1, atype2) modules subst heaps
| succ
- = unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi TArrow TA_Multi modules subst heaps
= (False, subst, heaps)
-unifyCVwithType is_exist tv_number [type_arg] type=:(atype1 --> atype2) modules subst heaps
+unifyCVwithType cv [type_arg] type=:(atype1 --> atype2) modules subst heaps
# (succ, subst, heaps) = unify type_arg atype2 modules subst heaps
| succ
- = unifyTypes (toTV is_exist tv_number) TA_Multi (TArrow1 atype1) TA_Multi modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi (TArrow1 atype1) TA_Multi modules subst heaps
= (False, subst, heaps)
-unifyCVwithType is_exist tv_number [] type=:(atype1 --> atype2) modules subst heaps
- = unifyTypes (toTV is_exist tv_number) TA_Multi type TA_Multi modules subst heaps
-
-unifyCVwithType is_exist tv_number [type_arg] type=:(TArrow1 atype) modules subst heaps
+unifyCVwithType cv [] type=:(atype1 --> atype2) modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi type TA_Multi modules subst heaps
+unifyCVwithType cv [type_arg] type=:(TArrow1 atype) modules subst heaps
# (succ, subst, heaps) = unify type_arg atype modules subst heaps
| succ
- = unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi TArrow TA_Multi modules subst heaps
= (False, subst, heaps)
-unifyCVwithType is_exist tv_number [] type=:(TArrow1 atype) modules subst heaps
- = unifyTypes (toTV is_exist tv_number) TA_Multi type TA_Multi modules subst heaps
-
-unifyCVwithType is_exist tv_number [] TArrow modules subst heaps
- = unifyTypes (toTV is_exist tv_number) TA_Multi TArrow TA_Multi modules subst heaps
-
-unifyCVwithType is_exist tv_number type_args type modules subst heaps
+unifyCVwithType cv [] type=:(TArrow1 atype) modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi type TA_Multi modules subst heaps
+unifyCVwithType cv [] TArrow modules subst heaps
+ = unifyTypes (toTV cv) TA_Multi TArrow TA_Multi modules subst heaps
+unifyCVwithType cv type_args type modules subst heaps
= (False, subst, heaps)
-unifyCVApplicationwithCVApplication is_exist1 tv_number1 type_args1 is_exist2 tv_number2 type_args2 modules subst heaps
+unifyCVApplicationwithCVApplication cv1 type_args1 cv2 type_args2 modules subst heaps
# arity1 = length type_args1
arity2 = length type_args2
diff = arity1 - arity2
| diff == 0
- # (succ, subst) = unify_cv_with_cv is_exist1 tv_number1 is_exist2 tv_number2 subst
+ # (succ, subst) = unify_cv_with_cv cv1 cv2 subst
| succ
= unify type_args1 type_args2 modules subst heaps
= (False, subst, heaps)
| diff < 0
# diff = 0 - diff
- (succ, subst, heaps) = unifyTypes (toTV is_exist1 tv_number1) TA_Multi (toCV is_exist2 tv_number2 :@: take diff type_args2) TA_Multi modules subst heaps
+ (succ, subst, heaps) = unifyTypes (toTV cv1) TA_Multi (cv2 :@: take diff type_args2) TA_Multi modules subst heaps
| succ
= unify type_args1 (drop diff type_args2) modules subst heaps
= (False, subst, heaps)
-// | otherwise
- # (succ, subst, heaps) = unifyTypes (toCV is_exist1 tv_number1 :@: take diff type_args1) TA_Multi (toTV is_exist2 tv_number2) TA_Multi modules subst heaps
+ # (succ, subst, heaps) = unifyTypes (cv1 :@: take diff type_args1) TA_Multi (toTV cv2) TA_Multi modules subst heaps
| succ
= unify (drop diff type_args1) type_args2 modules subst heaps
= (False, subst, heaps)
where
- unify_cv_with_cv is_exist1 tv_number1 is_exist2 tv_number2 subst
+ unify_cv_with_cv (TempCV tv_number1) (TempCV tv_number2) subst
| tv_number1 == tv_number2
= (True, subst)
- | is_exist1
- | is_exist2
- = (False, subst)
- = (True, { subst & [tv_number2] = TempQV tv_number1})
- | is_exist2
- = (True, { subst & [tv_number1] = TempQV tv_number2})
- = (True, { subst & [tv_number1] = TempV tv_number2})
-
-
+ = (True, {subst & [tv_number1] = TempV tv_number2})
+ unify_cv_with_cv (TempCV tv_number1) (TempQCV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (True, {subst & [tv_number1] = TempQV tv_number2})
+ unify_cv_with_cv (TempCV tv_number1) (TempQCDV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (True, {subst & [tv_number1] = TempQDV tv_number2})
+ unify_cv_with_cv (TempQCV tv_number1) (TempCV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (True, {subst & [tv_number2] = TempQV tv_number1})
+ unify_cv_with_cv (TempQCV tv_number1) (TempQCV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (False, subst)
+ unify_cv_with_cv (TempQCV tv_number1) (TempQCDV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (False, subst)
+ unify_cv_with_cv (TempQCDV tv_number1) (TempCV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (True, {subst & [tv_number2] = TempQDV tv_number1})
+ unify_cv_with_cv (TempQCDV tv_number1) (TempQCV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (False, subst)
+ unify_cv_with_cv (TempQCDV tv_number1) (TempQCDV tv_number2) subst
+ | tv_number1 == tv_number2
+ = (True, subst)
+ = (False, subst)
+
+toTV (TempCV temp_var_id) = TempV temp_var_id
+toTV (TempQCV temp_var_id) = TempQV temp_var_id
+toTV (TempQCDV temp_var_id) = TempQDV temp_var_id
+
instance fromInt TypeAttribute
where
fromInt AttrUni = TA_Unique
@@ -602,7 +625,9 @@ freshConsVariable {tv_info_ptr} type_var_heap
-> TempCV temp_var_id
TempQV temp_var_id
-> TempQCV temp_var_id
- TV var
+ TempQDV temp_var_id
+ -> TempQCDV temp_var_id
+ TV var
-> CV var
_
-> abort "type.icl: to_constructor_variable, fresh_type\n" ---> fresh_type
@@ -655,7 +680,7 @@ freshCopyOfTFAType 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 })
+ = (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
@@ -667,7 +692,6 @@ freshCopyOfTFAType vars type type_heaps
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 }
@@ -687,7 +711,6 @@ where
fresh_existential_attribute (TA_Var {av_ident,av_info_ptr}) (exi_attr_vars, attr_store, attr_heap)
= ([ attr_store : exi_attr_vars ], inc attr_store, attr_heap <:= (av_info_ptr, AVI_Attr (TA_TempVar attr_store)))
-// ---> ("fresh_existential_attribute", av_info_ptr,av_ident)
fresh_existential_attribute attr state
= state
@@ -742,12 +765,10 @@ freshAlgebraicType {glob_module, glob_object} patterns common_defs ts=:{ts_var_s
= fresh_symbol_types patterns common_defs.[glob_module].com_cons_defs ts_var_store ts_attr_store ts_type_heaps ts_exis_variables
= (cons_types, alg_type, attr_env, td_rhs,
{ ts & ts_var_store = ts_var_store, ts_attr_store = ts_attr_store, ts_type_heaps = ts_type_heaps, ts_exis_variables = ts_exis_variables })
-// ---> ("freshAlgebraicType", alg_type, cons_types)
where
fresh_symbol_types [{ap_symbol={glob_object},ap_expr}] cons_defs var_store attr_store type_heaps all_exis_variables
# {cons_type = ct=:{st_args,st_attr_env,st_result}, cons_exi_vars} = cons_defs.[glob_object.ds_index]
(exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps
-// -?-> (not (isEmpty cons_exi_vars), ("fresh_symbol_types", cons_exi_vars, ct))
(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 }
(fresh_args, type_heaps) = freshCopy st_args type_heaps
@@ -758,7 +779,6 @@ where
= fresh_symbol_types patterns cons_defs var_store attr_store type_heaps all_exis_variables
{cons_type = ct=:{st_args,st_attr_env}, cons_exi_vars} = cons_defs.[glob_object.ds_index]
(exis_variables, var_store, attr_store, type_heaps) = freshExistentialVariables cons_exi_vars var_store attr_store type_heaps
-// -?-> (not (isEmpty cons_exi_vars), ("fresh_symbol_types", cons_exi_vars, ct))
(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 }
all_exis_variables = add_exis_variables ap_expr exis_variables all_exis_variables
@@ -795,7 +815,7 @@ fresh_overloaded_list_type [{ap_symbol}:patterns] pd_cons_symbol pd_nil_symbol d
make_cons_type_from_decons_type stdStrictLists_index decons_u_index common_defs ts
# {me_ident,me_type,me_type_ptr} = common_defs.[stdStrictLists_index].com_member_defs.[decons_u_index]
(fun_type_copy,ts) = determineSymbolTypeOfFunction pos me_ident 1 me_type me_type_ptr common_defs ts
- {tst_args,tst_arity,tst_lifted,tst_result,tst_context,tst_attr_env}=fun_type_copy
+ {tst_args,tst_arity,tst_lifted,tst_result,tst_context,tst_attr_env}=fun_type_copy
# result_type = case tst_args of [t] -> t
# argument_types = case tst_result.at_type of
TA _ args=:[arg1,arg2] -> args
@@ -829,9 +849,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con
= ({ 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] !(!*TypeVarHeap, !Int) -> (!*TypeVarHeap, !Int)
fresh_type_variables type_variables state
= foldSt fresh_type_variable type_variables state
@@ -876,7 +894,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con
| 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) = mapSt fresh_arg_type arg_types type_heaps
= (arg_types, (var_store, attr_store, exis_variables, type_heaps))
@@ -884,7 +902,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con
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)
+ = ({at & at_attribute = fresh_attribute, at_type = at_type}, type_heaps)
fresh_arg_type at type_heaps
= freshCopy at type_heaps
@@ -939,7 +957,7 @@ freshInequality {ai_demanded,ai_offered} attr_heap
(AVI_Attr (TA_TempVar dem_attr_var)) = av_dem_info
(AVI_Attr (TA_TempVar off_attr_var)) = av_off_info
= ({ac_demanded = dem_attr_var, ac_offered = off_attr_var}, attr_heap)
-
+
freshEnvironment [ineq : ineqs] attr_heap
# (fresh_ineq, attr_heap) = freshInequality ineq attr_heap
(fresh_env, attr_heap) = freshEnvironment ineqs attr_heap
@@ -947,9 +965,10 @@ freshEnvironment [ineq : ineqs] attr_heap
freshEnvironment [] attr_heap
= ([], attr_heap)
+freshTypeContexts :: Bool [TypeContext] *(*TypeHeaps,*VarHeap) -> *(![TypeContext],!*(!*TypeHeaps,!*VarHeap))
freshTypeContexts fresh_context_vars tcs cs_and_var_heap
= mapSt (fresh_type_context fresh_context_vars) tcs cs_and_var_heap
-where
+where
fresh_type_context fresh_context_vars tc=:{tc_types} (type_heaps, var_heap)
# (tc_types, type_heaps) = mapSt fresh_context_type tc_types type_heaps
| fresh_context_vars
@@ -1026,6 +1045,7 @@ where
-> determine_cummulative_attribute types cumm_attr attr_vars (prop_class >> 1)
_
-> abort ("determine_cummulative_attribute" ---> at_attribute)
+
combine_attributes (TA_Var attr_var) cumm_attr prop_vars attr_var_heap attr_vars attr_env ps_error
= case cumm_attr of
TA_Unique
@@ -1163,8 +1183,8 @@ determineSymbolTypeOfFunction pos ident act_arity st=:{st_args,st_result,st_attr
(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, 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,
+ # (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) }
-> currySymbolType copy_symb_type act_arity ts
@@ -1243,7 +1263,7 @@ getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_k
get_specials SP_None = []
getSymbolType pos ti {symb_kind = SK_Constructor {glob_module,glob_object}} n_app_args ts
# (fresh_cons_type, ts) = standardRhsConstructorType pos glob_object glob_module n_app_args ti ts
- = (fresh_cons_type, [], ts)
+ = (fresh_cons_type, [], ts)
getSymbolType pos ti {symb_kind = SK_NewTypeConstructor {gi_module,gi_index}} n_app_args ts
# (fresh_cons_type, ts) = standardRhsConstructorType pos gi_index gi_module n_app_args ti ts
= (fresh_cons_type, [], ts)
@@ -1255,7 +1275,7 @@ getSymbolType pos ti=:{ti_functions,ti_common_defs,ti_main_dcl_module_n} {symb_k
UncheckedType fun_type
# (fun_type_copy, ts) = currySymbolType fun_type n_app_args ts
-> (fun_type_copy, [], ts)
- SpecifiedType fun_type lifted_arg_types _
+ SpecifiedType fun_type lifted_arg_types _
# (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 } n_app_args ts
@@ -1357,7 +1377,7 @@ where
position = CP_LiftedFunArg fun_ident.symb_ident fv_ident
req_type_coercions = [{ tc_demanded = lt, tc_offered = e_type, tc_position = position, tc_coercible = True } : reqs.req_type_coercions ]
ts_expr_heap = storeAttribute opt_expr_ptr lt.at_attribute ts.ts_expr_heap
- = requirements_of_lifted_and_normal_args ti fun_ident (arg_nr+1) fun_args exprs lts ({ reqs & req_type_coercions = req_type_coercions}, { ts & ts_expr_heap = ts_expr_heap })
+ = requirements_of_lifted_and_normal_args ti fun_ident (arg_nr+1) fun_args exprs lts ({ reqs & req_type_coercions = req_type_coercions}, {ts & ts_expr_heap = ts_expr_heap})
requirements_of_args :: !TypeInput !SymbIdent !Int ![Expression] ![AType] !(!u:Requirements, !*TypeState) -> (!u:Requirements, !*TypeState)
requirements_of_args ti _ _ [] [] reqs_ts
@@ -1466,9 +1486,8 @@ where
requirements_of_dynamic_patterns ti goal_type [dp=:{dp_position, dp_type} : dps] used_dyn_types (reqs, ts=:{ts_expr_heap})
# (EI_TempDynamicPattern _ _ _ _ dyn_type dyn_context dyn_expr_ptr type_code_symbol, ts_expr_heap)
= readPtr dp_type ts_expr_heap
- (reqs_ts)
- = possibly_accumulate_reqs_in_new_group
- dp_position
+ (reqs_ts)
+ = possibly_accumulate_reqs_in_new_group dp_position
(requirements_of_dynamic_pattern dyn_type dyn_context dyn_expr_ptr type_code_symbol ti goal_type dp)
(reqs, { ts & ts_expr_heap = ts_expr_heap})
= requirements_of_dynamic_patterns ti goal_type dps [ [dyn_type] : used_dyn_types ] reqs_ts
@@ -1485,7 +1504,7 @@ where
# reqs = { reqs & req_type_coercions = [ type_coercion : reqs.req_type_coercions], req_overloaded_calls = [dyn_expr_ptr : reqs.req_overloaded_calls ]}
= (reqs, { ts & ts_expr_heap = ts_expr_heap <:=
(dyn_expr_ptr, EI_Overloaded {oc_symbol = type_code_symbol, oc_context = dyn_context, oc_specials = []}) })
-
+
requirements_of_default ti (Yes expr) case_default_pos goal_type reqs_ts
= possibly_accumulate_reqs_in_new_group
case_default_pos
@@ -1593,7 +1612,6 @@ where
req_type_coercions = old_req_type_coercions }
= (res_type, opt_expr_ptr, (reqs_with_new_group, ts))
-
instance requirements DynamicExpr
where
requirements ti {dyn_expr,dyn_info_ptr} (reqs, ts=:{ts_expr_heap})
@@ -1927,7 +1945,7 @@ addToBase info_ptr atype=:{at_type = TFA atvs type} optional_position ts_var_hea
= ts_var_heap <:= (info_ptr, VI_FAType atvs { atype & at_type = type} optional_position)
addToBase info_ptr type optional_position ts_var_heap
= ts_var_heap <:= (info_ptr, VI_Type type optional_position)
-
+
attributedBasicType (BT_String string_type) ts=:{ts_attr_store}
= ({ at_attribute = TA_TempVar ts_attr_store, at_type = string_type}, {ts & ts_attr_store = inc ts_attr_store})
attributedBasicType bas_type ts=:{ts_attr_store}
@@ -2018,103 +2036,102 @@ where
*/
fresh_dynamics dyn_ptrs state
= foldSt fresh_dynamic dyn_ptrs state
+ where
+ fresh_dynamic dyn_ptr (var_store, type_heaps, var_heap, expr_heap, predef_symbols)
+ # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
+ = case dyn_info of
+ EI_Dynamic opt_dyn_type=:(Yes {dt_uni_vars,dt_type,dt_global_vars}) loc_dynamics
+ # (th_vars, var_store) = fresh_existential_attributed_variables dt_uni_vars (type_heaps.th_vars, var_store)
+ (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store)
+ (tdt_type, type_heaps) = freshCopy dt_type { type_heaps & th_vars = th_vars }
+ (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols))
+ = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols)
+ -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap,
+ expr_heap <:= (dyn_ptr, EI_TempDynamicType opt_dyn_type loc_dynamics tdt_type contexts expr_ptr type_code_symbol), predef_symbols)
+ EI_Dynamic No loc_dynamics
+ # fresh_var = TempV var_store
+ tdt_type = { at_attribute = TA_Multi, at_type = fresh_var }
+
+ # ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass]
+ # pds_ident = predefined_idents.[PD_TypeCodeClass]
+ tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }}
+ (pds, predef_symbols) = predef_symbols![PD_TypeCodeMember]
+ ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember]
+ pds_ident = predefined_idents.[PD_TypeCodeMember]
+ tc_member_symb = { symb_ident = pds_ident, symb_kind = SK_OverloadedFunction {glob_module = pds_module, glob_object = pds_def }}
+ (new_var_ptr, var_heap) = newPtr VI_Empty var_heap
+ context = {tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}
+ (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
+ -> fresh_local_dynamics loc_dynamics (inc var_store, type_heaps, var_heap,
+ expr_heap <:= (dyn_ptr, EI_TempDynamicType No loc_dynamics tdt_type [context] expr_ptr tc_member_symb), predef_symbols)
+ EI_DynamicTypeWithVars loc_type_vars dt=:{dt_uni_vars,dt_type,dt_global_vars} loc_dynamics
+ # (fresh_vars, (th_vars, var_store)) = fresh_existential_dynamic_pattern_variables loc_type_vars (type_heaps.th_vars, var_store)
+ (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store)
+ (tdt_type, type_heaps) = freshCopy (add_universal_vars_to_type dt_uni_vars dt_type) { type_heaps & th_vars = th_vars }
+ (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols))
+ = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols)
+ -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap,
+ expr_heap <:= (dyn_ptr, EI_TempDynamicPattern loc_type_vars dt loc_dynamics fresh_vars tdt_type contexts expr_ptr type_code_symbol), predef_symbols)
+ EI_UnmarkedDynamic _ _
+ -> (var_store, type_heaps, var_heap, expr_heap, predef_symbols)
+ where
+ fresh_local_dynamics loc_dynamics state
+ = foldSt fresh_dynamic loc_dynamics state
- fresh_dynamic dyn_ptr (var_store, type_heaps, var_heap, expr_heap, predef_symbols)
- # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
- = case dyn_info of
- EI_Dynamic opt_dyn_type=:(Yes {dt_uni_vars,dt_type,dt_global_vars}) loc_dynamics
- # (th_vars, var_store) = fresh_existential_attributed_variables dt_uni_vars (type_heaps.th_vars, var_store)
- (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store)
- (tdt_type, type_heaps) = freshCopy dt_type { type_heaps & th_vars = th_vars }
- (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols))
- = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols)
- -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap,
- expr_heap <:= (dyn_ptr, EI_TempDynamicType opt_dyn_type loc_dynamics tdt_type contexts expr_ptr type_code_symbol), predef_symbols)
- EI_Dynamic No loc_dynamics
- # fresh_var = TempV var_store
- tdt_type = { at_attribute = TA_Multi, at_type = fresh_var }
-
+ determine_context_and_expr_ptr global_vars (var_heap, expr_heap, type_var_heap, predef_symbols)
# ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass]
# pds_ident = predefined_idents.[PD_TypeCodeClass]
- tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }}
- (pds, predef_symbols) = predef_symbols![PD_TypeCodeMember]
- ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember]
- pds_ident = predefined_idents.[PD_TypeCodeMember]
- tc_member_symb = { symb_ident = pds_ident, symb_kind = SK_OverloadedFunction {glob_module = pds_module, glob_object = pds_def }}
- (new_var_ptr, var_heap) = newPtr VI_Empty var_heap
- context = {tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}
- (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
- -> fresh_local_dynamics loc_dynamics (inc var_store, type_heaps, var_heap,
- expr_heap <:= (dyn_ptr, EI_TempDynamicType No loc_dynamics tdt_type [context] expr_ptr tc_member_symb), predef_symbols)
- EI_DynamicTypeWithVars loc_type_vars dt=:{dt_uni_vars,dt_type,dt_global_vars} loc_dynamics
- # (fresh_vars, (th_vars, var_store)) = fresh_existential_variables loc_type_vars (type_heaps.th_vars, var_store)
- (th_vars, var_store) = fresh_type_variables dt_global_vars (th_vars, var_store)
- (tdt_type, type_heaps) = freshCopy (add_universal_vars_to_type dt_uni_vars dt_type) { type_heaps & th_vars = th_vars }
- (contexts, expr_ptr, type_code_symbol, (var_heap, expr_heap, type_var_heap, predef_symbols))
- = determine_context_and_expr_ptr dt_global_vars (var_heap, expr_heap, type_heaps.th_vars, predef_symbols)
- -> fresh_local_dynamics loc_dynamics (var_store, { type_heaps & th_vars = type_var_heap }, var_heap,
- expr_heap <:= (dyn_ptr, EI_TempDynamicPattern loc_type_vars dt loc_dynamics fresh_vars tdt_type contexts expr_ptr type_code_symbol), predef_symbols)
- EI_UnmarkedDynamic _ _
- -> (var_store, type_heaps, var_heap, expr_heap, predef_symbols)
-// ---> ("fresh_dynamic : EI_UnmarkedDynamic")
-
- fresh_local_dynamics loc_dynamics state
- = foldSt fresh_dynamic loc_dynamics state
+ tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }}
+ ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember]
+ pds_ident = predefined_idents.[PD_TypeCodeMember]
+ tc_member_symb = { symb_ident = pds_ident, symb_kind = SK_TypeCode}
+ (contexts, (var_heap, type_var_heap)) = mapSt (build_type_context tc_class_symb) global_vars (var_heap, type_var_heap)
+ (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
+ = (contexts, expr_ptr, tc_member_symb, (var_heap, expr_heap, type_var_heap, predef_symbols))
+ where
+ build_type_context tc_class_symb {tv_info_ptr} (var_heap, type_var_heap)
+ # (TVI_Type fresh_var, type_var_heap) = readPtr tv_info_ptr type_var_heap
+ (new_var_ptr, var_heap) = newPtr VI_Empty var_heap
+ = ({tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap))
+
+ fresh_existential_attributed_variables type_variables state
+ = foldSt (\{atv_variable={tv_info_ptr}} (var_heap, var_store) -> (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store))
+ type_variables state
+
+ fresh_existential_dynamic_pattern_variables type_variables state
+ = mapSt (\{tv_info_ptr} (var_heap, var_store) -> (var_store, (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store)))
+ type_variables state
+ fresh_type_variables type_variables state
+ = foldSt fresh_type_variable type_variables state
+
+ fresh_type_variable {tv_info_ptr} (var_heap, var_store)
+ # (var_info, var_heap) = readPtr tv_info_ptr var_heap
+ = case var_info of
+ TVI_Empty
+ -> (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store)
+ _
+ -> (var_heap, var_store)
clear_dynamics dyn_ptrs heaps
= foldSt clear_dynamic dyn_ptrs heaps
-
- clear_dynamic dyn_ptr (var_heap, expr_heap)
- # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
- = case dyn_info of
- EI_Dynamic (Yes {dt_global_vars}) loc_dynamics
- -> clear_local_dynamics loc_dynamics (clear_type_vars dt_global_vars var_heap, expr_heap)
- EI_Dynamic No loc_dynamics
- -> clear_local_dynamics loc_dynamics (var_heap, expr_heap)
- EI_DynamicTypeWithVars loc_type_vars {dt_global_vars} loc_dynamics
- -> clear_local_dynamics loc_dynamics (clear_type_vars dt_global_vars var_heap, expr_heap)
- EI_UnmarkedDynamic _ _
- -> (var_heap, expr_heap)
-
-
- clear_local_dynamics loc_dynamics state
- = foldSt clear_dynamic loc_dynamics state
-
- clear_type_vars type_vars var_heap
- = foldSt (\{tv_info_ptr} -> writePtr tv_info_ptr TVI_Empty) type_vars var_heap
-
- fresh_existential_attributed_variables type_variables state
- = foldSt (\{atv_variable={tv_info_ptr}} (var_heap, var_store) -> (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store))
- type_variables state
- fresh_existential_variables type_variables state
- = mapSt (\{tv_info_ptr} (var_heap, var_store) -> (var_store, (var_heap <:= (tv_info_ptr, TVI_Type (TempQV var_store)), inc var_store)))
- type_variables state
- fresh_type_variables type_variables state
- = foldSt fresh_type_variable type_variables state
-
- fresh_type_variable {tv_info_ptr} (var_heap, var_store)
- # (var_info, var_heap) = readPtr tv_info_ptr var_heap
- = case var_info of
- TVI_Empty
- -> (var_heap <:= (tv_info_ptr, TVI_Type (TempV var_store)), inc var_store)
- _
- -> (var_heap, var_store)
-
- determine_context_and_expr_ptr global_vars (var_heap, expr_heap, type_var_heap, predef_symbols)
- # ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeClass]
- # pds_ident = predefined_idents.[PD_TypeCodeClass]
- tc_class_symb = {glob_module = pds_module, glob_object = {ds_ident = pds_ident, ds_arity = 1, ds_index = pds_def }}
- ({pds_module,pds_def},predef_symbols) = predef_symbols![PD_TypeCodeMember]
- pds_ident = predefined_idents.[PD_TypeCodeMember]
- tc_member_symb = { symb_ident = pds_ident, symb_kind = SK_TypeCode}
- (contexts, (var_heap, type_var_heap)) = mapSt (build_type_context tc_class_symb) global_vars (var_heap, type_var_heap)
- (expr_ptr, expr_heap) = newPtr EI_Empty expr_heap
- = (contexts, expr_ptr, tc_member_symb, (var_heap, expr_heap, type_var_heap, predef_symbols))
-
- build_type_context tc_class_symb {tv_info_ptr} (var_heap, type_var_heap)
- # (TVI_Type fresh_var, type_var_heap) = readPtr tv_info_ptr type_var_heap
- (new_var_ptr, var_heap) = newPtr VI_Empty var_heap
- = ({tc_class = TCClass tc_class_symb, tc_types = [fresh_var], tc_var = new_var_ptr}, (var_heap, type_var_heap))
+ where
+ clear_dynamic dyn_ptr (var_heap, expr_heap)
+ # (dyn_info, expr_heap) = readPtr dyn_ptr expr_heap
+ = case dyn_info of
+ EI_Dynamic (Yes {dt_global_vars}) loc_dynamics
+ -> clear_local_dynamics loc_dynamics (clear_type_vars dt_global_vars var_heap, expr_heap)
+ EI_Dynamic No loc_dynamics
+ -> clear_local_dynamics loc_dynamics (var_heap, expr_heap)
+ EI_DynamicTypeWithVars loc_type_vars {dt_global_vars} loc_dynamics
+ -> clear_local_dynamics loc_dynamics (clear_type_vars dt_global_vars var_heap, expr_heap)
+ EI_UnmarkedDynamic _ _
+ -> (var_heap, expr_heap)
+
+ clear_local_dynamics loc_dynamics state
+ = foldSt clear_dynamic loc_dynamics state
+
+ clear_type_vars type_vars var_heap
+ = foldSt (\{tv_info_ptr} -> writePtr tv_info_ptr TVI_Empty) type_vars var_heap
add_universal_vars_to_type [] at
= at
@@ -2170,7 +2187,7 @@ where
ts_error = check_caf_context (newPosition fun_ident fun_pos) fun_kind clean_fun_type ts_error
th_attrs = ts_type_heaps.th_attrs
(out, th_attrs)
- = case list_inferred_types of
+ = case list_inferred_types of
No
-> (out, th_attrs)
Yes show_attributes
@@ -2219,46 +2236,6 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_args_strictness,st_vars,
, fe_index :: !Index
, fe_location :: !IdentPos
}
-/*
-ste_kind_to_string s
- = case s of
- (STE_FunctionOrMacro _)
- -> "STE_FunctionOrMacro"
- STE_Type
- -> "STE_Type"
- STE_Constructor
- -> "STE_Constructor"
- (STE_Selector _)
- -> "STE_Selector"
- STE_Class
- -> "STE_Class"
- (STE_Field _)
- -> "STE_Field"
- STE_Member
- -> "STE_Member"
- (STE_Instance _)
- -> "STE_Instance"
- (STE_Variable _)
- -> "STE_Variable"
- (STE_TypeVariable _)
- -> "STE_TypeVariable"
- (STE_TypeAttribute _)
- -> "STE_TypeAttribute"
- (STE_BoundTypeVariable _)
- -> "STE_BoundTypeVariable"
- (STE_Imported a b)
- -> "STE_Imported "+++ ste_kind_to_string a
- STE_DclFunction
- -> "STE_DclFunction"
- (STE_Module _)
- -> "STE_Module"
- STE_ClosedModule
- -> "STE_ClosedModule"
- STE_Empty
- -> "STE_Empty"
- _
- -> "STE_???"
-*/
typeProgram :: !{! Group} !Int !*{# FunDef} !IndexRange !(Optional Bool) !CommonDefs !{!Declaration} ![([Declaration], Int, Position)] !{# DclModule} !NumberSet
!*TypeDefInfos !*Heaps !*PredefinedSymbols !*File !*File
@@ -2408,14 +2385,14 @@ where
#! comp = comps.[group_index]
# funs_and_state = type_component list_inferred_types comp.group_members class_instances ti funs_and_state
= type_components list_inferred_types (inc group_index) comps class_instances ti funs_and_state
-
+/*
show_component comp fun_defs
= foldSt show_fun comp ([], fun_defs)
where
show_fun fun_index (names, fun_defs)
# ({fun_ident}, fun_defs) = fun_defs![fun_index]
= ([fun_ident : names], fun_defs)
-
+*/
get_index_of_start_rule predef_symbols
# ({pds_def, pds_module}, predef_symbols) = predef_symbols![PD_Start]
| pds_def <> NoIndex && pds_module == main_dcl_module_n
@@ -2665,10 +2642,8 @@ 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)
-
update_function_types :: !Index !{!Group} !*{!FunctionType} !*{#FunDef} -> (!*{#FunDef}, !*{!FunctionType})
update_function_types group_index comps fun_env fun_defs
@@ -2807,7 +2782,7 @@ where
= create_instance_types class_members list_members (TA ai_record []) (size class_members) funs_heaps_and_error
where
first_instance_index=ai_members.[0].cim_index
-
+
create_instance_types :: {#DefinedSymbol} {#MemberDef} Type !Int !(!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin)
-> (!*{#FunDef}, !*TypeHeaps, !*ErrorAdmin)
create_instance_types members list_members record_type member_index funs_heaps_and_error
@@ -2891,7 +2866,7 @@ getPositionOfExpr expr var_heap
= (CP_Expression expr, var_heap)
getTypeInfoOfVariable {var_info_ptr} var_heap
- # (var_info, var_heap)= readPtr var_info_ptr var_heap
+ # (var_info, var_heap) = readPtr var_info_ptr var_heap
= case var_info of
VI_Type _ type_info
-> (type_info, var_heap)