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
e783db98
Commit
e783db98
authored
Apr 26, 2000
by
Martin Wierich
Browse files
changes to make compiler compatible with itself
parent
13d15f5c
Changes
39
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/Heap.dcl
View file @
e783db98
...
...
@@ -28,4 +28,4 @@ ptrToInt :: !(Ptr w) -> Int
where
(
ptr
,
val
)
=
ptr_and_val
instance
==
Ptr
a
instance
==
(
Ptr
a
)
frontend/Heap.icl
View file @
e783db98
...
...
@@ -131,7 +131,7 @@ ptrToInt2 p = code {
rtn
}
;
instance
==
Ptr
a
instance
==
(
Ptr
a
)
where
{
(==)
p1
p2
=
code {
push_r_args_b
1
1
1
1
1
...
...
frontend/StdCompare.dcl
View file @
e783db98
...
...
@@ -9,14 +9,12 @@ Equal :== 0
class
(=<)
infix
4
a
::
!
a
!
a
->
CompareValue
instance
=<
Int
,
Expression
,
{#
Char
},
Ident
,
[
a
]
|
=<
a
,
BasicType
//, Global a | =< a
instance
=<
Int
,
Expression
,
{#
Char
},
Ident
,
[
a
]
|
=<
a
,
BasicType
//,
(
Global a
)
| =< a
instance
=<
Type
instance
==
BasicType
,
TypeVar
,
TypeSymbIdent
,
DefinedSymbol
,
TypeContext
,
BasicValue
,
FunKind
,
Global
a
|
==
a
,
Priority
,
Assoc
export
==
Int
FunKind
,
(
Global
a
)
|
==
a
,
Priority
,
Assoc
instance
<
MemberDef
frontend/StdCompare.icl
View file @
e783db98
...
...
@@ -11,7 +11,7 @@ instance == FunKind
where
(==)
fk1
fk2
=
equal_constructor
fk1
fk2
instance
==
Global
a
|
==
a
instance
==
(
Global
a
)
|
==
a
where
(==)
g1
g2
=
g1
.
glob_module
==
g2
.
glob_module
&&
g1
.
glob_object
==
g2
.
glob_object
...
...
@@ -188,7 +188,7 @@ where
(=<)
id1
id2
=
id1
.
id_name
=<
id2
.
id_name
instance
=<
Global
a
|
=<
a
instance
=<
(
Global
a
)
|
=<
a
where
(=<)
g1
g2
=
(
g1
.
glob_module
,
g1
.
glob_object
)
=<
(
g2
.
glob_module
,
g2
.
glob_object
)
...
...
frontend/_aconcat.dcl
View file @
e783db98
system
module
_aconcat
import
_System
Array
,
StdInt
,
StdEnum
,
StdList
import
Std
Array
,
StdInt
,
StdEnum
,
StdList
arrayConcat
a1
a2
:==
r2
where
r2
={
r1
&
[
i
+
s1
]=
a2
.[
i
]
\\
i
<-[
0
..
s2
-1
]}
r1
={
r0
&
[
i
]=
a1
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray (s1+s2) // 2.0
r0
=
_createArrayc
(
s1
+
s2
)
s1
=
size
a1
s2
=
size
a2
...
...
@@ -16,6 +17,7 @@ arrayPlusList a l
where
r2
={
r1
&
[
i
+
s1
]=
e
\\
i
<-[
0
..
s2
-1
]
&
e
<-
l
}
r1
={
r0
&
[
i
]=
a
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray (s1+s2) // 2.0
r0
=
_createArrayc
(
s1
+
s2
)
s1
=
size
a
s2
=
length
l
...
...
@@ -26,6 +28,7 @@ arrayPlusRevList a l
where
r2
={
r1
&
[
sr
-
i
]=
e
\\
i
<-[
1
..
s2
]
&
e
<-
l
}
r1
={
r0
&
[
i
]=
a
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray sr // 2.0
r0
=
_createArrayc
sr
sr
=
s1
+
s2
s2
=
length
l
...
...
frontend/_aconcat.icl
View file @
e783db98
implementation
module
_aconcat
import
_System
Array
,
StdInt
,
StdEnum
,
StdList
import
Std
Array
,
StdInt
,
StdEnum
,
StdList
arrayConcat
a1
a2
:==
r2
where
r2
={
r1
&
[
i
+
s1
]=
a2
.[
i
]
\\
i
<-[
0
..
s2
-1
]}
r1
={
r0
&
[
i
]=
a1
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray (s1+s2) // 2.0
r0
=
_createArrayc
(
s1
+
s2
)
s1
=
size
a1
s2
=
size
a2
...
...
@@ -16,22 +17,17 @@ arrayPlusList a l
where
r2
={
r1
&
[
i
+
s1
]=
e
\\
i
<-[
0
..
s2
-1
]
&
e
<-
l
}
r1
={
r0
&
[
i
]=
a
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray (s1+s2) // 2.0
r0
=
_createArrayc
(
s1
+
s2
)
s1
=
size
a
s2
=
length
l
/*
:== case l of
[]
-> a
_
-> arrayConcat a { x \\ x <- l }
*/
arrayPlusRevList
a
l
:==
r2
where
r2
={
r1
&
[
sr
-
i
]=
e
\\
i
<-[
1
..
s2
]
&
e
<-
l
}
r1
={
r0
&
[
i
]=
a
.[
i
]
\\
i
<-[
0
..
s1
-1
]}
// r0=_createArray sr // 2.0
r0
=
_createArrayc
sr
sr
=
s1
+
s2
s1
=
size
a
...
...
frontend/analtypes.icl
View file @
e783db98
...
...
@@ -340,9 +340,9 @@ where
|
(
ldep
==
cMAXINT
||
ldep
==
my_mark
)
#
(
as_deps
,
as_check_marks
,
group
)
=
close_group
type_module
type_index
as_deps
as_check_marks
[]
(
kinds
,
(
type_properties
,
as_kind_heap
,
as_td_infos
))
=
determine_kinds_and_properties_of_group
group
as_kind_heap
as_td_infos
kind_heap
=
unify_var_binds
con_var_binds
as_kind_heap
as_
kind_heap
=
unify_var_binds
con_var_binds
as_kind_heap
(
normalized_top_vars
,
(
kind_var_store
,
as_kind_heap
))
=
normalize_top_vars
con_top_var_binds
0
as_kind_heap
(
as_kind_heap
,
as_td_infos
)
=
update_type_group_info
group
kinds
type_properties
normalized_top_vars
group
as_next_group_num
kind_var_store
as_kind_heap
as_td_infos
(
as_kind_heap
,
as_td_infos
)
=
update_type_group_info
group
kinds
type_properties
normalized_top_vars
group
as_next_group_num
0
kind_var_store
as_kind_heap
as_td_infos
=
(
cMAXINT
,
({
con_top_var_binds
=
[],
con_var_binds
=
[]
},
{
as
&
as_check_marks
=
as_check_marks
,
as_deps
=
as_deps
,
as_kind_heap
=
as_kind_heap
,
as_td_infos
=
as_td_infos
,
as_next_group_num
=
inc
as_next_group_num
}))
...
...
@@ -363,7 +363,7 @@ where
=
(
kinds
,
(
combineTypeProperties
type_properties
tdi_properties
,
kind_heap
,
as_td_infos
))
retrieve_kind
(
KindVar
kind_info_ptr
)
kind_heap
#
!
kind_info
=
s
readPtr
kind_info_ptr
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
kind_info_ptr
kind_heap
=
(
determine_kind
kind_info
,
kind_heap
)
where
determine_kind
(
KI_Indirection
kind
)
...
...
@@ -379,12 +379,12 @@ where
unify_var_bind
::
!
VarBind
!*
KindHeap
->
*
KindHeap
unify_var_bind
{
vb_var
,
vb_vars
}
kind_heap
#
!
kind_info
=
s
readPtr
vb_var
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
vb_var
kind_heap
#
(
vb_var
,
kind_heap
)
=
determine_var_bind
vb_var
kind_info
kind_heap
=
redirect_vars
vb_var
vb_vars
kind_heap
where
redirect_vars
kind_info_ptr
[
var_info_ptr
:
var_info_ptrs
]
kind_heap
#
!
kind_info
=
s
readPtr
var_info_ptr
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
var_info_ptr
kind_heap
#
(
var_info_ptr
,
kind_heap
)
=
determine_var_bind
var_info_ptr
kind_info
kind_heap
|
kind_info_ptr
==
var_info_ptr
=
redirect_vars
kind_info_ptr
var_info_ptrs
kind_heap
...
...
@@ -393,14 +393,14 @@ where
=
kind_heap
determine_var_bind
_
(
KI_VarBind
kind_info_ptr
)
kind_heap
#
!
kind_info
=
s
readPtr
kind_info_ptr
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
kind_info_ptr
kind_heap
=
determine_var_bind
kind_info_ptr
kind_info
kind_heap
determine_var_bind
kind_info_ptr
kind_info
kind_heap
=
(
kind_info_ptr
,
kind_heap
)
nomalize_var
::
!
KindInfoPtr
!
KindInfo
!(!
Int
,!*
KindHeap
)
->
(!
Int
,!(!
Int
,!*
KindHeap
))
nomalize_var
orig_kind_info
(
KI_VarBind
kind_info_ptr
)
(
kind_store
,
kind_heap
)
#
!
kind_info
=
s
readPtr
kind_info_ptr
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
kind_info_ptr
kind_heap
=
nomalize_var
kind_info_ptr
kind_info
(
kind_store
,
kind_heap
)
nomalize_var
kind_info_ptr
(
KI_NormVar
var_number
)
(
kind_store
,
kind_heap
)
=
(
var_number
,
(
kind_store
,
kind_heap
))
...
...
@@ -412,23 +412,23 @@ where
where
normalize_top_var
::
!
KindInfoPtr
!(!
Int
,!*
KindHeap
)
->
(!
Int
,!(!
Int
,!*
KindHeap
))
normalize_top_var
kind_info_ptr
(
kind_store
,
kind_heap
)
#
!
kind_info
=
s
readPtr
kind_info_ptr
kind_heap
#
(
kind_info
,
kind_heap
)
=
readPtr
kind_info_ptr
kind_heap
=
nomalize_var
kind_info_ptr
kind_info
(
kind_store
,
kind_heap
)
// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef})
update_type_group_info
[
td
:
tds
]
[
td_kinds
:
tds_kinds
]
type_properties
top_vars
group
group_nr
kind_store
kind_heap
td_infos
#
(
kind_store
,
kind_heap
,
td_infos
)
=
update_type_def_info
td
td_kinds
type_properties
top_vars
group
group_nr
kind_store
kind_heap
td_infos
=
update_type_group_info
tds
tds_kinds
type_properties
top_vars
group
group_nr
kind_store
kind_heap
td_infos
update_type_group_info
[]
[]
type_properties
top_vars
group
group_nr
kind_store
kind_heap
td_infos
// update_type_group_info :: ![Index] ![[TypeKind]] !TypeProperties ![Int] ![Int]
!Index
!Int !*KindHeap !*{# CheckedTypeDef} -> (!*KindHeap,!*{# CheckedTypeDef})
update_type_group_info
[
td
:
tds
]
[
td_kinds
:
tds_kinds
]
type_properties
top_vars
group
group_nr
loc_type_index
kind_store
kind_heap
td_infos
#
(
kind_store
,
kind_heap
,
td_infos
)
=
update_type_def_info
td
td_kinds
type_properties
top_vars
group
group_nr
loc_type_index
kind_store
kind_heap
td_infos
=
update_type_group_info
tds
tds_kinds
type_properties
top_vars
group
group_nr
(
inc
loc_type_index
)
kind_store
kind_heap
td_infos
update_type_group_info
[]
[]
type_properties
top_vars
group
group_nr
loc_type_index
kind_store
kind_heap
td_infos
=
(
kind_heap
,
td_infos
)
// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int !*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef})
update_type_def_info
{
glob_module
,
glob_object
}
td_kinds
type_properties
top_vars
group
group_nr
kind_store
kind_heap
td_infos
// update_type_def_info :: !Int ![TypeKind] !TypeProperties ![Int] ![Int] !Int
!Index !Int
!*KindHeap !*{# CheckedTypeDef} -> (!Int,!*KindHeap,!*{# CheckedTypeDef})
update_type_def_info
{
glob_module
,
glob_object
}
td_kinds
type_properties
top_vars
group
group_nr
loc_type_index
kind_store
kind_heap
td_infos
#
(
td_info
=:{
tdi_kinds
},
td_infos
)
=
td_infos
![
glob_module
].[
glob_object
]
#
(
group_vars
,
cons_vars
,
kind_store
,
kind_heap
)
=
determine_type_def_info
tdi_kinds
td_kinds
top_vars
kind_store
kind_heap
=
(
kind_store
,
kind_heap
,
{
td_infos
&
[
glob_module
].[
glob_object
]
=
{
td_info
&
tdi_properties
=
type_properties
,
tdi_kinds
=
td_kinds
,
tdi_group
=
group
,
tdi_group_vars
=
group_vars
,
tdi_cons_vars
=
cons_vars
,
tdi_group_nr
=
group_nr
}
})
tdi_group_vars
=
group_vars
,
tdi_cons_vars
=
cons_vars
,
tdi_group_nr
=
group_nr
,
tdi_tmp_index
=
loc_type_index
}
})
// ---> ("update_type_def_info", glob_module, glob_object, group_nr)
where
determine_type_def_info
[
KindVar
kind_info_ptr
:
kind_vars
]
[
kind
:
kinds
]
top_vars
kind_store
kind_heap
...
...
frontend/analunitypes.icl
View file @
e783db98
This diff is collapsed.
Click to expand it.
frontend/check.icl
View file @
e783db98
This diff is collapsed.
Click to expand it.
frontend/checksupport.dcl
View file @
e783db98
...
...
@@ -78,12 +78,12 @@ cConversionTableSize :== 8
}
::
IclModule
=
{
icl_name
::
!
Ident
,
icl_functions
::
!.{#
FunDef
}
,
icl_instances
::
!
IndexRange
,
icl_specials
::
!
IndexRange
,
icl_common
::
!.
CommonDefs
,
icl_declared
::
!
Declarations
{
icl_name
::
!
Ident
,
icl_functions
::
!.{#
FunDef
}
,
icl_instances
::
!
IndexRange
,
icl_specials
::
!
IndexRange
,
icl_common
::
!.
CommonDefs
,
icl_declared
::
!
Declarations
,
icl_imported_objects
::
![
ImportedObject
]
}
...
...
@@ -121,7 +121,7 @@ instance envLookUp TypeVar, AttributeVar, ATypeVar
class
toIdent
a
::
!
a
->
Ident
instance
toIdent
ConsDef
,
TypeDef
a
,
ClassDef
,
MemberDef
,
FunDef
,
SelectorDef
// , ClassInstance
instance
toIdent
ConsDef
,
(
TypeDef
a
)
,
ClassDef
,
MemberDef
,
FunDef
,
SelectorDef
// , ClassInstance
instance
toIdent
SymbIdent
,
TypeSymbIdent
,
BoundVar
,
TypeVar
,
ATypeVar
,
Ident
instance
toInt
STE_Kind
...
...
@@ -129,7 +129,7 @@ instance <<< STE_Kind, IdentPos, Declaration
retrieveAndRemoveImportsFromSymbolTable
::
![(.
a
,.
Declarations
)]
[
Declaration
]
*(
Heap
SymbolTableEntry
)
->
([
Declaration
],.
Heap
SymbolTableEntry
);
retrieveAndRemoveImportsOfModuleFromSymbolTable
::
![.
Declaration
]
![.
Declaration
]
![.
Declaration
]
!*(
Heap
SymbolTableEntry
)
->
([
Declaration
],.
Heap
SymbolTableEntry
);
addLocalFunctionDefsToSymbolTable
::
Level
Index
.
Index
u
:
(
a
FunDef
)
*
SymbolTable
*
ErrorAdmin
->
(
v
:(
a
FunDef
),.
SymbolTable
,
.
ErrorAdmin
)
|
Array
.
a
,
[
u
<=
v
];
addLocalFunctionDefsToSymbolTable
::
!
Level
!
Index
!
Index
!
u
:
{#
FunDef
}
!
*
SymbolTable
!
*
ErrorAdmin
->
(
!
u
:{#
FunDef
},
!*
SymbolTable
,
!*
ErrorAdmin
)
addDefToSymbolTable
::
!
Level
!
Index
!
Ident
!
STE_Kind
!*
SymbolTable
!*
ErrorAdmin
->
(!*
SymbolTable
,
!*
ErrorAdmin
)
addDeclaredSymbolsToSymbolTable
::
.
Bool
.
Int
![.
Declaration
]
![.
Declaration
]
!*
CheckState
->
.
CheckState
;
addLocalSymbolsToSymbolTable
::
![.
Declaration
]
Int
!*
CheckState
->
.
CheckState
;
...
...
@@ -139,5 +139,4 @@ retrieveImportsFromSymbolTable :: ![Import ImportDeclaration] ![Declaration] !*{
removeFieldFromSelectorDefinition
::
!
Ident
.
Int
.
Int
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
removeDeclarationsFromSymbolTable
::
![
Declaration
]
!
Int
!*(
Heap
SymbolTableEntry
)
->
*
Heap
SymbolTableEntry
;
removeLocalIdentsFromSymbolTable
::
.
Int
!.[
Ident
]
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
removeLocalsFromSymbolTable
::
.
Level
.[
Ident
]
LocalDefs
u
:(
a
b
)
*(
Heap
SymbolTableEntry
)
->
(
v
:(
a
b
),.
Heap
SymbolTableEntry
)
|
Array
.
a
&
select_u
,
toIdent
b
,
[
u
<=
v
];
removeIdentFromSymbolTable
::
!.
Int
!
Ident
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
frontend/checksupport.icl
View file @
e783db98
...
...
@@ -226,12 +226,12 @@ where
_
->
([{
symbol
&
dcl_kind
=
ste_kind
}
:
decls
],
symbol_table
<:=
(
id_info
,
ste_previous
))
addLocalFunctionDefsToSymbolTable
::
Level
Index
.
Index
u
:
(
a
FunDef
)
*
SymbolTable
*
ErrorAdmin
->
(
v
:(
a
FunDef
),.
SymbolTable
,
.
ErrorAdmin
)
|
Array
.
a
,
[
u
<=
v
];
addLocalFunctionDefsToSymbolTable
::
!
Level
!
Index
!
Index
!
u
:
{#
FunDef
}
!
*
SymbolTable
!
*
ErrorAdmin
->
(
!
u
:{#
FunDef
},
!*
SymbolTable
,
!*
ErrorAdmin
)
addLocalFunctionDefsToSymbolTable
level
from_index
to_index
fun_defs
symbol_table
error
|
from_index
==
to_index
=
(
fun_defs
,
symbol_table
,
error
)
#
!
fun_def
=
fun_defs
.
[
from_index
]
(
symbol_table
,
error
)
=
addDefToSymbolTable
level
from_index
fun_def
.
fun_symb
(
STE_FunctionOrMacro
[])
symbol_table
error
#
(
fun_def
,
fun_def
s
)
=
fun_defs
!
[
from_index
]
(
symbol_table
,
error
)
=
addDefToSymbolTable
level
from_index
fun_def
.
fun_symb
(
STE_FunctionOrMacro
[])
symbol_table
error
=
addLocalFunctionDefsToSymbolTable
level
(
inc
from_index
)
to_index
fun_defs
symbol_table
error
NewEntry
symbol_table
symb_ptr
def_kind
def_index
level
previous
:==
...
...
@@ -328,10 +328,9 @@ where
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
#!
entry
=
sreadPtr
id_info
symbol_table
#
{
ste_index
}
=
entry
#!
{
dcl_declared
={
dcls_import
,
dcls_local
}}
=
modules
.[
ste_index
]
(
decls
,
symbol_table
)
=
retrieveAndRemoveImportsOfModuleFromSymbolTable
dcls_import
dcls_local
decls
symbol_table
#
({
ste_index
},
symbol_table
)
=
readPtr
id_info
symbol_table
({
dcl_declared
={
dcls_import
,
dcls_local
}},
modules
)
=
modules
![
ste_index
]
(
decls
,
symbol_table
)
=
retrieveAndRemoveImportsOfModuleFromSymbolTable
dcls_import
dcls_local
decls
symbol_table
=
retrieveImportsFromSymbolTable
mods
decls
modules
symbol_table
retrieveImportsFromSymbolTable
[]
decls
modules
symbol_table
=
(
decls
,
modules
,
symbol_table
)
...
...
@@ -356,22 +355,19 @@ removeDeclarationsFromSymbolTable decls scope symbol_table
=
foldSt
(
remove_declaration
scope
)
decls
symbol_table
where
remove_declaration
scope
{
dcl_ident
={
id_name
,
id_info
},
dcl_index
}
symbol_table
#!
entry
=
sreadPtr
id_info
symbol_table
#
{
ste_kind
,
ste_previous
}
=
entry
#
({
ste_kind
,
ste_previous
},
symbol_table
)
=
readPtr
id_info
symbol_table
=
case
ste_kind
of
STE_Field
field_id
#
symbol_table
=
removeFieldFromSelectorDefinition
field_id
NoIndex
dcl_index
symbol_table
|
ste_previous
.
ste_def_level
==
scope
->
symbol_table
<:=
(
id_info
,
ste_previous
.
ste_previous
)
->
symbol_table
<:=
(
id_info
,
ste_previous
)
// MW..
STE_Empty
->
symbol_table
// ..MW
_
|
ste_previous
.
ste_def_level
==
scope
->
symbol_table
<:=
(
id_info
,
ste_previous
.
ste_previous
)
->
symbol_table
<:=
(
id_info
,
ste_previous
)
STE_Field
field_id
#
symbol_table
=
removeFieldFromSelectorDefinition
field_id
NoIndex
dcl_index
symbol_table
|
ste_previous
.
ste_def_level
==
scope
->
symbol_table
<:=
(
id_info
,
ste_previous
.
ste_previous
)
->
symbol_table
<:=
(
id_info
,
ste_previous
)
STE_Empty
->
symbol_table
_
|
ste_previous
.
ste_def_level
==
scope
->
symbol_table
<:=
(
id_info
,
ste_previous
.
ste_previous
)
->
symbol_table
<:=
(
id_info
,
ste_previous
)
removeLocalIdentsFromSymbolTable
::
.
Int
!.[
Ident
]
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
...
...
@@ -379,21 +375,6 @@ removeLocalIdentsFromSymbolTable level idents symbol_table
=
foldSt
(
removeIdentFromSymbolTable
level
)
idents
symbol_table
removeLocalsFromSymbolTable
::
.
Level
.[
Ident
]
LocalDefs
u
:(
a
b
)
*(
Heap
SymbolTableEntry
)
->
(
v
:(
a
b
),.
Heap
SymbolTableEntry
)
|
Array
.
a
&
select_u
,
toIdent
b
,
[
u
<=
v
];
removeLocalsFromSymbolTable
level
loc_vars
(
CollectedLocalDefs
{
loc_functions
={
ir_from
,
ir_to
}})
defs
symbol_table
=
remove_defs_from_symbol_table
level
ir_from
ir_to
defs
(
removeLocalIdentsFromSymbolTable
level
loc_vars
symbol_table
)
where
remove_defs_from_symbol_table
level
from_index
to_index
defs
symbol_table
|
from_index
==
to_index
=
(
defs
,
symbol_table
)
#!
def
=
defs
.[
from_index
]
id_info
=
(
toIdent
def
).
id_info
entry
=
sreadPtr
id_info
symbol_table
|
level
==
entry
.
ste_def_level
=
remove_defs_from_symbol_table
level
(
inc
from_index
)
to_index
defs
(
symbol_table
<:=
(
id_info
,
entry
.
ste_previous
))
=
remove_defs_from_symbol_table
level
(
inc
from_index
)
to_index
defs
symbol_table
removeIdentFromSymbolTable
::
!.
Int
!
Ident
!*(
Heap
SymbolTableEntry
)
->
.
Heap
SymbolTableEntry
;
removeIdentFromSymbolTable
level
{
id_name
,
id_info
}
symbol_table
#!
{
ste_previous
,
ste_def_level
}
=
sreadPtr
id_info
symbol_table
...
...
@@ -432,7 +413,7 @@ instance toIdent ConsDef
where
toIdent
cons
=
cons
.
cons_symb
instance
toIdent
TypeDef
a
instance
toIdent
(
TypeDef
a
)
where
toIdent
td
=
td
.
td_name
...
...
@@ -511,9 +492,6 @@ where
(<<<)
file
(
STE_BoundTypeVariable
_)
=
file
<<<
"STE_BoundTypeVariable"
(<<<)
file
(
STE_BoundType
_)
=
file
<<<
"STE_BoundType"
(<<<)
file
(
STE_Imported
_
_)
=
file
<<<
"STE_Imported"
...
...
frontend/checktypes.dcl
View file @
e783db98
...
...
@@ -20,6 +20,9 @@ checkDynamicTypes :: !Index ![ExprInfoPtr] !(Optional SymbolType) !u:{# CheckedT
createClassDictionaries
::
!
Index
!*{#
ClassDef
}
!
u
:{#.
DclModule
}
!
Index
!
Index
!
Index
!*
TypeVarHeap
!*
VarHeap
!*
CheckState
->
(!*{#
ClassDef
},
!
u
:{#
DclModule
},
![
CheckedTypeDef
],
![
SelectorDef
],
![
ConsDef
],
!*
TypeVarHeap
,
!*
VarHeap
,
!*
CheckState
)
bindTypeVarsAndAttributes
::
!
TypeAttribute
!
TypeAttribute
![
ATypeVar
]
![
AType
]
!*
TypeHeaps
->
*
TypeHeaps
;
clearBindingsOfTypeVarsAndAttributes
::
!
TypeAttribute
![
ATypeVar
]
!*
TypeHeaps
->
*
TypeHeaps
;
isATopConsVar
cv
:==
cv
<
0
encodeTopConsVar
cv
:==
dec
(~
cv
)
decodeTopConsVar
cv
:==
~(
inc
cv
)
frontend/checktypes.icl
View file @
e783db98
This diff is collapsed.
Click to expand it.
frontend/comparedefimp.icl
View file @
e783db98
...
...
@@ -38,7 +38,7 @@ import RWSDebug
}
::
TypesCorrespondMonad
:==
!*
TypesCorrespondState
->
(!
Bool
,
!*
TypesCorrespondState
)
:==
!*
TypesCorrespondState
->
*
(!
Bool
,
!*
TypesCorrespondState
)
::
ExpressionsCorrespondState
=
{
ec_correspondences
// ec_correspondences.[i]==j <=> (functions i and j are already compared
...
...
@@ -130,7 +130,6 @@ compareDefImp untransformed dcl_modules icl_module heaps error_admin
(
icl_functions
,
hp_var_heap
,
hp_expression_heap
,
tc_state
,
error_admin
)
=
compareMacrosWithConversion
conversion_table
.[
cMacroDefs
]
dcl_macros
untransformed
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
...
...
@@ -155,9 +154,6 @@ compareDefImp untransformed 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
)
#
icl_index
=
conversions
.[
dclIndex
]
|
icl_index
==
dclIndex
...
...
@@ -172,9 +168,6 @@ 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
...
...
@@ -337,19 +330,25 @@ instance t_corresponds [a] | t_corresponds a where
t_corresponds
_
_
=
return
False
instance
t_corresponds
{#
a
}
|
t_corresponds
,
select_u
,
size_u
a
where
// instance t_corresponds {# a} | t_corresponds a & Array {#} a // 2.0
instance
t_corresponds
{#
a
}
|
ArrayElem
,
t_corresponds
a
where
t_corresponds
dclArray
iclArray
#
size_dclArray
=
size
dclArray
|
size_dclArray
<>
size
iclArray
=
return
False
=
loop
(
size_dclArray
-1
)
dclArray
iclArray
=
loop
(
size_dclArray
-1
)
dclArray
iclArray
where
// loop :: !Int !{# a} !{# a} -> *TypesCorrespondMonad | t_corresponds a & Array {#} a // 2.0
loop
i
dclArray
iclArray
|
i
<
0
=
return
True
=
t_corresponds
dclArray
.[
i
]
iclArray
.[
i
]
=
t_corresponds
dclArray
.[
i
]
iclArray
.[
i
]
&&&
loop
(
i
-1
)
dclArray
iclArray
instance
t_corresponds
(
Optional
a
)
|
t_corresponds
a
where
t_corresponds
No
No
=
return
True
...
...
@@ -437,7 +436,6 @@ instance t_corresponds AType where
_
->
(
False
,
tc_state
)
_
->
(
False
,
tc_state
)
where
simple_corresponds
dclDef
iclDef
=
t_corresponds
dclDef
.
at_attribute
iclDef
.
at_attribute
&&&
t_corresponds
dclDef
.
at_type
iclDef
.
at_type
...
...
@@ -486,7 +484,7 @@ instance t_corresponds AType where
#
(
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
)
//
--->("binding", atv_variable.tv_name,"to",actual_arg)
//
--->("binding", atv_variable.tv_name,"to",actual_arg)
bind_type_vars`
_
_
type_var_heap
=
type_var_heap
...
...
@@ -711,7 +709,7 @@ instance e_corresponds FunDef where
where
from_body
(
TransformedBody
{
tb_args
,
tb_rhs
})
=
(
tb_args
,
[
tb_rhs
])
from_body
(
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
...
...
@@ -775,6 +773,8 @@ instance e_corresponds Expression where
=
e_corresponds
dcl
icl
e_corresponds
EE
EE
=
do_nothing
e_corresponds
(
NoBind
_)
(
NoBind
_)
=
do_nothing
e_corresponds
_
_
=
give_error
""
...
...
frontend/convertDynamics.icl
View file @
e783db98
...
...
@@ -44,7 +44,7 @@ where
convert_groups
group_nr
groups
global_type_instances
fun_defs_and_ci
|
group_nr
==
size
groups
=
(
groups
,
fun_defs_and_ci
)
#
!
group
=
groups
.
[
group_nr
]
#
(
group
,
group
s
)
=
groups
!
[
group_nr
]
=
convert_groups
(
inc
group_nr
)
groups
global_type_instances
(
foldSt
(
convert_function
group_nr
global_type_instances
)
group
.
group_members
fun_defs_and_ci
)
convert_function
group_nr
global_type_instances
fun
(
fun_defs
,
ci
)
...
...
@@ -568,7 +568,7 @@ zipAppend2 xs [] zs = zs
zipAppend2
[
x
:
xs
]
[
y
:
ys
]
zs
=
[
(
x
,
y
)
:
zipAppend2
xs
ys
zs
]
instance
<<<
Ptr
a
instance
<<<
(
Ptr
a
)
where
(<<<)
file
ptr
=
file
<<<
ptrToInt
ptr
...
...
frontend/convertcases.icl
View file @
e783db98
...
...
@@ -28,7 +28,7 @@ where
convertCases
bound_vars
group_index
common_defs
t
ci
=
app2St
(
convertCases
bound_vars
group_index
common_defs
,
convertCases
bound_vars
group_index
common_defs
)
t
ci
instance
convertCases
Bind
a
b
|
convertCases
a
instance
convertCases
(
Bind
a
b
)
|
convertCases
a
where
convertCases
bound_vars
group_index
common_defs
bind
=:{
bind_src
}
ci
#
(
bind_src
,
ci
)
=
convertCases
bound_vars
group_index
common_defs
bind_src
ci
...
...
@@ -456,7 +456,7 @@ where
group_index
=
gf_fun_def
.
fun_info
.
fi_group_index
(
Yes
ft
)
=
gf_fun_def
.
fun_type
(
ft
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
ft
imported_types
imported_conses
type_heaps
var_heap
#
!
group
=
groups
.
[
group_index
]
#
(
group
,
group
s
)
=
groups
!
[
group_index
]
=
({
groups
&
[
group_index
]
=
{
group
&
group_members
=
[
gf_fun_index
:
group
.
group_members
]}
},
[
{
gf_fun_def
&
fun_type
=
Yes
ft
}:
fun_defs
],
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
...
...
@@ -478,13 +478,13 @@ where
convert_groups
group_nr
groups
dcl_functions
common_defs
fun_defs_and_ci
|
group_nr
==
size
groups
=
(
groups
,
fun_defs_and_ci
)
#
!
group
=
groups
.
[
group_nr
]
#
(
group
,
group
s
)
=
groups
!
[
group_nr
]
=
convert_groups
(
inc
group_nr
)
groups
dcl_functions
common_defs
(
foldSt
(
convert_function
group_nr
dcl_functions
common_defs
)
group
.
group_members
fun_defs_and_ci
)
convert_function
group_index
dcl_functions
common_defs
fun
(
fun_defs
,
collected_imports
,
ci
)
#
!
fun_def
=
fun_defs
.
[
fun
]
#
(
fun_def
,
fun_def
s
)
=
fun_defs
!
[
fun
]
#
{
fun_body
,
fun_type
}
=
fun_def
(
fun_body
,
(
collected_imports
,
ci
))
=
eliminate_code_sharing_in_function
dcl_functions
common_defs
fun_body
/* (fun_body ---> ("convert_function", fun_def.fun_symb, fun_body)) */
(
collected_imports
,
ci
)
(
fun_body
,
ci
)
=
convert_cases_into_function_patterns
fun_body
fun_type
group_index
common_defs
ci
...
...
@@ -621,10 +621,11 @@ where
=
(
imported_types
,
type_heaps
,
var_heap
)
convert_imported_constructors
common_defs
[
{
glob_module
,
glob_object
}
:
conses
]
imported_types
type_heaps
var_heap
#
{
com_cons_defs
,
com_selector_defs
}
=
common_defs
.[
glob_module
]
{
cons_type_ptr
,
cons_type
,
cons_type_index
}
=
common_defs
.[
glob_module
].
com_cons_defs
.[
glob_object
]
{
cons_type_ptr
,
cons_type
,
cons_type_index
,
cons_symb
}
=
common_defs
.[
glob_module
].
com_cons_defs
.[
glob_object
]
(
cons_type
,
imported_types
,
conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
common_defs
cons_type
imported_types
conses
type_heaps
var_heap
var_heap
=
var_heap
<:=
(
cons_type_ptr
,
VI_ExpandedType
cons_type
)
({
td_rhs
},
imported_types
)
=
imported_types
![
glob_module
].[
cons_type_index
]
// ---> ("convert_imported_constructors", cons_symb, cons_type)
=
case
td_rhs
of
RecordType
{
rt_fields
}
#
(
imported_types
,
conses
,
type_heaps
,
var_heap
)
...
...
@@ -820,10 +821,12 @@ where
*/
copy
EE
cp_info
=
(
EE
,
cp_info
)
copy
(
NoBind
ptr
)
cp_info
=
(
NoBind
ptr
,
cp_info
)
copy
expr
cp_info
=
abort
(
"copy (Expression) does not match"
--->
expr
)
instance
copy
Optional
a
|
copy
a
instance
copy
(
Optional
a
)
|
copy
a
where
copy
(
Yes
expr
)
cp_info
#
(
expr
,
cp_info
)
=
copy
expr
cp_info
...
...
@@ -1049,6 +1052,8 @@ where
=
weightedRefCount
dcl_functions
common_defs
depth
type_code_expr
rc_info
weightedRefCount
dcl_functions
common_defs
depth
EE
rc_info
=
rc_info
weightedRefCount
dcl_functions
common_defs
depth
(
NoBind
ptr
)
rc_info
=
rc_info
weightedRefCount
dcl_functions
common_defs
depth
expr
rc_info
=
abort
(
"weightedRefCount [Expression] (convertcases, 864))"
--->
expr
)
...
...
@@ -1294,13 +1299,13 @@ where
di_expr_heap
=
writePtr
inner_let_info_ptr
(
EI_LetType
((
take
nr_of_strict_lets
let_type
)++
strict_inner_types
))
di_expr_heap
->
(
Let
{
inner_let
&
let_strict_binds
=
let_strict_binds
++
inner_let
.
let_strict_binds
},