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
00b04d8a
Commit
00b04d8a
authored
Apr 11, 2002
by
Artem Alimarine
Browse files
support for generic type context like in
foo :: a a -> Bool | eq{|*|} a
parent
017accb7
Changes
26
Hide whitespace changes
Inline
Side-by-side
backend/backendconvert.icl
View file @
00b04d8a
...
...
@@ -15,7 +15,7 @@ import backendsupport, backendpreprocess
// trace macro
(-*->)
infixl
(-*->)
value
trace
:==
value
//
---> trace
:==
value
//---> trace
/*
sfoldr op r l
:== foldr l
...
...
@@ -1257,10 +1257,10 @@ convertRules rules main_dcl_module_n aliasDummyId be
=
convert
t
rulesP
be
convertRule
::
Ident
(
Int
,
FunDef
)
Int
->
BEMonad
BEImpRuleP
convertRule
aliasDummyId
(
index
,
{
fun_type
=
Yes
type
,
fun_body
=
body
,
fun_pos
,
fun_kind
,
fun_symb
})
main_dcl_module_n
convertRule
aliasDummyId
(
index
,
{
fun_type
=
Yes
type
,
fun_body
=
body
,
fun_pos
,
fun_kind
,
fun_symb
,
fun_info
})
main_dcl_module_n
// | trace_tn fun_symb.id_name
=
beRule
index
(
cafness
fun_kind
)
(
convertTypeAlt
index
main_dcl_module_n
(
type
-*->
(
"convertRule"
,
fun_symb
.
id_name
,
index
,
type
)))
(
convertTypeAlt
index
main_dcl_module_n
(
type
-*->
(
"convertRule"
,
fun_symb
.
id_name
,
index
,
type
,
(
fun_info
.
fi_group_index
,
body
)
)))
(
convertFunctionBody
index
(
positionToLineNumber
fun_pos
)
aliasDummyId
body
main_dcl_module_n
)
where
cafness
::
FunKind
->
Int
...
...
backend/backendinterface.icl
View file @
00b04d8a
...
...
@@ -385,7 +385,7 @@ where
=
([
type
:
reversedTypes
],
reversedContexts
)
dictionary_to_context
klass
args
=
{
tc_class
=
klass
,
tc_types
=
[
at_type
\\
{
at_type
}
<-
args
],
tc_var
=
nilPtr
}
=
{
tc_class
=
TCClass
klass
,
tc_types
=
[
at_type
\\
{
at_type
}
<-
args
],
tc_var
=
nilPtr
}
typeToClass
::
DictionaryToClassInfo
TypeSymbIdent
->
Optional
(
Global
DefinedSymbol
)
typeToClass
info
{
type_name
,
type_arity
,
type_index
={
glob_module
,
glob_object
}}
...
...
frontend/StdCompare.dcl
View file @
00b04d8a
...
...
@@ -15,7 +15,7 @@ instance =< Type, SymbIdent
instance
==
BasicType
,
TypeVar
,
AttributeVar
,
AttrInequality
,
TypeSymbIdent
,
DefinedSymbol
,
TypeContext
,
BasicValue
,
FunKind
,
(
Global
a
)
|
==
a
,
Priority
,
Assoc
,
Type
,
ConsVariable
,
SignClassification
,
TypeCons
ConsVariable
,
SignClassification
,
TypeCons
,
TCClass
instance
<
MemberDef
...
...
frontend/StdCompare.icl
View file @
00b04d8a
...
...
@@ -48,6 +48,14 @@ instance == TypeContext
where
(==)
tc1
tc2
=
tc1
.
tc_class
==
tc2
.
tc_class
&&
tc1
.
tc_types
==
tc2
.
tc_types
instance
==
TCClass
where
(==)
(
TCClass
x
)
(
TCClass
y
)
=
x
==
y
(==)
(
TCGeneric
{
gtc_class
})
(
TCClass
y
)
=
gtc_class
==
y
(==)
(
TCClass
x
)
(
TCGeneric
{
gtc_class
})
=
x
==
gtc_class
(==)
(
TCGeneric
{
gtc_generic
=
g1
,
gtc_kind
=
k1
})
(
TCGeneric
{
gtc_generic
=
g2
,
gtc_kind
=
k2
})
=
g1
==
g2
&&
k1
==
k2
instance
==
BasicType
where
(==)
bt1
bt2
=
equal_constructor
bt1
bt2
...
...
frontend/analtypes.icl
View file @
00b04d8a
...
...
@@ -681,12 +681,17 @@ determine_kinds_of_type_contexts modules type_contexts class_infos as
=
foldSt
(
determine_kinds_of_type_context
modules
)
type_contexts
(
class_infos
,
as
)
where
determine_kinds_of_type_context
::
!{#
CommonDefs
}
!
TypeContext
!(!*
ClassDefInfos
,
!*
AnalyseState
)
->
(!*
ClassDefInfos
,
!*
AnalyseState
)
determine_kinds_of_type_context
modules
{
tc_class
={
glob_module
,
glob_object
={
ds_ident
,
ds_index
}},
tc_types
}
(
class_infos
,
as
)
determine_kinds_of_type_context
modules
{
tc_class
=
TCClass
{
glob_module
,
glob_object
={
ds_ident
,
ds_index
}},
tc_types
}
(
class_infos
,
as
)
#
(
class_kinds
,
class_infos
)
=
class_infos
![
glob_module
,
ds_index
]
|
length
class_kinds
==
length
tc_types
#
as
=
fold2St
(
verify_kind_of_type
modules
)
class_kinds
tc_types
as
=
(
class_infos
,
as
)
=
abort
(
"determine_kinds_of_type_context"
--->
(
ds_ident
,
class_kinds
,
tc_types
))
determine_kinds_of_type_context
modules
{
tc_class
=
TCGeneric
{
gtc_generic
,
gtc_kind
},
tc_types
}
(
class_infos
,
as
)
|
length
tc_types
==
1
#
as
=
verify_kind_of_type
modules
gtc_kind
(
hd
tc_types
)
as
=
(
class_infos
,
as
)
=
abort
(
"determine_kinds_of_type_context"
--->
(
gtc_generic
.
glob_object
.
ds_ident
,
gtc_kind
,
tc_types
))
verify_kind_of_type
modules
req_kind
type
as
#
(
kind_of_type
,
as
=:{
as_kind_heap
,
as_error
})
=
determineKind
modules
type
as
...
...
@@ -772,8 +777,10 @@ where
determine_kinds_of_context_classes
contexts
class_infos_and_as
=
foldSt
(
determine_kinds_of_context_class
modules
)
contexts
class_infos_and_as
where
determine_kinds_of_context_class
modules
{
tc_class
={
glob_module
,
glob_object
={
ds_index
}}}
infos_and_as
determine_kinds_of_context_class
modules
{
tc_class
=
TCClass
{
glob_module
,
glob_object
={
ds_index
}}}
infos_and_as
=
determine_kinds_of_class
modules
glob_module
ds_index
infos_and_as
determine_kinds_of_context_class
modules
{
tc_class
=
TCGeneric
{
gtc_kind
}}
infos_and_as
=
infos_and_as
bind_kind_vars
type_vars
kind_ptrs
type_var_heap
=
fold2St
bind_kind_var
type_vars
kind_ptrs
type_var_heap
...
...
@@ -880,7 +887,7 @@ where
(
as_type_var_heap
,
as_kind_heap
)
=
bindFreshKindVariablesToTypeVars
it_vars
as_type_var_heap
as_kind_heap
as
=
{
as
&
as_type_var_heap
=
as_type_var_heap
,
as_kind_heap
=
as_kind_heap
,
as_error
=
as_error
}
(
class_infos
,
as
)
=
determine_kinds_of_type_contexts
common_defs
[{
tc_class
=
ins_class
,
tc_types
=
it_types
,
tc_var
=
nilPtr
}
:
it_context
]
class_infos
as
[{
tc_class
=
TCClass
ins_class
,
tc_types
=
it_types
,
tc_var
=
nilPtr
}
:
it_context
]
class_infos
as
=
(
class_infos
,
{
as
&
as_error
=
popErrorAdmin
as
.
as_error
})
check_kinds_of_generics
common_defs
index
generic_defs
class_infos
gen_heap
as
...
...
frontend/check.icl
View file @
00b04d8a
...
...
@@ -884,7 +884,7 @@ checkAndCollectTypesOfContextsOfSpecials :: [TypeContext] *PredefinedSymbols *Er
checkAndCollectTypesOfContextsOfSpecials
type_contexts
predef_symbols
error
=
mapSt2
check_and_collect_context_types_of_special
type_contexts
predef_symbols
error
where
check_and_collect_context_types_of_special
{
tc_class
={
glob_object
={
ds_ident
,
ds_index
},
glob_module
},
tc_types
}
predef_symbols
error
check_and_collect_context_types_of_special
{
tc_class
=
TCClass
{
glob_object
={
ds_ident
,
ds_index
},
glob_module
},
tc_types
}
predef_symbols
error
|
hasNoTypeVariables
tc_types
=
(
tc_types
,
predef_symbols
,
error
)
#
{
pds_def
,
pds_module
}
=
predef_symbols
.[
PD_ArrayClass
]
...
...
@@ -894,6 +894,8 @@ where
|
glob_module
==
pds_module
&&
ds_index
==
pds_def
&&
is_lazy_or_strict_list
tc_types
predef_symbols
=
(
tc_types
,
predef_symbols
,
error
)
=
(
tc_types
,
predef_symbols
,
checkError
ds_ident
.
id_name
"illegal specialization"
error
)
check_and_collect_context_types_of_special
{
tc_class
=
TCGeneric
{
gtc_generic
},
tc_types
}
predef_symbols
error
=
(
tc_types
,
predef_symbols
,
checkError
gtc_generic
.
glob_object
.
ds_ident
.
id_name
"genenric specials are illegal"
error
)
hasNoTypeVariables
[]
=
True
...
...
@@ -3408,6 +3410,7 @@ where
<=<
adjustPredefSymbol
PD_ConsRIGHT
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_GenericBimap
mod_index
STE_Generic
<=<
adjustPredefSymbol
PD_bimapId
mod_index
STE_DclFunction
<=<
adjustPredefSymbol
PD_TypeGenericDict
mod_index
STE_Type
)
#
(
pre_mod
,
cs_predef_symbols
)
=
cs_predef_symbols
![
PD_StdMisc
]
|
pre_mod
.
pds_def
==
mod_index
...
...
frontend/checktypes.icl
View file @
00b04d8a
...
...
@@ -3,7 +3,7 @@ implementation module checktypes
import
StdEnv
import
syntax
,
checksupport
,
check
,
typesupport
,
utilities
,
compilerSwitches
// , RWSDebug
import
genericsupport
::
TypeSymbols
=
{
ts_type_defs
::
!.{#
CheckedTypeDef
}
...
...
@@ -671,9 +671,11 @@ checkInstanceType mod_index ins_class it=:{it_types,it_context} specials type_de
where
is_type_var
(
TV
_)
=
True
is_type_var
_
=
False
compare_context_and_instance_types
ins_class
it_types
{
tc_class
,
tc_types
}
cs_error
|
ins_class
<>
tc_class
compare_context_and_instance_types
ins_class
it_types
{
tc_class
=
TCGeneric
_,
tc_types
}
cs_error
=
cs_error
compare_context_and_instance_types
ins_class
it_types
{
tc_class
=
TCClass
clazz
,
tc_types
}
cs_error
|
ins_class
<>
clazz
=
cs_error
#
are_equal
=
fold2St
compare_context_and_instance_type
it_types
tc_types
True
...
...
@@ -807,76 +809,59 @@ where
checkTypeContext
::
!
Index
!
TypeContext
!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
)
->
(!
TypeContext
,!(!
v
:{#
ClassDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
))
checkTypeContext
mod_index
tc
=:{
tc_class
=
tc_class
=:{
glob_object
=
class_name
=:{
ds_ident
=
ds_ident
=:{
id_name
,
id_info
},
ds_arity
}},
tc_types
}
(
class_defs
,
ots
,
oti
,
cs
=:{
cs_symbol_table
,
cs_predef_symbols
})
#
(
entry
,
cs_symbol_table
)
=
readPtr
id_info
cs_symbol_table
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
#
(
class_index
,
class_module
)
=
retrieveGlobalDefinition
entry
STE_Class
mod_index
|
class_index
<>
NotFound
#
(
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
}
(
tc_types
,
(
ots
,
oti
,
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
cs
=
check_context_types
class_def
.
class_name
tc_types
cs
tc
=
{
tc
&
tc_class
=
{
tc_class
&
glob_object
=
{
class_name
&
ds_index
=
class_index
},
glob_module
=
class_module
},
tc_types
=
tc_types
}
|
class_def
.
class_arity
==
ds_arity
=
(
tc
,
(
class_defs
,
ots
,
oti
,
cs
))
=
(
tc
,
(
class_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"used with wrong arity"
cs
.
cs_error
}))
=
({
tc
&
tc_types
=
[]},
(
class_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"undefined"
cs
.
cs_error
}))
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
)
|
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_types
tc_class
[]
cs
=:{
cs_error
}
=
{
cs
&
cs_error
=
checkError
tc_class
"type context should contain one or more type variables"
cs_error
}
check_context_types
tc_class
[((
CV
{
tv_name
})
:@:
_):_]
cs
=:{
cs_error
}
=
cs
// = { cs & cs_error = checkError tv_name "not allowed as higher order type variable in context" cs_error}
check_context_types
tc_class
[
TV
_
:
types
]
cs
=
cs
check_context_types
tc_class
[
type
:
types
]
cs
=
check_context_types
tc_class
types
cs
checkTypeContext1
::
!
Index
!
TypeContext
!(!
v
:{#
ClassDef
},
!
x
:{#
GenericDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
)
->
(!
TypeContext
,!(!
v
:{#
ClassDef
},
!
x
:{#
GenericDef
},
!
u
:
OpenTypeSymbols
,
!*
OpenTypeInfo
,
!*
CheckState
))
checkTypeContext1
mod_index
tc
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
)
#
(
entry
,
cs
)
=
get_entry
tc
cs
=
check_context
mod_index
entry
tc
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
)
where
get_entry
tc
cs
=:{
cs_symbol_table
}
#
(
entry
,
cs_symbol_table
)
=
readPtr
tc
.
tc_class
.
glob_object
.
ds_ident
.
id_info
cs_symbol_table
=
(
entry
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
check_context
mod_index
entry
tc
=:{
tc_class
=
tc_class
=:{
glob_object
=
class_name
=:{
ds_ident
=
ds_ident
=:{
id_name
,
id_info
},
ds_arity
}},
tc_types
}
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
)
check_context_class
(
TCClass
cl
)
(
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
|
class_index
<>
NotFound
#
(
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
}
(
tc_types
,
(
ots
,
oti
,
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
cs
=
check_context_types
class_def
.
class_name
tc_types
cs
tc
=
{
tc
&
tc_class
=
{
tc_class
&
glob_object
=
{
class_name
&
ds_index
=
class_index
},
glob_module
=
class_module
},
tc_types
=
tc_types
}
|
class_def
.
class_arity
==
ds_arity
=
(
tc
,
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
))
=
(
tc
,
(
class_defs
,
generic_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"used with wrong arity"
cs
.
cs_error
}))
=
({
tc
&
tc_types
=
[]},
(
class_defs
,
generic_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"class undefined"
cs
.
cs_error
}))
check_context
mod_index
entry
tc
=:{
tc_class
=
tc_class
=:{
glob_object
=
class_name
=:{
ds_ident
=
ds_ident
=:{
id_name
,
id_info
},
ds_arity
}},
tc_types
}
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
)
#
(
generic_index
,
generic_module
)
=
retrieveGlobalDefinition
entry
STE_Generic
mod_index
#
ots
=
{
ots
&
ots_modules
=
ots_modules
}
|
class_def
.
class_arity
==
cl
.
glob_object
.
ds_arity
#
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
)
#
gen_name
=
gtc_generic
.
glob_object
.
ds_ident
#
(
entry
,
cs_symbol_table
)
=
readPtr
gen_name
.
id_info
cs
.
cs_symbol_table
#
cs
=
{
cs
&
cs_symbol_table
=
cs_symbol_table
}
#
clazz
=
{
glob_module
=
-1
,
glob_object
=
{
ds_ident
=
genericIdentToClassIdent
gen_name
gtc_kind
,
ds_arity
=
1
,
ds_index
=
-1
}
}
#
(
generic_index
,
generic_module
)
=
retrieveGlobalDefinition
entry
STE_Generic
mod_index
|
generic_index
<>
NotFound
#
(
generic_def
,
generic_index
,
generic_defs
,
ots_modules
)
=
getGenericDef
generic_index
generic_module
mod_index
generic_defs
ots
.
ots_modules
ots
=
{
ots
&
ots_modules
=
ots_modules
}
(
tc_types
,
(
ots
,
oti
,
cs
))
=
checkOpenTypes
mod_index
cGlobalScope
DAK_Ignore
tc_types
(
ots
,
oti
,
cs
)
//cs = check_context_types generic_def.gen_name tc_types cs
tc
=
{
tc
&
tc_class
=
{
tc_class
&
glob_object
=
{
class_name
&
ds_index
=
generic_index
},
glob_module
=
generic_module
},
tc_types
=
tc_types
}
|
ds_arity
==
1
=
(
tc
,
(
class_defs
,
generic_defs
,
ots
,
oti
,
cs
))
=
(
tc
,
(
class_defs
,
generic_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"used with wrong arity"
cs
.
cs_error
}))
=
({
tc
&
tc_types
=
[]},
(
class_defs
,
generic_defs
,
ots
,
oti
,
{
cs
&
cs_error
=
checkError
id_name
"generic undefined"
cs
.
cs_error
}))
|
gtc_generic
.
glob_object
.
ds_arity
==
1
#
checked_gen
=
{
glob_module
=
generic_module
,
glob_object
=
{
gtc_generic
.
glob_object
&
ds_index
=
generic_index
}
}
=
(
TCGeneric
{
gtc
&
gtc_generic
=
checked_gen
,
gtc_class
=
clazz
},
(
class_defs
,
ots
,
cs
))
#
cs_error
=
checkError
gen_name
"generic used with wrong arity: generic has always has one class argument"
cs
.
cs_error
=
(
TCGeneric
{
gtc
&
gtc_class
=
clazz
},
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
#
cs_error
=
checkError
gen_name
"generic undefined"
cs
.
cs_error
=
(
TCGeneric
{
gtc
&
gtc_class
=
clazz
},
(
class_defs
,
ots
,
{
cs
&
cs_error
=
cs_error
}))
check_context_types
tc_class
[]
cs
=:{
cs_error
}
=
{
cs
&
cs_error
=
checkError
tc_class
"type context should contain one or more type variables"
cs_error
}
check_context_types
tc_class
[((
CV
{
tv_name
})
:@:
_):_]
cs
=:{
cs_error
}
...
...
@@ -887,6 +872,7 @@ where
check_context_types
tc_class
[
type
:
types
]
cs
=
check_context_types
tc_class
types
cs
checkTypeContexts
::
![
TypeContext
]
!
Index
!
v
:{#
ClassDef
}
!
u
:
OpenTypeSymbols
!*
OpenTypeInfo
!*
CheckState
->
(![
TypeContext
],
!
u
:{#
CheckedTypeDef
},
!
v
:{#
ClassDef
},
u
:{#
DclModule
},
!*
TypeHeaps
,
!*
CheckState
)
checkTypeContexts
tcs
mod_index
class_defs
ots
oti
cs
...
...
@@ -1412,7 +1398,7 @@ where
[
field
:
rev_fields
]
var_heap
symbol_table
=
(
rev_fields
,
var_heap
,
symbol_table
)
build_context_fields
mod_index
field_nr
[{
tc_class
=
{
glob_module
,
glob_object
={
ds_index
}}}:
tcs
]
rec_type
rec_type_index
build_context_fields
mod_index
field_nr
[{
tc_class
=
TCClass
{
glob_module
,
glob_object
={
ds_index
}}}:
tcs
]
rec_type
rec_type_index
next_selector_index
rev_fields
rev_field_types
class_defs
modules
var_heap
symbol_table
#
({
class_name
,
class_arity
,
class_dictionary
=
{
ds_ident
,
ds_index
}},
_,
class_defs
,
modules
)
=
getClassDef
ds_index
glob_module
mod_index
class_defs
modules
type_symb
=
MakeTypeSymbIdent
{
glob_object
=
ds_index
,
glob_module
=
glob_module
}
ds_ident
class_arity
...
...
@@ -1432,6 +1418,17 @@ where
(
field
,
var_heap
,
symbol_table
)
=
build_field
field_nr
class_name
.
id_name
rec_type_index
rec_type
field_type
next_selector_index
var_heap
symbol_table
=
build_context_fields
mod_index
(
inc
field_nr
)
tcs
rec_type
rec_type_index
(
inc
next_selector_index
)
[
field
:
rev_fields
]
[
field_type
:
rev_field_types
]
class_defs
modules
var_heap
symbol_table
build_context_fields
mod_index
field_nr
[{
tc_class
=
TCGeneric
{
gtc_generic
,
gtc_kind
}}
:
tcs
]
rec_type
rec_type_index
next_selector_index
rev_fields
rev_field_types
class_defs
modules
var_heap
symbol_table
// FIXME: We do not know the type before the generic phase.
// The generic phase currently does not update the type.
#
field_type
=
makeAttributedType
TA_Multi
TE
#
class_name
=
genericIdentToClassIdent
gtc_generic
.
glob_object
.
ds_ident
gtc_kind
#
(
field
,
var_heap
,
symbol_table
)
=
build_field
field_nr
class_name
.
id_name
rec_type_index
rec_type
field_type
next_selector_index
var_heap
symbol_table
=
build_context_fields
mod_index
(
inc
field_nr
)
tcs
rec_type
rec_type_index
(
inc
next_selector_index
)
[
field
:
rev_fields
]
[
field_type
:
rev_field_types
]
class_defs
modules
var_heap
symbol_table
build_context_fields
mod_index
field_nr
[]
rec_type
rec_type_index
next_selector_index
rev_fields
rev_field_types
class_defs
modules
var_heap
symbol_table
=
(
next_selector_index
,
rev_fields
,
rev_field_types
,
class_defs
,
modules
,
var_heap
,
symbol_table
)
...
...
frontend/comparedefimp.icl
View file @
00b04d8a
...
...
@@ -724,6 +724,15 @@ instance t_corresponds TypeContext where
=
t_corresponds
dclDef
.
tc_class
iclDef
.
tc_class
&&&
t_corresponds
dclDef
.
tc_types
iclDef
.
tc_types
instance
t_corresponds
TCClass
where
t_corresponds
(
TCClass
class1
)
(
TCClass
class2
)
=
t_corresponds
class1
class2
t_corresponds
(
TCGeneric
{
gtc_generic
=
gen1
,
gtc_kind
=
kind1
})
(
TCGeneric
{
gtc_generic
=
gen2
,
gtc_kind
=
kind2
})
=
t_corresponds
gen1
gen2
&&&
equal
kind1
kind2
t_corresponds
_
_
=
return
False
instance
t_corresponds
DefinedSymbol
where
t_corresponds
dclDef
iclDef
=
equal
dclDef
.
ds_ident
iclDef
.
ds_ident
...
...
frontend/convertimportedtypes.icl
View file @
00b04d8a
...
...
@@ -10,9 +10,16 @@ convertDclModule main_dcl_module_n dcl_mods common_defs imported_types imported_
#
{
dcl_functions
,
dcl_common
=
dcl_common
=:{
com_type_defs
,
com_cons_defs
,
com_selector_defs
},
dcl_macro_conversions
}
=
dcl_mods
.[
main_dcl_module_n
]
=
case
dcl_macro_conversions
of
Yes
_
#
(
icl_type_defs
,
imported_types
)
=
imported_types
![
main_dcl_module_n
]
#!(
icl_type_defs
,
imported_types
)
=
imported_types
![
main_dcl_module_n
]
common_defs
=
{
common
\\
common
<-:
common_defs
}
common_defs
=
{
common_defs
&
[
main_dcl_module_n
]
=
dcl_common
}
/*
// AA: HACK: extend dcl modules with the icl module
icl_common = common_defs.[main_dcl_module_n]
common_defs = arrayPlusList common_defs [icl_common]
common_defs = { common_defs & [main_dcl_module_n] = dcl_common }
*/
types_and_heaps
=
convert_dcl_functions
dcl_functions
common_defs
(
{
imported_types
&
[
main_dcl_module_n
]
=
com_type_defs
},
imported_conses
,
var_heap
,
type_heaps
)
types_and_heaps
=
convertConstructorTypes
com_cons_defs
main_dcl_module_n
common_defs
types_and_heaps
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
=
convertSelectorTypes
com_selector_defs
main_dcl_module_n
common_defs
types_and_heaps
...
...
@@ -24,7 +31,7 @@ where
=
iFoldSt
(
convert_dcl_function
dcl_functions
common_defs
)
0
(
size
dcl_functions
)
types_and_heaps
convert_dcl_function
dcl_functions
common_defs
dcl_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
ft_type
,
ft_type_ptr
}
=
dcl_functions
.[
dcl_index
]
#
!
{
ft_type
,
ft_type_ptr
,
ft_symb
}
=
dcl_functions
.[
dcl_index
]
(
ft_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
cDontRemoveAnnotations
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
ft_type_ptr
,
VI_ExpandedType
ft_type
),
type_heaps
)
...
...
@@ -33,7 +40,7 @@ convertConstructorTypes cons_defs main_dcl_module_n common_defs types_and_heaps
=
iFoldSt
(
convert_constructor_type
common_defs
cons_defs
)
0
(
size
cons_defs
)
types_and_heaps
where
convert_constructor_type
common_defs
cons_defs
cons_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
cons_type_ptr
,
cons_type
}
=
cons_defs
.[
cons_index
]
#
!
{
cons_type_ptr
,
cons_type
,
cons_symb
}
=
cons_defs
.[
cons_index
]
(
cons_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
cDontRemoveAnnotations
common_defs
cons_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
cons_type_ptr
,
VI_ExpandedType
cons_type
),
type_heaps
)
...
...
@@ -42,7 +49,7 @@ convertSelectorTypes selector_defs main_dcl_module_n common_defs types_and_heaps
=
iFoldSt
(
convert_selector_type
common_defs
selector_defs
)
0
(
size
selector_defs
)
types_and_heaps
where
convert_selector_type
common_defs
selector_defs
sel_index
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
{
sd_type_ptr
,
sd_type
}
=
selector_defs
.[
sel_index
]
#
!
{
sd_type_ptr
,
sd_type
,
sd_symb
}
=
selector_defs
.[
sel_index
]
(
sd_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
cDontRemoveAnnotations
common_defs
sd_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
var_heap
<:=
(
sd_type_ptr
,
VI_ExpandedType
sd_type
),
type_heaps
)
...
...
@@ -50,7 +57,7 @@ where
convertIclModule
::
!
Int
!{#
CommonDefs
}
!*{#{#
CheckedTypeDef
}}
!
ImportedConstructors
!*
VarHeap
!*
TypeHeaps
->
(!*{#{#
CheckedTypeDef
}},
!
ImportedConstructors
,
!*
VarHeap
,
!*
TypeHeaps
)
convertIclModule
main_dcl_module_n
common_defs
imported_types
imported_conses
var_heap
type_heaps
#
types_and_heaps
=
convertConstructorTypes
common_defs
.[
main_dcl_module_n
].
com_cons_defs
main_dcl_module_n
common_defs
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
#
!
types_and_heaps
=
convertConstructorTypes
common_defs
.[
main_dcl_module_n
].
com_cons_defs
main_dcl_module_n
common_defs
(
imported_types
,
imported_conses
,
var_heap
,
type_heaps
)
=
convertSelectorTypes
common_defs
.[
main_dcl_module_n
].
com_selector_defs
main_dcl_module_n
common_defs
types_and_heaps
convertImportedTypeSpecifications
::
!
Int
!{#
DclModule
}
!{#
{#
FunType
}
}
!{#
CommonDefs
}
!
ImportedConstructors
!
ImportedFunctions
...
...
@@ -62,7 +69,7 @@ convertImportedTypeSpecifications main_dcl_module_n dcl_mods dcl_functions commo
#
abstract_type_indexes
=
iFoldSt
(
determine_abstract_type
com_type_defs
)
0
(
size
com_type_defs
)
[]
|
isEmpty
abstract_type_indexes
->
convert_imported_type_specs
dcl_functions
common_defs
imported_conses
imported_functions
imported_types
type_heaps
var_heap
#
(
icl_type_defs
,
imported_types
)
=
imported_types
![
main_dcl_module_n
]
#
!
(
icl_type_defs
,
imported_types
)
=
imported_types
![
main_dcl_module_n
]
type_defs
=
foldSt
(
insert_abstract_type
/*conversion_table.[cTypeDefs]*/
)
abstract_type_indexes
{
icl_type_def
\\
icl_type_def
<-:
icl_type_defs
}
(
imported_types
,
type_heaps
,
var_heap
)
=
convert_imported_type_specs
dcl_functions
common_defs
imported_conses
imported_functions
...
...
@@ -93,21 +100,21 @@ where
=
convert_imported_constructors
common_defs
imported_conses
imported_types
type_heaps
var_heap
convert_imported_function
dcl_functions
common_defs
{
glob_object
,
glob_module
}
(
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
#
{
ft_type_ptr
,
ft_type
}
=
dcl_functions
.[
glob_module
].[
glob_object
]
#
!
{
ft_type_ptr
,
ft_type
,
ft_symb
}
=
dcl_functions
.[
glob_module
].[
glob_object
]
(
ft_type
,
imported_types
,
imported_conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
cDontRemoveAnnotations
common_defs
ft_type
main_dcl_module_n
imported_types
imported_conses
type_heaps
var_heap
=
(
imported_types
,
imported_conses
,
type_heaps
,
var_heap
<:=
(
ft_type_ptr
,
VI_ExpandedType
ft_type
))
convert_imported_constructors
common_defs
[]
imported_types
type_heaps
var_heap
=
(
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
]
#
!
{
com_cons_defs
,
com_selector_defs
}
=
common_defs
.[
glob_module
]
{
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
cDontRemoveAnnotations
common_defs
cons_type
main_dcl_module_n
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)
//
---> ("convert_imported_constructors", cons_symb, cons_type)
=
case
td_rhs
of
RecordType
{
rt_fields
}
#
(
imported_types
,
conses
,
type_heaps
,
var_heap
)
...
...
@@ -118,9 +125,8 @@ where
->
convert_imported_constructors
common_defs
conses
imported_types
type_heaps
var_heap
where
convert_type_of_imported_field
module_index
selector_defs
fields
field_index
(
imported_types
,
conses
,
type_heaps
,
var_heap
)
#
field_index
=
fields
.[
field_index
].
fs_index
{
sd_type_ptr
,
sd_type
}
=
selector_defs
.[
field_index
]
#
!
field_index
=
fields
.[
field_index
].
fs_index
{
sd_type_ptr
,
sd_type
,
sd_symb
}
=
selector_defs
.[
field_index
]
(
sd_type
,
imported_types
,
conses
,
type_heaps
,
var_heap
)
=
convertSymbolType
cDontRemoveAnnotations
common_defs
sd_type
main_dcl_module_n
imported_types
conses
type_heaps
var_heap
=
(
imported_types
,
conses
,
type_heaps
,
var_heap
<:=
(
sd_type_ptr
,
VI_ExpandedType
sd_type
))
frontend/explicitimports.icl
View file @
00b04d8a
...
...
@@ -824,9 +824,13 @@ instance check_completeness Type where
=
ccs
instance
check_completeness
TypeContext
where
check_completeness
{
tc_class
,
tc_types
}
cci
ccs
check_completeness
{
tc_class
=
TCClass
class_symb
,
tc_types
}
cci
ccs
=
check_completeness
tc_types
cci
(
check_whether_ident_is_imported
tc_class
.
glob_object
.
ds_ident
STE_Class
cci
ccs
)
(
check_whether_ident_is_imported
class_symb
.
glob_object
.
ds_ident
STE_Class
cci
ccs
)
check_completeness
{
tc_class
=
TCGeneric
{
gtc_generic
},
tc_types
}
cci
ccs
=
check_completeness
tc_types
cci
(
check_whether_ident_is_imported
gtc_generic
.
glob_object
.
ds_ident
STE_Generic
cci
ccs
)
instance
check_completeness
(
TypeDef
TypeRhs
)
where
check_completeness
td
=:{
td_rhs
,
td_context
}
cci
ccs
...
...
frontend/frontend.icl
View file @
00b04d8a
...
...
@@ -211,7 +211,6 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
= (-1,predef_symbols)
# (cleanup_info, acc_args, components, fun_defs, var_heap, expression_heap)
= analyseGroups common_defs imported_funs array_instances.ali_instances_range main_dcl_module_n stdStrictLists_module_n (components -*-> "Analyse") fun_defs var_heap expression_heap
// # (components, fun_defs, error) = showComponents2 components 0 fun_defs acc_args error
(components, fun_defs, dcl_types, used_conses, var_heap, type_heaps, expression_heap, acc_args)
...
...
frontend/general.dcl
View file @
00b04d8a
...
...
@@ -5,6 +5,7 @@ from StdEnv import instance <<< Int,class <<< (..),instance + Int,class + (..),i
0.2*/
//1.3
from
StdEnv
import
<<<,
+,
~
from
StdString
import
String
//3.1
instance
~
Bool
...
...
@@ -32,6 +33,9 @@ hasOption :: (Optional x) -> Bool
::
Choice
a
b
=
Either
a
|
Or
b
(--->)
infix
::
.
a
!
b
->
.
a
|
<<<
b
(<---)
infix
::
!.
a
!
b
->
.
a
|
<<<
b
traceValue
::
!
String
!
String
.
a
->
.
a
(-?->)
infix
::
.
a
!(!
Bool
,
!
b
)
->
.
a
|
<<<
b
instance
+
{#
Char
}
...
...
frontend/general.icl
View file @
00b04d8a
...
...
@@ -67,6 +67,17 @@ where
=
val
=
halt
// Strict version of --->, which evaluates its lhs first
(<---)
infix
::
!.
a
!
b
->
.
a
|
<<<
b
(<---)
value
message
=
value
--->
message
// Tracing evaluation of a value, otherwise acts like identity
traceValue
::
!
String
!
String
.
a
->
.
a
traceValue
contextdesc
valuedesc
value
=
(
value
<---
(
contextdesc
+++
" <<== "
+++
valuedesc
))
--->
(
contextdesc
+++
" ==>> "
+++
valuedesc
)
(-?->)
infix
::
.
a
!(!
Bool
,
!
b
)
->
.
a
|
<<<
b
(-?->)
val
(
cond
,
message
)
|
cond
...
...
frontend/generics1.icl
View file @
00b04d8a
...
...
@@ -16,6 +16,15 @@ from transform import Group
import
genericsupport
//****************************************************************************************
// tracing
//****************************************************************************************
traceGenerics
context
message
x
//:== traceValue context message x
:==
x
//**************************************************************************************
// Data types
//**************************************************************************************
...
...
@@ -77,33 +86,43 @@ convertGenerics
#!
td_infos
=
clearTypeDefInfos
td_infos
//---> ("used module numbers ", main_dcl_module_n, numberSetToList used_module_numbers)
#!
(
modules
,
heaps
)
=
clearGenericDefs
modules
heaps
#!
(
iso_range
,
funs
,
groups
,
td_infos
,
modules
,
heaps
,
error
)
=
buildGenericRepresentations
(
main_dcl_module_n
/*---> "====================== call buildGenericRepresentations"*/
)
predefs
funs
groups
td_infos
modules
heaps
error
#!
(
modules
,
heaps
)
=
traceGenerics
"convertGenerics"
"buildGenericRepresentations"
(
clearGenericDefs
modules
heaps
)
#
(
iso_range
,
funs
,
groups
,
td_infos
,
modules
,
heaps
,
error
)
=
traceGenerics
"convertGenerics"
"buildGenericRepresentations"
(
buildGenericRepresentations
main_dcl_module_n
predefs
funs
groups
td_infos
modules
heaps
error
)
|
not
error
.
ea_ok
=
(
modules
,
groups
,
funs
,
[],
td_infos
,
heaps
,
hash_table
,
u_predefs
,
dcl_modules
,
error
)
// build classes for each kind of each generic function
#!
(
modules
,
dcl_modules
,
heaps
,
symbol_table
,
td_infos
,
error
)
=
buildClasses
=
traceGenerics
"convertGenerics"
"buildClasses"
(
buildClasses
main_dcl_module_n
used_module_numbers
modules
dcl_modules
heaps
hash_table
.
hte_symbol_heap
td_infos
error
//---> ("====================== call buildClasses")
modules
dcl_modules
heaps
hash_table
.
hte_symbol_heap
td_infos
error
)
#!
hash_table
=
{
hash_table
&
hte_symbol_heap
=
symbol_table
}
|
not
error
.
ea_ok
=
(
modules
,
groups
,
funs
,
[],
td_infos
,
heaps
,
hash_table
,
u_predefs
,
dcl_modules
,
error
)
#!
(
instance_range
,
funs
,
groups
,
modules
,
dcl_modules
,
td_infos
,
heaps
,
error
)
=
convertGenericCases
main_dcl_module_n
used_module_numbers
predefs
funs
groups
modules
dcl_modules
td_infos
heaps
error
//---> ("====================== call convertGenericCases"
)
=
traceGenerics
"convertGenerics"
"convertGenericCases"
(
convertGenericCases
main_dcl_module_n
used_module_numbers
predefs
funs
groups
modules
dcl_modules
td_infos
heaps
error
)