Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
compiler
Commits
137d0d83
Commit
137d0d83
authored
Aug 27, 2001
by
Sjaak Smetsers
Browse files
Universally quantified types added
Bug fix in reference marking
parent
2c487bd0
Changes
11
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/checktypes.icl
View file @
137d0d83
This diff is collapsed.
Click to expand it.
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_a
ttribute
token
pState
#
(
succ
,
attr
,
pState
)
=
tryA
ttribute
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
adjustAttribute
OfTypeVariable
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)"
try
AttributedFreeT
ype
V
ar
pState
#
(
vars
,
pState
)
=
wantList
"existential quantified variable(s)"
try
_existential_t
ype
_v
ar
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)"
try
AttributedFreeT
ype
V
ar
pState
#
(
vars
,
pState
)
=
wantList
"universal quantified variable(s)"
try
_universal_t
ype
_v
ar
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_
defaul
t
}
var_heap
=
ref_mark_of_algebraic_case
free_vars
sel
def
case_
expr
patterns
case_
explicit
case_
defaul
t
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.
Click to expand it.
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
)
=
clean
UpTypeAttribute
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