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
6af73849
Commit
6af73849
authored
Feb 14, 2007
by
John van Groningen
Browse files
implement qualified explicit imports
parent
30a9c9a8
Changes
16
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/check.icl
View file @
6af73849
This diff is collapsed.
Click to expand it.
frontend/checkFunctionBodies.icl
View file @
6af73849
This diff is collapsed.
Click to expand it.
frontend/checksupport.dcl
View file @
6af73849
...
...
@@ -103,6 +103,7 @@ cConversionTableSize :== 10
,
icl_function_indices
::
!
IclFunctionIndices
,
icl_common
::
!.
CommonDefs
,
icl_import
::
!{!
Declaration
}
,
icl_qualified_imports
::
![([
Declaration
],
ModuleN
,
Position
)]
,
icl_imported_objects
::
![
ImportedObject
]
,
icl_foreign_exports
::
![
ForeignExport
]
,
icl_used_module_numbers
::
!
NumberSet
...
...
frontend/checksupport.icl
View file @
6af73849
...
...
@@ -362,8 +362,8 @@ where
#
({
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
decl_index
symbol_table
STE_Field
selector
_id
#
symbol_table
=
removeFieldFromSelectorDefinition
selector
_id
NoIndex
decl_index
symbol_table
|
ste_previous
.
ste_def_level
==
scope
->
symbol_table
<:=
(
id_info
,
ste_previous
.
ste_previous
)
->
symbol_table
<:=
(
id_info
,
ste_previous
)
...
...
frontend/checktypes.icl
View file @
6af73849
...
...
@@ -4,6 +4,7 @@ import StdEnv
import
syntax
,
checksupport
,
check
,
typesupport
,
utilities
,
compilerSwitches
// , RWSDebug
import
genericsupport
from
explicitimports
import
search_qualified_ident
,::
NameSpaceN
,
TypeNameSpaceN
,
ClassNameSpaceN
::
TypeSymbols
=
{
ts_type_defs
::
!.{#
CheckedTypeDef
}
...
...
@@ -100,16 +101,35 @@ where
retrieveTypeDefinition
::
SymbolPtr
!
Index
!*
SymbolTable
![
SymbolPtr
]
->
((!
Index
,
!
Index
),
!*
SymbolTable
,
![
SymbolPtr
])
retrieveTypeDefinition
type_ptr
mod_index
symbol_table
used_types
#
(
entry
,
symbol_table
)
=
readPtr
type_ptr
symbol_table
=
case
entry
of
({
ste_kind
=
this_kind
=:
STE_Imported
STE_Type
decl_index
,
ste_def_level
,
ste
_index
}
)
->
((
ste_index
,
decl
_index
),
symbol_table
<:=
(
type_ptr
,
{
entry
&
ste_kind
=
STE_UsedType
decl
_index
this_kind
}),
[
type_ptr
:
used_types
])
({
ste_kind
=
this_kind
=:
STE_Type
,
ste_def_level
,
ste_index
})
#
(
entry
=:{
ste_kind
,
ste_def_level
,
ste_index
}
,
symbol_table
)
=
readPtr
type_ptr
symbol_table
=
case
ste_kind
of
this_kind
=:
(
STE_Imported
STE_Type
ste_mod
_index
)
->
((
ste_index
,
ste_mod
_index
),
symbol_table
<:=
(
type_ptr
,
{
entry
&
ste_kind
=
STE_UsedType
ste_mod
_index
this_kind
}),
[
type_ptr
:
used_types
])
this_kind
=:
STE_Type
|
ste_def_level
==
cGlobalScope
->
((
ste_index
,
mod_index
),
symbol_table
<:=
(
type_ptr
,
{
entry
&
ste_kind
=
STE_UsedType
mod_index
this_kind
}),
[
type_ptr
:
used_types
])
->
((
NotFound
,
mod_index
),
symbol_table
,
used_types
)
({
ste_kind
=
STE_UsedType
mod_index
_
,
ste_def_level
,
ste_index
})
STE_UsedType
mod_index
_
->
((
ste_index
,
mod_index
),
symbol_table
,
used_types
)
this_kind
=:(
STE_UsedQualifiedType
uqt_mod_index
uqt_index
orig_kind
)
|
uqt_mod_index
==
mod_index
&&
uqt_index
==
ste_index
->
((
ste_index
,
mod_index
),
symbol_table
,
used_types
)
->
retrieve_type_definition
orig_kind
with
retrieve_type_definition
(
STE_UsedQualifiedType
uqt_mod_index
uqt_index
orig_kind
)
|
uqt_mod_index
==
mod_index
&&
uqt_index
==
ste_index
=
((
ste_index
,
mod_index
),
symbol_table
,
used_types
)
=
retrieve_type_definition
orig_kind
retrieve_type_definition
(
STE_Imported
STE_Type
ste_mod_index
)
=
((
ste_index
,
ste_mod_index
),
symbol_table
<:=
(
type_ptr
,
{
entry
&
ste_kind
=
STE_UsedType
ste_mod_index
this_kind
}),
used_types
)
retrieve_type_definition
STE_Type
|
ste_def_level
==
cGlobalScope
=
((
ste_index
,
mod_index
),
symbol_table
<:=
(
type_ptr
,
{
entry
&
ste_kind
=
STE_UsedType
mod_index
this_kind
}),
used_types
)
=
((
NotFound
,
mod_index
),
symbol_table
,
used_types
)
retrieve_type_definition
(
STE_UsedType
mod_index
_)
=
((
ste_index
,
mod_index
),
symbol_table
,
used_types
)
retrieve_type_definition
_
=
((
NotFound
,
mod_index
),
symbol_table
,
used_types
)
_
->
((
NotFound
,
mod_index
),
symbol_table
,
used_types
)
...
...
@@ -157,25 +177,70 @@ where
#
(
arg_type
,
_,
ts_ti_cs
)
=
bindTypes
cti
arg_type
ts_ti_cs
(
res_type
,
_,
ts_ti_cs
)
=
bindTypes
cti
res_type
ts_ti_cs
=
(
arg_type
-->
res_type
,
TA_Multi
,
ts_ti_cs
)
//AA..
bindTypes
cti
(
TArrow1
type
)
ts_ti_cs
#
(
type
,
_,
ts_ti_cs
)
=
bindTypes
cti
type
ts_ti_cs
=
(
TArrow1
type
,
TA_Multi
,
ts_ti_cs
)
//..AA
bindTypes
cti
(
CV
tv
:@:
types
)
ts_ti_cs
#
(
tv
,
type_attr
,
ts_ti_cs
)
=
bindTypes
cti
tv
ts_ti_cs
(
types
,
_,
ts_ti_cs
)
=
bindTypes
cti
types
ts_ti_cs
=
(
CV
tv
:@:
types
,
type_attr
,
ts_ti_cs
)
// Sjaak 16-08-01
bindTypes
cti
(
TFA
vars
type
)
(
ts
,
ti
=:{
ti_type_heaps
},
cs
)
#
(
type_vars
,
(_,
ti_type_heaps
,
cs
))
=
addTypeVariablesToSymbolTable
cRankTwoScope
vars
[]
ti_type_heaps
cs
(
type
,
_,
(
ts
,
ti
,
cs
))
=
bindTypes
cti
type
(
ts
,
{
ti
&
ti_type_heaps
=
ti_type_heaps
},
cs
)
cs_symbol_table
=
removeAttributedTypeVarsFromSymbolTable
cRankTwoScope
type_vars
cs
.
cs_symbol_table
=
(
TFA
type_vars
type
,
TA_Multi
,
(
ts
,
ti
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
}))
// ... Sjaak
bindTypes
cti
=:{
cti_module_index
,
cti_type_index
,
cti_lhs_attribute
}
type
=:(
TQualifiedIdent
module_id
type_name
types
)
(
ts
=:{
ts_type_defs
,
ts_modules
},
ti
,
cs
)
#
(
found
,{
decl_kind
,
decl_ident
=
type_ident
,
decl_index
=
type_index
},
cs
)
=
search_qualified_ident
module_id
type_name
TypeNameSpaceN
cs
|
not
found
=
(
TE
,
TA_Multi
,
(
ts
,
ti
,
cs
))
=
case
decl_kind
of
STE_Imported
STE_Type
type_module
#
({
td_arity
,
td_attribute
,
td_rhs
},
type_index
,
ts_type_defs
,
ts_modules
)
=
getTypeDef
type_index
type_module
cti_module_index
ts_type_defs
ts_modules
ts
=
{
ts
&
ts_type_defs
=
ts_type_defs
,
ts_modules
=
ts_modules
}
(
cs_symbol_table
,
ti_used_types
)
=
add_qualified_type_to_used_types
type_ident
.
id_info
type_module
type_index
cs
.
cs_symbol_table
ti
.
ti_used_types
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
ti
=
{
ti
&
ti_used_types
=
ti_used_types
}
#
type_cons
=
MakeNewTypeSymbIdent
type_ident
(
length
types
)
|
checkArityOfType
type_cons
.
type_arity
td_arity
td_rhs
#
(
types
,
_,
ts_ti_cs
)
=
bindTypes
cti
types
(
ts
,
ti
,
cs
)
|
type_module
==
cti_module_index
&&
cti_type_index
==
type_index
->
(
TA
{
type_cons
&
type_index
=
{
glob_object
=
type_index
,
glob_module
=
type_module
}}
types
,
cti_lhs_attribute
,
ts_ti_cs
)
->
(
TA
{
type_cons
&
type_index
=
{
glob_object
=
type_index
,
glob_module
=
type_module
}}
types
,
determine_type_attribute
td_attribute
,
ts_ti_cs
)
->
(
TE
,
TA_Multi
,
(
ts
,
ti
,
{
cs
&
cs_error
=
checkError
type_cons
.
type_ident
"used with wrong arity"
cs
.
cs_error
}))
_
->
(
TE
,
TA_Multi
,
(
ts
,
ti
,
{
cs
&
cs_error
=
checkError
(
module_id
.
id_name
+++
"@"
+++
type_name
)
"not imported"
cs
.
cs_error
}))
where
add_qualified_type_to_used_types
symbol_table_ptr
type_module
type_index
symbol_table
used_types
#
(
entry
=:{
ste_kind
,
ste_index
},
symbol_table
)
=
readPtr
symbol_table_ptr
symbol_table
=
case
ste_kind
of
STE_UsedQualifiedType
mod_index
decl_index
next_kind
|
(
mod_index
==
type_module
&&
decl_index
==
type_index
)
||
qualified_type_occurs
next_kind
ste_index
type_module
type_index
->
(
symbol_table
,
used_types
)
#
entry
=
{
entry
&
ste_kind
=
STE_UsedQualifiedType
type_module
type_index
ste_kind
}
->
(
writePtr
symbol_table_ptr
entry
symbol_table
,
used_types
)
STE_UsedType
ste_module
next_kind
|
(
ste_module
==
type_module
&&
ste_index
==
type_index
)
||
qualified_type_occurs
next_kind
ste_index
type_module
type_index
->
(
symbol_table
,
used_types
)
#
entry
=
{
entry
&
ste_kind
=
STE_UsedQualifiedType
type_module
type_index
ste_kind
}
->
(
writePtr
symbol_table_ptr
entry
symbol_table
,
used_types
)
_
#
entry
=
{
entry
&
ste_kind
=
STE_UsedQualifiedType
type_module
type_index
ste_kind
}
->
(
writePtr
symbol_table_ptr
entry
symbol_table
,
[
symbol_table_ptr
:
used_types
])
qualified_type_occurs
(
STE_UsedQualifiedType
mod_index
decl_index
next_kind
)
ste_index
type_module
type_index
|
mod_index
==
type_module
&&
decl_index
==
type_index
=
True
=
qualified_type_occurs
next_kind
ste_index
type_module
type_index
qualified_type_occurs
(
STE_UsedType
ste_module
next_kind
)
ste_index
type_module
type_index
|
ste_module
==
type_module
&&
ste_index
==
type_index
=
True
=
qualified_type_occurs
next_kind
ste_index
type_module
type_index
qualified_type_occurs
_
_
_
_
=
False
bindTypes
cti
type
ts_ti_cs
=
(
type
,
TA_Multi
,
ts_ti_cs
)
addToAttributeEnviron
::
!
TypeAttribute
!
TypeAttribute
![
AttrInequality
]
!*
ErrorAdmin
->
(![
AttrInequality
],!*
ErrorAdmin
)
addToAttributeEnviron
TA_Multi
_
attr_env
error
...
...
@@ -349,11 +414,21 @@ where
retrieve_used_types
symb_ptrs
symbol_table
=
foldSt
retrieve_used_type
symb_ptrs
([],
symbol_table
)
where
where
retrieve_used_type
symb_ptr
(
used_types
,
symbol_table
)
#
(
ste
=:{
ste_kind
=
STE_UsedType
decl_index
orig_kind
,
ste_index
},
symbol_table
)
=
readPtr
symb_ptr
symbol_table
=
([{
gi_module
=
decl_index
,
gi_index
=
ste_index
}
:
used_types
],
symbol_table
<:=
(
symb_ptr
,
{
ste
&
ste_kind
=
orig_kind
}))
#
(
ste
=:{
ste_kind
,
ste_index
},
symbol_table
)
=
readPtr
symb_ptr
symbol_table
#
(
orig_kind
,
used_types
)
=
retrieve_used_types_of_ident
ste_kind
ste_index
used_types
=
(
used_types
,
symbol_table
<:=
(
symb_ptr
,
{
ste
&
ste_kind
=
orig_kind
}))
retrieve_used_types_of_ident
(
STE_UsedType
mod_index
orig_kind
)
ste_index
used_types
#
used_types
=
[{
gi_module
=
mod_index
,
gi_index
=
ste_index
}
:
used_types
]
=
retrieve_used_types_of_ident
orig_kind
ste_index
used_types
retrieve_used_types_of_ident
(
STE_UsedQualifiedType
mod_index
decl_index
orig_kind
)
ste_index
used_types
#
used_types
=
[{
gi_module
=
mod_index
,
gi_index
=
decl_index
}
:
used_types
]
=
retrieve_used_types_of_ident
orig_kind
ste_index
used_types
retrieve_used_types_of_ident
orig_kind
ste_index
used_types
=
(
orig_kind
,
used_types
)
CS_Checked
:==
1
CS_Checking
:==
0
...
...
@@ -607,7 +682,6 @@ checkOpenAType mod_index scope dem_attr_kind type=:{ at_type=TA type_cons=:{type
ots
=
{
ots
&
ots_type_defs
=
ots_type_defs
,
ots_modules
=
ots_modules
}
|
x_check_dynamic_types
&&
checkAbstractType
type_module
td_rhs
=
(
type
,
(
ots
,
oti
,
{
cs
&
cs_error
=
checkError
type_ident
"(abstract type) not permitted in a dynamic type"
cs
.
cs_error
}))
|
checkArityOfType
type_cons
.
type_arity
td_arity
td_rhs
#
type_cons
=
{
type_cons
&
type_index
=
{
glob_object
=
type_index
,
glob_module
=
type_module
}}
(
types
,
(
ots
,
oti
,
cs
))
=
check_args_of_type_cons
mod_index
scope
dem_attr_kind
types
td_args
(
ots
,
oti
,
cs
)
...
...
@@ -674,6 +748,27 @@ where
remove_universal_var
{
atv_variable
=
{
tv_ident
}}
cs_symbol_table
=
removeDefinitionFromSymbolTable
cRankTwoScope
tv_ident
cs_symbol_table
checkOpenAType
mod_index
scope
dem_attr_kind
type
=:{
at_type
=
TQualifiedIdent
module_id
type_name
types
,
at_attribute
}
(
ots
=:{
ots_type_defs
,
ots_modules
},
oti
,
cs
=:{
cs_symbol_table
,
cs_x
={
x_check_dynamic_types
}})
#
(
found
,{
decl_kind
,
decl_ident
=
type_ident
,
decl_index
=
type_index
},
cs
)
=
search_qualified_ident
module_id
type_name
TypeNameSpaceN
cs
|
not
found
=
(
type
,
(
ots
,
oti
,
cs
))
=
case
decl_kind
of
STE_Imported
STE_Type
type_module
#
id_name
=
type_name
#
type_cons
=
MakeNewTypeSymbIdent
type_ident
(
length
types
)
#
({
td_arity
,
td_args
,
td_attribute
,
td_rhs
},
type_index
,
ots_type_defs
,
ots_modules
)
=
getTypeDef
type_index
type_module
mod_index
ots_type_defs
ots_modules
ots
=
{
ots
&
ots_type_defs
=
ots_type_defs
,
ots_modules
=
ots_modules
}
|
x_check_dynamic_types
&&
checkAbstractType
type_module
td_rhs
->
(
type
,
(
ots
,
oti
,
{
cs
&
cs_error
=
checkError
type_ident
"(abstract type) not permitted in a dynamic type"
cs
.
cs_error
}))
|
checkArityOfType
type_cons
.
type_arity
td_arity
td_rhs
#
type_cons
=
{
type_cons
&
type_index
=
{
glob_object
=
type_index
,
glob_module
=
type_module
}}
(
types
,
(
ots
,
oti
,
cs
))
=
check_args_of_type_cons
mod_index
scope
dem_attr_kind
types
td_args
(
ots
,
oti
,
cs
)
(
new_attr
,
oti
,
cs
)
=
newAttribute
(
new_demanded_attribute
dem_attr_kind
td_attribute
)
id_name
at_attribute
oti
cs
->
({
type
&
at_type
=
TA
type_cons
types
,
at_attribute
=
new_attr
}
,
(
ots
,
oti
,
cs
))
->
(
type
,
(
ots
,
oti
,
{
cs
&
cs_error
=
checkError
type_ident
"used with wrong arity"
cs
.
cs_error
}))
_
->
(
type
,
(
ots
,
oti
,
{
cs
&
cs_error
=
checkError
(
module_id
.
id_name
+++
"@"
+++
type_name
)
"not imported"
cs
.
cs_error
}))
checkOpenAType
mod_index
scope
dem_attr
type
=:{
at_attribute
}
(
ots
,
oti
,
cs
)
#
(
new_attr
,
oti
,
cs
)
=
newAttribute
dem_attr
"."
at_attribute
oti
cs
=
({
type
&
at_attribute
=
new_attr
},
(
ots
,
oti
,
cs
))
...
...
@@ -866,15 +961,14 @@ where
checkTypeContext
::
!
Index
!
TypeContext
!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
)
->
(!
TypeContext
,!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
))
checkTypeContext
mod_index
tc
=:{
tc_class
,
tc_types
}
(
class_defs
,
ots
,
oti
,
cs
)
#
(
tc_class
,
(
class_defs
,
ots
,
cs
=:{
cs_error
}))
=
check_context_class
tc_class
(
class_defs
,
ots
,
cs
)
#
(
tc_class
,
(
class_defs
,
ots
,
cs
=:{
cs_error
}))
=
check_context_class
tc_class
tc_types
(
class_defs
,
ots
,
cs
)
|
cs_error
.
ea_ok
#
(
tc_types
,
(
ots
,
oti
,
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
#
cs
=
check_context_types
tc_class
tc_types
cs
=
({
tc
&
tc_class
=
tc_class
,
tc_types
=
tc_types
},
(
class_defs
,
ots
,
oti
,
cs
))
=
({
tc
&
tc_types
=
[]},
(
class_defs
,
ots
,
oti
,
cs
))
where
check_context_class
(
TCClass
cl
)
(
class_defs
,
ots
,
cs
)
check_context_class
(
TCClass
cl
)
tc_types
(
class_defs
,
ots
,
cs
)
#
(
entry
,
cs_symbol_table
)
=
readPtr
cl
.
glob_object
.
ds_ident
.
id_info
cs
.
cs_symbol_table
#
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
#
(
class_index
,
class_module
)
=
retrieveGlobalDefinition
entry
STE_Class
mod_index
...
...
@@ -882,17 +976,32 @@ where
#
(
class_def
,
class_index
,
class_defs
,
ots_modules
)
=
getClassDef
class_index
class_module
mod_index
class_defs
ots
.
ots_modules
#
ots
=
{
ots
&
ots_modules
=
ots_modules
}
|
class_def
.
class_arity
==
cl
.
glob_object
.
ds_arity
#
checked_class
=
{
cl
#
checked_class
=
{
cl
&
glob_module
=
class_module
,
glob_object
=
{
cl
.
glob_object
&
ds_index
=
class_index
}
}
}
=
(
TCClass
checked_class
,
(
class_defs
,
ots
,
cs
))
#
cs_error
=
checkError
cl
.
glob_object
.
ds_ident
"class used with wrong arity"
cs
.
cs_error
=
(
TCClass
cl
,
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
#
cs_error
=
checkError
cl
.
glob_object
.
ds_ident
"class undefined"
cs
.
cs_error
=
(
TCClass
cl
,
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
check_context_class
(
TCGeneric
gtc
=:{
gtc_generic
,
gtc_kind
})
(
class_defs
,
ots
,
cs
)
=
(
TCClass
cl
,
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
check_context_class
tc_class
=:(
TCQualifiedIdent
module_id
class_name
)
tc_types
(
class_defs
,
ots
,
cs
)
#
(
found
,{
decl_kind
,
decl_ident
=
type_ident
,
decl_index
=
class_index
},
cs
)
=
search_qualified_ident
module_id
class_name
ClassNameSpaceN
cs
|
not
found
=
(
tc_class
,
(
class_defs
,
ots
,
cs
))
=
case
decl_kind
of
STE_Imported
STE_Class
class_module
#
({
class_ident
,
class_arity
},
class_index
,
class_defs
,
ots_modules
)
=
getClassDef
class_index
class_module
mod_index
class_defs
ots
.
ots_modules
#
ots
=
{
ots
&
ots_modules
=
ots_modules
}
|
class_arity
==
length
tc_types
#
checked_class
=
{
glob_object
=
MakeDefinedSymbol
class_ident
class_index
class_arity
,
glob_module
=
class_module
}
->
(
TCClass
checked_class
,
(
class_defs
,
ots
,
cs
))
#
cs_error
=
checkError
(
module_id
.
id_name
+++
"@"
+++
class_name
)
"class used with wrong arity"
cs
.
cs_error
->
(
tc_class
,
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
_
->
(
tc_class
,
(
class_defs
,
ots
,
{
cs
&
cs_error
=
checkError
(
module_id
.
id_name
+++
"@"
+++
class_name
)
"class undefined"
cs
.
cs_error
}))
check_context_class
(
TCGeneric
gtc
=:{
gtc_generic
,
gtc_kind
})
tc_types
(
class_defs
,
ots
,
cs
)
#
gen_ident
=
gtc_generic
.
glob_object
.
ds_ident
#
(
entry
,
cs_symbol_table
)
=
readPtr
gen_ident
.
id_info
cs
.
cs_symbol_table
#
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
...
...
frontend/explicitimports.dcl
View file @
6af73849
...
...
@@ -7,11 +7,18 @@ import syntax, checksupport
,
ini_imp_decl
::
!
ImportDeclaration
}
::
SolvedImports
=
{
si_explicit
::
![([
Declaration
],
Position
)]
,
si_implicit
::
![(
Index
,
Position
)]
// module indices
::
ExplicitImport
=
!
{
ei_module_n
::
!
Int
,
ei_position
::
!
Position
,
ei_symbols
::
![
ImportNrAndIdents
],
ei_qualified
::
!
Bool
}
::
SolvedImports
=
{
si_explicit
::
![([
Declaration
],
Position
)]
,
si_qualified_explicit
::
![([
Declaration
],
ModuleN
,
Position
)]
,
si_implicit
::
![(
ModuleN
,
Position
)]
}
markExplImpSymbols
::
!
Int
!*(!*{!*{!
u
:
ExplImpInfo
}},
!*
SymbolTable
)
->
(!.[
Ident
],!(!{!{!
u
:
ExplImpInfo
}},!.
SymbolTable
))
...
...
@@ -19,10 +26,26 @@ markExplImpSymbols :: !Int !*(!*{!*{!u:ExplImpInfo}}, !*SymbolTable)
updateExplImpForMarkedSymbol
::
!
Index
!
Declaration
!
SymbolTableEntry
!
u
:{#
DclModule
}
!{!{!*
ExplImpInfo
}}
!*
SymbolTable
->
(!
u
:{#
DclModule
},
!{!{!.
ExplImpInfo
}},
!.
SymbolTable
)
solveExplicitImports
::
!(
IntKeyHashtable
[
(
Int
,
Position
,[
ImportNrAndIdents
])
])
!{#
Int
}
!
Index
solveExplicitImports
::
!(
IntKeyHashtable
[
ExplicitImport
])
!{#
Int
}
!
Index
!*(!
v
:{#
DclModule
},!*{#
Int
},!{!*
ExplImpInfo
},!*
CheckState
)
->
(!.
SolvedImports
,!
(!
v
:{#
DclModule
},!.{#
Int
},!{!.
ExplImpInfo
},!.
CheckState
))
checkExplicitImportCompleteness
::
![([
Declaration
],
Position
)]
!*{#
DclModule
}
!*{#
FunDef
}
!*{#*{#
FunDef
}}
!*
ExpressionHeap
!*
CheckState
->
(!.{#
DclModule
},!.{#
FunDef
},!*{#*{#
FunDef
}},!.
ExpressionHeap
,!.
CheckState
)
checkExplicitImportCompleteness
::
![([
Declaration
],
Position
)]
![([
Declaration
],
Int
,
Position
)]
!*{#
DclModule
}
!*{#
FunDef
}
!*{#*{#
FunDef
}}
!*
ExpressionHeap
!*
CheckState
->
(!.{#
DclModule
},!.{#
FunDef
},!*{#*{#
FunDef
}},!.
ExpressionHeap
,!.
CheckState
)
store_qualified_explicit_imports_in_symbol_table
::
![([
Declaration
],
Int
,
Position
)]
![(
SymbolPtr
,
STE_Kind
)]
!*
SymbolTable
*{#
DclModule
}
->
(![(
SymbolPtr
,
STE_Kind
)],!*
SymbolTable
,!*{#
DclModule
})
::
NameSpaceN
:==
Int
ExpressionNameSpaceN
:==
0
TypeNameSpaceN
:==
1
ClassNameSpaceN
:==
2
FieldNameSpaceN
:==
3
OtherNameSpaceN
:==
4
search_qualified_ident
::
!
Ident
{#
Char
}
!
NameSpaceN
!*
CheckState
->
(!
Bool
,!
DeclarationRecord
,!*
CheckState
)
search_qualified_import
::
!
String
!
SortedQualifiedImports
!
NameSpaceN
->
(!
Bool
,!
DeclarationRecord
)
search_qualified_imports
::
!
String
!
SortedQualifiedImports
!
NameSpaceN
->
[
DeclarationRecord
]
restore_module_ste_kinds_in_symbol_table
::
![(
SymbolPtr
,
STE_Kind
)]
!*
SymbolTable
->
*
SymbolTable
frontend/explicitimports.icl
View file @
6af73849
This diff is collapsed.
Click to expand it.
frontend/frontend.icl
View file @
6af73849
...
...
@@ -65,7 +65,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
select_and_remove_icl_functions_from_record
::
!*
IclModule
->
(!.{#
FunDef
},!.
IclModule
)
select_and_remove_icl_functions_from_record
icl_mod
=:{
icl_functions
}
=
(
icl_functions
,{
icl_mod
&
icl_functions
={}})
#
{
icl_common
,
icl_function_indices
,
icl_name
,
icl_import
,
icl_imported_objects
,
#
{
icl_common
,
icl_function_indices
,
icl_name
,
icl_import
,
icl_
qualified_imports
,
icl_
imported_objects
,
icl_foreign_exports
,
icl_used_module_numbers
,
icl_copied_from_dcl
}
=
icl_mod
/*
(_,f,files) = fopen "components" FWriteText files
...
...
@@ -167,7 +167,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
=
(
No
,{},{},
main_dcl_module_n
,
predef_symbols
,
hash_table
,
files
,
error
,
io
,
out
,
tcl_file
,
heaps
)
#
(
ok
,
fun_defs
,
array_instances
,
common_defs
,
imported_funs
,
type_def_infos
,
heaps
,
predef_symbols
,
error
,
out
)
=
typeProgram
(
components
-*->
"Typing"
)
main_dcl_module_n
fun_defs
icl_function_indices
.
ifi_specials_indices
list_inferred_types
icl_common
[
a
\\
a
<-:
icl
_import
]
dcl_mods
icl_used_module_numbers
td_infos
heaps
predef_symbols
error
out
dcl_mods
=
typeProgram
(
components
-*->
"Typing"
)
main_dcl_module_n
fun_defs
icl_function_indices
.
ifi_specials_indices
list_inferred_types
icl_common
icl_import
icl_qualified
_import
s
dcl_mods
icl_used_module_numbers
td_infos
heaps
predef_symbols
error
out
|
not
ok
=
(
No
,{},{},
main_dcl_module_n
,
predef_symbols
,
hash_table
,
files
,
error
,
io
,
out
,
tcl_file
,
heaps
)
...
...
@@ -289,8 +289,8 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules cached_dcl_m
#
heaps
=
{
hp_var_heap
=
var_heap
,
hp_expression_heap
=
expression_heap
,
hp_type_heaps
=
type_heaps
,
hp_generic_heap
=
heaps
.
hp_generic_heap
}
#
fe
={
fe_icl
=
{
icl_functions
=
fun_defs
,
icl_function_indices
=
icl_function_indices
,
icl_common
=
icl_common
,
icl_import
=
icl_import
,
icl_
imported_objects
=
icl_imported_objects
,
icl_
foreign_exports
=
icl_foreign_expor
ts
,
icl_name
=
icl_name
,
icl_used_module_numbers
=
icl_used_module_numbers
,
icl_import
=
icl_import
,
icl_
qualified_imports
=
icl_qualified_imports
,
icl_imported_objects
=
icl_
imported_objec
ts
,
icl_foreign_exports
=
icl_foreign_exports
,
icl_name
=
icl_name
,
icl_used_module_numbers
=
icl_used_module_numbers
,
icl_copied_from_dcl
=
icl_copied_from_dcl
,
icl_modification_time
=
icl_mod
.
icl_modification_time
}
,
fe_dcls
=
dcl_mods
,
fe_components
=
components
...
...
frontend/parse.icl
View file @
6af73849
This diff is collapsed.
Click to expand it.
frontend/postparse.icl
View file @
6af73849
...
...
@@ -349,6 +349,11 @@ where
collectFunctions
e
icl_module
ca
=
(
e
,
ca
)
instance
collectFunctions
FieldNameOrQualifiedFieldName
where
collectFunctions
e
icl_module
ca
=
(
e
,
ca
)
instance
collectFunctions
(
ParsedInstance
a
)
|
collectFunctions
a
where
collectFunctions
inst
=:{
pi_members
}
icl_module
ca
#
(
pi_members
,
ca
)
=
collectFunctions
pi_members
icl_module
ca
...
...
@@ -997,7 +1002,7 @@ transformArrayDenot exprs
scanModules
::
[
ParsedImport
]
[
ScannedModule
]
[
Ident
]
SearchPaths
Bool
Bool
(
ModTimeFunction
*
Files
)
*
Files
*
CollectAdmin
->
(
Bool
,
[
ScannedModule
],*
Files
,
*
CollectAdmin
)
scanModules
[]
parsed_modules
cached_modules
searchPaths
support_generics
support_dynamics
modtimefunction
files
ca
=
(
True
,
parsed_modules
,
files
,
ca
)
scanModules
[{
import_module
,
import_
symbols
,
import_
file_position
}
:
mods
]
parsed_modules
cached_modules
searchPaths
support_generics
support_dynamics
modtimefunction
files
ca
scanModules
[{
import_module
,
import_file_position
}
:
mods
]
parsed_modules
cached_modules
searchPaths
support_generics
support_dynamics
modtimefunction
files
ca
|
in_cache
import_module
cached_modules
=
scanModules
mods
parsed_modules
cached_modules
searchPaths
support_generics
support_dynamics
modtimefunction
files
ca
#
(
found_module
,
mod_type
)
=
try_to_find
import_module
parsed_modules
...
...
@@ -1454,6 +1459,7 @@ reorganiseDefinitionsAndAddTypes mod_ident support_dynamics icl_module defs ca
{
import_module
=
clean_types_module_ident
,
import_symbols
=
[]
,
import_file_position
=
NoPos
,
import_qualified
=
False
}
#
imports
=
if
(
mod_ident
==
clean_types_module_ident
)
[]
[
clean_types_module
]
=
reorganiseDefinitions
icl_module
[
PD_Import
imports
:
defs
]
0
0
0
0
ca
...
...
frontend/scanner.dcl
View file @
6af73849
...
...
@@ -23,6 +23,7 @@ instance <<< FilePosition
::
Token
=
IdentToken
!.
String
// an identifier
|
UnderscoreIdentToken
!.
String
// an identifier that starts with a '_'
|
QualifiedIdentToken
!
String
!.
String
// a qualified identifier
|
IntToken
!.
String
// an integer
|
RealToken
!.
String
// a real
|
StringToken
!.
String
// a string
...
...
frontend/scanner.icl
View file @
6af73849
...
...
@@ -110,6 +110,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4;
::
Token
=
IdentToken
!
.
String
// an identifier
|
UnderscoreIdentToken
!.
String
// an identifier that starts with a '_'
|
QualifiedIdentToken
!
String
!.
String
// a qualified identifier
|
IntToken
!.
String
// an integer
|
RealToken
!.
String
// a real
|
StringToken
!.
String
// a string
...
...
@@ -773,32 +774,75 @@ new_exp_char c = isSpace c
ScanIdentFast
::
!
Int
!
Input
!
ScanContext
->
(!
Token
,
!
Input
)
ScanIdentFast
n
input
=:{
inp_stream
=
OldLine
i
line
stream
,
inp_pos
}
co
#
end_i
=
ScanIdentCharsInString
i
line
co
#
(
end_i
,
qualified
)
=
ScanIdentCharsInString
i
line
co
with
ScanIdentCharsInString
::
!
Int
!{#
Char
}
!
ScanContext
->
Int
ScanIdentCharsInString
::
!
Int
!{#
Char
}
!
ScanContext
->
(!
Int
,!
Bool
)
ScanIdentCharsInString
i
line
co
|
i
<
size
line
&&
IsIdentChar
line
.[
i
]
co
=
ScanIdentCharsInString
(
i
+1
)
line
co
=
i
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
CheckReserved
co
(
line
%
(
i
-
n
,
end_i
-1
))
input
|
i
<
size
line
|
IsIdentChar
line
.[
i
]
co
=
ScanIdentCharsInString
(
i
+1
)
line
co
=
(
i
,
line
.[
i
]==
'@'
)
=
(
i
,
False
)
|
not
qualified
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
CheckReservedIdent
co
(
line
%
(
i
-
n
,
end_i
-1
))
input
#
i2
=
end_i
+1
|
i2
==
size
line
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
CheckReservedIdent
co
(
line
%
(
i
-
n
,
end_i
-1
))
input
#
c
=
line
.[
i2
]
|
IsIdentChar
c
co
#
module_name
=
line
%
(
i
-
n
,
end_i
-1
)
#
end_i
=
ScanIdentCharsInString
(
i2
+1
)
line
co
with
ScanIdentCharsInString
::
!
Int
!{#
Char
}
!
ScanContext
->
Int
ScanIdentCharsInString
i
line
co
|
i
<
size
line
&&
IsIdentChar
line
.[
i
]
co
=
ScanIdentCharsInString
(
i
+1
)
line
co
=
i
#
ident_name
=
line
%
(
i2
,
end_i
-1
)
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
(
QualifiedIdentToken
module_name
ident_name
,
input
)
|
isSpecialChar
c
#
module_name
=
line
%
(
i
-
n
,
end_i
-1
)
#
end_i
=
ScanSpecialCharsInString
(
i2
+1
)
line
with
ScanSpecialCharsInString
::
!
Int
!{#
Char
}
->
Int
ScanSpecialCharsInString
i
line
|
i
<
size
line
&&
isSpecialChar
line
.[
i
]
=
ScanSpecialCharsInString
(
i
+1
)
line
=
i
#
ident_name
=
line
%
(
i2
,
end_i
-1
)
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
(
QualifiedIdentToken
module_name
ident_name
,
input
)
#
pos
=
{
inp_pos
&
fp_col
=
inp_pos
.
fp_col
+
(
end_i
-
i
)}
#
input
=
{
input
&
inp_stream
=
OldLine
end_i
line
stream
,
inp_pos
=
pos
}
=
CheckReservedIdent
co
(
line
%
(
i
-
n
,
end_i
-1
))
input
ScanOperator
::
!
Int
!
Input
![
Char
]
!
ScanContext
->
(!
Token
,
!
Input
)
ScanOperator
n
input
token
co
#
(
eof
,
c
,
input
)
=
ReadNormalChar
input
|
eof
=
CheckReserved
co
(
revCharListToString
n
token
)
input
|
eof
=
CheckReserved
Operator
(
revCharListToString
n
token
)
input
|
isSpecialChar
c
=
ScanOperator
(
n
+
1
)
input
[
c
:
token
]
co
=
CheckReserved
co
(
revCharListToString
n
token
)
(
charBack
input
)
=
CheckReservedOperator
(
revCharListToString
n
token
)
(
charBack
input
)
CheckReservedIdent
::
!
ScanContext
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckReservedIdent
GeneralContext
s
i
=
CheckGeneralContext
s
i
CheckReservedIdent
TypeContext
s
i
=
CheckTypeContext
s
i
CheckReservedIdent
FunctionContext
s
i
=
CheckFunctContext
s
i
CheckReservedIdent
CodeContext
s
i
=
CheckCodeContext
s
i
CheckReservedIdent
GenericContext
s
i
=
CheckGenericContext
s
i
CheckReserved
::
!
ScanContext
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckReserved
GeneralContext
s
i
=
CheckGeneralContext
s
i
CheckReserved
TypeContext
s
i
=
CheckTypeContext
s
i
CheckReserved
FunctionContext
s
i
=
CheckFunctContext
s
i
CheckReserved
CodeContext
s
i
=
CheckCodeContext
s
i
CheckReserved
GenericContext
s
i
=
CheckGenericContext
s
i
CheckReservedOperator
::
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckReservedOperator
"!"
input
=
(
ExclamationToken
,
input
)
CheckReservedOperator
"*/"
input
=
(
ErrorToken
"Unexpected end of comment, */"
,
input
)
CheckReservedOperator
s
input
=
(
IdentToken
s
,
input
)
CheckGeneralContext
::
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckGeneralContext
::
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckGeneralContext
s
input
=
case
s
of
"module"
->
(
ModuleToken
,
input
)
...
...
@@ -819,8 +863,6 @@ CheckEveryContext s input
"generic"
->
(
GenericToken
,
input
)
"derive"
->
(
DeriveToken
,
input
)
"otherwise"
->
(
OtherwiseToken
,
input
)
"!"
->
(
ExclamationToken
,
input
)
"*/"
->
(
ErrorToken
"Unexpected end of comment, */"
,
input
)
"infixr"
#
(
error
,
n
,
input
)
=
GetPrio
input
->
case
error
of
Yes
err
->
(
ErrorToken
err
,
input
)
//-->> ("Error token generated: "+err)
...
...
@@ -1424,6 +1466,8 @@ where
toString
EndOfFileToken
=
"end of file"
toString
(
ErrorToken
id
)
=
"Scanner error: "
+
id
toString
(
QualifiedIdentToken
module_name
ident_name
)
=
module_name
+++
"@"
+++
ident_name
toString
GenericToken
=
"generic"
toString
DeriveToken
=
"derive"
toString
GenericOpenToken
=
"{|"
...
...
@@ -1451,6 +1495,8 @@ where
equal_args_of_tokens
(
LetToken
l1
)
(
LetToken
l2
)
=
l1
==
l2
equal_args_of_tokens
(
SeqLetToken
l1
)
(
SeqLetToken
l2
)
=
l1
==
l2
equal_args_of_tokens
(
ErrorToken
id1
)
(
ErrorToken
id2
)
=
id1
==
id2
equal_args_of_tokens
(
QualifiedIdentToken
module_name1
ident_name1
)
(
QualifiedIdentToken
module_name2
ident_name2
)
=
ident_name1
==
ident_name2
&&
module_name1
==
module_name2
equal_args_of_tokens
_
_
=
True
/* Sjaak ... */
...
...
frontend/syntax.dcl
View file @
6af73849
...
...
@@ -48,10 +48,11 @@ instance == FunctionOrMacroIndex
|
STE_TypeVariable
!
TypeVarInfoPtr
|
STE_TypeAttribute
!
AttrVarInfoPtr
|
STE_BoundTypeVariable
!
STE_BoundTypeVariable
|
STE_Imported
!
STE_Kind
!
Index
|
STE_Imported
!
STE_Kind
!
ModuleN
|
STE_DclFunction
|
STE_Module
!(
Module
(
CollectedDefinitions
ClassInstance
IndexRange
))
|
STE_ClosedModule
|
STE_ModuleQualifiedImports
!
SortedQualifiedImports
|
STE_Empty
/* for creating class dictionaries */
|
STE_DictType
!
CheckedTypeDef
...
...
@@ -64,14 +65,19 @@ instance == FunctionOrMacroIndex
the "actual" dcl module.
*/
|
STE_BelongingSymbol
!
Int
|
STE_ExplImpSymbolNotImported
!
ModuleN