Skip to content

GitLab

Commit c0be2f4c authored by Artem Alimarine's avatar Artem Alimarine
Browse files

added constructor/type/field information to generics

parent 57d0ce34
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.
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 "StdGeneric2",
[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 :: AType // generic structure type
{ gtr_type :: GenTypeStruct // 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
| type_symb2.type_name.id_name == "GenericDict"
= unify class_atype {arg_type & at_type = TA type_symb1 args2}
unify_dict class_atype arg_type
= unify class_atype arg_type
| not succ
= abort