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
725dc4d8
Commit
725dc4d8
authored
Nov 13, 2002
by
Sjaak Smetsers
Browse files
Removed bugs in analysis of abstract data types and adjusted typing of record updates
parent
e0c8f1db
Changes
4
Hide whitespace changes
Inline
Side-by-side
frontend/analtypes.icl
View file @
725dc4d8
...
...
@@ -334,6 +334,7 @@ kindInfoToKind kind_info kind_heap
::
TypeProperties
:==
BITVECT
combineTypeProperties
prop1
prop2
:==
(
combineHyperstrictness
prop1
prop2
)
bitor
(
combineCoercionProperties
prop1
prop2
)
addHyperstrictness
prop1
prop2
:==
prop1
bitor
(
combineHyperstrictness
prop1
prop2
)
condCombineTypeProperties
has_root_attr
prop1
prop2
|
has_root_attr
...
...
@@ -381,7 +382,8 @@ analTypes_for_TA type_name glob_module glob_object type_arity types has_root_att
#
(
type_properties
,
conds_as
)
=
anal_types_of_rec_type_cons
modules
form_tvs
types
tdi_kinds
(
conds
,
as
)
=
(
kind
,
type_properties
,
conds_as
)
#
(
type_properties
,
conds_as
)
=
anal_types_of_type_cons
modules
form_tvs
types
tdi_kinds
(
conds
,
as
)
=
(
kind
,
type_properties
,
conds_as
)
// = (kind, type_properties, conds_as)
=
(
kind
,
addHyperstrictness
type_properties
tdi_properties
,
conds_as
)
=
(
KI_Const
,
tdi_properties
,
(
conds
,
{
as
&
as_error
=
checkError
type_name
type_appl_error
as
.
as_error
}))
where
anal_types_of_rec_type_cons
modules
form_tvs
[]
_
conds_as
...
...
@@ -547,13 +549,14 @@ where
|
is_abstract_type
=
as
#
(
type_properties
,
conds
,
as
)
=
foldSt
(
anal_type_def
modules
)
group
(
cIsHyperStrict
,
{
con_top_var_binds
=
[],
con_var_binds
=
[]
},
as
)
as
=
foldSt
(
check_dcl_properties
modules
dcl_types
dcl_mod_index
type_properties
)
group
as
(
kinds_in_group
,
(
as_kind_heap
,
as_td_infos
))
=
mapSt
determine_kinds
group
(
as
.
as_kind_heap
,
as
.
as_td_infos
)
as_kind_heap
=
unify_var_binds
conds
.
con_var_binds
as_kind_heap
(
normalized_top_vars
,
(
kind_var_store
,
as_kind_heap
))
=
normalize_top_vars
conds
.
con_top_var_binds
0
as_kind_heap
(
as_kind_heap
,
as_td_infos
)
=
update_type_def_infos
type_properties
normalized_top_vars
group
kinds_in_group
kind_var_store
as_kind_heap
as_td_infos
=
{
as
&
as_kind_heap
=
as_kind_heap
,
as_td_infos
=
as_td_infos
}
as
=
{
as
&
as_kind_heap
=
as_kind_heap
,
as_td_infos
=
as_td_infos
}
as
=
foldSt
(
check_dcl_properties
modules
dcl_types
dcl_mod_index
type_properties
)
group
as
=
as
init_type_def_infos
modules
gi
=:{
gi_module
,
gi_index
}
(
is_abstract_type
,
type_def_infos
,
as_type_var_heap
,
kind_heap
)
#
{
td_args
,
td_rhs
}
=
modules
.[
gi_module
].
com_type_defs
.[
gi_index
]
...
...
@@ -673,31 +676,37 @@ where
check_dcl_properties
modules
dcl_types
dcl_mod_index
properties
{
gi_module
,
gi_index
}
as
|
gi_module
==
dcl_mod_index
&&
gi_index
<
size
dcl_types
#
{
td_
rh
s
}
=
dcl_types
.[
gi_index
]
#
{
td_
name
,
td_rhs
,
td_args
,
td_po
s
}
=
dcl_types
.[
gi_index
]
=
case
td_rhs
of
AbstractType
spec_properties
|
equivalent_properties
spec_properties
properties
|
spec_properties
bitand
cIsNonCoercible
==
0
#
(
as_type_var_heap
,
as_td_infos
,
as_error
)
=
check_possitive_sign
gi_module
gi_index
modules
as
.
as_type_var_heap
as
.
as_td_infos
as
.
as_error
=
{
as
&
as_type_var_heap
=
as_type_var_heap
,
as_td_infos
=
as_td_infos
,
as_error
=
as_error
}
#
as_error
=
checkError
"abstract type properties conflict with derived properties in implementation module"
""
as
.
as_error
=
{
as
&
as_error
=
as_error
}
#
as_error
=
pushErrorAdmin
(
newPosition
td_name
td_pos
)
as
.
as_error
|
check_coercibility
spec_properties
properties
// ---> ("check_coercibility", td_name, spec_properties, properties)
|
check_hyperstrictness
spec_properties
properties
|
spec_properties
bitand
cIsNonCoercible
==
0
#
(
as_type_var_heap
,
as_td_infos
,
as_error
)
=
check_possitive_sign
gi_module
gi_index
modules
td_args
as
.
as_type_var_heap
as
.
as_td_infos
as_error
=
{
as
&
as_type_var_heap
=
as_type_var_heap
,
as_td_infos
=
as_td_infos
,
as_error
=
popErrorAdmin
as_error
}
=
{
as
&
as_error
=
popErrorAdmin
as_error
}
#
as_error
=
checkError
"abstract type as defined in the implementation module is not hyperstrict"
""
as_error
=
{
as
&
as_error
=
popErrorAdmin
as_error
}
#
as_error
=
checkError
"abstract type as defined in the implementation module is not coercible"
""
as_error
=
{
as
&
as_error
=
popErrorAdmin
as_error
}
_
=
as
=
as
where
equivalent_properties
icl_props
dcl_props
|
icl_props
bitand
cIsNonCoercible
>
0
&&
dcl_props
bitand
cIsNonCoercible
==
0
=
False
|
dcl_props
bitand
cIsHyperStrict
>
0
&&
icl_props
bitand
cIsHyperStrict
==
0
=
False
=
True
check_coercibility
dcl_props
icl_props
=
dcl_props
bitand
cIsNonCoercible
>
0
||
icl_props
bitand
cIsNonCoercible
==
0
check_hyperstrictness
dcl_props
icl_props
=
dcl_props
bitand
cIsHyperStrict
==
0
||
icl_props
bitand
cIsHyperStrict
>
0
check_possitive_sign
mod_index
type_index
modules
type_var_heap
type_def_infos
error
#
(
signs
,
type_var_heap
,
type_def_infos
)
=
signClassification
mod_index
type_index
[]
modules
type_var_heap
type_def_infos
check_possitive_sign
mod_index
type_index
modules
td_args
type_var_heap
type_def_infos
error
#
top_signs
=
[
TopSignClass
\\
_
<-
td_args
]
#
(
signs
,
type_var_heap
,
type_def_infos
)
=
signClassification
mod_index
type_index
top_signs
modules
type_var_heap
type_def_infos
|
signs
.
sc_neg_vect
==
0
=
(
type_var_heap
,
type_def_infos
,
error
)
#
error
=
checkError
"abstract type
properties conflict with derived properties in implementation modul
e"
""
error
#
error
=
checkError
"
signs of
abstract type
variables should be positiv
e"
""
error
=
(
type_var_heap
,
type_def_infos
,
error
)
...
...
frontend/analunitypes.icl
View file @
725dc4d8
...
...
@@ -132,7 +132,7 @@ where
collect_sign_class_of_type_def
group_nr
signs_of_group_vars
ci
{
gi_module
,
gi_index
}
(
sign_requirements
,
type_var_heap
,
td_infos
)
#
({
tdi_group_vars
,
tdi_kinds
,
tdi_index_in_group
},
td_infos
)
=
td_infos
![
gi_module
].[
gi_index
]
{
td_name
,
td_args
,
td_rhs
}
=
ci
.[
gi_module
].
com_type_defs
.[
gi_index
]
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name,
(glob_module, glob_object),
tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
// (rev_hio_signs, type_var_heap) = bind_type_vars_to_signs td_args (tdi_group_vars ---> ("bind_type_vars_to_signs",td_name, tdi_group_vars)) tdi_kinds signs_of_group_vars ([], type_var_heap)
(
rev_hio_signs
,
type_var_heap
)
=
bind_type_vars_to_signs
td_args
tdi_group_vars
tdi_kinds
signs_of_group_vars
([],
type_var_heap
)
(
sign_env
,
scs
)
=
sign_class_of_type_def
gi_module
td_rhs
group_nr
ci
{
scs_type_var_heap
=
type_var_heap
,
scs_type_def_infos
=
td_infos
,
scs_rec_appls
=
[]
}
...
...
frontend/syntax.dcl
View file @
725dc4d8
...
...
@@ -603,7 +603,12 @@ pIsSafe :== True
from
convertDynamics
import
::
TypeCodeVariableInfo
,
::
DynamicValueAliasInfo
::
VarInfo
=
VI_Empty
|
VI_Type
!
AType
!(
Optional
CoercionPosition
)
|
VI_FAType
![
ATypeVar
]
!
AType
!(
Optional
CoercionPosition
)
|
::
VI_TypeInfo
=
VITI_Empty
|
VITI_Coercion
CoercionPosition
|
VITI_PatternType
[
AType
]
VI_TypeInfo
//:: VarInfo = VI_Empty | VI_Type !AType !(Optional CoercionPosition) | VI_FAType ![ATypeVar] !AType !(Optional CoercionPosition) |
::
VarInfo
=
VI_Empty
|
VI_Type
!
AType
!
VI_TypeInfo
|
VI_FAType
![
ATypeVar
]
!
AType
!
VI_TypeInfo
|
VI_Occurrence
!
Occurrence
|
VI_UsedVar
!
Ident
|
VI_Expression
!
Expression
|
VI_Variable
!
Ident
!
VarInfoPtr
|
VI_LiftedVariable
!
VarInfoPtr
|
VI_Count
!
Int
/* the reference count of a variable */
!
Bool
/* true if the variable is global, false otherwise */
|
...
...
frontend/type.icl
View file @
725dc4d8
...
...
@@ -787,7 +787,7 @@ freshOverloadedListType (OverloadedList _ stdStrictLists_index decons_u_index ni
cWithFreshContextVars
:==
True
cWithoutFreshContextVars
:==
False
freshSymbolType
::
!(
Optional
CoercionPosition
)
!
Bool
!
SymbolType
{#
u
:
CommonDefs
}
!*
TypeState
->
(!
TempSymbolType
,!*
TypeState
)
//
freshSymbolType :: !(Optional CoercionPosition) !Bool !SymbolType {#u:CommonDefs} !*TypeState -> (!TempSymbolType,!*TypeState)
freshSymbolType
is_appl
fresh_context_vars
st
=:{
st_vars
,
st_args
,
st_result
,
st_context
,
st_attr_vars
,
st_attr_env
,
st_arity
}
common_defs
ts
=:{
ts_var_store
,
ts_attr_store
,
ts_type_heaps
,
ts_var_heap
,
ts_cons_variables
,
ts_exis_variables
}
#
(
th_vars
,
ts_var_store
)
=
fresh_type_variables
st_vars
(
ts_type_heaps
.
th_vars
,
ts_var_store
)
...
...
@@ -910,7 +910,7 @@ addToExistentialVariables pos new_exis_variables exis_variables
=
[(
pos
,
new_exis_variables
)
:
exis_variables
]
freshInequality
::
AttrInequality
*(
Heap
AttrVarInfo
)
->
(!
AttrCoercion
,!.
Heap
AttrVarInfo
);
//
freshInequality :: AttrInequality *(Heap AttrVarInfo) -> (!AttrCoercion,!.Heap AttrVarInfo);
freshInequality
{
ai_demanded
,
ai_offered
}
attr_heap
#
(
av_dem_info
,
attr_heap
)
=
readPtr
ai_demanded
.
av_info_ptr
attr_heap
(
av_off_info
,
attr_heap
)
=
readPtr
ai_offered
.
av_info_ptr
attr_heap
...
...
@@ -1349,7 +1349,8 @@ where
requirements_of_guarded_expressions
(
AlgebraicPatterns
alg_type
patterns
)
ti
=:{
ti_common_defs
}
match_expr
pattern_type
opt_pattern_ptr
goal_type
(
reqs
,
ts
)
#
(
cons_types
,
result_type
,
new_attr_env
,
ts
)
=
freshAlgebraicType
alg_type
patterns
ti_common_defs
ts
(
used_cons_types
,
(
reqs
,
ts
))
=
requirements_of_algebraic_patterns
ti
patterns
cons_types
goal_type
[]
(
reqs
,
ts
)
ts_var_heap
=
update_case_variable
match_expr
cons_types
ts
.
ts_var_heap
(
used_cons_types
,
(
reqs
,
ts
))
=
requirements_of_algebraic_patterns
ti
patterns
cons_types
goal_type
[]
(
reqs
,
{
ts
&
ts_var_heap
=
ts_var_heap
}
)
ts_expr_heap
=
storeAttribute
opt_pattern_ptr
result_type
.
at_attribute
ts
.
ts_expr_heap
(
position
,
ts_var_heap
)
=
getPositionOfExpr
match_expr
ts
.
ts_var_heap
=
(
reverse
used_cons_types
,
({
reqs
&
req_type_coercions
=
[{
tc_demanded
=
result_type
,
tc_offered
=
pattern_type
,
tc_position
=
position
,
...
...
@@ -1430,7 +1431,7 @@ where
requirements_of_dynamic_pattern
dyn_type
dyn_context
dyn_expr_ptr
type_code_symbol
ti
goal_type
{
dp_var
={
fv_info_ptr
},
dp_rhs
}
(
reqs
,
ts
=:{
ts_expr_heap
,
ts_var_heap
})
#
ts_var_heap
=
addToBase
fv_info_ptr
dyn_type
No
ts_var_heap
#
ts_var_heap
=
addToBase
fv_info_ptr
dyn_type
VITI_Empty
ts_var_heap
(
dp_rhs_type
,
opt_expr_ptr
,
(
reqs
,
ts
))
=
requirements
ti
dp_rhs
(
reqs
,
{
ts
&
ts_expr_heap
=
ts_expr_heap
,
ts_var_heap
=
ts_var_heap
})
ts_expr_heap
=
storeAttribute
opt_expr_ptr
dp_rhs_type
.
at_attribute
ts
.
ts_expr_heap
type_coercion
=
{
tc_demanded
=
goal_type
,
tc_offered
=
dp_rhs_type
,
tc_position
=
CP_Expression
dp_rhs
,
tc_coercible
=
True
}
...
...
@@ -1454,6 +1455,20 @@ where
ts_expr_heap
=
storeAttribute
opt_expr_ptr
res_type
.
at_attribute
ts
.
ts_expr_heap
=
({
reqs
&
req_type_coercions
=
[
{
tc_demanded
=
goal_type
,
tc_offered
=
res_type
,
tc_position
=
CP_Expression
expr
,
tc_coercible
=
True
}
:
reqs
.
req_type_coercions
]
},
{
ts
&
ts_expr_heap
=
ts_expr_heap
})
update_case_variable
(
Var
{
var_name
,
var_info_ptr
,
var_expr_ptr
})
[
cons_types
]
var_heap
#
(
var_info
,
var_heap
)
=
readPtr
var_info_ptr
var_heap
// ---> ("update_case_variable 1", var_name, cons_types)
=
case
var_info
of
VI_Type
type
type_info
->
var_heap
<:=
(
var_info_ptr
,
VI_Type
type
(
VITI_PatternType
cons_types
type_info
))
VI_FAType
vars
type
type_info
->
var_heap
<:=
(
var_info_ptr
,
VI_FAType
vars
type
(
VITI_PatternType
cons_types
type_info
))
_
->
abort
"update_case_variable"
// ---> (var_name <<- var_info))
update_case_variable
expr
cons_types
var_heap
=
var_heap
// ---> ("update_case_variable 2", expr, cons_types)
instance
requirements
Let
where
...
...
@@ -1469,7 +1484,7 @@ where
make_base
[{
lb_src
,
lb_dst
={
fv_name
,
fv_info_ptr
}}:
bs
]
var_types
ts
=:{
ts_var_heap
}
#
(
v
,
ts
)
=
freshAttributedVariable
ts
optional_position
=
if
(
is_rare_name
fv_name
)
(
Yes
(
CP_Expression
lb_src
))
No
optional_position
=
if
(
is_rare_name
fv_name
)
(
VITI_Coercion
(
CP_Expression
lb_src
))
VITI_Empty
=
make_base
bs
[
v
:
var_types
]
{
ts
&
ts_var_heap
=
writePtr
fv_info_ptr
(
VI_Type
v
optional_position
)
ts
.
ts_var_heap
}
make_base
[]
var_types
ts
=
(
var_types
,
ts
)
...
...
@@ -1631,14 +1646,15 @@ where
requirements
ti
(
RecordUpdate
{
glob_module
,
glob_object
={
ds_index
,
ds_arity
}}
expression
expressions
)
(
reqs
,
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
}
coercion
=
{
tc_demanded
=
lhs
.
tst_result
,
tc_offered
=
expression_type
,
tc_position
=
CP_Expression
expression
,
tc_coercible
=
True
}
=
(
rhs
.
tst_result
,
No
,
({
reqs
&
req_attr_coercions
=
rhs
.
tst_attr_env
++
lhs
.
tst_attr_env
++
reqs
.
req_attr_coercions
,
req_type_coercions
=
[
coercion
:
reqs
.
req_type_coercions
]},
ts
))
(
lhs_args
,
reqs_ts
)
=
determine_record_type
cp
ds_index
glob_module
ds_arity
ti
expression
expression_type
opt_expr_ptr
reqs_ts
(
reqs
,
ts
)
=
requirements_of_fields
ti
expression
expressions
rhs
.
tst_args
lhs_args
reqs_ts
// ts = { ts & ts_expr_heap = storeAttribute opt_expr_ptr lhs_result.at_attribute ts.ts_expr_heap }
// coercion = { tc_demanded = lhs_result, tc_offered = expression_type, tc_position = CP_Expression expression, tc_coercible = True }
// = (rhs.tst_result, No, ({ reqs & req_attr_coercions = rhs.tst_attr_env ++ lhs_attr_env ++ reqs.req_attr_coercions, ts))
=
(
rhs
.
tst_result
,
No
,
({
reqs
&
req_attr_coercions
=
rhs
.
tst_attr_env
++
reqs
.
req_attr_coercions
},
ts
))
// req_type_coercions = [ coercion : reqs.req_type_coercions ]}, ts))
where
requirements_of_fields
ti
expression
[]
_
_
reqs_ts
=
reqs_ts
...
...
@@ -1655,6 +1671,28 @@ where
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
dem_field_type
.
at_attribute
ts
.
ts_expr_heap
}
coercion
=
{
tc_demanded
=
dem_field_type
,
tc_offered
=
expr_type
,
tc_position
=
CP_Expression
bind_src
,
tc_coercible
=
True
}
=
({
reqs
&
req_type_coercions
=
[
coercion
:
reqs
.
req_type_coercions
]},
ts
)
determine_record_type
cp
cons_index
mod_index
arity
ti
(
Var
var
)
expression_type
opt_expr_ptr
(
reqs
,
ts
=:{
ts_var_heap
})
#
(
type_info
,
ts_var_heap
)
=
getTypeInfoOfVariable
var
ts_var_heap
ts
=
{
ts
&
ts_var_heap
=
ts_var_heap
}
=
case
type_info
of
VITI_PatternType
arg_types
_
->
(
arg_types
,
(
reqs
,
ts
))
// ---> ("determine_record_type (Yes)", result_type, arg_types)
_
->
new_lhs_constructor_type
cp
cons_index
mod_index
arity
ti
expression_type
opt_expr_ptr
(
reqs
,
ts
)
// ---> ("determine_record_type (No) 1")
determine_record_type
cp
cons_index
mod_index
arity
ti
_
expression_type
opt_expr_ptr
reqs_ts
=
new_lhs_constructor_type
cp
cons_index
mod_index
arity
ti
expression_type
opt_expr_ptr
reqs_ts
// ---> ("determine_record_type (No) 2")
new_lhs_constructor_type
cp
cons_index
mod_index
arity
ti
expression_type
opt_expr_ptr
(
reqs
,
ts
)
#
(
lhs
,
ts
)
=
standardLhsConstructorType
cp
cons_index
mod_index
arity
ti
ts
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
lhs
.
tst_result
.
at_attribute
ts
.
ts_expr_heap
}
coercion
=
{
tc_demanded
=
lhs
.
tst_result
,
tc_offered
=
expression_type
,
tc_position
=
cp
,
tc_coercible
=
True
}
req_type_coercions
=
[
coercion
:
reqs
.
req_type_coercions
]
req_attr_coercions
=
lhs
.
tst_attr_env
++
reqs
.
req_attr_coercions
=
(
lhs
.
tst_args
,
({
reqs
&
req_type_coercions
=
req_type_coercions
,
req_attr_coercions
=
req_attr_coercions
},
ts
))
requirements
ti
(
TupleSelect
tuple_symbol
arg_nr
expr
)
(
reqs
=:{
req_attr_coercions
},
ts
)
#
(
position
,
ts_var_heap
)
=
getPositionOfExpr
expr
ts
.
ts_var_heap
...
...
@@ -1814,8 +1852,8 @@ makeBase _ _ [] [] ts_var_heap
=
ts_var_heap
makeBase
fun_or_cons_ident
arg_nr
[{
fv_name
,
fv_info_ptr
}
:
vars
]
[
type
:
types
]
ts_var_heap
|
is_rare_name
fv_name
=
makeBase
fun_or_cons_ident
(
arg_nr
+1
)
vars
types
(
addToBase
fv_info_ptr
type
(
Yes
(
CP_FunArg
fun_or_cons_ident
arg_nr
))
ts_var_heap
)
=
makeBase
fun_or_cons_ident
(
arg_nr
+1
)
vars
types
(
addToBase
fv_info_ptr
type
No
ts_var_heap
)
=
makeBase
fun_or_cons_ident
(
arg_nr
+1
)
vars
types
(
addToBase
fv_info_ptr
type
(
VITI_Coercion
(
CP_FunArg
fun_or_cons_ident
arg_nr
))
ts_var_heap
)
=
makeBase
fun_or_cons_ident
(
arg_nr
+1
)
vars
types
(
addToBase
fv_info_ptr
type
VITI_Empty
ts_var_heap
)
addToBase
info_ptr
atype
=:{
at_type
=
TFA
atvs
type
}
optional_position
ts_var_heap
=
ts_var_heap
<:=
(
info_ptr
,
VI_FAType
atvs
{
atype
&
at_type
=
type
}
optional_position
)
...
...
@@ -2451,7 +2489,7 @@ where
_
->
(
bitvects
,
subst
)
build_coercion_env
::
[.
FunctionRequirements
]
v
:{!
Type
}
*
Coercions
{#
CommonDefs
}
{#
Int
}
*{#*{#
TypeDefInfo
}}
*
TypeHeaps
!*
ErrorAdmin
->
(!
w
:{!
Type
},!.
Coercions
,!
u
:{#
u
:{#
TypeDefInfo
}},!.
TypeHeaps
,!.
ErrorAdmin
),
[
v
<=
w
];
//
build_coercion_env :: [.FunctionRequirements] v:{!Type} *Coercions {#CommonDefs} {#Int} *{#*{#TypeDefInfo}} *TypeHeaps !*ErrorAdmin -> (!w:{!Type},!.Coercions,!u:{#u:{#TypeDefInfo}},!.TypeHeaps,!.ErrorAdmin), [v <= w];
build_coercion_env
[{
fe_requirements
={
req_type_coercion_groups
},
fe_location
={
ip_ident
}}
:
reqs_list
]
subst
coercion_env
common_defs
cons_var_vects
type_signs
type_var_heap
error
#
(
subst
,
coercion_env
,
type_signs
,
type_var_heap
,
error
)
=
foldSt
(
build_coercion_env_for_alternative
ip_ident
common_defs
cons_var_vects
)
...
...
@@ -2770,17 +2808,29 @@ where
is_rare_name
{
id_name
}
=
id_name
.[
0
]==
'_'
getPositionOfExpr
expr
=:(
Var
{
var_info_ptr
})
var_heap
=
case
readPtr
var_info_ptr
var_heap
of
(
VI_Type
_
(
Yes
position
),
var_heap
)
getPositionOfExpr
expr
=:(
Var
var
)
var_heap
#
(
type_info
,
var_heap
)
=
getTypeInfoOfVariable
var
var_heap
=
case
type_info
of
VITI_Coercion
position
->
(
position
,
var_heap
)
(
VI_FAType
_
_
(
Yes
position
),
var_heap
)
VITI_PatternType
_
(
VITI_Coercion
position
)
->
(
position
,
var_heap
)
(_,
var_heap
)
_
->
(
CP_Expression
expr
,
var_heap
)
getPositionOfExpr
expr
var_heap
=
(
CP_Expression
expr
,
var_heap
)
getTypeInfoOfVariable
{
var_info_ptr
}
var_heap
#
(
var_info
,
var_heap
)=
readPtr
var_info_ptr
var_heap
=
case
var_info
of
VI_Type
_
type_info
->
(
type_info
,
var_heap
)
VI_FAType
_
_
type_info
->
(
type_info
,
var_heap
)
_
->
abort
"getTypeInfoOfVariable"
empty_id
=:
{
id_name
=
""
,
id_info
=
nilPtr
}
instance
<<<
(
Ptr
a
)
...
...
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