Commit 137d0d83 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Universally quantified types added

Bug fix in reference marking
parent 2c487bd0
This diff is collapsed.
......@@ -442,10 +442,7 @@ where
# (inst_var, (type_pattern_vars, var_heap)) = addLocalTCInstance var_number (type_pattern_vars, var_heap)
= (CA_LocalTypeCode inst_var, (new_contexts, special_instances, type_pattern_vars, var_heap))
reduce_tc_context type_code_class (TempV var_number) (new_contexts, special_instances, type_pattern_vars, var_heap)
// MV ...
// was: # (tc_var, var_heap) = newPtr VI_Empty var_heap
# (tc_var, var_heap) = newPtr VI_FreeTypeVarAtRuntime var_heap
// ... MV
# (tc_var, var_heap) = newPtr VI_Empty var_heap
tc = { tc_class = type_code_class, tc_types = [TempV var_number], tc_var = tc_var }
| containsContext tc new_contexts
= (CA_Context tc, (new_contexts, special_instances, type_pattern_vars, var_heap))
......@@ -920,7 +917,7 @@ where
fun_def = { fun_def & fun_body = TransformedBody {tb & tb_rhs = tb_rhs}, fun_info = { fun_info & fi_local_vars = ui_local_vars}}
= update_dynamics funs type_pattern_vars ({ ui_fun_defs & [fun] = fun_def })
ui_fun_env ui_symbol_heap x_type_code_info ui_var_heap ui_error predef_symbols
removeOverloadedFunctions :: ![Index] ![LocalTypePatternVariable] !Int!*{#FunDef} !*{! FunctionType} !*ExpressionHeap
!*TypeCodeInfo !*VarHeap !*ErrorAdmin !*{#PredefinedSymbol}
-> (!*{#FunDef}, !*{! FunctionType}, !*ExpressionHeap, !*TypeCodeInfo, !*VarHeap, !*ErrorAdmin, !*{#PredefinedSymbol})
......@@ -966,7 +963,7 @@ where
-> ([var_info_ptr : variables], var_heap <:= (var_info_ptr, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
// ---> ("determine_class_argument (VI_ForwardClassVar)", ptrToInt tc_var, ptrToInt var_info_ptr)
_
-> abort "determine_class_argument (overloading.icl)"
-> abort ("determine_class_argument 1 (overloading.icl)")// <<- var_info)
VI_Empty
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
......@@ -974,7 +971,7 @@ where
-> ([tc_var : variables], var_heap <:= (tc_var, VI_ClassVar (build_var_name id_name) new_info_ptr 0))
// ---> ("determine_class_argument (VI_Empty)", ptrToInt tc_var)
_
-> abort "determine_class_argument (overloading.icl)"
-> abort ("determine_class_argument 2 (overloading.icl)") // <<- var_info)
build_var_name id_name
= { id_name = "_v" +++ id_name, id_info = nilPtr }
......
......@@ -1539,24 +1539,28 @@ optionalAnnotAndAttr pState
# (token, pState) = nextToken TypeContext pState
| token == ExclamationToken
# (token, pState) = nextToken TypeContext pState
(_ , attr, pState) = optional_attribute token pState
// Sjaak (_ , attr, pState) = optional_attribute token pState
(_ , attr, pState) = tryAttribute token pState
= (True, AN_Strict, attr, pState)
| otherwise // token <> ExclamationToken
# (succ, attr, pState) = optional_attribute token pState
# (succ, attr, pState) = tryAttribute token pState
= (succ, AN_None, attr, pState)
where
optional_attribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState)
optional_attribute DotToken pState = (True, TA_Anonymous, pState)
optional_attribute AsteriskToken pState = (True, TA_Unique, pState)
optional_attribute (IdentToken id) pState
| isLowerCaseName id
# (token, pState) = nextToken TypeContext pState
| ColonToken == token
# (ident, pState) = stringToIdent id IC_TypeAttr pState
= (True, TA_Var (makeAttributeVar ident), pState)
= (False, TA_None, tokenBack (tokenBack pState))
optional_attribute _ pState = (False, TA_None, tokenBack pState)
// Sjaak 210801 ...
tryAttribute :: !Token !ParseState -> (!Bool, !TypeAttribute, !ParseState)
tryAttribute DotToken pState = (True, TA_Anonymous, pState)
tryAttribute AsteriskToken pState = (True, TA_Unique, pState)
tryAttribute (IdentToken id) pState
| isLowerCaseName id
# (token, pState) = nextToken TypeContext pState
| ColonToken == token
# (ident, pState) = stringToIdent id IC_TypeAttr pState
= (True, TA_Var (makeAttributeVar ident), pState)
= (False, TA_None, tokenBack (tokenBack pState))
tryAttribute _ pState = (False, TA_None, tokenBack pState)
// ... Sjaak
cIsInfix :== True
cIsNotInfix :== False
......@@ -1649,16 +1653,25 @@ where
_
-> (MakeTypeVar erroneousIdent, parseError "Type variable" (Yes token) "<type variable>" pState)
adjustAttribute :: !TypeAttribute Type *ParseState -> (TypeAttribute,*ParseState)
adjustAttribute TA_Anonymous (TV {tv_name={id_name}}) pState
# (ident, pState) = stringToIdent id_name IC_TypeAttr pState
= (TA_Var (makeAttributeVar ident), pState)
adjustAttribute TA_Anonymous (GTV {tv_name={id_name}}) pState
// Sjaak 210801 ...
adjustAttribute :: !TypeAttribute Type *ParseState -> (!TypeAttribute, !*ParseState)
adjustAttribute attr (TV {tv_name}) pState
= adjustAttributeOfTypeVariable attr tv_name pState
adjustAttribute attr (GTV {tv_name}) pState
= adjustAttributeOfTypeVariable attr tv_name pState
adjustAttribute attr type pState
= (attr, pState)
adjustAttributeOfTypeVariable :: !TypeAttribute !Ident !*ParseState -> (!TypeAttribute, !*ParseState)
adjustAttributeOfTypeVariable TA_Anonymous {id_name} pState
# (ident, pState) = stringToIdent id_name IC_TypeAttr pState
= (TA_Var (makeAttributeVar ident), pState)
adjustAttribute attr type pState
adjustAttributeOfTypeVariable attr _ pState
= (attr, pState)
// ... Sjaak 210801
stringToType :: !String !ParseState -> (!Type, !ParseState)
stringToType name pState
| isLowerCaseName name
......@@ -1937,6 +1950,7 @@ wantDynamicType pState
# (type_vars, pState) = optionalUniversalQuantifiedVariables pState
(type, pState) = want pState
= ({ dt_uni_vars = type_vars, dt_type = type, dt_global_vars = [] }, pState)
/* PK
:: QuantifierKind = UniversalQuantifier | ExistentialQuantifier
......@@ -1970,38 +1984,56 @@ optionalExistentialQuantifiedVariables pState
# (token, pState) = nextToken TypeContext pState
= case token of
ExistsToken
# (vars, pState) = wantList "existential quantified variable(s)" tryAttributedFreeTypeVar pState
# (vars, pState) = wantList "existential quantified variable(s)" try_existential_type_var pState
-> (vars, wantToken TypeContext "Existential Quantified Variables" ColonToken pState)
_ -> ([], tokenBack pState)
where
try_existential_type_var :: !ParseState -> (Bool,ATypeVar,ParseState)
try_existential_type_var pState
# (token, pState) = nextToken TypeContext pState
= case token of
DotToken
// Sjaak 210801 ...
# (typevar, pState) = wantTypeVar pState
-> (True, {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar}, pState)
// ... Sjaak
_
# (succ, typevar, pState) = tryTypeVarT token pState
| succ
# atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}
-> (True,atypevar,pState)
-> (False,abort "no ATypeVar",pState)
// Sjaak 210801 ....
optionalUniversalQuantifiedVariables :: !*ParseState -> *(![ATypeVar],!*ParseState)
optionalUniversalQuantifiedVariables pState
# (token, pState) = nextToken TypeContext pState
= case token of
ForAllToken
# (vars, pState) = wantList "universal quantified variable(s)" tryAttributedFreeTypeVar pState
# (vars, pState) = wantList "universal quantified variable(s)" try_universal_type_var pState
-> (vars, wantToken TypeContext "Universal Quantified Variables" ColonToken pState)
_ -> ([], tokenBack pState)
where
try_universal_type_var :: !ParseState -> (Bool, ATypeVar, ParseState)
try_universal_type_var pState
# (token, pState) = nextToken TypeContext pState
(succ, attr, pState) = try_universal_attribute token pState
| succ
# (typevar, pState) = wantTypeVar pState
(attr, pState) = adjustAttributeOfTypeVariable attr typevar.tv_name pState
= (True, {atv_attribute = attr, atv_annotation = AN_None, atv_variable = typevar}, pState)
# (succ, typevar, pState) = tryTypeVarT token pState
| succ
= (True, {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}, pState)
= (False, abort "no ATypeVar", pState)
try_universal_attribute DotToken pState = (True, TA_Anonymous, pState)
try_universal_attribute AsteriskToken pState = (True, TA_Unique, pState)
try_universal_attribute token pState = (False, TA_None, pState)
// ... Sjaak
tryAttributedFreeTypeVar :: !ParseState -> (Bool,ATypeVar,ParseState)
tryAttributedFreeTypeVar pState
# (token, pState) = nextToken TypeContext pState
= case token of
DotToken
// RWS ...
# (token, pState) = nextToken TypeContext pState
// ... RWS
# (succ,typevar, pState) = tryTypeVarT token pState
| succ
# atypevar = {atv_attribute = TA_Anonymous, atv_annotation = AN_None, atv_variable = typevar}
-> (True,atypevar,pState)
-> (False,abort "no ATypeVar",pState)
_
# (succ,typevar, pState) = tryTypeVarT token pState
| succ
# atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}
-> (True,atypevar,pState)
-> (False,abort "no ATypeVar",pState)
/* PK
optionalQuantifiedVariables :: !QuantifierKind !*ParseState -> *(![ATypeVar],!*ParseState)
......
......@@ -6,7 +6,7 @@ import syntax, Heap, typesupport, check, overloading, unitype, utilities //, RWS
NotASelector :== -1
class refMark expr :: ![[FreeVar]] !Int !(Optional Expression) !expr !*VarHeap -> *VarHeap
class refMark expr :: ![[FreeVar]] !Int !(Optional [(FreeVar,ReferenceCount)]) !expr !*VarHeap -> *VarHeap
instance refMark [a] | refMark a
......@@ -141,8 +141,8 @@ where
# (VI_Occurrence occ, var_heap) = readPtr fv_info_ptr var_heap
= var_heap <:= (fv_info_ptr, VI_Occurrence { occ & occ_ref_count = RC_Unused, occ_bind = OB_OpenLet lb_src })
refMark free_vars sel def (Case {case_expr,case_guards,case_default,case_explicit}) var_heap
= refMarkOfCase free_vars sel case_expr case_guards case_explicit (combineDefaults def case_default case_explicit) var_heap
refMark free_vars sel def (Case kees) var_heap
= refMarkOfCase free_vars sel def kees var_heap
refMark free_vars sel _ (Selection _ expr selectors) var_heap
= refMark free_vars (field_number selectors) No expr var_heap
where
......@@ -257,28 +257,28 @@ where
_
-> var_heap
refMarkOfCase free_vars sel expr (AlgebraicPatterns type patterns) explicit defaul var_heap
= ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
refMarkOfCase free_vars sel def {case_expr, case_guards=AlgebraicPatterns type patterns, case_explicit, case_default} var_heap
= ref_mark_of_algebraic_case free_vars sel def case_expr patterns case_explicit case_default var_heap
where
ref_mark_of_algebraic_case free_vars sel (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap
ref_mark_of_algebraic_case free_vars sel def (Var {var_name,var_info_ptr,var_expr_ptr}) patterns explicit defaul var_heap
# (VI_Occurrence var_occ=:{occ_bind,occ_ref_count}, var_heap) = readPtr var_info_ptr var_heap
= case occ_bind of
OB_Empty
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap
OB_OpenLet let_expr
# var_heap = var_heap <:= (var_info_ptr, VI_Occurrence { var_occ & occ_ref_count = occ_ref_count, occ_bind = OB_LockedLet let_expr })
var_heap = refMark free_vars sel No let_expr var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap
OB_LockedLet _
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern True var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap
OB_Pattern vars ob
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel patterns explicit defaul var_heap
ref_mark_of_algebraic_case free_vars sel expr patterns explicit defaul var_heap
= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns explicit defaul var_heap
-> ref_mark_of_algebraic_case_with_variable_pattern False var_info_ptr var_expr_ptr var_occ free_vars sel def patterns explicit defaul var_heap
ref_mark_of_algebraic_case free_vars sel def expr patterns explicit defaul var_heap
= ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns explicit defaul var_heap
ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr {occ_ref_count = RC_Unused}
free_vars sel patterns case_explicit case_default var_heap
# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
free_vars sel def patterns case_explicit case_default var_heap
# var_heap = ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap
(VI_Occurrence var_occ, var_heap) = readPtr var_info_ptr var_heap
= case var_occ.occ_ref_count of
RC_Unused
......@@ -288,22 +288,25 @@ where
-> var_heap <:= (var_info_ptr, VI_Occurrence { var_occ &
occ_ref_count = RC_Used { rcu & rcu_uniquely = [var_expr_ptr : rcu.rcu_uniquely] }})
ref_mark_of_algebraic_case_with_variable_pattern with_composite_pattern var_info_ptr var_expr_ptr
var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel patterns case_explicit case_default var_heap
var_occ=:{occ_ref_count = RC_Used {rcu_multiply,rcu_uniquely,rcu_selectively}} free_vars sel def patterns case_explicit case_default var_heap
# var_occ = { var_occ & occ_ref_count = RC_Used { rcu_multiply = collectAllSelections rcu_selectively (rcu_uniquely ++ [var_expr_ptr : rcu_multiply]),
rcu_uniquely = [], rcu_selectively = [] }}
var_heap = var_heap <:= (var_info_ptr, VI_Occurrence var_occ )
= ref_mark_of_patterns with_composite_pattern free_vars sel (Yes var_info_ptr) patterns case_explicit case_default var_heap
= ref_mark_of_patterns with_composite_pattern free_vars sel def (Yes var_info_ptr) patterns case_explicit case_default var_heap
ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel expr patterns case_explicit case_default var_heap
ref_mark_of_algebraic_case_with_non_variable_pattern free_vars sel def expr patterns case_explicit case_default var_heap
# var_heap = refMark free_vars NotASelector No expr var_heap
= ref_mark_of_patterns True free_vars sel No patterns case_explicit case_default var_heap
= ref_mark_of_patterns True free_vars sel def No patterns case_explicit case_default var_heap
ref_mark_of_patterns with_composite_pattern free_vars sel opt_pattern_var patterns case_explicit case_default var_heap
ref_mark_of_patterns with_composite_pattern free_vars sel def opt_pattern_var patterns case_explicit case_default var_heap
# (local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap
(with_pattern_bindings, pattern_depth, used_lets, var_heap)
= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets (propagateDefault case_explicit case_default))
patterns (False, 0, [], var_heap)
= refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap
= foldSt (ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def) patterns (False, 0, used_lets, var_heap)
= addRefMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars def used_lets var_heap
// = refMarkOfDefault (with_composite_pattern && with_pattern_bindings) pattern_depth free_vars sel case_default used_lets var_heap
ref_mark_of_algebraic_pattern free_vars sel opt_pattern_var local_lets def {ap_vars,ap_expr}
(with_pattern_bindings, pattern_depth, used_lets, var_heap)
......@@ -311,7 +314,7 @@ where
var_heap = saveOccurrences free_vars var_heap
used_pattern_vars = collectPatternsVariables ap_vars
var_heap = bind_optional_pattern_variable opt_pattern_var used_pattern_vars var_heap
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap
var_heap = refMark [ [ fv \\ (fv,_) <- used_pattern_vars ] : free_vars ] sel def ap_expr var_heap // (var_heap ---> ("ref_mark_of_algebraic_pattern", ap_expr))
var_heap = restore_binding_of_pattern_variable opt_pattern_var used_pattern_vars var_heap
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
var_heap = clear_local_vars used_pattern_vars var_heap
......@@ -342,13 +345,15 @@ where
// ---> ("restore_binding_of_pattern_variable", occ_ref_count)
restore_binding_of_pattern_variable _ used_pattern_vars var_heap
= var_heap
refMarkOfCase free_vars sel expr (BasicPatterns type patterns) explicit defaul var_heap
# var_heap = refMark free_vars NotASelector No expr var_heap
refMarkOfCase free_vars sel def {case_expr,case_guards=BasicPatterns type patterns,case_default,case_explicit} var_heap
# var_heap = refMark free_vars NotASelector No case_expr var_heap
(local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets (propagateDefault explicit defaul))
patterns (0, [], var_heap)
= refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
(def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_basic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap)
= addRefMarkOfDefault False pattern_depth free_vars def used_lets var_heap
// = refMarkOfDefault False pattern_depth free_vars sel defaul used_lets var_heap
// ---> ("refMarkOfCase", expr, [ (bp_value, bp_expr) \\ {bp_value, bp_expr} <- patterns])
where
ref_mark_of_basic_pattern free_vars sel local_lets def {bp_expr} (pattern_depth, used_lets, var_heap)
......@@ -358,14 +363,16 @@ where
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
= (pattern_depth, used_lets, var_heap)
refMarkOfCase free_vars sel expr (DynamicPatterns patterns) explicit defaul var_heap
refMarkOfCase free_vars sel def {case_expr,case_guards=DynamicPatterns patterns,case_default,case_explicit} var_heap
# var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars NotASelector No expr var_heap
var_heap = refMark free_vars NotASelector No case_expr var_heap
(used_free_vars, var_heap) = collectUsedFreeVariables free_vars var_heap
var_heap = parCombine free_vars var_heap
(local_lets, var_heap) = collectLocalLetVars free_vars var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets (propagateDefault explicit defaul)) patterns (0, [], var_heap)
= refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
(def, used_lets, var_heap) = refMarkOfDefault case_explicit free_vars sel def case_default local_lets var_heap
(pattern_depth, used_lets, var_heap) = foldSt (ref_mark_of_dynamic_pattern free_vars sel local_lets def) patterns (0, used_lets, var_heap)
= addRefMarkOfDefault True pattern_depth free_vars def used_lets var_heap
// = refMarkOfDefault True pattern_depth free_vars sel defaul used_lets var_heap
where
ref_mark_of_dynamic_pattern free_vars sel local_lets def {dp_var, dp_rhs} (pattern_depth, used_lets, var_heap)
# pattern_depth = inc pattern_depth
......@@ -375,20 +382,55 @@ where
(used_lets, var_heap) = collectUsedLetVars local_lets (used_lets, var_heap)
= (pattern_depth, used_lets, var_heap)
propagateDefault case_explicit case_default
refMarkOfDefault case_explicit free_vars sel def (Yes expr) local_lets var_heap
# var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars sel No expr var_heap
(used_lets, var_heap) = collectUsedLetVars local_lets ([], var_heap)
(occurrences, var_heap) = restore_occurrences free_vars var_heap
= (Yes occurrences, used_lets, var_heap)
where
restore_occurrences free_vars var_heap
= foldSt (foldSt restore_occurrence) free_vars ([], var_heap)
where
restore_occurrence fv=:{fv_name,fv_info_ptr} (occurrences, var_heap)
# (VI_Occurrence old_occ=:{occ_ref_count,occ_previous = [prev_ref_count : occ_previous]}, var_heap) = readPtr fv_info_ptr var_heap
var_heap = var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = prev_ref_count, occ_previous = occ_previous })
= case occ_ref_count of
RC_Unused
-> (occurrences, var_heap)
_
-> ([(fv,occ_ref_count) : occurrences ], var_heap)
refMarkOfDefault case_explicit free_vars sel def No local_lets var_heap
| case_explicit
= No
= case_default
= (No, [], var_heap)
= (def, [], var_heap)
addRefMarkOfDefault do_par_combine pattern_depth free_vars (Yes occurrences) used_lets var_heap
# var_heap = saveOccurrences free_vars var_heap
var_heap = foldSt set_occurrence occurrences var_heap
var_heap = setUsedLetVars used_lets var_heap
= caseCombine do_par_combine free_vars var_heap (inc pattern_depth)
where
set_occurrence (fv=:{fv_name,fv_info_ptr}, ref_count) var_heap
# (VI_Occurrence old_occ=:{occ_ref_count}, var_heap) = readPtr fv_info_ptr var_heap
= var_heap <:= (fv_info_ptr, VI_Occurrence {old_occ & occ_ref_count = ref_count } )
addRefMarkOfDefault do_par_combine pattern_depth free_vars No used_lets var_heap
# var_heap = setUsedLetVars used_lets var_heap
= caseCombine do_par_combine free_vars var_heap pattern_depth
/*
refMarkOfDefault do_par_combine pattern_depth free_vars sel (Yes expr) used_lets var_heap
# pattern_depth = inc pattern_depth
var_heap = saveOccurrences free_vars var_heap
var_heap = refMark free_vars sel No expr var_heap
var_heap = refMark free_vars sel No (expr ---> ("refMarkOfDefault", (expr, free_vars))) var_heap
var_heap = setUsedLetVars used_lets var_heap
= caseCombine do_par_combine free_vars var_heap pattern_depth
refMarkOfDefault do_par_combine pattern_depth free_vars sel No used_lets var_heap
# var_heap = setUsedLetVars used_lets var_heap
= caseCombine do_par_combine free_vars var_heap pattern_depth
*/
parCombine free_vars var_heap
= foldSt (foldSt (par_combine)) free_vars var_heap
......
......@@ -26,7 +26,7 @@ instance toString Ident
, ste_previous :: SymbolTableEntry
}
:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int }
:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr }
:: STE_Kind = STE_FunctionOrMacro ![Index]
| STE_Type
......@@ -540,7 +540,6 @@ cIsALocalVar :== False
// ... MdM
| VI_Labelled_Empty {#Char} // RWS debugging
| VI_LocalLetVar // RWS, mark Let vars during case transformation
| VI_FreeTypeVarAtRuntime // MV (dynamics), mark type variables which continue to exist at run-time.
:: ExtendedVarInfo = EVI_VarType !AType
......@@ -862,7 +861,7 @@ cNonRecursiveAppl :== False
:: TypeVarInfo = TVI_Empty
| TVI_Type !Type
| TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect universally quantified type variables
| TVI_TypeVar !TypeVarInfoPtr // Sjaak: to collect and check universally quantified type variables
| TVI_Forward !TempVarId | TVI_TypeKind !KindInfoPtr
| TVI_SignClass !Index !SignClassification !TypeVarInfo | TVI_PropClass !Index !PropClassification !TypeVarInfo
| TVI_Attribute TypeAttribute
......@@ -907,10 +906,11 @@ cNonRecursiveAppl :== False
, atv_variable :: !TypeVar
}
:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar
:: 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_Locked !TypeAttribute
| TA_MultiOfPropagatingConsVar // only filled in after type checking, semantically equal to TA_Multi
| TA_PA_BUG
:: AttributeVar =
{ av_name :: !Ident
......
......@@ -30,7 +30,7 @@ where toString {import_module} = toString import_module
, ste_previous :: SymbolTableEntry
}
:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr /* TD */, stv_position :: Int }
:: STE_BoundTypeVariable = { stv_count :: !Int, stv_attribute :: !TypeAttribute, stv_info_ptr :: !TypeVarInfoPtr }
:: STE_Kind = STE_FunctionOrMacro ![Index]
| STE_Type
......@@ -525,7 +525,6 @@ cIsALocalVar :== False
// ... MdM
| VI_Labelled_Empty {#Char} // RWS debugging
| VI_LocalLetVar // RWS, mark Let vars during case transformation
| VI_FreeTypeVarAtRuntime // MV (dynamics), mark type variables which continue to exist at run-time.
:: ExtendedVarInfo = EVI_VarType !AType
......@@ -881,10 +880,11 @@ cNotVarNumber :== -1
, atv_variable :: !TypeVar
}
:: TypeAttribute = TA_Unique | TA_Multi | TA_Var !AttributeVar | TA_RootVar AttributeVar | TA_TempVar !Int | TA_TempExVar
:: 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_Locked !TypeAttribute
| TA_MultiOfPropagatingConsVar
| TA_PA_BUG
:: AttributeVar =
{ av_name :: !Ident
......@@ -1312,8 +1312,8 @@ where
= "@@ "
toString (TA_List _ _)
= "??? "
toString TA_TempExVar
= PA_BUG "(E)" (abort "toString TA_TempExVar")
toString TA_PA_BUG
= PA_BUG "(E)" (abort "toString TA_PA_BUG")
instance <<< Annotation
where
......
......@@ -2428,6 +2428,11 @@ where
= (cons_var :@: types, ets)
expandSynTypes rem_annots common_defs type=:(TA type_symb types) ets
= expand_syn_types_in_TA rem_annots common_defs type_symb types TA_Multi ets
// Sjaak 240801 ...
expandSynTypes rem_annots common_defs (TFA vars type) ets
# (type, ets) = expandSynTypes rem_annots common_defs type ets
= (TFA vars type, ets)
// ... Sjaak
expandSynTypes rem_annots common_defs type ets
= (type, ets)
......
This diff is collapsed.
......@@ -49,19 +49,20 @@ simplifyTypeApplication (TArrow1 _) _
:: VarEnv :== {! Type }
:: CleanUpState =
{ cus_var_env :: !.VarEnv
, cus_attr_env :: !.AttributeEnv
{ cus_var_env :: !.VarEnv
, cus_attr_env :: !.AttributeEnv
, cus_appears_in_lifted_part :: !.LargeBitvect
, cus_heaps :: !.TypeHeaps
, cus_var_store :: !Int
, cus_attr_store :: !Int
, cus_error :: !.ErrorAdmin
, cus_heaps :: !.TypeHeaps
, cus_var_store :: !Int
, cus_attr_store :: !Int
, cus_exis_vars :: ![(Int,TypeAttribute)]
, cus_error :: !.ErrorAdmin
}
:: CleanUpInput =
{ cui_coercions :: !{! CoercionTree}
, cui_attr_part :: !AttributePartition
, cui_top_level :: !Bool
{ cui_coercions :: !{! CoercionTree}
, cui_attr_part :: !AttributePartition
, cui_top_level :: !Bool
, cui_is_lifted_part :: !Bool
}
......@@ -69,8 +70,20 @@ class clean_up a :: !CleanUpInput !a !*CleanUpState -> (!a, !*CleanUpState)
instance clean_up AType
where
clean_up cui atype=:{at_attribute, at_type = TempQV qv_number} cus
| cui.cui_top_level
# (at_attribute, cus) = cleanUpTypeAttribute True cui at_attribute cus
# (type, cus) = cus!cus_var_env.[qv_number]
(var, cus) = cleanUpVariable True type qv_number cus
= ({atype & at_attribute = at_attribute, at_type = var, at_annotation = AN_None},
{cus & cus_exis_vars = add_new_variable type qv_number at_attribute cus.cus_exis_vars})
where
add_new_variable TE ev_number ev_attr cus_exis_vars
= [(ev_number, ev_attr) : cus_exis_vars]
add_new_variable type ev_number ev_attr cus_exis_vars
= cus_exis_vars
clean_up cui atype=:{at_attribute,at_type} cus
# (at_attribute, cus) = clean_up cui at_attribute cus
# (at_attribute, cus) = cleanUpTypeAttribute False cui at_attribute cus
(at_type, cus) = clean_up cui at_type cus
= ({atype & at_attribute = at_attribute, at_type = at_type, at_annotation = AN_None}, cus)
......@@ -78,51 +91,49 @@ where
attrIsUndefined TA_None = True
attrIsUndefined _ = False