Skip to content
GitLab
Commit 137d0d83 authored by Sjaak Smetsers's avatar Sjaak Smetsers
Browse files

Universally quantified types added 

Bug fix in reference marking
parent 2c487bd0
Expand all Hide whitespace changes
Inline Side-by-side
frontend/checktypes.icl
View file @ 137d0d83
This diff is collapsed.
frontend/overloading.icl
View file @ 137d0d83
......@@ -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 }
......
frontend/parse.icl
View file @ 137d0d83
......@@ -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)
......
frontend/refmark.icl
View file @ 137d0d83
......@@ -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
......
frontend/syntax.dcl
View file @ 137d0d83
......@@ -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
......
frontend/syntax.icl
View file @ 137d0d83
......@@ -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
......
frontend/trans.icl
View file @ 137d0d83
......@@ -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)
......
frontend/type.icl
View file @ 137d0d83
This diff is collapsed.
frontend/typesupport.icl
View file @ 137d0d83
......@@ -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
instance clean_up TypeAttribute