Skip to content
GitLab
Menu
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
3916b4cb
Commit
3916b4cb
authored
Mar 01, 2000
by
Martin Wierich
Browse files
bugfixes
parent
742a0948
Changes
6
Hide whitespace changes
Inline
Side-by-side
frontend/checksupport.dcl
View file @
3916b4cb
...
...
@@ -109,6 +109,7 @@ newPosition :: !Ident !Position -> IdentPos
checkError
::
!
a
!
b
!*
ErrorAdmin
->
*
ErrorAdmin
|
<<<
a
&
<<<
b
checkWarning
::
!
a
!
b
!*
ErrorAdmin
->
*
ErrorAdmin
|
<<<
a
&
<<<
b
checkErrorWithIdentPos
::
!
IdentPos
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
class
envLookUp
a
::
!
a
!(
Env
Ident
.
b
)
->
(!
Bool
,.
b
)
...
...
@@ -128,9 +129,7 @@ addLocalFunctionDefsToSymbolTable :: Level Index .Index u:(a FunDef) *SymbolTabl
addDefToSymbolTable
::
!
Level
!
Index
!
Ident
!
STE_Kind
!*
SymbolTable
!*
ErrorAdmin
->
(!*
SymbolTable
,
!*
ErrorAdmin
)
addDeclaredSymbolsToSymbolTable
::
.
Bool
.
Int
![.
Declaration
]
![.
Declaration
]
!*
CheckState
->
.
CheckState
;
addLocalSymbolsToSymbolTable
::
![.
Declaration
]
Int
!*
CheckState
->
.
CheckState
;
addImportedFunctionOrMacro
::
!
Ident
.
Int
!*
CheckState
->
.
CheckState
;
addFieldToSelectorDefinition
::
!
Ident
(
Global
.
Int
)
!*
CheckState
->
.
CheckState
;
addImportedSymbol
::
!
Ident
STE_Kind
.
Int
.
Int
!*
CheckState
->
.
CheckState
;
addGlobalDefinitionsToSymbolTable
::
![.
Declaration
]
!*
CheckState
->
.
CheckState
;
retrieveImportsFromSymbolTable
::
![
Import
ImportDeclaration
]
![
Declaration
]
!*{#
DclModule
}
!*(
Heap
SymbolTableEntry
)
->
*(![
Declaration
],!*{#
DclModule
},!*
Heap
SymbolTableEntry
);
removeFieldFromSelectorDefinition
::
!
Ident
.
Int
.
Int
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
...
...
frontend/checksupport.icl
View file @
3916b4cb
...
...
@@ -155,6 +155,12 @@ checkWarning id mess error=:{ea_file,ea_loc=[]}
checkWarning
id
mess
error
=:{
ea_file
,
ea_loc
}
=
{
error
&
ea_file
=
ea_file
<<<
"Check Warning "
<<<
hd
ea_loc
<<<
":
\"
"
<<<
id
<<<
"
\"
"
<<<
mess
<<<
'\n'
}
checkErrorWithIdentPos
::
!
IdentPos
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
checkErrorWithIdentPos
ident_pos
mess
error_admin
#
error_admin
=
pushErrorAdmin
ident_pos
error_admin
error_admin
=
checkError
ident_pos
.
ip_ident
mess
error_admin
=
popErrorAdmin
error_admin
class
envLookUp
a
::
!
a
!(
Env
Ident
.
b
)
->
(!
Bool
,.
b
)
instance
envLookUp
TypeVar
...
...
@@ -241,11 +247,11 @@ addDeclaredSymbolsToSymbolTable :: .Bool .Int ![.Declaration] ![.Declaration] !*
addDeclaredSymbolsToSymbolTable
is_dcl_mod
ste_index
locals
imported
cs
=
addLocalSymbolsToSymbolTable
locals
ste_index
(
add_imports_to_symbol_table
is_dcl_mod
imported
cs
)
where
add_imports_to_symbol_table
is_dcl_mod
[{
dcl_ident
,
dcl_kind
,
dcl_index
}
:
symbols
]
cs
add_imports_to_symbol_table
is_dcl_mod
[{
dcl_ident
,
dcl_
pos
,
dcl_
kind
,
dcl_index
}
:
symbols
]
cs
=
case
dcl_kind
of
STE_Imported
def_kind
def_mod
|
is_dcl_mod
||
def_mod
<>
cIclModIndex
->
add_imports_to_symbol_table
is_dcl_mod
symbols
(
addImportedSymbol
dcl_ident
def_kind
dcl_index
def_mod
cs
)
->
add_imports_to_symbol_table
is_dcl_mod
symbols
(
addImportedSymbol
dcl_ident
dcl_pos
def_kind
dcl_index
def_mod
cs
)
->
add_imports_to_symbol_table
is_dcl_mod
symbols
cs
STE_FunctionOrMacro
_
->
add_imports_to_symbol_table
is_dcl_mod
symbols
(
addImportedFunctionOrMacro
dcl_ident
dcl_index
cs
)
...
...
@@ -253,12 +259,12 @@ where
=
cs
addLocalSymbolsToSymbolTable
::
![.
Declaration
]
Int
!*
CheckState
->
.
CheckState
;
addLocalSymbolsToSymbolTable
[{
dcl_ident
,
dcl_kind
,
dcl_index
}
:
symbols
]
mod_index
cs
addLocalSymbolsToSymbolTable
[{
dcl_ident
,
dcl_
pos
,
dcl_
kind
,
dcl_index
}
:
symbols
]
mod_index
cs
=
case
dcl_kind
of
STE_FunctionOrMacro
_
->
addLocalSymbolsToSymbolTable
symbols
mod_index
(
addImportedFunctionOrMacro
dcl_ident
dcl_index
cs
)
_
->
addLocalSymbolsToSymbolTable
symbols
mod_index
(
addImportedSymbol
dcl_ident
dcl_kind
dcl_index
mod_index
cs
)
->
addLocalSymbolsToSymbolTable
symbols
mod_index
(
addImportedSymbol
dcl_ident
dcl_pos
dcl_kind
dcl_index
mod_index
cs
)
addLocalSymbolsToSymbolTable
[]
mod_index
cs
=
cs
...
...
@@ -284,29 +290,29 @@ addFieldToSelectorDefinition {id_info} glob_field_index cs=:{cs_symbol_table}
_
->
{
cs
&
cs_symbol_table
=
NewEntry
cs
.
cs_symbol_table
id_info
(
STE_Selector
[
glob_field_index
])
NoIndex
cModuleScope
entry
}
addImportedSymbol
::
!
Ident
STE_Kind
.
Int
.
Int
!*
CheckState
->
.
CheckState
;
addImportedSymbol
ident
def_kind
def_index
def_mod
cs
=:{
cs_symbol_table
}
addImportedSymbol
::
!
Ident
!
Position
!
STE_Kind
!
.
Int
!
.
Int
!*
CheckState
->
.
CheckState
;
addImportedSymbol
ident
pos
def_kind
def_index
def_mod
cs
=:{
cs_symbol_table
}
#
(
entry
,
cs_symbol_table
)
=
readPtr
ident
.
id_info
cs_symbol_table
=
add_imported_symbol
entry
ident
def_kind
def_index
def_mod
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
=
add_imported_symbol
entry
ident
pos
def_kind
def_index
def_mod
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
where
add_imported_symbol
entry
=:{
ste_kind
=
STE_Empty
}
{
id_name
,
id_info
}
def_kind
def_index
def_mod
cs
=:{
cs_symbol_table
}
add_imported_symbol
entry
=:{
ste_kind
=
STE_Empty
}
{
id_name
,
id_info
}
_
def_kind
def_index
def_mod
cs
=:{
cs_symbol_table
}
#
cs
=
{
cs
&
cs_symbol_table
=
NewEntry
cs_symbol_table
id_info
(
STE_Imported
def_kind
def_mod
)
def_index
cModuleScope
entry
}
=
case
def_kind
of
STE_Field
selector_id
->
addFieldToSelectorDefinition
selector_id
{
glob_module
=
def_mod
,
glob_object
=
def_index
}
cs
_
->
cs
add_imported_symbol
entry
=:{
ste_kind
=
STE_Imported
kind
mod_index
,
ste_index
}
ident
=:{
id_info
}
def_kind
def_index
def_mod
cs
add_imported_symbol
entry
=:{
ste_kind
=
STE_Imported
kind
mod_index
,
ste_index
}
ident
=:{
id_info
}
_
def_kind
def_index
def_mod
cs
|
kind
==
def_kind
&&
mod_index
==
def_mod
&&
ste_index
==
def_index
=
cs
add_imported_symbol
entry
ident
def_kind
def_index
def_mod
cs
=:{
cs_error
}
=
{
cs
&
cs_error
=
checkError
ident
" multiply imported"
cs_error
}
add_imported_symbol
entry
ident
pos
def_kind
def_index
def_mod
cs
=:{
cs_error
}
=
{
cs
&
cs_error
=
checkError
WithIdentPos
(
newPosition
ident
pos
)
" multiply imported"
cs_error
}
addGlobalDefinitionsToSymbolTable
::
![.
Declaration
]
!*
CheckState
->
.
CheckState
;
addGlobalDefinitionsToSymbolTable
decls
cs
=
foldSt
add_global_definition
decls
cs
where
add_global_definition
{
dcl_ident
=
ident
=:{
id_info
},
dcl_kind
,
dcl_index
}
cs
=:{
cs_symbol_table
}
add_global_definition
{
dcl_ident
=
ident
=:{
id_info
},
dcl_
pos
,
dcl_
kind
,
dcl_index
}
cs
=:{
cs_symbol_table
}
#!
entry
=
sreadPtr
id_info
cs_symbol_table
|
entry
.
ste_def_level
<
cGlobalScope
#
cs
=
{
cs
&
cs_symbol_table
=
NewEntry
cs_symbol_table
id_info
dcl_kind
dcl_index
cGlobalScope
entry
}
...
...
@@ -315,7 +321,7 @@ where
->
addFieldToSelectorDefinition
selector_id
{
glob_module
=
NoIndex
,
glob_object
=
dcl_index
}
cs
_
->
cs
=
{
cs
&
cs_error
=
checkError
ident
"(global definition) already defined"
cs
.
cs_error
}
=
{
cs
&
cs_error
=
checkError
WithIdentPos
(
newPosition
ident
dcl_pos
)
"(global definition) already defined"
cs
.
cs_error
}
retrieveImportsFromSymbolTable
::
![
Import
ImportDeclaration
]
![
Declaration
]
!*{#
DclModule
}
!*(
Heap
SymbolTableEntry
)
->
*(![
Declaration
],!*{#
DclModule
},!*
Heap
SymbolTableEntry
);
retrieveImportsFromSymbolTable
[{
import_module
=
import_module
=:{
id_info
},
import_symbols
}
:
mods
]
decls
modules
symbol_table
...
...
frontend/comparedefimp.dcl
View file @
3916b4cb
...
...
@@ -5,5 +5,5 @@ import syntax, checksupport
// compare definition and implementation module
compareDefImp
::
!*{#
DclModule
}
!*
IclModule
!*
Heaps
!*
ErrorAdmin
->
(!.{#
DclModule
},
!.
IclModule
,!.
Heaps
,!.
ErrorAdmin
)
;
->
(!.{#
DclModule
},
!.
IclModule
,!.
Heaps
,!.
ErrorAdmin
)
frontend/comparedefimp.icl
View file @
3916b4cb
...
...
@@ -67,7 +67,9 @@ import RWSDebug
::
!
Int
}
class
t_corresponds
a
::
a
a
->
*
TypesCorrespondMonad
::
OptionalCorrespondenceNumber
=
CorrespondenceNumber
!
Int
|
Bound
|
Unbound
class
t_corresponds
a
::
!
a
!
a
->
*
TypesCorrespondMonad
// whether two types correspond
class
e_corresponds
a
::
!
a
!
a
->
ExpressionsCorrespondMonad
// check for correspondence of expressions
...
...
@@ -75,13 +77,13 @@ class e_corresponds a :: !a !a -> ExpressionsCorrespondMonad
class
getIdentPos
a
::
a
->
IdentPos
class
CorrespondenceNumber
a
where
toCorrespondenceNumber
::
.
a
->
Optional
Int
toCorrespondenceNumber
::
.
a
->
Optional
CorrespondenceNumber
fromCorrespondenceNumber
::
Int
->
.
a
initial_hwn
hwn_heap
=
{
hwn_heap
=
hwn_heap
,
hwn_number
=
0
}
compareDefImp
::
!*{#
DclModule
}
!*
IclModule
!*
Heaps
!*
ErrorAdmin
->
(!.{#
DclModule
},
!.
IclModule
,!.
Heaps
,!.
ErrorAdmin
)
;
->
(!.{#
DclModule
},
!.
IclModule
,!.
Heaps
,!.
ErrorAdmin
)
compareDefImp
dcl_modules
icl_module
heaps
error_admin
#
(
main_dcl_module
,
dcl_modules
)
=
dcl_modules
![
cIclModIndex
]
=
case
main_dcl_module
.
dcl_conversions
of
...
...
@@ -114,18 +116,20 @@ compareDefImp dcl_modules icl_module heaps error_admin
(
icl_com_selector_defs
,
tc_state
,
error_admin
)
=
compareWithConversions
conversion_table
.[
cSelectorDefs
]
dcl_common
.
com_selector_defs
icl_com_selector_defs
tc_state
error_admin
(
icl_com_member_defs
,
tc_state
,
error_admin
)
=
compareWithConversions
conversion_table
.[
cMemberDefs
]
dcl_common
.
com_member_defs
icl_com_member_defs
tc_state
error_admin
(
icl_com_class_defs
,
tc_state
,
error_admin
)
=
compareWithConversions
conversion_table
.[
cClassDefs
]
dcl_common
.
com_class_defs
icl_com_class_defs
tc_state
error_admin
(
icl_com_member_defs
,
tc_state
,
error_admin
)
=
compareWithConversions
conversion_table
.[
cMemberDefs
]
dcl_common
.
com_member_defs
icl_com_member_defs
tc_state
error_admin
(
icl_com_instance_defs
,
tc_state
,
error_admin
)
=
compareWithConversions
conversion_table
.[
cInstanceDefs
]
dcl_common
.
com_instance_defs
icl_com_instance_defs
tc_state
error_admin
/* XXX macro comparision doesn't work yet
(icl_functions, hp_var_heap, hp_expression_heap, tc_state, error_admin)
= compareMacrosWithConversion conversion_table.[cMacroDefs] dcl_macros
icl_functions hp_var_heap hp_expression_heap tc_state error_admin
*/
(
icl_functions
,
tc_state
,
error_admin
)
=
compareFunctionTypesWithConversions
conversion_table
.[
cFunctionDefs
]
dcl_functions
icl_functions
tc_state
error_admin
...
...
@@ -139,7 +143,7 @@ compareDefImp dcl_modules icl_module heaps error_admin
=
{
hp_var_heap
=
hp_var_heap
,
hp_expression_heap
=
hp_expression_heap
,
hp_type_heaps
=
{
th_vars
=
tc_type_vars
.
hwn_heap
,
th_attrs
=
tc_attr_vars
.
hwn_heap
}}
->
(
tc_dcl_modules
,
{
icl_module
&
icl_common
=
icl_common
,
icl_functions
=
icl_functions
},
heaps
,
error_admin
)
heaps
,
error_admin
)
where
copy
original
#!
size
=
size
original
...
...
@@ -156,6 +160,9 @@ compareDefImp dcl_modules icl_module heaps error_admin
compareWithConversions
conversions
dclDefs
iclDefs
tc_state
error_admin
=
iFoldSt
(
compareWithConversion
conversions
dclDefs
)
0
(
size
conversions
)
(
iclDefs
,
tc_state
,
error_admin
)
compareWithConversion
::
!
w
:(
a
x
:
Int
)
!.(
b
c
)
!
Int
!(!
u
:(
d
c
),
!*
TypesCorrespondState
,
!*
ErrorAdmin
)
->
(!
v
:(
d
c
),
!.
TypesCorrespondState
,
!.
ErrorAdmin
)
|
Array
.
b
&
getIdentPos
,
select_u
,
t_corresponds
,
uselect_u
c
&
Array
.
d
&
Array
.
a
,
[
u
<=
v
,
w
<=
x
];
compareWithConversion
conversions
dclDefs
dclIndex
(
iclDefs
,
tc_state
,
error_admin
)
#
(
iclDef
,
iclDefs
)
=
iclDefs
![
conversions
.[
dclIndex
]]
(
corresponds
,
tc_state
)
=
t_corresponds
dclDefs
.[
dclIndex
]
iclDef
tc_state
...
...
@@ -167,6 +174,9 @@ compareFunctionTypesWithConversions conversions dcl_fun_types icl_functions tc_s
=
iFoldSt
(
compareTwoFunctionTypes
conversions
dcl_fun_types
)
0
(
size
conversions
)
(
icl_functions
,
tc_state
,
error_admin
)
compareTwoFunctionTypes
::
!
w
:(
a
x
:
Int
)
!.(
b
FunType
)
!.
Int
!(!
u
:(
c
FunDef
),!*
TypesCorrespondState
,!*
ErrorAdmin
)
->
(!
v
:(
c
FunDef
),!.
TypesCorrespondState
,!.
ErrorAdmin
)
|
Array
.
b
&
Array
.
c
&
Array
.
a
,
[
u
<=
v
,
w
<=
x
];
compareTwoFunctionTypes
conversions
dcl_fun_types
dclIndex
(
icl_functions
,
tc_state
,
error_admin
)
#
(
fun_def
=:{
fun_type
},
icl_functions
)
=
icl_functions
![
conversions
.[
dclIndex
]]
=
case
fun_type
of
...
...
@@ -175,19 +185,22 @@ compareTwoFunctionTypes conversions dcl_fun_types dclIndex (icl_functions, tc_st
#
dcl_symbol_type
=
dcl_fun_types
.[
dclIndex
].
ft_type
tc_state
=
init_attr_vars
(
dcl_symbol_type
.
st_attr_vars
++
icl_symbol_type
.
st_attr_vars
)
tc_state
tc_type_vars
=
init_type_vars
(
dcl_symbol_type
.
st_vars
++
icl_symbol_type
.
st_vars
)
tc_state
.
tc_type_vars
tc_state
=
init_type_vars
(
dcl_symbol_type
.
st_vars
++
icl_symbol_type
.
st_vars
)
tc_state
(
corresponds
,
tc_state
)
=
t_corresponds
dcl_symbol_type
icl_symbol_type
{
tc_state
&
tc_type_vars
=
tc_type_vars
}
=
t_corresponds
dcl_symbol_type
icl_symbol_type
tc_state
|
corresponds
->
(
icl_functions
,
tc_state
,
error_admin
)
->
generate_error
error_message
fun_def
icl_functions
tc_state
error_admin
init_type_vars
type_vars
tc_type_vars
=:{
hwn_heap
}
#
hwn_heap
=
foldSt
init_type_var
type_vars
hwn_heap
=
{
tc_type_vars
&
hwn_heap
=
hwn_heap
}
init_type_var
{
tv_info_ptr
}
heap
=
writePtr
tv_info_ptr
TVI_Empty
heap
init_type_vars
type_vars
tc_state
=:{
tc_type_vars
}
#
tc_type_vars
=
init_type_vars`
type_vars
tc_type_vars
=
{
tc_state
&
tc_type_vars
=
tc_type_vars
}
where
init_type_vars`
type_vars
tc_type_vars
=:{
hwn_heap
}
#
hwn_heap
=
foldSt
init_type_var
type_vars
hwn_heap
=
{
tc_type_vars
&
hwn_heap
=
hwn_heap
}
init_type_var
{
tv_info_ptr
}
heap
=
writePtr
tv_info_ptr
TVI_Empty
heap
generate_error
message
iclDef
iclDefs
tc_state
error_admin
#
ident_pos
=
getIdentPos
iclDef
...
...
@@ -209,6 +222,7 @@ compareMacrosWithConversion conversions macro_range icl_functions var_heap expr_
compareMacroWithConversion
conversions
ir_from
dclIndex
ec_state
=
compareTwoMacroFuns
dclIndex
conversions
.[
dclIndex
-
ir_from
]
ec_state
compareTwoMacroFuns
::
!.
Int
!.
Int
!*
ExpressionsCorrespondState
->
.
ExpressionsCorrespondState
;
compareTwoMacroFuns
dclIndex
iclIndex
ec_state
=:{
ec_correspondences
,
ec_icl_functions
,
ec_error_admin
}
#
(
dcl_function
,
ec_icl_functions
)
=
ec_icl_functions
![
dclIndex
]
...
...
@@ -223,62 +237,57 @@ compareTwoMacroFuns dclIndex iclIndex
instance
getIdentPos
(
TypeDef
a
)
where
getIdentPos
{
td_name
,
td_pos
}
=
makeIdentPos
td_name
td_pos
=
newPosition
td_name
td_pos
instance
getIdentPos
ConsDef
where
getIdentPos
{
cons_symb
,
cons_pos
}
=
makeIdentPos
cons_symb
cons_pos
=
newPosition
cons_symb
cons_pos
instance
getIdentPos
SelectorDef
where
getIdentPos
{
sd_symb
,
sd_pos
}
=
makeIdentPos
sd_symb
sd_pos
=
newPosition
sd_symb
sd_pos
instance
getIdentPos
ClassDef
where
getIdentPos
{
class_name
,
class_pos
}
=
makeIdentPos
class_name
class_pos
=
newPosition
class_name
class_pos
instance
getIdentPos
MemberDef
where
getIdentPos
{
me_symb
,
me_pos
}
=
makeIdentPos
me_symb
me_pos
=
newPosition
me_symb
me_pos
instance
getIdentPos
ClassInstance
where
getIdentPos
{
ins_ident
,
ins_pos
}
=
makeIdentPos
ins_ident
ins_pos
=
newPosition
ins_ident
ins_pos
instance
getIdentPos
FunDef
where
getIdentPos
{
fun_symb
,
fun_pos
}
=
makeIdentPos
fun_symb
fun_pos
makeIdentPos
ident
(
FunPos
fileName
lineNr
_)
=
{
ip_ident
=
ident
,
ip_line
=
lineNr
,
ip_file
=
fileName
}
makeIdentPos
ident
(
LinePos
fileName
lineNr
)
=
{
ip_ident
=
ident
,
ip_line
=
lineNr
,
ip_file
=
fileName
}
makeIdentPos
ident
NoPos
=
{
ip_ident
=
ident
,
ip_line
=
0
,
ip_file
=
""
}
=
newPosition
fun_symb
fun_pos
instance
CorrespondenceNumber
VarInfo
where
toCorrespondenceNumber
(
VI_CorrespondenceNumber
number
)
=
Yes
number
toCorrespondenceNumber
_
=
No
=
CorrespondenceNumber
number
toCorrespondenceNumber
VI_Empty
=
Unbound
fromCorrespondenceNumber
number
=
VI_CorrespondenceNumber
number
instance
CorrespondenceNumber
TypeVarInfo
where
toCorrespondenceNumber
(
TVI_CorrespondenceNumber
number
)
=
Yes
number
toCorrespondenceNumber
_
=
No
=
CorrespondenceNumber
number
toCorrespondenceNumber
TVI_Empty
=
Unbound
toCorrespondenceNumber
(
TVI_AType
_)
=
Bound
fromCorrespondenceNumber
number
=
TVI_CorrespondenceNumber
number
instance
CorrespondenceNumber
AttrVarInfo
where
toCorrespondenceNumber
(
AVI_CorrespondenceNumber
number
)
=
Yes
number
toCorrespondenceNumber
_
=
No
=
CorrespondenceNumber
number
toCorrespondenceNumber
AVI_Empty
=
Unbound
fromCorrespondenceNumber
number
=
AVI_CorrespondenceNumber
number
...
...
@@ -295,9 +304,9 @@ tryToUnifyVars ptr1 ptr2 heapWithNumber
#!
info1
=
sreadPtr
ptr1
heapWithNumber
.
hwn_heap
info2
=
sreadPtr
ptr2
heapWithNumber
.
hwn_heap
=
case
(
toCorrespondenceNumber
info1
,
toCorrespondenceNumber
info2
)
of
(
Yes
number1
,
Yes
number2
)
(
CorrespondenceNumber
number1
,
CorrespondenceNumber
number2
)
->
(
number1
==
number2
,
heapWithNumber
)
(
No
,
No
)
(
Unbound
,
Unbound
)
->
(
True
,
assignCorrespondenceNumber
ptr1
ptr2
heapWithNumber
)
_
->
(
False
,
heapWithNumber
)
...
...
@@ -348,12 +357,14 @@ instance t_corresponds (TypeDef TypeRhs) where
=
undef
<<-
"t_corresponds (TypeDef): iclDef.td_arity <> length iclDef.td_args"
// ... sanity check
#
tc_state
=
{
tc_state
&
tc_visited_syn_types
.[
dclDef
.
td_index
]
=
True
}
tc_state
=
init_atv_variables
dclDef
.
td_args
iclDef
.
td_args
tc_state
tc_state
=
init_attr_vars
dclDef
.
td_attrs
tc_state
tc_state
=
init_attr_vars
iclDef
.
td_attrs
tc_state
tc_state
=
init_atype_vars
dclDef
.
td_args
tc_state
tc_state
=
init_atype_vars
iclDef
.
td_args
tc_state
(
corresponds
,
tc_state
)
=
t_corresponds
dclDef
.
td_args
iclDef
.
td_args
tc_state
|
not
corresponds
=
(
corresponds
,
tc_state
)
#
tc_state
=
init_attr_vars
(
dclDef
.
td_attrs
++
iclDef
.
td_attrs
)
tc_state
icl_root_has_anonymous_attr
=
root_has_anonymous_attr
iclDef
.
td_attribute
iclDef
.
td_rhs
#
icl_root_has_anonymous_attr
=
root_has_anonymous_attr
iclDef
.
td_attribute
iclDef
.
td_rhs
|
icl_root_has_anonymous_attr
<>
root_has_anonymous_attr
dclDef
.
td_attribute
dclDef
.
td_rhs
&&
isnt_abstract
dclDef
.
td_rhs
=
(
False
,
tc_state
)
...
...
@@ -378,15 +389,6 @@ instance t_corresponds (TypeDef TypeRhs) where
isnt_abstract
(
AbstractType
_)
=
False
isnt_abstract
_
=
True
init_atv_variables
[
dcl_type_var
:
dcl_type_vars
]
[
icl_type_var
:
icl_type_vars
]
tc_state
=:{
tc_type_vars
}
#
tc_type_vars
=
assignCorrespondenceNumber
dcl_type_var
.
atv_variable
.
tv_info_ptr
icl_type_var
.
atv_variable
.
tv_info_ptr
tc_type_vars
=
init_atv_variables
dcl_type_vars
icl_type_vars
{
tc_state
&
tc_type_vars
=
tc_type_vars
}
init_atv_variables
_
_
tc_state
=
tc_state
instance
t_corresponds
TypeContext
where
t_corresponds
dclDef
iclDef
=
t_corresponds
dclDef
.
tc_class
iclDef
.
tc_class
...
...
@@ -434,6 +436,12 @@ instance t_corresponds AType where
#
({
dcl_common
},
tc_state
)
=
tc_state
!
tc_dcl_modules
.[
glob_module
]
type_def
=
dcl_common
.
com_type_defs
.[
glob_object
]
=
case
type_def
.
td_rhs
of
SynType
{
at_type
=
TV
type_var
,
at_attribute
}
// a "projection" type. attributes are treated in a special way
#
arg_pos
=
get_arg_pos
type_var
type_def
.
td_args
0
dcl_arg
=
dclArgs
!!
arg_pos
coerced_dcl_arg
=
{
dcl_arg
&
at_attribute
=
determine_type_attribute
type_def
.
td_attribute
}
->
t_corresponds
coerced_dcl_arg
icl_atype
tc_state
SynType
atype
#
tc_state
=
{
tc_state
&
tc_type_vars
=
bind_type_vars
type_def
.
td_args
dclArgs
tc_state
.
tc_type_vars
}
...
...
@@ -441,7 +449,7 @@ instance t_corresponds AType where
tc_state
=
opt_set_visited_bit
is_defined_in_main_dcl
glob_object
True
tc_state
atype
=
{
atype
&
at_attribute
=
determine_type_attribute
type_def
.
td_attribute
}
(
corresponds
,
tc_state
)
=
t_corresponds
atype
icl_atype
tc_state
#
tc_state
=
opt_set_visited_bit
is_defined_in_main_dcl
glob_object
False
tc_state
tc_state
=
opt_set_visited_bit
is_defined_in_main_dcl
glob_object
False
tc_state
->
(
corresponds
,
tc_state
)
AbstractType
_
#!
icl_type_def
=
tc_state
.
tc_icl_type_defs
.[
tc_state
.
tc_type_conversions
.[
glob_object
]]
...
...
@@ -450,22 +458,32 @@ instance t_corresponds AType where
tc_state
=
init_attr_vars
icl_type_def
.
td_attrs
tc_state
->
case
icl_type_def
.
td_rhs
of
SynType
atype
#
atype
=
{
atype
&
at_attribute
=
determine_type_attribute
type_def
.
td_attribute
}
// XXX auch bei abstract types
#
atype
=
{
atype
&
at_attribute
=
determine_type_attribute
type_def
.
td_attribute
}
->
t_corresponds
atype
icl_atype
tc_state
_
->
(
False
,
tc_state
)
_
->
(
False
,
tc_state
)
where
bind_type_vars
formal_args
actual_args
tc_type_vars
#
(
ok
,
hwn_heap
)
=
bind_type_vars`
formal_args
actual_args
tc_type_vars
.
hwn_heap
#
hwn_heap
=
bind_type_vars`
formal_args
actual_args
tc_type_vars
.
hwn_heap
=
{
tc_type_vars
&
hwn_heap
=
hwn_heap
}
bind_type_vars`
[{
atv_variable
}:
formal_args
]
[
actual_arg
:
actual_args
]
type_var_heap
#
(
actual_arg
,
type_var_heap
)
=
possibly_dereference
actual_arg
type_var_heap
=
bind_type_vars`
formal_args
actual_args
(
writePtr
atv_variable
.
tv_info_ptr
(
TVI_AType
actual_arg
)
type_var_heap
)
bind_type_vars`
[]
[]
type_var_heap
=
(
True
,
type_var_heap
)
// --->("binding", atv_variable.tv_name,"to",actual_arg)
bind_type_vars`
_
_
type_var_heap
=
(
False
,
type_var_heap
)
=
type_var_heap
possibly_dereference
atype
=:{
at_type
=
TV
{
tv_info_ptr
}}
type_var_heap
#!
dereferenced
=
sreadPtr
tv_info_ptr
type_var_heap
=
case
dereferenced
of
TVI_AType
atype2
->
(
atype2
,
type_var_heap
)
_
->
(
atype
,
type_var_heap
)
possibly_dereference
atype
type_var_heap
=
(
atype
,
type_var_heap
)
opt_set_visited_bit
True
glob_object
bit
tc_state
=
{
tc_state
&
tc_visited_syn_types
.[
glob_object
]
=
bit
}
...
...
@@ -474,6 +492,10 @@ instance t_corresponds AType where
determine_type_attribute
TA_Unique
=
TA_Unique
determine_type_attribute
_
=
TA_Multi
get_arg_pos
x
[
h
:
t
]
count
|
x
==
h
.
atv_variable
=
count
=
get_arg_pos
x
t
(
inc
count
)
instance
t_corresponds
TypeAttribute
where
t_corresponds
TA_Unique
TA_Unique
...
...
@@ -482,7 +504,9 @@ instance t_corresponds TypeAttribute where
=
return
True
t_corresponds
(
TA_Var
dclDef
)
(
TA_Var
iclDef
)
=
t_corresponds
dclDef
iclDef
t_corresponds
_
TA_Anonymous
// XXX comment
t_corresponds
(
TA_RootVar
dclDef
)
(
TA_RootVar
iclDef
)
=
t_corresponds
dclDef
iclDef
t_corresponds
_
TA_Anonymous
=
return
True
t_corresponds
TA_None
icl
=
case
icl
of
...
...
@@ -575,20 +599,24 @@ instance t_corresponds FieldSymbol where
instance
t_corresponds
ConsDef
where
t_corresponds
dclDef
iclDef
=
exi_vars_correspond
dclDef
.
cons_exi_vars
iclDef
.
cons_exi_vars
=
do
(
init_atype_vars
(
dclDef
.
cons_exi_vars
++
iclDef
.
cons_exi_vars
))
&&&
t_corresponds
dclDef
.
cons_type
iclDef
.
cons_type
&&&
equal
dclDef
.
cons_symb
iclDef
.
cons_symb
&&&
equal
dclDef
.
cons_priority
iclDef
.
cons_priority
instance
t_corresponds
SelectorDef
where
t_corresponds
dclDef
iclDef
=
exi_vars_correspond
dclDef
.
sd_exi_vars
iclDef
.
sd_exi_vars
=
do
(
init_atype_vars
(
dclDef
.
sd_exi_vars
++
iclDef
.
sd_exi_vars
))
&&&
t_corresponds
dclDef
.
sd_type
iclDef
.
sd_type
&&&
equal
dclDef
.
sd_field_nr
iclDef
.
sd_field_nr
exi_vars_correspond
dcl_exi_vars
icl_exi_vars
tc_state
#
tc_state
=
init_atv_variables
dcl_exi_vars
icl_exi_vars
tc_state
=
t_corresponds
dcl_exi_vars
icl_exi_vars
tc_state
init_atype_vars
atype_vars
tc_state
=:{
tc_type_vars
}
#
type_heap
=
foldSt
init_type_var
atype_vars
tc_type_vars
.
hwn_heap
tc_type_vars
=
{
tc_type_vars
&
hwn_heap
=
type_heap
}
=
{
tc_state
&
tc_type_vars
=
tc_type_vars
}
where
init_type_var
{
atv_variable
}
type_heap
=
writePtr
atv_variable
.
tv_info_ptr
TVI_Empty
type_heap
instance
t_corresponds
SymbolType
where
t_corresponds
dclDef
iclDef
...
...
@@ -604,14 +632,17 @@ instance t_corresponds AttrInequality where
instance
t_corresponds
ClassDef
where
t_corresponds
dclDef
iclDef
=
equal
dclDef
.
class_name
iclDef
.
class_name
=
do
(
init_type_vars
(
dclDef
.
class_args
++
iclDef
.
class_args
))
&&&
equal
dclDef
.
class_name
iclDef
.
class_name
&&&
t_corresponds
dclDef
.
class_args
iclDef
.
class_args
&&&
t_corresponds
dclDef
.
class_context
iclDef
.
class_context
&&&
t_corresponds
dclDef
.
class_members
iclDef
.
class_members
instance
t_corresponds
MemberDef
where
t_corresponds
dclDef
iclDef
=
equal
dclDef
.
me_symb
iclDef
.
me_symb
=
do
(
init_type_vars
(
dclDef
.
me_type
.
st_vars
++
iclDef
.
me_type
.
st_vars
))
&&&
do
(
init_attr_vars
(
dclDef
.
me_type
.
st_attr_vars
++
iclDef
.
me_type
.
st_attr_vars
))
&&&
equal
dclDef
.
me_symb
iclDef
.
me_symb
&&&
equal
dclDef
.
me_offset
iclDef
.
me_offset
&&&
equal
dclDef
.
me_priority
iclDef
.
me_priority
&&&
t_corresponds
dclDef
.
me_type
iclDef
.
me_type
...
...
@@ -623,10 +654,10 @@ instance t_corresponds ClassInstance where
t_corresponds`
dclDef
iclDef
tc_state
#
tc_state
=
init_attr_vars
(
dclDef
.
it_attr_vars
++
iclDef
.
it_attr_vars
)
tc_state
tc_
type_vars
=
init_type_vars
(
dclDef
.
it_vars
++
iclDef
.
it_vars
)
tc_state
.
tc_type_vars
tc_
state
=
init_type_vars
(
dclDef
.
it_vars
++
iclDef
.
it_vars
)
tc_state
(
corresponds
,
tc_state
)
=
t_corresponds
dclDef
.
it_types
iclDef
.
it_types
{
tc_state
&
tc_type_vars
=
tc_type_vars
}
=
t_corresponds
dclDef
.
it_types
iclDef
.
it_types
tc_state
|
not
corresponds
=
(
corresponds
,
tc_state
)
=
t_corresponds
dclDef
.
it_context
iclDef
.
it_context
tc_state
...
...
@@ -672,7 +703,7 @@ instance e_corresponds FunDef where
where
fromBody
(
TransformedBody
{
tb_args
,
tb_rhs
})
=
(
tb_args
,
[
tb_rhs
])
fromBody
(
CheckedBody
{
cb_args
,
cb_rhs
})
=
(
cb_args
,
cb_rhs
)
instance
e_corresponds
TransformedBody
where
e_corresponds
dclDef
iclDef
=
e_corresponds
dclDef
.
tb_args
iclDef
.
tb_args
...
...
@@ -940,6 +971,8 @@ implies a b :== not a || b
(
o`
)
infixr
0
(
o`
)
f
g
:==
\
state
->
g
(
f
state
)
do
f
=
\
state
->
(
True
,
f
state
)
// XXX should be a macro (but this crashes the 1.3.2 compiler)
(&&&)
infixr
(&&&)
m1
m2
...
...
frontend/main.icl
View file @
3916b4cb
...
...
@@ -20,15 +20,6 @@ Start world
=
fclose
ms_out
world
CommandLoop
proj
ms
=:{
ms_io
}
#
answer
=
"c t5
\n
"
(
command
,
argument
)
=
SplitAtLayoutChar
(
dropWhile
isSpace
(
fromString
answer
))
|
command
==
[]
=
CommandLoop
proj
{
ms
&
ms_io
=
ms_io
}
#
(
ready
,
proj
,
ms
)
=
DoCommand
command
argument
proj
{
ms
&
ms_io
=
ms_io
}
=
ms
/*
CommandLoop
proj
ms
=:{
ms_io
}
#
(
answer
,
ms_io
)
=
freadline
(
ms_io
<<<
"> "
)
(
command
,
argument
)
=
SplitAtLayoutChar
(
dropWhile
isSpace
(
fromString
answer
))
...
...
@@ -38,7 +29,6 @@ CommandLoop proj ms=:{ms_io}
|
ready
=
ms
=
CommandLoop
proj
ms
*/
::
MainStateDefs
funs
funtypes
types
conses
classes
instances
members
selectors
=
{
msd_funs
::
!
funs
...
...
frontend/trans.icl
View file @
3916b4cb
...
...
@@ -1485,11 +1485,11 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars type_var_heap
->
bind_and_unify_types
root_1
root_2
type_var_heap
bind_and_unify_types
(
TV
tv_1
)
type
type_var_heap
|
not
(
is_non_variable_type
type
)
=
abort
"compiler error in trans.icl: assertion failed (1)"
=
abort
"compiler error in trans.icl: assertion failed (1)
XXX
"
=
bind_variable_to_type
tv_1
type
type_var_heap
bind_and_unify_types
type
(
TV
tv_1
)
type_var_heap
|
not
(
is_non_variable_type
type
)
=
abort
"compiler error in trans.icl: assertion failed (2)"
=
abort
"compiler error in trans.icl: assertion failed (2)
XXX
"
=
bind_variable_to_type
tv_1
type
type_var_heap
bind_and_unify_types
(
TA
_
arg_types1
)
(
TA
_
arg_types2
)
type_var_heap
=
bind_and_unify_atype_lists
arg_types1
arg_types2
type_var_heap
...
...
@@ -1499,8 +1499,12 @@ createBindingsForUnifiedTypes type_1 type_2 all_type_vars type_var_heap
=
type_var_heap
bind_and_unify_types
((
CV
l1
)
:@:
r1
)
((
CV
l2
)
:@:
r2
)
type_var_heap
=
bind_and_unify_atype_lists
r1
r2
(
bind_and_unify_types
(
TV
l1
)
(
TV
l2
)
type_var_heap
)
// bind_and_unify_types x y _
// = abort ("bind_and_unify_types"--->(x,y))
bind_and_unify_types
(
TA
type_symb
r1
)
((
CV
l2
)
:@:
r2
)
type_var_heap
=
bind_and_unify_atype_lists
r1
r2
(
bind_and_unify_types
(
TA
type_symb
[])
(
TV
l2
)
type_var_heap
)
bind_and_unify_types
((
CV
l1
)
:@:
r1
)
(
TA
type_symb
r2
)
type_var_heap