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
c0be2f4c
Commit
c0be2f4c
authored
Jun 03, 2002
by
Artem Alimarine
Browse files
added constructor/type/field information to generics
parent
57d0ce34
Changes
17
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/StdCompare.icl
View file @
c0be2f4c
...
...
@@ -129,6 +129,8 @@ instance == TypeCons where
(==)
(
TypeConsSymb
x
)
(
TypeConsSymb
y
)
=
x
==
y
(==)
(
TypeConsBasic
x
)
(
TypeConsBasic
y
)
=
x
==
y
(==)
TypeConsArrow
TypeConsArrow
=
True
(==)
(
TypeConsVar
x
)
(
TypeConsVar
y
)
=
x
==
y
(==)
_
_
=
False
::
CompareValue
:==
Int
Smaller
:==
-1
...
...
frontend/check.icl
View file @
c0be2f4c
...
...
@@ -53,7 +53,8 @@ where
//# (heaps, cs) = check_generic_vars gen_def heaps cs
#
gen_defs
=
{
gen_defs
&
[
index
]
=
gen_def
}
#
cs
=
popErrorAdmin
cs
#
(
cs
=:{
cs_x
})
=
popErrorAdmin
cs
#!
cs
=
{
cs
&
cs_x
=
{
cs_x
&
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdGeneric
}}
=
(
gen_defs
,
type_defs
,
class_defs
,
modules
,
heaps
,
cs
)
//---> ("check_generic", gen_name, gen_def.gen_vars, gen_def.gen_type)
...
...
@@ -219,7 +220,8 @@ where
#!
(
heaps
,
cs
)
=
check_star_case
gc_type_cons
generic_def
gindex
heaps
cs
#!
cs
=
popErrorAdmin
cs
#!
(
cs
=:{
cs_x
})
=
popErrorAdmin
cs
#!
cs
=
{
cs
&
cs_x
=
{
cs_x
&
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdGeneric
}}
=
(
gen_case_defs
,
generic_defs
,
type_defs
,
modules
,
heaps
,
cs
)
//---> ("check_generic_case", gc_name, gc_type_cons)
...
...
@@ -3408,6 +3410,33 @@ where
<=<
adjustPredefSymbol
PD_TypeEITHER
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_ConsLEFT
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_ConsRIGHT
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TypeCONS
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_ConsCONS
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TypeFIELD
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_ConsFIELD
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_GenericInfo
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_NoGenericInfo
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_GenericConsInfo
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_GenericFieldInfo
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenericConsDescriptor
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenericConsDescriptor
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenericFieldDescriptor
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenericFieldDescriptor
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenericTypeDefDescriptor
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenericTypeDefDescriptor
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenConsPrio
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenConsNoPrio
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenConsPrio
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenConsAssoc
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenConsAssocNone
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenConsAssocLeft
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenConsAssocRight
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_TGenType
mod_index
STE_Type
<=<
adjustPredefSymbol
PD_CGenTypeCons
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenTypeVar
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenTypeArrow
mod_index
STE_Constructor
<=<
adjustPredefSymbol
PD_CGenTypeApp
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
...
...
frontend/checkFunctionBodies.icl
View file @
c0be2f4c
...
...
@@ -3,6 +3,7 @@ implementation module checkFunctionBodies
import
syntax
,
typesupport
,
parse
,
checksupport
,
utilities
,
checktypes
,
transform
,
predef
//, RWSDebug
import
explicitimports
,
comparedefimp
from
check
import
checkFunctions
,
checkDclMacros
import
compilerSwitches
cIsInExpressionList
:==
True
cIsNotInExpressionList
:==
False
...
...
@@ -1182,25 +1183,46 @@ checkExpression free_vars (PE_Generic id=:{id_name,id_info} kind) e_input e_stat
check_generic_expr
free_vars
entry
id
kind
e_input
e_state
e_info
cs
=:{
cs_error
}
=
(
EE
,
free_vars
,
e_state
,
e_info
,
{
cs
&
cs_error
=
checkError
id
"not a generic"
cs_error
})
check_it
free_vars
mod_index
gen_index
id
kind
e_input
e_state
=:{
es_expr_heap
}
e_info
cs
check_it
free_vars
mod_index
gen_index
id
kind
e_input
e_state
=:{
es_expr_heap
}
e_info
cs
#
(
generic_info_expr
,
es_expr_heap
,
cs
)
=
build_generic_info
es_expr_heap
cs
#!
(
app_args
,
es_expr_heap
,
cs
)
=
SwitchGenericInfo
([
generic_info_expr
],
es_expr_heap
,
cs
)
([],
es_expr_heap
,
cs
)
#!
symb_kind
=
SK_Generic
{
glob_object
=
gen_index
,
glob_module
=
mod_index
}
kind
#!
symbol
=
{
symb_name
=
id
,
symb_kind
=
symb_kind
}
#!
(
new_info_ptr
,
es_expr_heap
)
=
newPtr
EI_Empty
es_expr_heap
#!
app
=
{
app_symb
=
symbol
,
app_args
=
[]
,
app_info_ptr
=
new_info_ptr
}
#!
app
=
{
app_symb
=
symbol
,
app_args
=
app_args
,
app_info_ptr
=
new_info_ptr
}
#!
e_state
=
{
e_state
&
es_expr_heap
=
es_expr_heap
}
#!
cs
=
{
cs
&
cs_x
.
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdGeneric
}
=
(
App
app
,
free_vars
,
e_state
,
e_info
,
cs
)
where
// adds NoGenericInfo argument to each generic call
build_generic_info
es_expr_heap
cs
=:{
cs_predef_symbols
}
#!
pds_ident
=
predefined_idents
.[
PD_NoGenericInfo
]
#!
({
pds_module
,
pds_def
},
cs_predef_symbols
)
=
cs_predef_symbols
!
[
PD_NoGenericInfo
]
#!
(
new_info_ptr
,
es_expr_heap
)
=
newPtr
EI_Empty
es_expr_heap
#!
app
=
{
app_symb
=
{
symb_name
=
pds_ident
,
symb_kind
=
SK_Constructor
{
glob_module
=
pds_module
,
glob_object
=
pds_def
}
}
,
app_args
=
[]
,
app_info_ptr
=
new_info_ptr
}
=
(
App
app
,
es_expr_heap
,
{
cs
&
cs_predef_symbols
=
cs_predef_symbols
})
add_kind
::
!
Index
!
TypeKind
!
u
:{#
GenericDef
}
!*
ExpressionState
->
(!
u
:{#
GenericDef
},
!*
ExpressionState
)
add_kind
generic_index
kind
generic_defs
e_state
=:{
es_generic_heap
}
/*
/*
#! ({gen_info_ptr}, generic_defs) = generic_defs ! [generic_index]
#! (gen_info, es_generic_heap) = readPtr gen_info_ptr es_generic_heap
#! gen_kinds = eqMerge [(kind,NoIndex)] gen_info.gen_kinds
#! es_generic_heap = writePtr gen_info_ptr {gen_info&gen_kinds=gen_kinds} es_generic_heap
*/
*/
=
(
generic_defs
,
{
e_state
&
es_generic_heap
=
es_generic_heap
})
checkExpression
free_vars
expr
e_input
e_state
e_info
cs
=
abort
"checkExpression (checkFunctionBodies.icl, line 868)"
// <<- expr
...
...
frontend/compilerSwitches.dcl
View file @
c0be2f4c
...
...
@@ -8,6 +8,7 @@ switch_import_syntax one_point_three two_point_zero :== two_point_zero
SwitchPreprocessor
preprocessor
no_preprocessor
:==
preprocessor
SwitchGenerics
on
off
:==
off
SwitchGenericInfo
on
off
:==
on
// MV...
// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol)
...
...
frontend/compilerSwitches.icl
View file @
c0be2f4c
...
...
@@ -8,6 +8,7 @@ switch_import_syntax one_point_three two_point_zero :== two_point_zero
SwitchPreprocessor
preprocessor
no_preprocessor
:==
preprocessor
SwitchGenerics
on
off
:==
off
SwitchGenericInfo
on
off
:==
on
// MV...
// - change T_ypeObjectType in StdDynamic (remove DummyModuleName-argument of T_ypeConsSymbol)
...
...
frontend/generics1.icl
View file @
c0be2f4c
This diff is collapsed.
Click to expand it.
frontend/parse.icl
View file @
c0be2f4c
...
...
@@ -495,10 +495,18 @@ where
=
case
token
of
GenericOpenToken
// generic function
#
(
type
,
pState
)
=
wantType
pState
#
(
ident
,
pState
)
=
stringToIdent
name
(
IC_GenericCase
type
)
pState
#
(
type_CONS_ident
,
pState
)
=
stringToIdent
"CONS"
IC_Type
pState
#
(
type_FIELD_ident
,
pState
)=
stringToIdent
"FIELD"
IC_Type
pState
#
(
generic_ident
,
pState
)
=
stringToIdent
name
IC_Generic
pState
#
(
type_cons
,
pState
)
=
get_type_cons
type
pState
with
get_type_cons
(
TA
type_symb
[])
pState
=
(
TypeConsSymb
type_symb
,
pState
)
get_type_cons
(
TA
type_symb
[])
pState
=
(
TypeConsSymb
type_symb
,
pState
)
get_type_cons
(
TA
type_symb
_)
pState
#
pState
=
parseError
"generic type, no constructor arguments allowed"
No
" |}"
pState
=
(
abort
"no TypeCons"
,
pState
)
get_type_cons
(
TB
tb
)
pState
=
(
TypeConsBasic
tb
,
pState
)
get_type_cons
TArrow
pState
...
...
@@ -506,19 +514,48 @@ where
get_type_cons
(
TV
tv
)
pState
=
(
TypeConsVar
tv
,
pState
)
get_type_cons
_
pState
#
pState
=
parseError
"generic type"
No
"
invalid
"
pState
#
pState
=
parseError
"generic type"
No
"
|}
"
pState
=
(
abort
"no TypeCons"
,
pState
)
#
pState
=
wantToken
FunctionContext
"type argument"
GenericCloseToken
pState
#
(
ident
,
pState
)
=
stringToIdent
name
(
IC_GenericCase
type
)
pState
#
(
generic_ident
,
pState
)
=
stringToIdent
name
IC_Generic
pState
#
(
token
,
pState
)
=
nextToken
GenericContext
pState
#
(
geninfo_arg
,
pState
)
=
case
token
of
GenericOfToken
#
(
ok
,
geninfo_arg
,
pState
)
=
trySimpleLhsExpression
pState
#
pState
=
wantToken
FunctionContext
"type argument"
GenericCloseToken
pState
|
ok
->
case
type_cons
of
(
TypeConsSymb
{
type_name
})
|
type_name
==
type_CONS_ident
#
(
cons_CONS_ident
,
pState
)
=
stringToIdent
"GenericConsInfo"
IC_Expression
pState
->
(
PE_List
[
PE_Ident
cons_CONS_ident
,
geninfo_arg
],
pState
)
|
type_name
==
type_FIELD_ident
#
(
cons_FIELD_ident
,
pState
)
=
stringToIdent
"GenericFieldInfo"
IC_Expression
pState
->
(
PE_List
[
PE_Ident
cons_FIELD_ident
,
geninfo_arg
],
pState
)
_
|
otherwise
->
(
geninfo_arg
,
pState
)
|
otherwise
#
pState
=
parseError
"generic case"
No
"simple lhs expression"
pState
->
(
PE_Empty
,
pState
)
GenericCloseToken
#
(
geninfo_ident
,
pState
)
=
stringToIdent
"geninfo"
IC_Expression
pState
->
(
PE_Ident
geninfo_ident
,
pState
)
_
#
pState
=
parseError
"generic type"
(
Yes
token
)
"of or |}"
pState
#
(
geninfo_ident
,
pState
)
=
stringToIdent
"geninfo"
IC_Expression
pState
->
(
PE_Ident
geninfo_ident
,
pState
)
//# pState = wantToken FunctionContext "type argument" GenericCloseToken pState
#
(
args
,
pState
)
=
parseList
trySimpleLhsExpression
pState
//# (geninfo_ident, pState) = stringToIdent "geninfo" IC_Expression pState
#
args
=
SwitchGenericInfo
[
geninfo_arg
:
args
]
args
// must be EqualToken or HashToken or ???
//# pState = wantToken FunctionContext "generic definition" EqualToken pState
//# pState = tokenBack pState
#(
ss_useLayout
,
pState
)
=
accScanState
UseLayout
pState
#
(
ss_useLayout
,
pState
)
=
accScanState
UseLayout
pState
#
localsExpected
=
isNotEmpty
args
||
isGlobalContext
parseContext
||
~
ss_useLayout
#
(
rhs
,
_,
pState
)
=
wantRhs
localsExpected
(
ruleDefiningRhsSymbol
parseContext
)
pState
...
...
@@ -1511,11 +1548,6 @@ wantGenericDefinition parseContext pos pState
, gen_vars = arg_vars
, gen_pos = pos
, gen_info_ptr = nilPtr
, gen_bimap =
{ ds_ident = {id_name = "", id_info = nilPtr}
, ds_index = NoIndex
, ds_arity = 0
}
}
= (PD_Generic gen_def, pState)
where
...
...
frontend/postparse.icl
View file @
c0be2f4c
...
...
@@ -1198,20 +1198,20 @@ collectGenericBodies :: !GenericCaseDef ![ParsedDefinition] !*CollectAdmin
-> (![ParsedBody], ![ParsedDefinition], !*CollectAdmin)
collectGenericBodies first_case all_defs=:[PD_GenericCase gc : defs] ca
| first_case.gc_name == gc.gc_name && first_case.gc_type_cons == gc.gc_type_cons
# (bodies, rest_defs, ca) = collectGenericBodies first_case defs ca
#
!
(bodies, rest_defs, ca) = collectGenericBodies first_case defs ca
# (GCB_ParsedBody args rhs) = gc.gc_body
# body =
#
!
body =
{ pb_args = args
, pb_rhs = rhs
, pb_position = gc.gc_pos
}
| first_case.gc_arity == gc.gc_arity
= ([body : bodies ], rest_defs, ca)
# msg = "This alternative has " + toString gc.gc_arity + " argument"
#
!
msg = "This
generic
alternative has " + toString gc.gc_arity + " argument"
+ (if (gc.gc_arity <> 1) "s" "")+" instead of " + toString first_case.gc_arity
# ca = postParseError gc.gc_pos msg ca
#
!
ca = postParseError gc.gc_pos msg ca
= ([body : bodies ], rest_defs, ca)
= ([], all_defs, ca)
= ([], all_defs, ca)
collectGenericBodies first_case defs ca
= ([], defs, ca)
...
...
frontend/predef.dcl
View file @
c0be2f4c
...
...
@@ -168,12 +168,41 @@ PD_ConsRIGHT :== 186
PD_TypePAIR
:==
187
PD_ConsPAIR
:==
188
PD_GenericBimap
:==
189
PD_bimapId
:==
190
PD_TypeGenericDict
:==
191
PD_NrOfPredefSymbols
:==
192
// for constructor info
PD_TypeCONS
:==
189
PD_ConsCONS
:==
190
PD_TypeFIELD
:==
191
PD_ConsFIELD
:==
192
PD_GenericInfo
:==
193
PD_NoGenericInfo
:==
194
PD_GenericConsInfo
:==
195
PD_GenericFieldInfo
:==
196
PD_TGenericConsDescriptor
:==
197
PD_CGenericConsDescriptor
:==
198
PD_TGenericFieldDescriptor
:==
199
PD_CGenericFieldDescriptor
:==
200
PD_TGenericTypeDefDescriptor
:==
201
PD_CGenericTypeDefDescriptor
:==
202
PD_TGenConsPrio
:==
203
PD_CGenConsNoPrio
:==
204
PD_CGenConsPrio
:==
205
PD_TGenConsAssoc
:==
206
PD_CGenConsAssocNone
:==
207
PD_CGenConsAssocLeft
:==
208
PD_CGenConsAssocRight
:==
209
PD_TGenType
:==
210
PD_CGenTypeCons
:==
211
PD_CGenTypeVar
:==
212
PD_CGenTypeArrow
:==
213
PD_CGenTypeApp
:==
214
PD_GenericBimap
:==
215
PD_bimapId
:==
216
PD_TypeGenericDict
:==
217
PD_NrOfPredefSymbols
:==
218
GetTupleConsIndex
tup_arity
:==
PD_Arity2TupleSymbol
+
tup_arity
-
2
GetTupleTypeIndex
tup_arity
:==
PD_Arity2TupleType
+
tup_arity
-
2
...
...
frontend/predef.icl
View file @
c0be2f4c
...
...
@@ -168,12 +168,42 @@ PD_ConsRIGHT :== 186
PD_TypePAIR
:==
187
PD_ConsPAIR
:==
188
PD_GenericBimap
:==
189
PD_bimapId
:==
190
// for constructor info
PD_TypeCONS
:==
189
PD_ConsCONS
:==
190
PD_TypeFIELD
:==
191
PD_ConsFIELD
:==
192
PD_GenericInfo
:==
193
PD_NoGenericInfo
:==
194
PD_GenericConsInfo
:==
195
PD_GenericFieldInfo
:==
196
PD_TGenericConsDescriptor
:==
197
PD_CGenericConsDescriptor
:==
198
PD_TGenericFieldDescriptor
:==
199
PD_CGenericFieldDescriptor
:==
200
PD_TGenericTypeDefDescriptor
:==
201
PD_CGenericTypeDefDescriptor
:==
202
PD_TGenConsPrio
:==
203
PD_CGenConsNoPrio
:==
204
PD_CGenConsPrio
:==
205
PD_TGenConsAssoc
:==
206
PD_CGenConsAssocNone
:==
207
PD_CGenConsAssocLeft
:==
208
PD_CGenConsAssocRight
:==
209
PD_TGenType
:==
210
PD_CGenTypeCons
:==
211
PD_CGenTypeVar
:==
212
PD_CGenTypeArrow
:==
213
PD_CGenTypeApp
:==
214
PD_GenericBimap
:==
215
PD_bimapId
:==
216
PD_TypeGenericDict
:==
217
PD_NrOfPredefSymbols
:==
218
PD_TypeGenericDict
:==
191
PD_NrOfPredefSymbols
:==
192
(<<=)
infixl
(<<=)
symbol_table
val
...
...
@@ -284,7 +314,7 @@ predefined_idents
[
PD_TypeID
]
=
i
"T_ypeID"
,
[
PD_ModuleID
]
=
i
"ModuleID"
,
[
PD_StdGeneric
]
=
i
"StdGeneric
2
"
,
[
PD_StdGeneric
]
=
i
"StdGeneric"
,
[
PD_TypeBimap
]
=
i
"Bimap"
,
[
PD_ConsBimap
]
=
i
"_Bimap"
,
[
PD_map_to
]
=
i
"map_to"
,
...
...
@@ -295,7 +325,35 @@ predefined_idents
[
PD_ConsLEFT
]
=
i
"LEFT"
,
[
PD_ConsRIGHT
]
=
i
"RIGHT"
,
[
PD_TypePAIR
]
=
i
"PAIR"
,
[
PD_ConsPAIR
]
=
i
"PAIR"
,
[
PD_ConsPAIR
]
=
i
"PAIR"
,
[
PD_TypeCONS
]
=
i
"CONS"
,
[
PD_ConsCONS
]
=
i
"CONS"
,
[
PD_TypeFIELD
]
=
i
"FIELD"
,
[
PD_ConsFIELD
]
=
i
"FIELD"
,
[
PD_GenericInfo
]
=
i
"GenericInfo"
,
[
PD_NoGenericInfo
]
=
i
"NoGenericInfo"
,
[
PD_GenericConsInfo
]
=
i
"GenericConsInfo"
,
[
PD_GenericFieldInfo
]
=
i
"GenericFieldInfo"
,
[
PD_TGenericConsDescriptor
]
=
i
"GenericConsDescriptor"
,
[
PD_CGenericConsDescriptor
]
=
i
"_GenericConsDescriptor"
,
[
PD_TGenericFieldDescriptor
]
=
i
"GenericFieldDescriptor"
,
[
PD_CGenericFieldDescriptor
]
=
i
"_GenericFieldDescriptor"
,
[
PD_TGenericTypeDefDescriptor
]
=
i
"GenericTypeDefDescriptor"
,
[
PD_CGenericTypeDefDescriptor
]
=
i
"_GenericTypeDefDescriptor"
,
[
PD_TGenConsPrio
]
=
i
"GenConsPrio"
,
[
PD_CGenConsNoPrio
]
=
i
"GenConsNoPrio"
,
[
PD_CGenConsPrio
]
=
i
"GenConsPrio"
,
[
PD_TGenConsAssoc
]
=
i
"GenConsAssoc"
,
[
PD_CGenConsAssocNone
]
=
i
"GenConsAssocNone"
,
[
PD_CGenConsAssocLeft
]
=
i
"GenConsAssocLeft"
,
[
PD_CGenConsAssocRight
]
=
i
"GenConsAssocRight"
,
[
PD_TGenType
]
=
i
"GenType"
,
[
PD_CGenTypeCons
]
=
i
"GenTypeCons"
,
[
PD_CGenTypeVar
]
=
i
"GenTypeVar"
,
[
PD_CGenTypeArrow
]
=
i
"GenTypeArrow"
,
[
PD_CGenTypeApp
]
=
i
"GenTypeApp"
,
[
PD_GenericBimap
]
=
i
"bimap"
,
[
PD_bimapId
]
=
i
"bimapId"
,
...
...
@@ -447,7 +505,34 @@ where
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsLEFT
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsRIGHT
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TypePAIR
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsPAIR
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsPAIR
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TypeCONS
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsCONS
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TypeFIELD
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_ConsFIELD
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_GenericInfo
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_NoGenericInfo
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_GenericConsInfo
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_GenericFieldInfo
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenericConsDescriptor
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenericConsDescriptor
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenericFieldDescriptor
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenericFieldDescriptor
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenericTypeDefDescriptor
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenericTypeDefDescriptor
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenConsPrio
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenConsNoPrio
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenConsPrio
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenConsAssoc
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenConsAssocNone
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenConsAssocLeft
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenConsAssocRight
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TGenType
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenTypeCons
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenTypeVar
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenTypeArrow
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_CGenTypeApp
)
<<-
(
local_predefined_idents
,
IC_Generic
,
PD_GenericBimap
)
<<-
(
local_predefined_idents
,
IC_Expression
,
PD_bimapId
)
<<-
(
local_predefined_idents
,
IC_Type
,
PD_TypeGenericDict
)
...
...
frontend/scanner.dcl
View file @
c0be2f4c
...
...
@@ -110,6 +110,7 @@ instance <<< FilePosition
|
DeriveToken
// derive
|
GenericOpenToken
// {|
|
GenericCloseToken
// |}
|
GenericOfToken
// of
|
ExistsToken
// E.
|
ForAllToken
// A.
...
...
@@ -119,6 +120,7 @@ instance <<< FilePosition
|
TypeContext
|
FunctionContext
|
CodeContext
|
GenericContext
::
Assoc
=
LeftAssoc
|
RightAssoc
|
NoAssoc
...
...
frontend/scanner.icl
View file @
c0be2f4c
...
...
@@ -196,6 +196,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4;
|
DeriveToken
// derive
|
GenericOpenToken
// {|
|
GenericCloseToken
// |}
|
GenericOfToken
// of
|
ExistsToken
// E.
|
ForAllToken
// A.
...
...
@@ -206,6 +207,7 @@ ScanOptionNoNewOffsideForSeqLetBit:==4;
|
TypeContext
|
FunctionContext
|
CodeContext
|
GenericContext
instance
==
ScanContext
where
...
...
@@ -794,6 +796,7 @@ 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
CheckGeneralContext
::
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckGeneralContext
s
input
...
...
@@ -846,6 +849,7 @@ CheckTypeContext s input
"Dynamic"
->
(
DynamicTypeToken
,
input
)
"special"
->
(
SpecialToken
,
input
)
"from"
->
(
FromToken
,
input
)
"of"
->
(
GenericOfToken
,
input
)
// AA
s
->
CheckEveryContext
s
input
CheckFunctContext
::
!
String
!
Input
->
(!
Token
,
!
Input
)
...
...
@@ -873,6 +877,12 @@ CheckCodeContext s input
"inline"
->
(
InlineToken
,
input
)
s
->
CheckEveryContext
s
input
CheckGenericContext
::
!
String
!
Input
->
(!
Token
,
!
Input
)
CheckGenericContext
s
input
=
case
s
of
"of"
->
(
GenericOfToken
,
input
)
s
->
CheckEveryContext
s
input
GetPrio
::
!
Input
->
(!
Optional
String
,
!
Int
,
!
Input
)
GetPrio
input
#
(
error
,
c
,
input
)
=
SkipWhites
input
...
...
frontend/syntax.dcl
View file @
c0be2f4c
...
...
@@ -292,7 +292,6 @@ cNameLocationDependent :== True
,
gen_type
::
!
SymbolType
// Generic type (st_vars include generic type vars)
,
gen_vars
::
![
TypeVar
]
// Generic type variables
,
gen_info_ptr
::
!
GenericInfoPtr
,
gen_bimap
::
!
DefinedSymbol
// fun def index of the bimap for the generic type
}
::
GenericClassInfo
=
...
...
@@ -457,8 +456,17 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
}
// AA..
// type structure is used to specialize a generic to a type
::
GenTypeStruct
=
GTSAppCons
TypeKind
[
GenTypeStruct
]
|
GTSAppVar
TypeVar
[
GenTypeStruct
]
|
GTSVar
TypeVar
|
GTSCons
DefinedSymbol
GenTypeStruct
|
GTSField
DefinedSymbol
GenTypeStruct
|
GTSE
::
GenericTypeRep
=
{
gtr_type
::
A
Type
// generic structure type
{
gtr_type
::
Gen
Type
Struct
// generic structure type
,
gtr_iso
::
DefinedSymbol
// the conversion isomorphism
}
// ..AA
...
...
frontend/syntax.icl
View file @
c0be2f4c
...
...
@@ -286,7 +286,6 @@ cNameLocationDependent :== True
,
gen_type
::
!
SymbolType
// Generic type (st_vars include generic type vars)
,
gen_vars
::
![
TypeVar
]
// Generic type variables
,
gen_info_ptr
::
!
GenericInfoPtr
,
gen_bimap
::
!
DefinedSymbol
// fun def index of the bimap for the generic type
}
::
GenericClassInfo
=
...
...
@@ -1038,8 +1037,17 @@ cNotVarNumber :== -1
}
// AA..
// type structure is used to specialize a generic to a type
::
GenTypeStruct
=
GTSAppCons
TypeKind
[
GenTypeStruct
]
|
GTSAppVar
TypeVar
[
GenTypeStruct
]
|
GTSVar
TypeVar
|
GTSCons
DefinedSymbol
GenTypeStruct
|
GTSField
DefinedSymbol
GenTypeStruct
|
GTSE
::
GenericTypeRep
=
{
gtr_type
::
AType
// generic structure type
{
gtr_type
::
GenTypeStruct
//
AType // generic structure type
,
gtr_iso
::
DefinedSymbol
// the conversion isomorphism
}
// ..AA
...
...
frontend/trans.icl
View file @
c0be2f4c
...
...
@@ -4,11 +4,11 @@ import StdEnv
import
syntax
,
transform
,
checksupport
,
StdCompare
,
check
,
utilities
,
unitype
,
typesupport
,
type
SwitchCaseFusion
fuse
dont_fuse
:==
fuse
SwitchGeneratedFusion
fuse
dont_fuse
:==
fuse
SwitchFunctionFusion
fuse
dont_fuse
:==
fuse
SwitchConstructorFusion
fuse
dont_fuse
:==
fuse
SwitchCurriedFusion
fuse
dont_fuse
:==
fuse
SwitchCaseFusion
fuse
dont_fuse
:==
dont_
fuse
SwitchGeneratedFusion
fuse
dont_fuse
:==
dont_
fuse
SwitchFunctionFusion
fuse
dont_fuse
:==
dont_
fuse
SwitchConstructorFusion
fuse
dont_fuse
:==
dont_
fuse
SwitchCurriedFusion
fuse
dont_fuse
:==
dont_
fuse
(-!->)
infix
::
!.
a
!
b
->
.
a
|
<<<
b
(-!->)
a
b
=
a
// ---> b
...
...
@@ -2076,8 +2076,23 @@ determine_arg (PR_Class class_app free_vars_and_types class_type) _ {fv_info_ptr
,
ti_functions
=
ro
.
ro_imported_funs
,
ti_main_dcl_module_n
=
ro
.
ro_main_dcl_module_n
}
// AA: Dummy generic dictionary does not unify with corresponding class dictionary.
// Make it unify
#
(
succ
,
das_subst
,
das_type_heaps
)
=
unify
class_atype
arg_type
type_input
das_subst
das_type_heaps
//AA: = unify class_atype arg_type type_input das_subst das_type_heaps
=
unify_dict
class_atype
arg_type
type_input
das_subst
das_type_heaps
with
unify_dict
class_atype
=:{
at_type
=
TA
type_symb1
args1
}
arg_type
=:{
at_type
=
TA
type_symb2
args2
}
|
type_symb1
==
type_symb2
=
unify
class_atype
arg_type
// FIXME: check indexes, not names. Need predefs for that.
|
type_symb1
.
type_name
.
id_name
==
"GenericDict"
=
unify
{
class_atype
&
at_type
=
TA
type_symb2
args1
}
arg_type