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
8024fd77
Commit
8024fd77
authored
Oct 05, 2001
by
Sjaak Smetsers
Browse files
Added existential attribute variables to type definitions
parent
5c8aeef4
Changes
4
Hide whitespace changes
Inline
Side-by-side
frontend/analtypes.icl
View file @
8024fd77
...
...
@@ -51,9 +51,9 @@ partionateAndExpandTypes used_module_numbers main_dcl_module_index icl_common=:{
=
(
reverse
pi_groups
,
common_defs
,
pi_type_def_infos
,
{
icl_common
&
com_type_defs
=
icl_type_defs
},
dcl_modules
,
type_heaps
,
error
)
where
copy_type_defs_and_create_marks_and_infos
used_module_numbers
main_dcl_module_index
nr_of_types_in_icl_mod
nr_of_modules
(
icl_type_defs
,
dcl_modules
)
#
type_defs
=
{
{}
\\
module_nr
<-
[
0
..
nr_of_modules
]
}
marks
=
{
{}
\\
module_nr
<-
[
0
..
nr_of_modules
]
}
type_def_infos
=
{
{}
\\
module_nr
<-
[
0
..
nr_of_modules
]
}
#
type_defs
=
{
{}
\\
module_nr
<-
[
1
..
nr_of_modules
]
}
marks
=
{
{}
\\
module_nr
<-
[
1
..
nr_of_modules
]
}
type_def_infos
=
{
{}
\\
module_nr
<-
[
1
..
nr_of_modules
]
}
=
iFoldSt
(
copy_type_def_and_create_marks_and_infos
used_module_numbers
main_dcl_module_index
nr_of_types_in_icl_mod
)
0
nr_of_modules
(
icl_type_defs
,
dcl_modules
,
type_defs
,
marks
,
type_def_infos
)
where
...
...
frontend/checktypes.icl
View file @
8024fd77
...
...
@@ -279,6 +279,7 @@ where
=
({
ts
&
ts_cons_defs
=
{
ts
.
ts_cons_defs
&
[
ds_index
]
=
{
cons_def
&
cons_type
=
cons_type
,
cons_index
=
cons_index
,
cons_type_index
=
cti
.
cti_type_index
,
cons_exi_vars
=
exi_vars
,
cons_type_ptr
=
new_type_ptr
,
cons_arg_vars
=
cons_arg_vars
}}},
{
ti
&
ti_var_heap
=
ti_var_heap
},
cs
)
// ---> ("bind_types_of_constructors", cons_def.cons_symb, exi_vars, cons_type)
where
bind_types_of_cons
::
![
AType
]
!
CurrentTypeInfo
![
TypeVar
]
![
AttrInequality
]
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
->
!(![
AType
],
![[
ATypeVar
]],
![
AttrInequality
],
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
))
...
...
@@ -1056,28 +1057,32 @@ where
=
(
TA_Unique
,
attr_vars
,
attr_var_heap
,
cs
)
check_attribute
is_rank_two
attr
name
attr_vars
attr_var_heap
cs
|
is_rank_two
=
check_rank_two_attribute
attr
name
attr_vars
attr_var_heap
cs
=
check_rank_two_attribute
attr
attr_vars
attr_var_heap
cs
=
check_global_attribute
attr
name
attr_vars
attr_var_heap
cs
where
check_global_attribute
TA_Multi
name
attr_vars
attr_var_heap
cs
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
new_var
=
{
av_name
=
emptyIdent
name
,
av_info_ptr
=
attr_info_ptr
}
=
(
TA_Var
new_var
,
[
new_var
:
attr_vars
],
attr_var_heap
,
cs
)
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
new_var
=
{
av_name
=
emptyIdent
name
,
av_info_ptr
=
attr_info_ptr
}
=
(
TA_Var
new_var
,
[
new_var
:
attr_vars
],
attr_var_heap
,
cs
)
check_global_attribute
TA_None
name
attr_vars
attr_var_heap
cs
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
new_var
=
{
av_name
=
emptyIdent
name
,
av_info_ptr
=
attr_info_ptr
}
=
(
TA_Var
new_var
,
[
new_var
:
attr_vars
],
attr_var_heap
,
cs
)
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
new_var
=
{
av_name
=
emptyIdent
name
,
av_info_ptr
=
attr_info_ptr
}
=
(
TA_Var
new_var
,
[
new_var
:
attr_vars
],
attr_var_heap
,
cs
)
check_global_attribute
_
name
attr_vars
attr_var_heap
cs
=
(
TA_Multi
,
attr_vars
,
attr_var_heap
,
checkError
name
"specified attribute variable not allowed"
cs
)
check_rank_two_attribute
TA_
Anonymous
name
attr_vars
attr_var_heap
cs
check_rank_two_attribute
(
TA_
Var
var
)
attr_vars
attr_var_heap
cs
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
new_var
=
{
var
&
av_info_ptr
=
attr_info_ptr
}
=
(
TA_Var
new_var
,
[
new_var
:
attr_vars
],
attr_var_heap
,
cs
)
check_rank_two_attribute
TA_Anonymous
attr_vars
attr_var_heap
cs
=
abort
"check_rank_two_attribute (TA_Anonymous, check_types.icl)"
/* # (attr_info_ptr, attr_var_heap) = newPtr AVI_Empty attr_var_heap
new_var = { av_name = emptyIdent name, av_info_ptr = attr_info_ptr}
= (TA_Var new_var, [new_var : attr_vars], attr_var_heap, cs)
check_rank_two_attribute
attr
name
attr_vars
attr_var_heap
cs
*/
check_rank_two_attribute
attr
attr_vars
attr_var_heap
cs
=
(
attr
,
attr_vars
,
attr_var_heap
,
cs
)
addExistentionalTypeVariablesToSymbolTable
::
!
TypeAttribute
![
ATypeVar
]
!*
TypeHeaps
!*
CheckState
->
(![
ATypeVar
],
!(!*
TypeHeaps
,
!*
CheckState
))
addExistentionalTypeVariablesToSymbolTable
root_attr
type_vars
heaps
cs
...
...
@@ -1092,15 +1097,15 @@ where
|
entry
.
ste_def_level
<
cGlobalScope
// cOuterMostLevel
#
(
tv_info_ptr
,
th_vars
)
=
newPtr
TVI_Empty
th_vars
atv_variable
=
{
atv_variable
&
tv_info_ptr
=
tv_info_ptr
}
(
atv_attribute
,
cs_error
)
=
check_attribute
atv_attribute
root_attr
tv_name
.
id_name
cs_error
(
atv_attribute
,
th_attrs
,
cs_error
)
=
check_attribute
atv_attribute
root_attr
tv_name
.
id_name
th_attrs
cs_error
cs_symbol_table
=
cs_symbol_table
<:=
(
tv_info
,
{
ste_index
=
NoIndex
,
ste_kind
=
STE_BoundTypeVariable
{
stv_attribute
=
atv_attribute
,
stv_info_ptr
=
tv_info_ptr
,
stv_count
=
0
},
ste_def_level
=
cGlobalScope
/* cOuterMostLevel */
,
ste_previous
=
entry
})
heaps
=
{
heaps
&
th_vars
=
th_vars
}
heaps
=
{
heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}
=
({
atv
&
atv_variable
=
atv_variable
,
atv_attribute
=
atv_attribute
},
(
heaps
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
,
cs_error
=
cs_error
}))
=
(
atv
,
({
heaps
&
th_vars
=
th_vars
},
{
cs
&
cs_symbol_table
=
cs_symbol_table
,
cs_error
=
checkError
tv_name
.
id_name
"type variable already defined"
cs_error
}))
/*
check_attribute :: !TypeAttribute !TypeAttribute !String !*ErrorAdmin
-> (!TypeAttribute, !*ErrorAdmin)
check_attribute TA_Multi root_attr name error
...
...
@@ -1117,6 +1122,28 @@ where
-> (PA_BUG (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error)
check_attribute attr root_attr name error
= (TA_Multi, checkError name "specified attribute not allowed" error)
*/
check_attribute
::
!
TypeAttribute
!
TypeAttribute
!
String
!*
AttrVarHeap
!*
ErrorAdmin
->
(!
TypeAttribute
,
!*
AttrVarHeap
,
!*
ErrorAdmin
)
check_attribute
TA_Multi
root_attr
name
attr_var_heap
error
=
(
TA_Multi
,
attr_var_heap
,
error
)
check_attribute
TA_None
root_attr
name
attr_var_heap
error
=
(
TA_Multi
,
attr_var_heap
,
error
)
check_attribute
TA_Unique
root_attr
name
attr_var_heap
error
=
(
TA_Unique
,
attr_var_heap
,
error
)
check_attribute
(
TA_Var
var
)
root_attr
name
attr_var_heap
error
=
case
root_attr
of
TA_Var
root_var
->
(
TA_RootVar
root_var
,
attr_var_heap
,
error
)
TA_Unique
#
(
attr_info_ptr
,
attr_var_heap
)
=
newPtr
AVI_Empty
attr_var_heap
->
(
TA_Var
{
var
&
av_info_ptr
=
attr_info_ptr
},
attr_var_heap
,
error
)
// -> (PA_BUG (TA_RootVar (abort "SwitchUniquenessBug is on")) root_attr, error)
check_attribute
attr
root_attr
name
attr_var_heap
error
=
(
TA_Multi
,
attr_var_heap
,
checkError
name
"specified attribute not allowed"
error
)
retrieveKinds
::
![
ATypeVar
]
*
TypeVarHeap
->
(![
TypeKind
],
!*
TypeVarHeap
)
retrieveKinds
type_vars
var_heap
=
mapSt
retrieve_kind
type_vars
var_heap
...
...
frontend/parse.icl
View file @
8024fd77
...
...
@@ -2034,9 +2034,11 @@ optionalExistentialQuantifiedVariables pState
#
(
token
,
pState
)
=
nextToken
TypeContext
pState
=
case
token
of
ExistsToken
#
(
vars
,
pState
)
=
wantList
"existential quantified variable(s)"
try
_existential_t
ype
_v
ar
pState
#
(
vars
,
pState
)
=
wantList
"existential quantified variable(s)"
try
QuantifiedT
ype
V
ar
pState
->
(
vars
,
wantToken
TypeContext
"Existential Quantified Variables"
ColonToken
pState
)
_
->
([],
tokenBack
pState
)
/* Sjaak 041001
where
try_existential_type_var :: !ParseState -> (Bool,ATypeVar,ParseState)
try_existential_type_var pState
...
...
@@ -2053,34 +2055,34 @@ where
# atypevar = {atv_attribute = TA_None, atv_annotation = AN_None, atv_variable = typevar}
-> (True,atypevar,pState)
-> (False,abort "no ATypeVar",pState)
// Sjaak
2
10
8
01 ....
*/
// Sjaak
04
1001 ....
optionalUniversalQuantifiedVariables
::
!*
ParseState
->
*(![
ATypeVar
],!*
ParseState
)
optionalUniversalQuantifiedVariables
pState
#
(
token
,
pState
)
=
nextToken
TypeContext
pState
=
case
token
of
ForAllToken
#
(
vars
,
pState
)
=
wantList
"universal quantified variable(s)"
try
_universal_t
ype
_v
ar
pState
#
(
vars
,
pState
)
=
wantList
"universal quantified variable(s)"
try
QuantifiedT
ype
V
ar
pState
->
(
vars
,
wantToken
TypeContext
"Universal Quantified Variables"
ColonToken
pState
)
_
->
([],
tokenBack
pState
)
where
try
_universal_t
ype
_v
ar
::
!
ParseState
->
(
Bool
,
ATypeVar
,
ParseState
)
try
_universal_t
ype
_v
ar
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
)
try
QuantifiedT
ype
V
ar
::
!
ParseState
->
(
Bool
,
ATypeVar
,
ParseState
)
try
QuantifiedT
ype
V
ar
pState
#
(
token
,
pState
)
=
nextToken
TypeContext
pState
(
succ
,
attr
,
pState
)
=
try_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
)
where
try_attribute
DotToken
pState
=
(
True
,
TA_Anonymous
,
pState
)
try_attribute
AsteriskToken
pState
=
(
True
,
TA_Unique
,
pState
)
try_attribute
token
pState
=
(
False
,
TA_None
,
pState
)
// ... Sjaak
...
...
frontend/type.icl
View file @
8024fd77
...
...
@@ -504,12 +504,8 @@ freshCopyOfAttributeVar {av_name,av_info_ptr} attr_var_heap
freshCopyOfTypeAttribute
(
TA_Var
avar
)
attr_var_heap
=
freshCopyOfAttributeVar
avar
attr_var_heap
/* A temporary hack to handle the new Object IO lib */
/* Should be removed !!!!!!!!!! */
freshCopyOfTypeAttribute
(
TA_RootVar
avar
)
attr_var_heap
=
PA_BUG
(
TA_PA_BUG
,
attr_var_heap
)
(
freshCopyOfAttributeVar
avar
attr_var_heap
)
=
freshCopyOfAttributeVar
avar
attr_var_heap
freshCopyOfTypeAttribute
TA_None
attr_var_heap
=
(
TA_Multi
,
attr_var_heap
)
freshCopyOfTypeAttribute
TA_Unique
attr_var_heap
...
...
@@ -517,7 +513,6 @@ freshCopyOfTypeAttribute TA_Unique attr_var_heap
freshCopyOfTypeAttribute
attr
attr_var_heap
=
(
attr
,
attr_var_heap
)
cIsExistential
:==
True
cIsNotExistential
:==
False
...
...
@@ -582,12 +577,20 @@ where
freshCopy
type
type_heaps
=
(
type
,
type_heaps
)
freshExistentialVariables
type_variables
state
=
foldSt
fresh_existential_variable
type_variables
state
freshExistentialVariables
type_variables
var_store
attr_store
type_heaps
=
foldSt
fresh_existential_variable
type_variables
([],
var_store
,
attr_store
,
type_heaps
)
where
fresh_existential_variable
{
atv_variable
={
tv_info_ptr
}}
(
var_heap
,
var_store
)
=
(
var_heap
<:=
(
tv_info_ptr
,
TVI_Type
(
TempQV
var_store
)),
inc
var_store
)
fresh_existential_variable
{
atv_variable
={
tv_info_ptr
},
atv_attribute
}
(
exi_attr_vars
,
var_store
,
attr_store
,
type_heaps
=:
{
th_vars
,
th_attrs
})
#
th_vars
=
th_vars
<:=
(
tv_info_ptr
,
TVI_Type
(
TempQV
var_store
))
#
var_store
=
inc
var_store
#
(
exi_attr_vars
,
attr_store
,
th_attrs
)
=
fresh_existential_attribute
atv_attribute
(
exi_attr_vars
,
attr_store
,
th_attrs
)
=
(
exi_attr_vars
,
var_store
,
attr_store
,
{
type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
})
fresh_existential_attribute
(
TA_Var
{
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
attr
state
=
state
fresh_type_variables
::
[
ATypeVar
]
*(*
Heap
TypeVarInfo
,
Int
)
->
*(!*
Heap
TypeVarInfo
,!
Int
);
fresh_type_variables
type_variables
state
=
foldSt
(\{
atv_variable
={
tv_info_ptr
}}
(
var_heap
,
var_store
)
->
(
var_heap
<:=
(
tv_info_ptr
,
TVI_Type
(
TempV
var_store
)),
inc
var_store
))
...
...
@@ -622,21 +625,6 @@ fresh_environment inequalities attr_env attr_heap
is_new_ineqality
dem_attr_var
off_attr_var
[]
=
True
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}]
cons_defs
var_store
type_heaps
#
{
cons_type
=
{
st_args
,
st_attr_env
,
st_result
},
cons_index
,
cons_exi_vars
}
=
cons_defs
.[
glob_object
.
ds_index
]
(
th_vars
,
var_store
)
=
freshExistentialVariables
cons_exi_vars
(
type_heaps
.
th_vars
,
var_store
)
(
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
,
th_vars
=
th_vars
}
(
fresh_args
,
type_heaps
)
=
freshCopy
st_args
type_heaps
=
([
fresh_args
],
result_type
,
var_store
,
attr_env
,
type_heaps
)
fresh_symbol_types
[{
ap_symbol
={
glob_object
}}
:
patterns
]
cons_defs
var_store
type_heaps
#
(
cons_types
,
result_type
,
var_store
,
attr_env
,
type_heaps
)
=
fresh_symbol_types
patterns
cons_defs
var_store
type_heaps
{
cons_type
=
{
st_args
,
st_attr_env
},
cons_index
,
cons_exi_vars
}
=
cons_defs
.[
glob_object
.
ds_index
]
(
th_vars
,
var_store
)
=
freshExistentialVariables
cons_exi_vars
(
type_heaps
.
th_vars
,
var_store
)
(
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
,
th_vars
=
th_vars
}
=
([
fresh_args
:
cons_types
],
result_type
,
var_store
,
attr_env
,
type_heaps
)
freshUniversalVariables
type_variables
state
=
foldSt
fresh_universal_variable
type_variables
state
...
...
@@ -645,15 +633,39 @@ where
=
(
var_heap
<:=
(
tv_info_ptr
,
TVI_Type
(
TempQV
var_store
)),
inc
var_store
)
freshAlgebraicType
::
!(
Global
Int
)
![
AlgebraicPattern
]
!{#
CommonDefs
}
!*
TypeState
->
(![[
AType
]],!
AType
,![
AttrCoercion
],!*
TypeState
)
freshAlgebraicType
{
glob_module
,
glob_object
}
patterns
common_defs
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_td_infos
}
freshAlgebraicType
{
glob_module
,
glob_object
}
patterns
common_defs
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_td_infos
,
ts_exis_variables
}
#
{
td_rhs
,
td_args
,
td_attrs
,
td_name
,
td_attribute
}
=
common_defs
.[
glob_module
].
com_type_defs
.[
glob_object
]
#
(
th_vars
,
ts_var_store
)
=
fresh_type_variables
td_args
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
(
th_attrs
,
ts_attr_store
)
=
fresh_attributes
td_attrs
(
ts_type_heaps
.
th_attrs
,
ts_attr_store
)
type_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}
(
cons_types
,
alg_type
,
ts_var_store
,
attr_env
,
type_heaps
)
=
fresh_symbol_types
patterns
common_defs
.[
glob_module
].
com_cons_defs
ts_var_store
type_heaps
=
(
cons_types
,
alg_type
,
attr_env
,
{
ts
&
ts_var_store
=
ts_var_store
,
ts_attr_store
=
ts_attr_store
,
ts_type_heaps
=
type_heaps
})
ts_type_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
,
th_attrs
=
th_attrs
}
(
cons_types
,
alg_type
,
attr_env
,
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_exis_variables
)
=
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
,
{
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
=
{
st_args
,
st_attr_env
,
st_result
},
cons_index
,
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
(
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
all_exis_variables
=
add_exis_variables
ap_expr
exis_variables
all_exis_variables
=
([
fresh_args
],
result_type
,
attr_env
,
var_store
,
attr_store
,
type_heaps
,
all_exis_variables
)
fresh_symbol_types
[{
ap_symbol
={
glob_object
},
ap_expr
}
:
patterns
]
cons_defs
var_store
attr_store
type_heaps
all_exis_variables
#
(
cons_types
,
result_type
,
attr_env
,
var_store
,
attr_store
,
type_heaps
,
all_exis_variables
)
=
fresh_symbol_types
patterns
cons_defs
var_store
attr_store
type_heaps
all_exis_variables
{
cons_type
=
{
st_args
,
st_attr_env
},
cons_index
,
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
(
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
=
([
fresh_args
:
cons_types
],
result_type
,
attr_env
,
var_store
,
attr_store
,
type_heaps
,
all_exis_variables
)
add_exis_variables
expr
[]
exis_variables
=
exis_variables
add_exis_variables
expr
new_exis_variables
exis_variables
=
[(
CP_Expression
expr
,
new_exis_variables
)
:
exis_variables
]
fresh_overloaded_list_type
[{
ap_symbol
}:
patterns
]
pd_cons_symbol
pd_nil_symbol
decons_u_index
nil_u_index
stdStrictLists_index
pos
functions
common_defs
ts
|
ap_symbol
.
glob_module
==
cPredefinedModuleIndex
...
...
@@ -760,7 +772,7 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con
(
fresh_type
,
type_heaps
)
=
freshCopy
type
type_heaps
type_heaps
=
clearBindings
vars
type_heaps
=
({
at
&
at_attribute
=
fresh_attribute
,
at_type
=
fresh_type
},
(
var_store
,
attr_store
,
add
_exis_v
ariables
pos
new_exis_variables
exis_variables
,
type_heaps
))
(
var_store
,
attr_store
,
add
ToExistentialV
ariables
pos
new_exis_variables
exis_variables
,
type_heaps
))
fresh_arg_type
_
at
(
var_store
,
attr_store
,
exis_variables
,
type_heaps
)
#
(
fresh_at
,
type_heaps
)
=
freshCopy
at
type_heaps
=
(
fresh_at
,
(
var_store
,
attr_store
,
exis_variables
,
type_heaps
))
...
...
@@ -774,10 +786,10 @@ freshSymbolType is_appl fresh_context_vars st=:{st_vars,st_args,st_result,st_con
fresh_attr
attr
state
=
state
add_exis_v
ariables
pos
[]
exis_variables
=
exis_variables
add_exis_v
ariables
pos
new_exis_variables
exis_variables
=
[(
pos
,
new_exis_variables
)
:
exis_variables
]
addToExistentialV
ariables
pos
[]
exis_variables
=
exis_variables
addToExistentialV
ariables
pos
new_exis_variables
exis_variables
=
[(
pos
,
new_exis_variables
)
:
exis_variables
]
freshArgumentsOfSymbolType
::
![
AType
]
!*
TypeHeaps
->
(![
AType
],
!*
TypeHeaps
)
freshArgumentsOfSymbolType
atypes
type_heaps
=
mapSt
fresh_arg_type
atypes
type_heaps
...
...
@@ -1024,10 +1036,12 @@ determineSymbolTypeOfFunction pos ident act_arity st=:{st_args,st_result,st_attr
ts_var_heap
=
ts
.
ts_var_heap
<:=
(
type_ptr
,
VI_PropagationType
st
)
}
->
currySymbolType
copy_symb_type
act_arity
ts
standardFieldSelectorType
pos
{
glob_object
={
ds_ident
,
ds_index
},
glob_module
}
{
ti_common_defs
}
ts
=:{
ts_var_store
,
ts_type_heaps
}
#!
{
sd_type
,
sd_exi_vars
}
=
ti_common_defs
.[
glob_module
].
com_selector_defs
.[
ds_index
]
#
(
th_vars
,
ts_var_store
)
=
freshExistentialVariables
sd_exi_vars
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
=
freshSymbolType
(
Yes
pos
)
cWithFreshContextVars
sd_type
ti_common_defs
{
ts
&
ts_type_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
},
ts_var_store
=
ts_var_store
}
standardFieldSelectorType
pos
{
glob_object
={
ds_ident
,
ds_index
},
glob_module
}
{
ti_common_defs
}
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_exis_variables
}
#
{
sd_type
,
sd_exi_vars
}
=
ti_common_defs
.[
glob_module
].
com_selector_defs
.[
ds_index
]
(
new_exis_variables
,
ts_var_store
,
ts_attr_store
,
ts_type_heaps
)
=
freshExistentialVariables
sd_exi_vars
ts_var_store
ts_attr_store
ts_type_heaps
ts_exis_variables
=
addToExistentialVariables
pos
new_exis_variables
ts_exis_variables
ts
=
{
ts
&
ts_type_heaps
=
ts_type_heaps
,
ts_var_store
=
ts_var_store
,
ts_attr_store
=
ts_attr_store
,
ts_exis_variables
=
ts_exis_variables
}
=
freshSymbolType
(
Yes
pos
)
cWithFreshContextVars
sd_type
ti_common_defs
ts
// ---> ("standardFieldSelectorType", ds_ident, inst)
standardTupleSelectorType
pos
{
ds_index
}
arg_nr
{
ti_common_defs
}
ts
...
...
@@ -1041,10 +1055,12 @@ standardRhsConstructorType pos index mod arity {ti_common_defs} ts
=
currySymbolType
fresh_type
arity
ts
// ---> ("standardRhsConstructorType", cons_symb, fresh_type)
standardLhsConstructorType
index
mod
arity
{
ti_common_defs
}
ts
=:{
ts_var_store
,
ts_type_heaps
}
#!
{
cons_symb
,
cons_type
,
cons_exi_vars
}
=
ti_common_defs
.[
mod
].
com_cons_defs
.[
index
]
#
(
th_vars
,
ts_var_store
)
=
freshExistentialVariables
cons_exi_vars
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
=
freshSymbolType
No
cWithFreshContextVars
cons_type
ti_common_defs
{
ts
&
ts_type_heaps
=
{
ts_type_heaps
&
th_vars
=
th_vars
},
ts_var_store
=
ts_var_store
}
standardLhsConstructorType
pos
index
mod
arity
{
ti_common_defs
}
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_exis_variables
}
#
{
cons_symb
,
cons_type
,
cons_exi_vars
}
=
ti_common_defs
.[
mod
].
com_cons_defs
.[
index
]
(
new_exis_variables
,
ts_var_store
,
ts_attr_store
,
ts_type_heaps
)
=
freshExistentialVariables
cons_exi_vars
ts_var_store
ts_attr_store
ts_type_heaps
ts_exis_variables
=
addToExistentialVariables
pos
new_exis_variables
ts_exis_variables
ts
=
{
ts
&
ts_type_heaps
=
ts_type_heaps
,
ts_var_store
=
ts_var_store
,
ts_attr_store
=
ts_attr_store
,
ts_exis_variables
=
ts_exis_variables
}
=
freshSymbolType
No
cWithFreshContextVars
cons_type
ti_common_defs
ts
// ---> ("standardLhsConstructorType", cons_symb, fresh_type)
::
ReferenceMarking
:==
Bool
...
...
@@ -1464,8 +1480,9 @@ where
=
(
composite_expr_type
,
opt_composite_expr_ptr
,
(
reqs
,
ts
))
requirements
ti
(
RecordUpdate
{
glob_module
,
glob_object
={
ds_index
,
ds_arity
}}
expression
expressions
)
(
reqs
,
ts
)
#
(
lhs
,
ts
)
=
standardLhsConstructorType
ds_index
glob_module
ds_arity
ti
ts
(
rhs
,
ts
)
=
standardRhsConstructorType
(
CP_Expression
expression
)
ds_index
glob_module
ds_arity
ti
ts
#
cp
=
CP_Expression
expression
(
lhs
,
ts
)
=
standardLhsConstructorType
cp
ds_index
glob_module
ds_arity
ti
ts
(
rhs
,
ts
)
=
standardRhsConstructorType
cp
ds_index
glob_module
ds_arity
ti
ts
(
expression_type
,
opt_expr_ptr
,
reqs_ts
)
=
requirements
ti
expression
(
reqs
,
ts
)
(
reqs
,
ts
)
=
requirements_of_fields
ti
expression
expressions
rhs
.
tst_args
lhs
.
tst_args
reqs_ts
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
lhs
.
tst_result
.
at_attribute
ts
.
ts_expr_heap
}
...
...
@@ -1504,10 +1521,11 @@ where
requirements
ti
(
MatchExpr
opt_tuple_type
{
glob_object
={
ds_arity
,
ds_index
},
glob_module
}
expr
)
(
reqs
,
ts
)
#
({
tst_result
,
tst_args
,
tst_attr_env
},
ts
)
=
standardLhsConstructorType
ds_index
glob_module
ds_arity
ti
ts
#
cp
=
CP_Expression
expr
({
tst_result
,
tst_args
,
tst_attr_env
},
ts
)
=
standardLhsConstructorType
cp
ds_index
glob_module
ds_arity
ti
ts
(
e_type
,
opt_expr_ptr
,
(
reqs
,
ts
))
=
requirements
ti
expr
(
reqs
,
ts
)
reqs
=
{
reqs
&
req_attr_coercions
=
tst_attr_env
++
reqs
.
req_attr_coercions
,
req_type_coercions
=
[{
tc_demanded
=
tst_result
,
tc_offered
=
e_type
,
tc_position
=
CP_Expression
expr
,
tc_coercible
=
True
}
:
reqs
.
req_type_coercions
]
}
req_type_coercions
=
[{
tc_demanded
=
tst_result
,
tc_offered
=
e_type
,
tc_position
=
cp
,
tc_coercible
=
True
}
:
reqs
.
req_type_coercions
]
}
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
tst_result
.
at_attribute
ts
.
ts_expr_heap
}
=
case
opt_tuple_type
of
Yes
{
glob_object
={
ds_ident
,
ds_index
,
ds_arity
},
glob_module
}
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment