Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
C
compiler
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
16
Issues
16
List
Boards
Labels
Service Desk
Milestones
Operations
Operations
Incidents
Analytics
Analytics
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Commits
Issue Boards
Open sidebar
clean-compiler-and-rts
compiler
Commits
5f2dae3d
Commit
5f2dae3d
authored
Nov 01, 2006
by
John van Groningen
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
allow TC to be used in the context of a class definition (e.g. class C a | TC a)
parent
23dcc68a
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
with
29 additions
and
22 deletions
+29
-22
frontend/overloading.icl
frontend/overloading.icl
+29
-22
No files found.
frontend/overloading.icl
View file @
5f2dae3d
...
...
@@ -20,7 +20,7 @@ import genericsupport, compilerSwitches, type_io_common
::
ReducedContexts
=
{
rcs_class_context
::
!
ReducedContext
,
rcs_constraints_contexts
::
![
ReducedContexts
]
,
rcs_constraints_contexts
::
![
ClassApplication
]
}
::
TypeCodeInstance
=
...
...
@@ -116,7 +116,7 @@ ObjectNotFound :== { glob_module = NotFound, glob_object = NotFound }
reduceContexts
::
!
ReduceInfo
![
TypeContext
]
!*
ReduceState
->
(![
ClassApplication
],
!*
ReduceState
)
reduceContexts
info
tcs
rs_state
=
mapSt
(
try_to_reduce_context
info
)
tcs
rs_state
where
where
try_to_reduce_context
::
!
ReduceInfo
!
TypeContext
!*
ReduceState
->
*(!
ClassApplication
,
!*
ReduceState
)
try_to_reduce_context
info
tc
rs_state
=:{
rs_predef_symbols
,
rs_new_contexts
}
|
context_is_reducible
tc
rs_predef_symbols
...
...
@@ -203,14 +203,15 @@ where
=
({
rcs_class_context
=
{
rc_class
=
class_symb
,
rc_inst_module
=
NoIndex
,
rc_inst_members
=
{},
rc_types
=
tc_types
,
rc_red_contexts
=
[]
},
rcs_constraints_contexts
=
constraints
},
rs_state
)
reduce_contexts_in_constraints
::
!
ReduceInfo
![
Type
]
![
TypeVar
]
![
TypeContext
]
*
ReduceState
->
*([
ReducedContexts
],*
ReduceState
)
reduce_contexts_in_constraints
::
!
ReduceInfo
![
Type
]
![
TypeVar
]
![
TypeContext
]
*
ReduceState
->
*([
ClassApplication
],*
ReduceState
)
reduce_contexts_in_constraints
info
types
class_args
[]
rs_state
=
([],
rs_state
)
=
([],
rs_state
)
reduce_contexts_in_constraints
info
types
class_args
class_context
rs_state
=:{
rs_type_heaps
=
rs_type_heaps
=:{
th_vars
}}
#
th_vars
=
fold2St
(\
type
{
tv_info_ptr
}
->
writePtr
tv_info_ptr
(
TVI_Type
type
))
types
class_args
th_vars
(
instantiated_context
,
rs_type_heaps
)
=
fresh_contexts
class_context
{
rs_type_heaps
&
th_vars
=
th_vars
}
#
rs_state
=
{
rs_state
&
rs_type_heaps
=
rs_type_heaps
}
=
mapSt
(
reduce_context
info
)
instantiated_context
rs_state
=
mapSt
(
reduce_
any_
context
info
)
instantiated_context
rs_state
find_instance
::
[
Type
]
!
InstanceTree
{#
CommonDefs
}
*
TypeHeaps
*
Coercions
->
*(
Global
Int
,[
TypeContext
],
Bool
,*
TypeHeaps
,*
Coercions
)
find_instance
co_types
(
IT_Node
this_inst_index
=:{
glob_object
,
glob_module
}
left
right
)
defs
type_heaps
coercion_env
...
...
@@ -536,7 +537,7 @@ where
reduce_TC_context
::
{#
CommonDefs
}
TCClass
Type
*
ReduceTCState
->
(
ClassApplication
,
!*
ReduceTCState
)
reduce_TC_context
defs
type_code_class
tc_type
rtcs_state
=
reduce_tc_context
defs
type_code_class
tc_type
rtcs_state
where
where
reduce_tc_context
::
{#
CommonDefs
}
TCClass
Type
*
ReduceTCState
->
(
ClassApplication
,
!*
ReduceTCState
)
reduce_tc_context
defs
type_code_class
type
=:(
TA
cons_id
=:{
type_index
}
cons_args
)
rtcs_state
=:{
rtcs_error
,
rtcs_type_heaps
}
#
rtcs_error
...
...
@@ -767,7 +768,8 @@ tryToSolveOverloading ocs main_dcl_module_n defs instance_info coercion_env os d
|
os
.
os_error
.
ea_ok
#
(
contexts
,
os_var_heap
)
=
foldSt
add_spec_contexts
ocs
(
contexts
,
os
.
os_var_heap
)
(
contexts
,
os_type_heaps
)
=
remove_super_classes
contexts
os
.
os_type_heaps
({
hp_var_heap
,
hp_expression_heap
,
hp_type_heaps
,
hp_generic_heap
},
dict_types
,
os_error
)
=
foldSt
(
convert_dictionaries
defs
contexts
)
reduced_contexts
({
hp_var_heap
,
hp_expression_heap
,
hp_type_heaps
,
hp_generic_heap
},
dict_types
,
os_error
)
=
foldSt
(
convert_dictionaries
defs
contexts
)
reduced_contexts
({
hp_var_heap
=
os_var_heap
,
hp_expression_heap
=
os
.
os_symbol_heap
,
hp_type_heaps
=
os_type_heaps
,
hp_generic_heap
=
os
.
os_generic_heap
},
[],
os
.
os_error
)
=
(
contexts
,
coercion_env
,
type_pattern_vars
,
dict_types
,
{
os
&
os_type_heaps
=
hp_type_heaps
,
os_symbol_heap
=
hp_expression_heap
,
os_var_heap
=
hp_var_heap
,
os_generic_heap
=
hp_generic_heap
,
os_error
=
os_error
}
)
=
([],
coercion_env
,
type_pattern_vars
,
[],
os
)
...
...
@@ -877,14 +879,14 @@ convertOverloadedCall defs contexts {symb_ident,symb_kind = SK_OverloadedFunctio
=
({
heaps
&
hp_expression_heap
=
heaps
.
hp_expression_heap
<:=
(
expr_ptr
,
inst_expr
)},
ptrs
,
error
)
where
adjust_member_application
defs
contexts
{
me_ident
,
me_offset
,
me_class
}
(
CA_Instance
red_contexts
)
class_exprs
heaps_and_ptrs
#
({
glob_module
,
glob_object
},
red_contexts
)
=
find_instance_of_member
me_class
me_offset
red_contexts
(
exprs
,
heaps_and_ptrs
)
=
convertClassApplsToExpressions
defs
contexts
red_contexts
heaps_and_ptrs
#
({
glob_module
,
glob_object
},
red_contexts
_appls
)
=
find_instance_of_member
me_class
me_offset
red_contexts
(
exprs
,
heaps_and_ptrs
)
=
convertClassApplsToExpressions
defs
contexts
red_contexts
_appls
heaps_and_ptrs
class_exprs
=
exprs
++
class_exprs
=
(
EI_Instance
{
glob_module
=
glob_module
,
glob_object
=
{
ds_ident
=
me_ident
,
ds_arity
=
length
class_exprs
,
ds_index
=
glob_object
}}
class_exprs
,
heaps_and_ptrs
)
adjust_member_application
defs
contexts
{
me_ident
,
me_offset
,
me_class
={
glob_module
,
glob_object
}}
(
CA_Context
tc
)
class_exprs
(
heaps
=:{
hp_type_heaps
},
ptrs
)
#
(
class_context
,
address
,
hp_type_heaps
)
=
determineContextAddress
contexts
defs
tc
hp_type_heaps
{
class_dictionary
={
ds_index
,
ds_ident
}}
=
defs
.[
glob_module
].
com_class_defs
.[
glob_object
]
#
{
class_dictionary
={
ds_index
,
ds_ident
}}
=
defs
.[
glob_module
].
com_class_defs
.[
glob_object
]
selector
=
selectFromDictionary
glob_module
ds_index
me_offset
defs
=
(
EI_Selection
(
generateClassSelection
address
[
RecordSelection
selector
me_offset
])
class_context
.
tc_var
class_exprs
,
({
heaps
&
hp_type_heaps
=
hp_type_heaps
},
ptrs
))
...
...
@@ -893,17 +895,19 @@ where
=
(
EI_TypeCode
(
TCE_Constructor
tci_constructor
(
map
expressionToTypeCodeExpression
exprs
)),
heaps_and_ptrs
)
adjust_member_application
defs
contexts
_
(
CA_LocalTypeCode
new_var_ptr
)
_
heaps_and_ptrs
=
(
EI_TypeCode
(
TCE_Var
new_var_ptr
),
heaps_and_ptrs
)
find_instance_of_member
::
(
Global
Int
)
Int
ReducedContexts
->
((
Global
Int
),[
ClassApplication
])
find_instance_of_member
me_class
me_offset
{
rcs_class_context
=
{
rc_class
,
rc_inst_module
,
rc_inst_members
,
rc_red_contexts
},
rcs_constraints_contexts
}
|
rc_class
.
glob_module
==
me_class
.
glob_module
&&
rc_class
.
glob_object
.
ds_index
==
me_class
.
glob_object
=
({
glob_module
=
rc_inst_module
,
glob_object
=
rc_inst_members
.[
me_offset
].
ds_index
},
rc_red_contexts
)
=
find_instance_of_member_in_constraints
me_class
me_offset
rcs_constraints_contexts
where
find_instance_of_member_in_constraints
me_class
me_offset
[
rcs
=:{
rcs_constraints_contexts
}
:
rcss
]
find_instance_of_member_in_constraints
me_class
me_offset
[
CA_Instance
rcs
=:{
rcs_constraints_contexts
}
:
rcss
]
=
find_instance_of_member
me_class
me_offset
{
rcs
&
rcs_constraints_contexts
=
rcs_constraints_contexts
++
rcss
}
find_instance_of_member_in_constraints
me_class
me_offset
[
_
:
rcss
]
=
find_instance_of_member_in_constraints
me_class
me_offset
rcss
find_instance_of_member_in_constraints
me_class
me_offset
[]
=
abort
"Error in module overloading: find_instance_of_member_in_constraints
\n
"
// AA..
convertOverloadedCall
defs
contexts
symbol
=:{
symb_ident
,
symb_kind
=
SK_Generic
gen_glob
kind
}
expr_ptr
class_appls
(
heaps
,
expr_info_ptrs
,
error
)
#!
(
opt_member_glob
,
hp_generic_heap
)
=
getGenericMember
gen_glob
kind
defs
heaps
.
hp_generic_heap
#!
heaps
=
{
heaps
&
hp_generic_heap
=
hp_generic_heap
}
...
...
@@ -912,8 +916,6 @@ convertOverloadedCall defs contexts symbol=:{symb_ident, symb_kind = SK_Generic
#
error
=
checkError
(
"no generic instances of "
+++
toString
symb_ident
+++
" for kind"
)
kind
error
->
(
heaps
,
expr_info_ptrs
,
error
)
Yes
member_glob
->
convertOverloadedCall
defs
contexts
{
symbol
&
symb_kind
=
SK_OverloadedFunction
member_glob
}
expr_ptr
class_appls
(
heaps
,
expr_info_ptrs
,
error
)
// ..AA
convertOverloadedCall
defs
contexts
{
symb_ident
,
symb_kind
=
SK_TypeCode
}
expr_info_ptr
class_appls
(
heaps
,
ptrs
,
error
)
#
(
class_expressions
,
(
heaps
,
ptrs
))
=
convertClassApplsToExpressions
defs
contexts
class_appls
(
heaps
,
ptrs
)
=
({
heaps
&
hp_expression_heap
=
heaps
.
hp_expression_heap
<:=
(
expr_info_ptr
,
EI_TypeCodes
(
map
expressionToTypeCodeExpression
class_expressions
))},
ptrs
,
error
)
...
...
@@ -922,9 +924,14 @@ convertOverloadedCall defs contexts {symb_ident} expr_info_ptr appls (heaps,ptrs
=
({
heaps
&
hp_expression_heap
=
heaps
.
hp_expression_heap
<:=
(
expr_info_ptr
,
EI_Context
class_expressions
)},
ptrs
,
error
)
expressionToTypeCodeExpression
(
TypeCodeExpression
texpr
)
=
texpr
expressionToTypeCodeExpression
(
ClassVariable
var_info_ptr
)
=
TCE_TypeTerm
var_info_ptr
expressionToTypeCodeExpression
expr
=
abort
"expressionToTypeCodeExpression (overloading.icl)"
// <<- expr)
expressionToTypeCodeExpression
(
TypeCodeExpression
texpr
)
=
texpr
expressionToTypeCodeExpression
(
ClassVariable
var_info_ptr
)
=
TCE_TypeTerm
var_info_ptr
expressionToTypeCodeExpression
(
Selection
NormalSelector
(
ClassVariable
var_info_ptr
)
selectors
)
=
TCE_Selector
(
init
selectors
)
var_info_ptr
expressionToTypeCodeExpression
expr
=
abort
"expressionToTypeCodeExpression (overloading.icl)"
generateClassSelection
address
last_selectors
=
mapAppend
(\(
off_set
,
selector
)
->
RecordSelection
selector
off_set
)
address
last_selectors
...
...
@@ -955,7 +962,7 @@ where
=
(
TypeCodeExpression
(
TCE_Constructor
tci_constructor
(
map
expressionToTypeCodeExpression
exprs
)),
heaps_and_ptrs
)
convert_reduced_contexts_to_expression
defs
contexts
{
rcs_class_context
,
rcs_constraints_contexts
}
heaps_and_ptrs
#
(
rcs_exprs
,
heaps_and_ptrs
)
=
mapSt
(
convert_
reduced_contexts
_to_expression
defs
contexts
)
rcs_constraints_contexts
heaps_and_ptrs
#
(
rcs_exprs
,
heaps_and_ptrs
)
=
mapSt
(
convert_
class_appl
_to_expression
defs
contexts
)
rcs_constraints_contexts
heaps_and_ptrs
=
convert_reduced_context_to_expression
defs
contexts
rcs_class_context
rcs_exprs
heaps_and_ptrs
where
convert_reduced_context_to_expression
::
{#
CommonDefs
}
[
TypeContext
]
ReducedContext
[
Expression
]
*(*
Heaps
,[
Ptr
ExprInfo
])
->
*(
Expression
,*(*
Heaps
,[
Ptr
ExprInfo
]))
...
...
@@ -1033,9 +1040,9 @@ determineContextAddress contexts defs this_context type_heaps
=
look_up_context_and_address
this_context
contexts
defs
type_heaps
where
look_up_context_and_address
::
!
TypeContext
![
TypeContext
]
!{#
CommonDefs
}
!*
TypeHeaps
->
(
TypeContext
,
[(
Int
,
Global
DefinedSymbol
)],
!*
TypeHeaps
)
look_up_context_and_address
context
[]
defs
type_heaps
look_up_context_and_address
this_
context
[]
defs
type_heaps
=
abort
"look_up_context_and_address (overloading.icl)"
look_up_context_and_address
this_context
[
tc
:
tcs
]
defs
type_heaps
look_up_context_and_address
this_context
[
tc
:
tcs
]
defs
type_heaps
#!
(
may_be_addres
,
type_heaps
)
=
determine_address
this_context
tc
[]
defs
type_heaps
=
case
may_be_addres
of
Yes
address
...
...
@@ -1260,7 +1267,7 @@ where
=
TCE_TypeTerm
var_info_ptr
convert_selectors
selectors
var_info_ptr
=
TCE_Selector
(
init
selectors
)
var_info_ptr
newTypeVariables
uni_vars
heaps
=
mapSt
new_type_variable
uni_vars
heaps
where
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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