aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--frontend/checkgenerics.icl2
-rw-r--r--frontend/generics1.icl810
-rw-r--r--frontend/parse.icl12
-rw-r--r--frontend/predef.dcl51
-rw-r--r--frontend/predef.icl12
-rw-r--r--frontend/syntax.dcl12
6 files changed, 478 insertions, 421 deletions
diff --git a/frontend/checkgenerics.icl b/frontend/checkgenerics.icl
index c4a05da..ddc2305 100644
--- a/frontend/checkgenerics.icl
+++ b/frontend/checkgenerics.icl
@@ -44,7 +44,7 @@ where
# initial_info =
{ gen_classes = createArray 32 []
, gen_var_kinds = []
- , gen_OBJECT_CONS_FIELD_indices = createArray 3 {ocf_module = -1,ocf_index = -1,ocf_ident={id_name="",id_info=nilPtr}}
+ , gen_rep_conses = createArray 4 {gcf_module = -1,gcf_index = -1,gcf_ident={id_name="",id_info=nilPtr}}
}
# (gen_info_ptr, hp_generic_heap) = newPtr initial_info hp_generic_heap
= ( {gen_def & gen_info_ptr = gen_info_ptr},
diff --git a/frontend/generics1.icl b/frontend/generics1.icl
index 0bde0b2..82247dd 100644
--- a/frontend/generics1.icl
+++ b/frontend/generics1.icl
@@ -39,6 +39,7 @@ import genericsupport
bimap_EITHER_function :: !FunctionIndexAndIdent,
bimap_OBJECT_function :: !FunctionIndexAndIdent,
bimap_CONS_function :: !FunctionIndexAndIdent,
+ bimap_RECORD_function :: !FunctionIndexAndIdent,
bimap_FIELD_function :: !FunctionIndexAndIdent
}
@@ -175,7 +176,10 @@ where
clearGenericDefs :: !*{#CommonDefs} !*Heaps -> (!*{#CommonDefs},!*Heaps)
clearGenericDefs modules heaps
= clear_module 0 modules heaps
-where
+where
+ initial_gen_classes
+ = createArray 32 []
+
clear_module n modules heaps
| n == size modules
= (modules, heaps)
@@ -183,10 +187,10 @@ where
#! (com_generic_defs, heaps) = updateArraySt clear_generic_def {x\\x<-:com_generic_defs} heaps
#! modules = {modules & [n].com_generic_defs = com_generic_defs}
= clear_module (inc n) modules heaps
-
+
clear_generic_def generic_def=:{gen_info_ptr} heaps=:{hp_generic_heap}
#! (gen_info, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
- #! gen_info = { gen_info & gen_classes = createArray 32 [] }
+ #! gen_info & gen_classes = initial_gen_classes
#! hp_generic_heap = writePtr gen_info_ptr gen_info hp_generic_heap
= (generic_def, {heaps & hp_generic_heap = hp_generic_heap})
@@ -217,6 +221,7 @@ buildGenericRepresentations gs=:{gs_main_module, gs_modules, gs_funs, gs_groups}
bimap_EITHER_function = undefined_function_and_ident,
bimap_OBJECT_function = undefined_function_and_ident,
bimap_CONS_function = undefined_function_and_ident,
+ bimap_RECORD_function = undefined_function_and_ident,
bimap_FIELD_function = undefined_function_and_ident
}
funs_and_groups = {fg_fun_index=size_funs, fg_group_index=size_groups, fg_funs=[], fg_groups=[],fg_bimap_functions= bimap_functions}
@@ -263,7 +268,9 @@ where
-> (funs_and_groups, gs)
build_generic_representation _ st = st
-:: ConsInfo = {ci_cons_info :: DefinedSymbol, ci_field_infos :: [DefinedSymbol]}
+:: TypeInfos
+ = AlgebraicInfo !DefinedSymbol ![DefinedSymbol]
+ | RecordInfo !DefinedSymbol ![DefinedSymbol]
buildGenericTypeRep :: !GlobalIndex /*type def index*/ !FunsAndGroups !*GenericState -> (!GenericTypeRep,!FunsAndGroups,!*GenericState)
buildGenericTypeRep type_index funs_and_groups
@@ -277,11 +284,11 @@ buildGenericTypeRep type_index funs_and_groups
# (type_def, gs_modules) = gs_modules![type_index.gi_module].com_type_defs.[type_index.gi_index]
- # (type_info, cons_infos, funs_and_groups, gs_modules, heaps, gs_error)
- = buildTypeDefInfo type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups gs_modules heaps gs_error
+ # (type_infos, funs_and_groups, gs_modules, heaps, gs_error)
+ = buildTypeDefInfo type_def type_index.gi_module gs_main_module gs_predefs funs_and_groups gs_modules heaps gs_error
# (atype, (gs_modules, gs_td_infos, heaps, gs_error))
- = buildStructType type_index type_info cons_infos gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
+ = buildStructType type_index type_infos gs_predefs (gs_modules, gs_td_infos, heaps, gs_error)
# (from_fun_ds, funs_and_groups, heaps, gs_error)
= buildConversionFrom type_index.gi_module type_def gs_main_module gs_predefs funs_and_groups heaps gs_error
@@ -505,6 +512,9 @@ where
simplify (GTSCons cons_info_ds x) st
# (x, st) = simplify x st
= (GTSCons cons_info_ds x, st)
+ simplify (GTSRecord cons_info_ds x) st
+ # (x, st) = simplify x st
+ = (GTSRecord cons_info_ds x, st)
simplify (GTSField field_info_ds x) st
# (x, st) = simplify x st
= (GTSField field_info_ds x, st)
@@ -521,6 +531,7 @@ where
occurs (GTSPair x y) st = occurs2 x y st
occurs (GTSEither x y) st = occurs2 x y st
occurs (GTSCons _ arg) st = occurs arg st
+ occurs (GTSRecord _ arg) st = occurs arg st
occurs (GTSField _ arg) st = occurs arg st
occurs (GTSObject _ arg) st = occurs arg st
occurs GTSE st = False
@@ -549,47 +560,45 @@ where
buildStructType ::
!GlobalIndex // type def global index
- !DefinedSymbol // type_info
- ![ConsInfo] // constructor and field info symbols
+ !TypeInfos // type, constructor and field info symbols
!PredefinedSymbols
(!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
-> ( !GenTypeStruct // the structure type
, (!*Modules, !*TypeDefInfos, !*Heaps, !*ErrorAdmin)
)
-buildStructType {gi_module,gi_index} type_info cons_infos predefs (modules, td_infos, heaps, error)
+buildStructType {gi_module,gi_index} type_infos predefs (modules, td_infos, heaps, error)
# (type_def=:{td_ident}, modules) = modules![gi_module].com_type_defs.[gi_index]
- = build_type type_def type_info cons_infos (modules, td_infos, heaps, error)
+ = build_type type_def type_infos (modules, td_infos, heaps, error)
where
- build_type {td_rhs=AlgType alts, td_ident, td_pos} type_info cons_infos st
+ build_type {td_rhs=AlgType alts, td_ident, td_pos} (AlgebraicInfo type_info cons_infos) st
# (cons_args, st) = zipWithSt (build_alt td_ident td_pos) alts cons_infos st
# type = build_sum_type cons_args
= (GTSObject type_info type, st)
build_type
{td_rhs=RecordType {rt_constructor}, td_ident, td_pos}
- type_info [{ci_cons_info, ci_field_infos}]
+ (RecordInfo ci_record_info ci_field_infos)
(modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[rt_constructor.ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# args = [GTSField fi arg \\ arg <- args & fi <- ci_field_infos]
- # prod_type = build_prod_type args
- # type = GTSCons ci_cons_info prod_type
- = (GTSObject type_info type, st)
+ # prod_type = build_prod_type args
+ = (GTSRecord ci_record_info prod_type, st)
# error = reportError td_ident td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
- build_type {td_rhs=SynType type,td_ident, td_pos} type_info cons_infos (modules, td_infos, heaps, error)
+ build_type {td_rhs=SynType type,td_ident, td_pos} type_infos (modules, td_infos, heaps, error)
# error = reportError td_ident td_pos "cannot build a generic representation of a synonym type" error
= (GTSE, (modules, td_infos, heaps, error))
- build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_info cdis (modules, td_infos, heaps, error)
+ build_type td=:{td_rhs=(AbstractType _),td_ident, td_arity, td_args, td_pos} type_infos (modules, td_infos, heaps, error)
# error = reportError td_ident td_pos "cannot build a generic representation of an abstract type" error
= (GTSE, (modules, td_infos, heaps, error))
- build_alt td_ident td_pos cons_def_sym=:{ds_index} {ci_cons_info} (modules, td_infos, heaps, error)
+ build_alt td_ident td_pos cons_def_sym=:{ds_index} cons_info (modules, td_infos, heaps, error)
# ({cons_type={st_args},cons_exi_vars}, modules) = modules![gi_module].com_cons_defs.[ds_index]
| isEmpty cons_exi_vars
# (args, st) = mapSt (convertATypeToGenTypeStruct td_ident td_pos predefs) st_args (modules, td_infos, heaps, error)
# prod_type = build_prod_type args
- = (GTSCons ci_cons_info prod_type, st)
+ = (GTSCons cons_info prod_type, st)
# error = reportError td_ident td_pos "cannot build a generic representation of an existential type" error
= (GTSE, (modules, td_infos, heaps, error))
@@ -599,7 +608,7 @@ where
where
build_pair x y = GTSPair x y
build_unit = GTSAppCons KindConst []
-
+
build_sum_type :: [GenTypeStruct] -> GenTypeStruct
build_sum_type types
= listToBin build_either build_void types
@@ -644,261 +653,265 @@ buildPredefTypeApp predef_index args predefs
// build type infos
buildTypeDefInfo ::
- !Index // type def module
!CheckedTypeDef // the type definition
+ !Index // type def module
!Index // icl module
!PredefinedSymbols
!FunsAndGroups !*Modules !*Heaps !*ErrorAdmin
- -> ( DefinedSymbol // type info
- , ![ConsInfo]
- , !FunsAndGroups, !*Modules, !*Heaps, !*ErrorAdmin)
-buildTypeDefInfo td_module td=:{td_rhs = AlgType alts} main_module_index predefs funs_and_groups modules heaps error
- = buildTypeDefInfo1 td_module td alts [] main_module_index predefs funs_and_groups modules heaps error
-buildTypeDefInfo td_module td=:{td_rhs = RecordType {rt_constructor, rt_fields}} main_module_index predefs funs_and_groups modules heaps error
- = buildTypeDefInfo1 td_module td [rt_constructor] [x\\x<-:rt_fields] main_module_index predefs funs_and_groups modules heaps error
-buildTypeDefInfo td_module td=:{td_rhs = SynType type, td_ident, td_pos} main_module_index predefs funs_and_groups modules heaps error
+ -> (!TypeInfos, !FunsAndGroups, !*Modules, !*Heaps, !*ErrorAdmin)
+buildTypeDefInfo td=:{td_rhs = AlgType alts} td_module main_module_index predefs funs_and_groups modules heaps error
+ = buildAlgebraicTypeDefInfo td alts td_module main_module_index predefs funs_and_groups modules heaps error
+buildTypeDefInfo td=:{td_rhs = RecordType {rt_constructor, rt_fields}} td_module main_module_index predefs funs_and_groups modules heaps error
+ = buildRecordTypeDefInfo td rt_constructor [x\\x<-:rt_fields] td_module main_module_index predefs funs_and_groups modules heaps error
+buildTypeDefInfo td=:{td_rhs = SynType type, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
# error = reportError td_ident td_pos "cannot build constructor uinformation for a synonym type" error
- = buildTypeDefInfo1 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error
-buildTypeDefInfo td_module td=:{td_rhs = AbstractType _, td_ident, td_pos} main_module_index predefs funs_and_groups modules heaps error
+ = buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
+buildTypeDefInfo td=:{td_rhs = AbstractType _, td_ident, td_pos} td_module main_module_index predefs funs_and_groups modules heaps error
# error = reportError td_ident td_pos "cannot build constructor uinformation for an abstract type" error
- = buildTypeDefInfo1 td_module td [] [] main_module_index predefs funs_and_groups modules heaps error
+ = buildAlgebraicTypeDefInfo td [] td_module main_module_index predefs funs_and_groups modules heaps error
-buildTypeDefInfo1 td_module {td_ident, td_pos, td_arity} alts fields main_module_index predefs
+buildAlgebraicTypeDefInfo {td_ident, td_pos, td_arity} alts td_module main_module_index predefs
funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error
# num_conses = length alts
- # num_fields = length fields
# new_group_index = inc group_index
- # type_def_dsc_index = fun_index
- # first_cons_dsc_index = fun_index + 1
- # cons_dsc_indexes = [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]
- # first_field_dsc_index = first_cons_dsc_index + num_conses
- # field_dsc_indexes = [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]
- # new_fun_index = first_field_dsc_index + num_fields
+ # cons_desc_list_index = fun_index
+ type_def_dsc_index = cons_desc_list_index + 1
+ first_gen_type_index = type_def_dsc_index + 1
+ first_cons_dsc_index = first_gen_type_index + num_conses
+ new_fun_index = first_cons_dsc_index + num_conses
# group = {group_members = [fun_index .. new_fun_index - 1]}
# new_groups = [group:groups]
-
- # type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
- # cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("cdi_"+++ds_ident.id_name), ds_index=i} \\
- {ds_ident} <- alts & i <- cons_dsc_indexes]
- # field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent("fdi_"+++fs_ident.id_name), ds_index=i} \\
- {fs_ident} <- fields & i <- field_dsc_indexes]
- # (type_def_dsc_fun, heaps) = build_type_def_dsc group_index cons_dsc_dss type_def_dsc_ds heaps
-
- # (cons_dsc_funs, (modules, heaps)) = zipWithSt (build_cons_dsc group_index type_def_dsc_ds field_dsc_dss) cons_dsc_dss alts (modules, heaps)
+ # cons_desc_list_ds = {ds_arity=0, ds_ident=makeIdent ("cli_"+++td_ident.id_name), ds_index=cons_desc_list_index}
+ type_def_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("tdi_"+++td_ident.id_name), ds_index=type_def_dsc_index}
+ gen_type_dss = [ {ds_arity=0, ds_ident=makeIdent ("gti_"+++ds_ident.id_name), ds_index=i} \\
+ {ds_ident} <- alts & i <- [first_gen_type_index .. first_gen_type_index + num_conses - 1]]
+ cons_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("cdi_"+++ds_ident.id_name), ds_index=i} \\
+ {ds_ident} <- alts & i <- [first_cons_dsc_index .. first_cons_dsc_index + num_conses - 1]]
- # (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index (hd cons_dsc_dss)) field_dsc_dss fields (modules, heaps)
-
- // NOTE: reverse order (new functions are added at the head)
- # new_funs = (reverse field_dsc_funs) ++ (reverse cons_dsc_funs) ++ [type_def_dsc_fun] ++ funs
+ # (cons_desc_list_fun, heaps) = build_cons_desc_list_function group_index cons_desc_list_ds cons_dsc_dss heaps
- # funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}
+ (type_def_dsc_fun, heaps) = build_type_def_dsc group_index type_def_dsc_ds cons_desc_list_ds heaps
- # (type_info_ds, (funs_and_groups, heaps))
- = build_type_info type_def_dsc_ds (funs_and_groups, heaps)
-
- # (cons_info_dss, (funs_and_groups, heaps))
- = mapSt build_cons_info cons_dsc_dss (funs_and_groups, heaps)
+ (gen_type_dsc_funs, (modules, heaps)) = zipWithSt (build_gen_type_function group_index main_module_index td_module td_pos predefs) gen_type_dss alts (modules, heaps)
- # (field_info_dss, (funs_and_groups, heaps))
- = mapSt build_field_info field_dsc_dss (funs_and_groups, heaps)
+ (cons_dsc_funs, (modules, heaps)) = zipWith3St (build_cons_dsc group_index type_def_dsc_ds) cons_dsc_dss gen_type_dss alts (modules, heaps)
- # cons_infos = case (cons_info_dss, field_info_dss) of
- ([cons_info_ds], field_infos) -> [{ci_cons_info = cons_info_ds, ci_field_infos = field_infos}]
- (cons_info_dss, []) -> [{ci_cons_info=x,ci_field_infos=[]}\\x<-cons_info_dss]
- _ -> abort "generics.icl sanity check: fields in non-record type\n"
+ // NOTE: reverse order (new functions are added at the head)
+ # new_funs = reverse cons_dsc_funs ++ reverse gen_type_dsc_funs ++ [type_def_dsc_fun, cons_desc_list_fun : funs]
+
+ # funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}
- = (type_info_ds, cons_infos, funs_and_groups, modules, heaps, error)
+ # cons_infos = AlgebraicInfo type_def_dsc_ds cons_dsc_dss
+
+ = (cons_infos, funs_and_groups, modules, heaps, error)
where
- build_type_def_dsc group_index cons_info_dss {ds_ident} heaps
- # td_name_expr = makeStringExpr td_ident.id_name
- # td_arity_expr = makeIntExpr td_arity
- # num_conses_expr = makeIntExpr (length alts)
+ build_cons_desc_list_function group_index {ds_ident} cons_info_dss heaps
# (cons_info_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) cons_info_dss heaps
- # (td_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps
-
- # (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor
- [ td_name_expr
- , td_arity_expr
- , num_conses_expr
- , td_conses_expr
- // TODO: module_name_expr
- ]
- predefs heaps
+ # (gtd_conses_expr, heaps) = makeListExpr cons_info_exprs predefs heaps // gtd_conses
+ # fun = makeFunction ds_ident group_index [] gtd_conses_expr No main_module_index td_pos
+ = (fun, heaps)
+ build_type_def_dsc group_index {ds_ident} cons_desc_list_ds heaps
+ # td_name_expr = makeStringExpr td_ident.id_name // gtd_name
+ # td_arity_expr = makeIntExpr td_arity // gtd_arity
+ # num_conses_expr = makeIntExpr (length alts) // gtd_num_conses
+ # (gtd_conses_expr, heaps) = buildFunApp main_module_index cons_desc_list_ds [] heaps // gtd_conses
+ # (body_expr, heaps) = buildPredefConsApp PD_CGenericTypeDefDescriptor
+ [td_name_expr, td_arity_expr, num_conses_expr, gtd_conses_expr] // TODO: module_name_expr
+ predefs heaps
# fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
= (fun, heaps)
- build_cons_dsc group_index type_def_info_ds field_dsc_dss cons_info_ds cons_ds (modules, heaps)
+ build_cons_dsc group_index type_def_info_ds {ds_ident} gen_type_ds cons_ds (modules, heaps)
# ({cons_ident,cons_type,cons_priority,cons_number,cons_exi_vars}, modules)
- = modules! [td_module].com_cons_defs.[cons_ds.ds_index]
- # name_expr = makeStringExpr cons_ident.id_name
- # arity_expr = makeIntExpr cons_type.st_arity
- # (prio_expr, heaps) = make_prio_expr cons_priority heaps
- # (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps
- # (type_expr, heaps) = make_type_expr cons_exi_vars cons_type heaps
- # (field_exprs, heaps) = mapSt (\x st->buildFunApp main_module_index x [] st) field_dsc_dss heaps
- # (fields_expr, heaps) = makeListExpr field_exprs predefs heaps
- # cons_index_expr = makeIntExpr cons_number
- # (body_expr, heaps)
+ = modules![td_module].com_cons_defs.[cons_ds.ds_index]
+ # name_expr = makeStringExpr cons_ident.id_name // gcd_name
+ # arity_expr = makeIntExpr cons_type.st_arity // gcd_arity
+ # (prio_expr, heaps) = make_prio_expr cons_priority predefs heaps // gcd_prio
+ # (type_def_expr, heaps) = buildFunApp main_module_index type_def_info_ds [] heaps // gcd_type_def
+ # (type_expr, heaps) = buildFunApp main_module_index gen_type_ds [] heaps // gcd_type
+ # cons_index_expr = makeIntExpr cons_number // gcd_index
+ # (body_expr, heaps)
= buildPredefConsApp PD_CGenericConsDescriptor
- [ name_expr
- , arity_expr
- , prio_expr
- , type_def_expr
- , type_expr
- , fields_expr
- , cons_index_expr
- ]
+ [name_expr, arity_expr, prio_expr, type_def_expr, type_expr, cons_index_expr]
predefs heaps
-
- # fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos
+ # fun = makeFunction ds_ident group_index [] body_expr No main_module_index td_pos
= (fun, (modules, heaps))
- where
- make_prio_expr NoPrio heaps
- = buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
- make_prio_expr (Prio assoc prio) heaps
- # assoc_predef = case assoc of
- NoAssoc -> PD_CGenConsAssocNone
- LeftAssoc -> PD_CGenConsAssocLeft
- RightAssoc -> PD_CGenConsAssocRight
- # (assoc_expr, heaps) = buildPredefConsApp assoc_predef [] predefs heaps
- # prio_expr = makeIntExpr prio
- = buildPredefConsApp PD_CGenConsPrio [assoc_expr, prio_expr] predefs heaps
-
- make_type_expr [] {st_vars, st_args, st_result} heaps=:{hp_type_heaps=type_heaps=:{th_vars}}
- # (_,th_vars) = foldSt (\ {tv_info_ptr} (n, th_vars) -> (n+1, writePtr tv_info_ptr (TVI_GenTypeVarNumber n) th_vars)) st_vars (0,th_vars)
- # heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
- # (arg_exprs, heaps) = mapSt make_expr1 st_args heaps
- # (result_expr, heaps) = make_expr1 st_result heaps
- # {hp_type_heaps=type_heaps=:{th_vars}} = heaps
- # th_vars = foldSt (\ {tv_info_ptr} th_vars -> writePtr tv_info_ptr TVI_Empty th_vars) st_vars th_vars
- # heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
- = curry arg_exprs result_expr heaps
- where
- curry [] result_expr heaps
- = (result_expr, heaps)
- curry [x:xs] result_expr heaps
- # (y, heaps) = curry xs result_expr heaps
- = make_arrow x y heaps
-
- make_expr1 :: !AType !*Heaps -> (!Expression, !*Heaps)
- make_expr1 {at_type} heaps = make_expr at_type heaps
-
- make_expr :: !Type !*Heaps -> (!Expression, !*Heaps)
- make_expr (TA type_symb arg_types) heaps
- # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
- # (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps
- = make_apps type_cons arg_exprs heaps
- make_expr (TAS type_symb arg_types _) heaps
- # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
- # (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps
- = make_apps type_cons arg_exprs heaps
- make_expr (x --> y) heaps
- # (x, heaps) = make_expr1 x heaps
- # (y, heaps) = make_expr1 y heaps
- = make_arrow x y heaps
- make_expr TArrow heaps
- = make_type_cons "(->)" heaps
- make_expr (TArrow1 type) heaps
- # (arg_expr, heaps) = make_expr1 type heaps
- # (arrow_expr, heaps) = make_type_cons "(->)" heaps
- = make_app arrow_expr arg_expr heaps
- make_expr (CV {tv_info_ptr} :@: arg_types) heaps
- # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
- # (tv_expr, heaps) = make_type_var tv_info_ptr heaps
- = make_apps tv_expr arg_exprs heaps
- make_expr (TB bt) heaps
- = make_type_cons (toString bt) heaps
- make_expr (TV {tv_info_ptr}) heaps
- = make_type_var tv_info_ptr heaps
- make_expr (GTV {tv_info_ptr}) heaps
- = make_type_var tv_info_ptr heaps
- make_expr (TQV {tv_info_ptr}) heaps
- = make_type_var tv_info_ptr heaps
- make_expr TE heaps
- = make_error_type_cons heaps
- make_expr (TFA _ _) heaps
- // error is reported in convertATypeToGenTypeStruct
- = make_error_type_cons heaps
- make_expr _ heaps
- = abort "type does not match\n"
-
- make_apps x [] heaps
- = (x, heaps)
- make_apps x [y:ys] heaps
- # (z, heaps) = make_app x y heaps
- = make_apps z ys heaps
-
- make_type_var tv_info_ptr heaps
- #! type_var_n = case sreadPtr tv_info_ptr heaps.hp_type_heaps.th_vars of
- TVI_GenTypeVarNumber n -> n
- = buildPredefConsApp PD_CGenTypeVar [makeIntExpr type_var_n] predefs heaps
-
- make_arrow x y heaps = buildPredefConsApp PD_CGenTypeArrow [x, y] predefs heaps
-
- make_app x y heaps = buildPredefConsApp PD_CGenTypeApp [x, y] predefs heaps
-
- make_error_type_cons heaps = make_type_cons "<error>" heaps
- make_type_expr [_:_] {st_vars, st_args, st_result} heaps
- // Error "cannot build a generic representation of an existential type" is reported in buildStructType
- = make_type_cons "<error>" heaps
- make_type_cons name heaps
- # name_expr = makeStringExpr name
- = buildPredefConsApp PD_CGenTypeCons [name_expr] predefs heaps
+make_prio_expr NoPrio predefs heaps
+ = buildPredefConsApp PD_CGenConsNoPrio [] predefs heaps
+make_prio_expr (Prio assoc prio) predefs heaps
+ # assoc_predef = case assoc of
+ NoAssoc -> PD_CGenConsAssocNone
+ LeftAssoc -> PD_CGenConsAssocLeft
+ RightAssoc -> PD_CGenConsAssocRight
+ # (assoc_expr, heaps) = buildPredefConsApp assoc_predef [] predefs heaps
+ # prio_expr = makeIntExpr prio
+ = buildPredefConsApp PD_CGenConsPrio [assoc_expr, prio_expr] predefs heaps
+
+buildRecordTypeDefInfo {td_ident, td_pos, td_arity} alt fields td_module main_module_index predefs
+ funs_and_groups=:{fg_fun_index=fun_index,fg_group_index=group_index,fg_funs=funs,fg_groups=groups} modules heaps error
- build_field_dsc group_index cons_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
- # name_expr = makeStringExpr fs_ident.id_name
- # ({sd_field_nr}, modules)
- = modules! [td_module].com_selector_defs.[fs_index]
- # index_expr = makeIntExpr sd_field_nr
- # (cons_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps
- # (body_expr, heaps)
- = buildPredefConsApp PD_CGenericFieldDescriptor
- [ name_expr
- , index_expr
- , cons_expr
- ]
- predefs heaps
- # fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos
- = (fun, (modules, heaps))
-
- build_cons_info cons_dsc_ds (funs_and_groups, heaps)
- # ident = makeIdent ("g"+++cons_dsc_ds.ds_ident.id_name)
+ # num_fields = length fields
+ # new_group_index = inc group_index
- # (cons_dsc_expr, heaps) = buildFunApp main_module_index cons_dsc_ds [] heaps
+ # gen_type_index = fun_index
+ field_list_index = gen_type_index + 1
+ cons_dsc_index = field_list_index + 1
+ first_field_dsc_index = cons_dsc_index + 1
+ new_fun_index = first_field_dsc_index + num_fields
- # (body_expr, heaps)
- = buildPredefConsApp PD_GenericConsInfo [cons_dsc_expr] predefs heaps
+ # group = {group_members = [fun_index .. new_fun_index - 1]}
+ # new_groups = [group:groups]
- # (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
- = (def_sym, (funs_and_groups, heaps))
+ # gen_type_ds = {ds_arity=0, ds_ident=makeIdent ("gti_"+++alt.ds_ident.id_name), ds_index=gen_type_index}
+ field_list_ds = {ds_arity=0, ds_ident=makeIdent ("fli_"+++alt.ds_ident.id_name), ds_index=field_list_index}
+ record_dsc_ds = {ds_arity=0, ds_ident=makeIdent ("rdi_"+++alt.ds_ident.id_name), ds_index=cons_dsc_index}
+ field_dsc_dss = [ {ds_arity=0, ds_ident=makeIdent ("fdi_"+++fs_ident.id_name), ds_index=i} \\
+ {fs_ident} <- fields & i <- [first_field_dsc_index .. first_field_dsc_index + num_fields - 1]]
- build_field_info field_dsc_ds (funs_and_groups, heaps)
- # ident = makeIdent ("g"+++field_dsc_ds.ds_ident.id_name)
+ # (gen_type_dsc_fun, (modules, heaps)) = build_gen_type_function group_index main_module_index td_module td_pos predefs gen_type_ds alt (modules, heaps)
- # (field_dsc_expr, heaps) = buildFunApp main_module_index field_dsc_ds [] heaps
+ (field_list_fun, (modules, heaps)) = build_field_list_function group_index field_list_ds (modules, heaps)
- # (body_expr, heaps)
- = buildPredefConsApp PD_GenericFieldInfo [field_dsc_expr] predefs heaps
+ (record_dsc_fun, (modules, heaps)) = build_record_dsc group_index td_ident record_dsc_ds gen_type_ds field_list_ds alt (modules, heaps)
- # (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
- = (def_sym, (funs_and_groups, heaps))
+ (field_dsc_funs, (modules, heaps)) = zipWithSt (build_field_dsc group_index record_dsc_ds) field_dsc_dss fields (modules, heaps)
+
+ // NOTE: reverse order (new functions are added at the head)
+ # new_funs = reverse field_dsc_funs ++ [record_dsc_fun, field_list_fun, gen_type_dsc_fun : funs]
- build_type_info type_dsc_ds (funs_and_groups, heaps)
- # ident = makeIdent ("g"+++type_dsc_ds.ds_ident.id_name)
+ # funs_and_groups = {funs_and_groups & fg_fun_index=new_fun_index, fg_group_index=new_group_index, fg_funs=new_funs, fg_groups=new_groups}
- # (type_dsc_expr, heaps) = buildFunApp main_module_index type_dsc_ds [] heaps
+ # cons_infos = RecordInfo record_dsc_ds field_dsc_dss
+ = (cons_infos, funs_and_groups, modules, heaps, error)
+where
+ build_field_list_function group_index field_list_ds (modules, heaps)
+ # field_exprs = [makeStringExpr id_name \\ {fs_ident={id_name}}<-fields]
+ # (fields_expr, heaps) = makeListExpr field_exprs predefs heaps // grd_fields
+ # fun = makeFunction field_list_ds.ds_ident group_index [] fields_expr No main_module_index td_pos
+ = (fun, (modules, heaps))
+
+ build_record_dsc group_index td_ident cons_info_ds gen_type_ds field_list_ds cons_ds (modules, heaps)
+ # ({cons_ident,cons_type,cons_priority,cons_number}, modules)
+ = modules![td_module].com_cons_defs.[cons_ds.ds_index]
+ # name_expr = makeStringExpr td_ident.id_name /*cons_ident.id_name*/ // grd_name
+ # arity_expr = makeIntExpr cons_type.st_arity // grd_arity
+ # td_arity_expr = makeIntExpr td_arity // grd_type_arity
+ # (type_expr, heaps) = buildFunApp main_module_index gen_type_ds [] heaps // grd_type
+ # (fields_expr, heaps) = buildFunApp main_module_index field_list_ds [] heaps // grd_fields
+ # (body_expr, heaps)
+ = buildPredefConsApp PD_CGenericRecordDescriptor
+ [name_expr, arity_expr, td_arity_expr, type_expr, fields_expr]
+ predefs heaps
+ # fun = makeFunction cons_info_ds.ds_ident group_index [] body_expr No main_module_index td_pos
+ = (fun, (modules, heaps))
+
+ build_field_dsc group_index record_dsc_ds field_dsc_ds {fs_ident, fs_index} (modules, heaps)
+ # ({sd_field_nr}, modules)
+ = modules![td_module].com_selector_defs.[fs_index]
+ # name_expr = makeStringExpr fs_ident.id_name // gfd_name
+ # index_expr = makeIntExpr sd_field_nr // gfd_index
+ # (cons_expr, heaps) = buildFunApp main_module_index record_dsc_ds [] heaps // gfd_cons
# (body_expr, heaps)
- = buildPredefConsApp PD_GenericTypeInfo [type_dsc_expr] predefs heaps
+ = buildPredefConsApp PD_CGenericFieldDescriptor
+ [name_expr, index_expr, cons_expr]
+ predefs heaps
+ # fun = makeFunction field_dsc_ds.ds_ident group_index [] body_expr No main_module_index td_pos
+ = (fun, (modules, heaps))
+
+build_gen_type_function group_index main_module_index td_module td_pos predefs cons_info_ds cons_ds (modules, heaps)
+ # ({cons_type,cons_exi_vars}, modules) = modules![td_module].com_cons_defs.[cons_ds.ds_index]
+ # (type_expr, heaps) = make_type_expr cons_exi_vars cons_type heaps
+ # fun = makeFunction cons_info_ds.ds_ident group_index [] type_expr No main_module_index td_pos
+ = (fun, (modules, heaps))
+where
+ make_type_expr [] {st_vars, st_args, st_result} heaps=:{hp_type_heaps=type_heaps=:{th_vars}}
+ # (_,th_vars) = foldSt (\ {tv_info_ptr} (n, th_vars) -> (n+1, writePtr tv_info_ptr (TVI_GenTypeVarNumber n) th_vars)) st_vars (0,th_vars)
+ # heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
+ # (arg_exprs, heaps) = mapSt make_expr1 st_args heaps
+ # (result_expr, heaps) = make_expr1 st_result heaps
+ # {hp_type_heaps=type_heaps=:{th_vars}} = heaps
+ # th_vars = foldSt (\ {tv_info_ptr} th_vars -> writePtr tv_info_ptr TVI_Empty th_vars) st_vars th_vars
+ # heaps = {heaps & hp_type_heaps={type_heaps & th_vars=th_vars}}
+ = curry arg_exprs result_expr heaps
+ where
+ curry [] result_expr heaps
+ = (result_expr, heaps)
+ curry [x:xs] result_expr heaps
+ # (y, heaps) = curry xs result_expr heaps
+ = make_arrow x y heaps
+
+ make_expr1 :: !AType !*Heaps -> (!Expression, !*Heaps)
+ make_expr1 {at_type} heaps = make_expr at_type heaps
+
+ make_expr :: !Type !*Heaps -> (!Expression, !*Heaps)
+ make_expr (TA type_symb arg_types) heaps
+ # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
+ # (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps
+ = make_apps type_cons arg_exprs heaps
+ make_expr (TAS type_symb arg_types _) heaps
+ # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
+ # (type_cons, heaps) = make_type_cons type_symb.type_ident.id_name heaps
+ = make_apps type_cons arg_exprs heaps
+ make_expr (x --> y) heaps
+ # (x, heaps) = make_expr1 x heaps
+ # (y, heaps) = make_expr1 y heaps
+ = make_arrow x y heaps
+ make_expr TArrow heaps
+ = make_type_cons "(->)" heaps
+ make_expr (TArrow1 type) heaps
+ # (arg_expr, heaps) = make_expr1 type heaps
+ # (arrow_expr, heaps) = make_type_cons "(->)" heaps
+ = make_app arrow_expr arg_expr heaps
+ make_expr (CV {tv_info_ptr} :@: arg_types) heaps
+ # (arg_exprs, heaps) = mapSt make_expr1 arg_types heaps
+ # (tv_expr, heaps) = make_type_var tv_info_ptr heaps
+ = make_apps tv_expr arg_exprs heaps
+ make_expr (TB bt) heaps
+ = make_type_cons (toString bt) heaps
+ make_expr (TV {tv_info_ptr}) heaps
+ = make_type_var tv_info_ptr heaps
+ make_expr (GTV {tv_info_ptr}) heaps
+ = make_type_var tv_info_ptr heaps
+ make_expr (TQV {tv_info_ptr}) heaps
+ = make_type_var tv_info_ptr heaps
+ make_expr TE heaps
+ = make_error_type_cons heaps
+ make_expr (TFA _ _) heaps
+ // error is reported in convertATypeToGenTypeStruct
+ = make_error_type_cons heaps
+ make_expr _ heaps
+ = abort "type does not match\n"
+
+ make_apps x [] heaps
+ = (x, heaps)
+ make_apps x [y:ys] heaps
+ # (z, heaps) = make_app x y heaps
+ = make_apps z ys heaps
+
+ make_type_var tv_info_ptr heaps
+ #! type_var_n = case sreadPtr tv_info_ptr heaps.hp_type_heaps.th_vars of
+ TVI_GenTypeVarNumber n -> n
+ = buildPredefConsApp PD_CGenTypeVar [makeIntExpr type_var_n] predefs heaps
+
+ make_arrow x y heaps = buildPredefConsApp PD_CGenTypeArrow [x, y] predefs heaps
+
+ make_app x y heaps = buildPredefConsApp PD_CGenTypeApp [x, y] predefs heaps
+
+ make_error_type_cons heaps = make_type_cons "<error>" heaps
+ make_type_expr [_:_] {st_vars, st_args, st_result} heaps
+ // Error "cannot build a generic representation of an existential type" is reported in buildStructType
+ = make_type_cons "<error>" heaps
- # (def_sym, funs_and_groups) = buildFunAndGroup ident [] body_expr No main_module_index td_pos funs_and_groups
- = (def_sym, (funs_and_groups, heaps))
+ make_type_cons name heaps
+ # name_expr = makeStringExpr name
+ = buildPredefConsApp PD_CGenTypeCons [name_expr] predefs heaps
// conversions functions
@@ -962,9 +975,9 @@ where
, !*Heaps // state
, !*ErrorAdmin)
build_expr_for_type_rhs type_def_mod type_def_index (AlgType def_symbols) arg_expr heaps error
- = build_expr_for_conses False type_def_mod type_def_index def_symbols arg_expr heaps error
+ = build_expr_for_conses type_def_mod type_def_index def_symbols arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (RecordType {rt_constructor}) arg_expr heaps error
- = build_expr_for_conses True type_def_mod type_def_index [rt_constructor] arg_expr heaps error
+ = build_expr_for_record type_def_mod type_def_index rt_constructor arg_expr heaps error
build_expr_for_type_rhs type_def_mod type_def_index (AbstractType _) arg_expr heaps error
#! error = checkErrorWithIdentPos (newPosition td_ident td_pos) "cannot build isomorphisms for an abstract type" error
= (EE, heaps, error)
@@ -973,34 +986,31 @@ where
= (EE, heaps, error)
// build conversion for constructors of a type def
- build_expr_for_conses is_record type_def_mod type_def_index cons_def_syms arg_expr heaps error
+ build_expr_for_conses type_def_mod type_def_index cons_def_syms arg_expr heaps error
# (case_alts, heaps, error)
- = build_exprs_for_conses is_record 0 (length cons_def_syms) type_def_mod cons_def_syms heaps error
+ = build_exprs_for_conses 0 (length cons_def_syms) type_def_mod cons_def_syms heaps error
# case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} case_alts
# (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
= (case_expr, heaps, error)
// build conversions for constructors
- build_exprs_for_conses :: !Bool !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
+ build_exprs_for_conses :: !Int !Int !Int ![DefinedSymbol] !*Heaps !*ErrorAdmin
-> ([AlgebraicPattern], !*Heaps, !*ErrorAdmin)
- build_exprs_for_conses is_record i n type_def_mod [] heaps error
+ build_exprs_for_conses i n type_def_mod [] heaps error
= ([], heaps, error)
- build_exprs_for_conses is_record i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
- #! (alt, heaps, error) = build_expr_for_cons is_record i n type_def_mod cons_def_sym heaps error
- #! (alts, heaps, error) = build_exprs_for_conses is_record (i+1) n type_def_mod cons_def_syms heaps error
+ build_exprs_for_conses i n type_def_mod [cons_def_sym:cons_def_syms] heaps error
+ #! (alt, heaps, error) = build_expr_for_cons i n type_def_mod cons_def_sym heaps error
+ #! (alts, heaps, error) = build_exprs_for_conses (i+1) n type_def_mod cons_def_syms heaps error
= ([alt:alts], heaps, error)
// build conversion for a constructor
- build_expr_for_cons :: !Bool !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin
+ build_expr_for_cons :: !Int !Int !Int !DefinedSymbol !*Heaps !*ErrorAdmin
-> (AlgebraicPattern, !*Heaps, !*ErrorAdmin)
- build_expr_for_cons is_record i n type_def_mod cons_def_sym=:{ds_ident, ds_arity} heaps error
+ build_expr_for_cons i n type_def_mod cons_def_sym=:{ds_ident, ds_arity} heaps error
#! names = ["x" +++ toString (i+1) +++ toString k \\ k <- [1..ds_arity]]
#! (var_exprs, vars, heaps) = buildVarExprs names heaps
- #! (arg_exprs, heaps) = build_fields is_record var_exprs heaps
- with
- build_fields False var_exprs heaps = (var_exprs, heaps)
- build_fields True var_exprs heaps = mapSdSt build_field var_exprs predefs heaps
+ #! arg_exprs = var_exprs
#! (expr, heaps) = build_prod arg_exprs predefs heaps
#! (expr, heaps) = build_cons expr predefs heaps
@@ -1015,7 +1025,7 @@ where
ap_position = NoPos
}
= (alg_pattern, heaps, error)
-
+
build_sum :: !Int !Int !Expression !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
build_sum i n expr predefs heaps
| n == 0 = abort "build sum of zero elements\n"
@@ -1027,7 +1037,20 @@ where
| otherwise
# (expr, heaps) = build_sum (i - (n/2)) (n - (n/2)) expr predefs heaps
= build_right expr predefs heaps
-
+
+ // build conversion for a record type def
+ build_expr_for_record type_def_mod type_def_index cons_def_sym=:{ds_ident, ds_arity} arg_expr heaps error
+ #! names = ["x1" +++ toString k \\ k <- [1..ds_arity]]
+ #! (var_exprs, vars, heaps) = buildVarExprs names heaps
+ #! (arg_exprs, heaps) = mapSdSt build_field var_exprs predefs heaps
+ #! (expr, heaps) = build_prod arg_exprs predefs heaps
+ #! (expr, heaps) = build_record expr predefs heaps
+ #! alg_pattern = { ap_symbol = {glob_module = type_def_mod, glob_object = cons_def_sym},
+ ap_vars = vars, ap_expr = expr, ap_position = NoPos }
+ # case_patterns = AlgebraicPatterns {gi_module = type_def_mod, gi_index = type_def_index} [alg_pattern]
+ # (case_expr, heaps) = buildCaseExpr arg_expr case_patterns heaps
+ = (case_expr, heaps, error)
+
build_prod :: ![Expression] !PredefinedSymbols !*Heaps -> (!Expression, !*Heaps)
build_prod [] predefs heaps = build_unit heaps
where
@@ -1038,7 +1061,7 @@ where
# (lexpr, heaps) = build_prod lexprs predefs heaps
# (rexpr, heaps) = build_prod rexprs predefs heaps
= build_pair lexpr rexpr predefs heaps
-
+
buildConversionFrom ::
!Index // type def module
!CheckedTypeDef // the type def
@@ -1071,12 +1094,11 @@ where
, !FreeVar
, !*Heaps, !*ErrorAdmin)
build_expr_for_type_rhs type_def_mod (AlgType def_symbols) heaps error
- #! (expr, var, heaps, error) = build_sum False type_def_mod def_symbols heaps error
+ #! (expr, var, heaps, error) = build_sum type_def_mod def_symbols heaps error
#! (expr, var, heaps) = build_case_object var expr predefs heaps
= (expr, var, heaps, error)
build_expr_for_type_rhs type_def_mod (RecordType {rt_constructor}) heaps error
- # (expr, var, heaps, error) = build_sum True type_def_mod [rt_constructor] heaps error
- #! (expr, var, heaps) = build_case_object var expr predefs heaps
+ # (expr, var, heaps, error) = build_record type_def_mod [rt_constructor] heaps error
= (expr, var, heaps, error)
build_expr_for_type_rhs type_def_mod (AbstractType _) heaps error
#! error = reportError td_ident td_pos "cannot build isomorphisms for an abstract type" error
@@ -1088,31 +1110,31 @@ where
= (EE, dummy_fv, heaps, error)
// build expression for sums
- build_sum ::
- !Bool // is record
- !Index
- ![DefinedSymbol]
- !*Heaps !*ErrorAdmin
- -> ( !Expression
- , !FreeVar // top variable
- , !*Heaps, !*ErrorAdmin)
- build_sum is_record type_def_mod [] heaps error
+ build_sum :: !Index ![DefinedSymbol] !*Heaps !*ErrorAdmin -> (!Expression,!FreeVar/*top variable*/,!*Heaps,!*ErrorAdmin)
+ build_sum type_def_mod [] heaps error
= abort "algebraic type with no constructors!\n"
- build_sum is_record type_def_mod [def_symbol] heaps error
+ build_sum type_def_mod [def_symbol] heaps error
#! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps
- #! (prod_expr, var, heaps) = build_prod is_record cons_app_expr cons_arg_vars heaps
+ #! (prod_expr, var, heaps) = build_prod False cons_app_expr cons_arg_vars heaps
#! (alt_expr, var, heaps) = build_case_cons var prod_expr predefs heaps
= (alt_expr, var, heaps, error)
- build_sum is_record type_def_mod def_symbols heaps error
+ build_sum type_def_mod def_symbols heaps error
#! (left_def_syms, right_def_syms) = splitAt ((length def_symbols) /2) def_symbols
#! (left_expr, left_var, heaps, error)
- = build_sum is_record type_def_mod left_def_syms heaps error
+ = build_sum type_def_mod left_def_syms heaps error
#! (right_expr, right_var, heaps, error)
- = build_sum is_record type_def_mod right_def_syms heaps error
- #! (case_expr, var, heaps) =
- build_case_either left_var left_expr right_var right_expr predefs heaps
+ = build_sum type_def_mod right_def_syms heaps error
+ #! (case_expr, var, heaps)
+ = build_case_either left_var left_expr right_var right_expr predefs heaps
= (case_expr, var, heaps, error)
-
+
+ build_record :: !Index ![DefinedSymbol] !*Heaps !*ErrorAdmin -> (!Expression,!FreeVar/*top variable*/,!*Heaps,!*ErrorAdmin)
+ build_record type_def_mod [def_symbol] heaps error
+ #! (cons_app_expr, cons_arg_vars, heaps) = build_cons_app type_def_mod def_symbol heaps
+ #! (prod_expr, var, heaps) = build_prod True cons_app_expr cons_arg_vars heaps
+ #! (alt_expr, var, heaps) = build_case_record var prod_expr predefs heaps
+ = (alt_expr, var, heaps, error)
+
// build expression for products
build_prod ::
!Bool // is record
@@ -1166,6 +1188,9 @@ build_object expr predefs heaps
build_cons expr predefs heaps
= buildPredefConsApp PD_ConsCONS [expr] predefs heaps
+build_record expr predefs heaps
+ = buildPredefConsApp PD_ConsRECORD [expr] predefs heaps
+
build_field var_expr predefs heaps
= buildPredefConsApp PD_ConsFIELD [var_expr] predefs heaps
@@ -1194,6 +1219,12 @@ build_case_cons var body_expr predefs heaps
# case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
= build_case_expr case_patterns heaps
+build_case_record var body_expr predefs heaps
+ # pat = buildPredefConsPattern PD_ConsRECORD [var] body_expr predefs
+ # {pds_module, pds_def} = predefs.[PD_TypeRECORD]
+ # case_patterns = AlgebraicPatterns {gi_module = pds_module, gi_index = pds_def} [pat]
+ = build_case_expr case_patterns heaps
+
build_case_field var body_expr predefs heaps
# pat = buildPredefConsPattern PD_ConsFIELD [var] body_expr predefs
# {pds_module, pds_def} = predefs.[PD_TypeFIELD]
@@ -1271,18 +1302,18 @@ where
#! (st, gs) = foldSt (build_class_if_needed gen_def) kinds (st, gs)
#! gencase = {gencase & gc_kind = kind}
- #! type_index = index_OBJECT_CONS_FIELD_type gencase.gc_type gs.gs_predefs
+ #! type_index = index_gen_cons_with_info_type gencase.gc_type gs.gs_predefs
| type_index>=0
# ({gc_body = GCB_FunIndex fun_index}) = gencase
gen_info_ptr = gen_def.gen_info_ptr
fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
- ocf_index = {ocf_module=module_index,ocf_index=fun_index,ocf_ident=fun_ident}
+ gcf_index = {gcf_module=module_index,gcf_index=fun_index,gcf_ident=fun_ident}
(gen_info,generic_heap) = readPtr gen_info_ptr gs.gs_genh
- gen_OBJECT_CONS_FIELD_indices = {gi\\gi<-:gen_info.gen_OBJECT_CONS_FIELD_indices}
- gen_OBJECT_CONS_FIELD_indices = {gen_OBJECT_CONS_FIELD_indices & [type_index]=ocf_index}
- gen_info = {gen_info & gen_OBJECT_CONS_FIELD_indices=gen_OBJECT_CONS_FIELD_indices}
+ gen_rep_conses = {gi\\gi<-:gen_info.gen_rep_conses}
+ gen_rep_conses = {gen_rep_conses & [type_index]=gcf_index}
+ gen_info = {gen_info & gen_rep_conses=gen_rep_conses}
generic_heap = writePtr gen_info_ptr gen_info generic_heap
gs = {gs & gs_genh=generic_heap}
= (gencase, st, gs)
@@ -1337,7 +1368,7 @@ where
#! ({gen_classes}, hp_generic_heap) = readPtr gen_info_ptr hp_generic_heap
= (lookupGenericClassInfo kind gen_classes, hp_generic_heap)
- add_generic_class_info {gen_info_ptr} class_info gs_genh
+ add_generic_class_info {gen_info_ptr} class_info gs_genh
#! (gen_info=:{gen_classes}, gs_genh) = readPtr gen_info_ptr gs_genh
#! gen_classes = addGenericClassInfo class_info gen_classes
= writePtr gen_info_ptr {gen_info & gen_classes=gen_classes} gs_genh
@@ -1520,8 +1551,7 @@ where
convertGenericCases :: !BimapFunctions !*GenericState -> (!IndexRange, !*GenericState)
convertGenericCases bimap_functions
gs=:{gs_main_module, gs_used_modules, gs_predefs, gs_funs, gs_groups, gs_modules, gs_dcl_modules, gs_td_infos,
- gs_avarh, gs_tvarh, gs_varh, gs_genh, gs_exprh,
- gs_error}
+ gs_avarh, gs_tvarh, gs_varh, gs_genh, gs_exprh, gs_error}
# heaps =
{ hp_expression_heap = gs_exprh
@@ -1610,7 +1640,7 @@ where
#! ({class_members}, modules) = modules![class_info.gci_module].com_class_defs.[class_info.gci_class]
#! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_members.[0].ds_index]
- #! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
+ #! has_generic_info = is_gen_cons_without_instances gc_type gs_predefs
#! ins_type = {it_vars = instance_vars_from_type_cons gc_type_cons, it_types = [gc_type], it_attr_vars = [], it_context = []}
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
@@ -1625,18 +1655,11 @@ where
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, heaps, error))
- # (fun_type_with_generic_info,type_heaps)
- = add_generic_info_to_type fun_type gs_predefs heaps.hp_type_heaps
- # heaps = {heaps & hp_type_heaps=type_heaps}
+ # fun_type_with_generic_info
+ = add_generic_info_to_type fun_type (index_gen_cons_with_info_type gc_type gs_predefs) gs_predefs
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type_with_generic_info dcl_functions heaps
-
- #! ({ds_ident,ds_arity,ds_index}, fun_info, heaps)
- = build_instance_member_with_generic_info module_index gc_ident gc_pos gc_kind fun_ident fun_index fun_type gs_predefs fun_info heaps
- # class_instance_member = {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}
-
- #! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, heaps, error))
build_main_instances_in_main_module :: !Index
@@ -1663,7 +1686,7 @@ where
#! (member_def, modules) = modules![class_info.gci_module].com_member_defs.[class_members.[0].ds_index]
#! ins_type = {it_vars = instance_vars_from_type_cons gc_type_cons, it_types = [gc_type], it_attr_vars = [], it_context = []}
- #! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
+ #! has_generic_info = is_gen_cons_without_instances gc_type gs_predefs
#! (fun_type, heaps, error)
= determine_type_of_member_instance member_def ins_type heaps error
@@ -1681,9 +1704,8 @@ where
#! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
- # (fun_type_with_generic_info,type_heaps)
- = add_generic_info_to_type fun_type gs_predefs heaps.hp_type_heaps
- # heaps = {heaps & hp_type_heaps=type_heaps}
+ # fun_type_with_generic_info
+ = add_generic_info_to_type fun_type (index_gen_cons_with_info_type gc_type gs_predefs) gs_predefs
#! (dcl_functions, heaps)
= update_dcl_function fun_index fun_ident fun_type_with_generic_info dcl_functions heaps
@@ -1691,12 +1713,6 @@ where
#! (fun_info, fun_defs, td_infos, modules, heaps, error)
= update_icl_function fun_index fun_ident gencase fun_type_with_generic_info has_generic_info
fun_info fun_defs td_infos modules heaps error
-
- #! ({ds_ident,ds_arity,ds_index}, fun_info, heaps)
- = build_instance_member_with_generic_info module_index gc_ident gc_pos gc_kind fun_ident fun_index fun_type gs_predefs fun_info heaps
- # class_instance_member = {cim_ident=ds_ident,cim_arity=ds_arity,cim_index=ds_index}
-
- #! ins_info = build_class_instance class_info.gci_class gc_ident gc_pos gc_kind class_instance_member ins_type ins_info
= (dcl_functions, modules, (fun_info, ins_info, fun_defs, td_infos, heaps, error))
instance_vars_from_type_cons (TypeConsVar tv)
@@ -1727,12 +1743,14 @@ where
= st
build_shorthand_instances module_index
gencase=:{gc_kind=gc_kind=:KindArrow kinds,gc_body=GCB_FunIndex fun_index,gc_type,gc_type_cons,gc_generic,gc_ident,gc_pos}
- st
+ st
+ | is_gen_cons_without_instances gc_type gs_predefs
+ // no shorthand instances for OBJECT, RECORD, CONS, FIELD, PAIR and EITHER
+ = st
= foldSt build_shorthand_instance [1 .. length kinds] st
where
build_shorthand_instance num_args
(modules, (fun_info, ins_info, heaps, error))
-
#! (consumed_kinds, rest_kinds) = splitAt num_args kinds
#! this_kind = case rest_kinds of
[] -> KindConst
@@ -1750,7 +1768,7 @@ where
# fun_ident = genericIdentToFunIdent gc_ident.id_name gc_type_cons
- #! has_generic_info = is_OBJECT_CONS_FIELD_type gc_type gs_predefs
+ #! has_generic_info = is_gen_cons_without_instances gc_type gs_predefs
#! (memfun_ds, fun_info, heaps)
= build_shorthand_instance_member module_index this_kind gc_generic has_generic_info fun_index fun_ident gc_pos fun_type arg_class_infos fun_info heaps
@@ -1821,10 +1839,7 @@ where
#! arg_exprs = gen_exprs ++ arg_var_exprs
# (body_expr, heaps)
- = if has_generic_info
- (let (generic_info_expr, heaps2) = buildPredefConsApp PD_NoGenericInfo [] gs_predefs heaps
- in buildFunApp2 module_index fun_index fun_ident [generic_info_expr:arg_exprs] heaps2)
- (buildFunApp2 module_index fun_index fun_ident arg_exprs heaps)
+ = buildFunApp2 module_index fun_index fun_ident arg_exprs heaps
#! (st, heaps) = fresh_symbol_type st heaps
@@ -1931,75 +1946,59 @@ where
}
= (ins_index+1, [ins:instances])
- // Creates a function that just calls the generic case function, but with an extra NoGenericInfo argument
- build_instance_member_with_generic_info module_index gc_ident gc_pos gcf_kind fun_ident fun_index st predefs fun_info heaps
- #! arg_var_names = ["x" +++ toString i \\ i <- [1..st.st_arity]]
- #! (arg_var_exprs, arg_vars, heaps) = buildVarExprs arg_var_names heaps
-
- # (generic_info_expr, heaps) = buildPredefConsApp PD_NoGenericInfo [] predefs heaps
- # arg_var_exprs = [generic_info_expr:arg_var_exprs]
-
- #! (expr_info_ptr, hp_expression_heap) = newPtr EI_Empty heaps.hp_expression_heap
- #! heaps = {heaps & hp_expression_heap = hp_expression_heap}
- #! expr = App
- { app_symb =
- { symb_ident=fun_ident
- , symb_kind=SK_Function {glob_module=module_index, glob_object=fun_index}
- }
- , app_args = arg_var_exprs
- , app_info_ptr = expr_info_ptr
- }
- #! (st, heaps) = fresh_symbol_type st heaps
- #! memfun_name = genericIdentToMemberIdent gc_ident.id_name gcf_kind
- #! (fun_ds, fun_info)
- = buildFunAndGroup memfun_name arg_vars expr (Yes st) gs_main_module gc_pos fun_info
- = (fun_ds, fun_info, heaps)
-
fresh_symbol_type :: !SymbolType !*Heaps -> (!SymbolType, !*Heaps)
fresh_symbol_type st heaps=:{hp_type_heaps}
# (fresh_st, hp_type_heaps) = freshSymbolType st hp_type_heaps
= (fresh_st, {heaps & hp_type_heaps = hp_type_heaps})
// add an argument for generic info at the beginning
-add_generic_info_to_type :: !SymbolType !{#PredefinedSymbol} !*TypeHeaps -> (!SymbolType,!*TypeHeaps)
-add_generic_info_to_type st=:{st_arity, st_args, st_args_strictness} predefs th=:{th_vars}
- #! {pds_module, pds_def} = predefs.[PD_GenericInfo]
- #! pds_ident = predefined_idents.[PD_GenericInfo]
- #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} pds_ident 0
- #! st = {st & st_args = [makeAType (TA type_symb []) TA_Multi : st_args]
- , st_arity = st_arity + 1
- , st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness
- }
- = (st, {th & th_vars = th_vars})
-
-index_OBJECT_CONS_FIELD_type :: !Type !{#PredefinedSymbol} -> Int
-index_OBJECT_CONS_FIELD_type (TA {type_index={glob_module,glob_object}} []) predefs
- # {pds_module,pds_def} = predefs.[PD_TypeOBJECT]
- | glob_module==pds_module && pds_def==glob_object
- = 0
- # {pds_module,pds_def} = predefs.[PD_TypeCONS]
- | glob_module==pds_module && pds_def==glob_object
- = 1
- # {pds_module,pds_def} = predefs.[PD_TypeFIELD]
- | glob_module==pds_module && pds_def==glob_object
- = 2
+add_generic_info_to_type :: !SymbolType !Int !{#PredefinedSymbol} -> SymbolType
+add_generic_info_to_type st=:{st_arity, st_args, st_args_strictness} generic_info_index predefs
+ # st_args = add_generic_info_types generic_info_index st_args predefs
+ = {st & st_args = st_args, st_arity = st_arity + 1, st_args_strictness = insert_n_lazy_values_at_beginning 1 st_args_strictness}
+where
+ add_generic_info_types 0 args predefs
+ # {pds_module, pds_def} = predefs.[PD_TGenericTypeDefDescriptor]
+ #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericTypeDefDescriptor] 0
+ = [makeAType (TA type_symb []) TA_Multi : args]
+ add_generic_info_types 1 args predefs
+ # {pds_module, pds_def} = predefs.[PD_TGenericConsDescriptor]
+ #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericConsDescriptor] 0
+ = [makeAType (TA type_symb []) TA_Multi : args]
+ add_generic_info_types 2 args predefs
+ # {pds_module, pds_def} = predefs.[PD_TGenericRecordDescriptor]
+ #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericRecordDescriptor] 0
+ = [makeAType (TA type_symb []) TA_Multi : args]
+ add_generic_info_types 3 args predefs
+ # {pds_module, pds_def} = predefs.[PD_TGenericFieldDescriptor]
+ #! type_symb = MakeTypeSymbIdent {glob_module = pds_module, glob_object = pds_def} predefined_idents.[PD_TGenericFieldDescriptor] 0
+ = [makeAType (TA type_symb []) TA_Multi : args]
+
+index_gen_cons_with_info_type :: !Type !{#PredefinedSymbol} -> Int
+index_gen_cons_with_info_type (TA {type_index={glob_module,glob_object}} []) predefs
+ | glob_module==predefs.[PD_StdGeneric].pds_def
+ | glob_object==predefs.[PD_TypeOBJECT].pds_def
+ = 0
+ | glob_object==predefs.[PD_TypeCONS].pds_def
+ = 1
+ | glob_object==predefs.[PD_TypeRECORD].pds_def
+ = 2
+ | glob_object==predefs.[PD_TypeFIELD].pds_def
+ = 3
+ = -1
= -1
-index_OBJECT_CONS_FIELD_type _ predefs
+index_gen_cons_with_info_type _ predefs
= -1
-is_OBJECT_CONS_FIELD_type :: !Type !{#PredefinedSymbol} -> Bool
-is_OBJECT_CONS_FIELD_type (TA {type_index={glob_module,glob_object}} []) predefs
- # {pds_module,pds_def} = predefs.[PD_TypeOBJECT]
- | glob_module==pds_module && pds_def==glob_object
- = True
- # {pds_module,pds_def} = predefs.[PD_TypeCONS]
- | glob_module==pds_module && pds_def==glob_object
- = True
- # {pds_module,pds_def} = predefs.[PD_TypeFIELD]
- | glob_module==pds_module && pds_def==glob_object
- = True
+is_gen_cons_without_instances :: !Type !{#PredefinedSymbol} -> Bool
+is_gen_cons_without_instances (TA {type_index={glob_module,glob_object}} []) predefs
+ | glob_module==predefs.[PD_StdGeneric].pds_def
+ = glob_object==predefs.[PD_TypeOBJECT].pds_def
+ || glob_object==predefs.[PD_TypeCONS].pds_def
+ || glob_object==predefs.[PD_TypeRECORD].pds_def
+ || glob_object==predefs.[PD_TypeFIELD].pds_def
= False
-is_OBJECT_CONS_FIELD_type _ predefs
+is_gen_cons_without_instances _ predefs
= False
buildGenericCaseBody ::
@@ -2069,11 +2068,11 @@ where
= specialize_generic_bimap gcf_generic gtr_type spec_env gc_ident gc_pos main_module_index predefs funs_and_groups heaps error
= (expr,funs_and_groups,td_infos,heaps,error)
- # ({gen_OBJECT_CONS_FIELD_indices},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap
+ # ({gen_rep_conses},generic_heap) = readPtr gen_info_ptr heaps.hp_generic_heap
heaps = {heaps & hp_generic_heap=generic_heap}
# (expr,td_infos,heaps,error)
- = specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_OBJECT_CONS_FIELD_indices main_module_index td_infos heaps error
+ = specializeGeneric gcf_generic gtr_type spec_env gc_ident gc_pos gen_rep_conses main_module_index td_infos heaps error
= (expr,funs_and_groups,td_infos,heaps,error)
// adaptor that converts a function for the generic representation into a
@@ -2304,12 +2303,12 @@ specializeGeneric ::
![(TypeVar, TypeVarInfo)] // specialization environment
!Ident // generic/generic case
!Position // of generic case
- !{#OBJECT_CONS_FIELD_index}
+ !{#GenericRepresentationConstructor}
!Index // main_module index
!*TypeDefInfos !*Heaps !*ErrorAdmin
-> (!Expression,
!*TypeDefInfos,!*Heaps,!*ErrorAdmin)
-specializeGeneric gen_index type spec_env gen_ident gen_pos gen_OBJECT_CONS_FIELD_indices main_module_index td_infos heaps error
+specializeGeneric gen_index type spec_env gen_ident gen_pos gen_rep_conses main_module_index td_infos heaps error
#! heaps = set_tvs spec_env heaps
#! (expr, (td_infos, heaps, error))
= specialize type (td_infos, heaps, error)
@@ -2340,22 +2339,34 @@ where
specialize (GTSCons cons_info_ds arg_type) st
# (arg_expr, (td_infos, heaps, error)) = specialize arg_type st
#! (generic_info_expr, heaps) = buildFunApp main_module_index cons_info_ds [] heaps
- # gen_CONS_index = gen_OBJECT_CONS_FIELD_indices.[1]
- | gen_CONS_index.ocf_module>=0
+ # gen_CONS_index = gen_rep_conses.[1]
+ | gen_CONS_index.gcf_module>=0
#! (expr, heaps)
- = buildFunApp2 gen_CONS_index.ocf_module gen_CONS_index.ocf_index gen_CONS_index.ocf_ident [generic_info_expr, arg_expr] heaps
+ = buildFunApp2 gen_CONS_index.gcf_module gen_CONS_index.gcf_index gen_CONS_index.gcf_ident [generic_info_expr, arg_expr] heaps
= (expr, (td_infos, heaps, error))
// no instance for CONS, report error here ?
#! (expr, heaps)
= buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps
= (expr, (td_infos, heaps, error))
+ specialize (GTSRecord record_info_ds arg_type) st
+ # (arg_expr, (td_infos, heaps, error)) = specialize arg_type st
+ #! (generic_info_expr, heaps) = buildFunApp main_module_index record_info_ds [] heaps
+ # gen_RECORD_index = gen_rep_conses.[2]
+ | gen_RECORD_index.gcf_module>=0
+ #! (expr, heaps)
+ = buildFunApp2 gen_RECORD_index.gcf_module gen_RECORD_index.gcf_index gen_RECORD_index.gcf_ident [generic_info_expr, arg_expr] heaps
+ = (expr, (td_infos, heaps, error))
+ // no instance for RECORD, report error here ?
+ #! (expr, heaps)
+ = buildGenericApp gen_index.gi_module gen_index.gi_index gen_ident (KindArrow [KindConst]) [arg_expr] heaps
+ = (expr, (td_infos, heaps, error))
specialize (GTSField field_info_ds arg_type) st
# (arg_expr, (td_infos, heaps, error)) = specialize arg_type st
#! (generic_info_expr, heaps) = buildFunApp main_module_index field_info_ds [] heaps
- # gen_FIELD_index = gen_OBJECT_CONS_FIELD_indices.[2]
- | gen_FIELD_index.ocf_module>=0
+ # gen_FIELD_index = gen_rep_conses.[3]
+ | gen_FIELD_index.gcf_module>=0
#! (expr, heaps)
- = buildFunApp2 gen_FIELD_index.ocf_module gen_FIELD_index.ocf_index gen_FIELD_index.ocf_ident [generic_info_expr, arg_expr] heaps
+ = buildFunApp2 gen_FIELD_index.gcf_module gen_FIELD_index.gcf_index gen_FIELD_index.gcf_ident [generic_info_expr, arg_expr] heaps
= (expr, (td_infos, heaps, error))
// no instance for FIELD, report error here ?
#! (expr, heaps)
@@ -2364,10 +2375,10 @@ where
specialize (GTSObject type_info_ds arg_type) st
# (arg_expr, (td_infos, heaps, error)) = specialize arg_type st
#! (generic_info_expr, heaps) = buildFunApp main_module_index type_info_ds [] heaps
- # gen_OBJECT_index = gen_OBJECT_CONS_FIELD_indices.[0]
- | gen_OBJECT_index.ocf_module>=0
+ # gen_OBJECT_index = gen_rep_conses.[0]
+ | gen_OBJECT_index.gcf_module>=0
#! (expr, heaps)
- = buildFunApp2 gen_OBJECT_index.ocf_module gen_OBJECT_index.ocf_index gen_OBJECT_index.ocf_ident [generic_info_expr, arg_expr] heaps
+ = buildFunApp2 gen_OBJECT_index.gcf_module gen_OBJECT_index.gcf_index gen_OBJECT_index.gcf_ident [generic_info_expr, arg_expr] heaps
= (expr, (td_infos, heaps, error))
// no instance for OBJECT, report error here ?
#! (expr, heaps)
@@ -2461,6 +2472,11 @@ where
(expr, funs_and_groups, heaps)
= bimap_CONS_expression [arg_expr] main_module_index predefs funs_and_groups heaps
= (expr, (funs_and_groups, heaps, error))
+ specialize (GTSRecord cons_info_ds arg_type) st
+ # (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st
+ (expr, funs_and_groups, heaps)
+ = bimap_RECORD_expression [arg_expr] main_module_index predefs funs_and_groups heaps
+ = (expr, (funs_and_groups, heaps, error))
specialize (GTSField field_info_ds arg_type) st
# (arg_expr, (funs_and_groups, heaps, error)) = specialize arg_type st
(expr, funs_and_groups, heaps)
@@ -3254,6 +3270,37 @@ bimap_CONS_expression arg_exprs main_module_index predefs funs_and_groups=:{fg_b
(bimap_arrow_expr,heaps) = buildFunApp2 main_module_index bimap_CONS_index bimap_CONS_ident arg_exprs heaps
= (bimap_arrow_expr,funs_and_groups,heaps)
+bimap_RECORD_expression arg_exprs main_module_index predefs funs_and_groups=:{fg_bimap_functions={bimap_RECORD_function={fii_index,fii_ident}}} heaps
+ | fii_index>=0
+ # (expr,heaps) = buildFunApp2 main_module_index fii_index fii_ident arg_exprs heaps
+ = (expr,funs_and_groups,heaps)
+ /*
+ bimap/RECORD arg
+ = {map_to = map/RECORD arg.map_to, map_from = map/RECORD arg.map_from}
+ where
+ map/RECORD f (RECORD x) = RECORD (f x)
+ */
+ # map_RECORD_ident = makeIdent "map/RECORD"
+ (f_expr,f_var,heaps) = buildVarExpr "f" heaps
+ (x_expr,x_var,heaps) = buildVarExpr "x" heaps
+
+ (cons_expr,heaps) = build_record (f_expr @ [x_expr]) predefs heaps
+ (case_expr,c_var,heaps) = build_case_record x_var cons_expr predefs heaps
+ args = [f_var,c_var]
+ (map_RECORD_index,funs_and_groups) = buildFunAndGroup2 map_RECORD_ident args case_expr main_module_index funs_and_groups
+
+ bimap_RECORD_ident = makeIdent "bimap/RECORD"
+ (to_arg_expr,from_arg_expr,arg_var,heaps) = build_var_with_bimap_selectors "arg" predefs heaps
+ (bimap_expr,heaps) = build_bimap_with_calls map_RECORD_index map_RECORD_ident [to_arg_expr] [from_arg_expr] main_module_index predefs heaps
+
+ args = [arg_var]
+ (bimap_RECORD_index,funs_and_groups) = buildFunAndGroup2 bimap_RECORD_ident args bimap_expr main_module_index funs_and_groups
+
+ funs_and_groups = {funs_and_groups & fg_bimap_functions.bimap_RECORD_function={fii_index=bimap_RECORD_index,fii_ident=bimap_RECORD_ident}}
+
+ (bimap_arrow_expr,heaps) = buildFunApp2 main_module_index bimap_RECORD_index bimap_RECORD_ident arg_exprs heaps
+ = (bimap_arrow_expr,funs_and_groups,heaps)
+
bimap_FIELD_expression arg_exprs main_module_index predefs funs_and_groups=:{fg_bimap_functions={bimap_FIELD_function={fii_index,fii_ident}}} heaps
| fii_index>=0
# (expr,heaps) = buildFunApp2 main_module_index fii_index fii_ident arg_exprs heaps
@@ -3817,6 +3864,7 @@ where
// This is the weakest requirement,
// since we do not know how the generic argument will be used
// in the instance functions. It depends on the instance type.
+/*
curryGenericArgType :: !SymbolType !String !*TypeHeaps
-> (!SymbolType, !*TypeHeaps)
curryGenericArgType st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs}
@@ -3832,7 +3880,7 @@ curryGenericArgType st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_va
, st_attr_vars = attr_vars
}
= (curried_st, {th & th_attrs = th_attrs})
- //---> ("curryGenericArgType", st, curried_st)
+*/
curryGenericArgType1 :: !SymbolType !String !*TypeHeaps -> (!SymbolType, !*TypeHeaps)
curryGenericArgType1 st=:{st_args, st_result, st_attr_env, st_attr_vars} attr_var_name th=:{th_attrs}
@@ -4551,6 +4599,16 @@ where
# (zs, st) = zipWithSt xs ys st
= ([z:zs], st)
+zipWith3St f l1 l2 l3 st
+ :== zipWith3St l1 l2 l3 st
+where
+ zipWith3St [] [] [] st
+ = ([], st)
+ zipWith3St [x:xs] [y:ys] [z:zs] st
+ # (r, st) = f x y z st
+ # (rs, st) = zipWith3St xs ys zs st
+ = ([r:rs], st)
+
zipWithSt2 f l1 l2 st1 st2
:== zipWithSt2 l1 l2 st1 st2
where
diff --git a/frontend/parse.icl b/frontend/parse.icl
index 1ad3a95..b1b16f5 100644
--- a/frontend/parse.icl
+++ b/frontend/parse.icl
@@ -569,6 +569,7 @@ where
# (ok, {at_type=type}, pState) = trySimpleType TA_None pState
# (ident, pState) = stringToIdent name (IC_GenericCase type) pState
# (type_CONS_ident, pState) = stringToIdent "CONS" IC_Type pState
+ # (type_RECORD_ident, pState) = stringToIdent "RECORD" IC_Type pState
# (type_FIELD_ident, pState)= stringToIdent "FIELD" IC_Type pState
# (type_OBJECT_ident, pState)= stringToIdent "OBJECT" IC_Type pState
# (generic_ident, pState) = stringToIdent name IC_Generic pState
@@ -599,14 +600,13 @@ where
-> case type_cons of
(TypeConsSymb {type_ident})
| type_ident == type_CONS_ident
- # (cons_CONS_ident, pState) = stringToIdent "GenericConsInfo" IC_Expression pState
- -> (PE_List [PE_Ident cons_CONS_ident, geninfo_arg], pState)
+ -> (geninfo_arg, pState)
+ | type_ident == type_RECORD_ident
+ -> (geninfo_arg, pState)
| type_ident == type_FIELD_ident
- # (cons_FIELD_ident, pState) = stringToIdent "GenericFieldInfo" IC_Expression pState
- -> (PE_List [PE_Ident cons_FIELD_ident, geninfo_arg], pState)
+ -> (geninfo_arg, pState)
| type_ident == type_OBJECT_ident
- # (cons_OBJECT_ident, pState) = stringToIdent "GenericTypeDefInfo" IC_Expression pState
- -> (PE_List [PE_Ident cons_OBJECT_ident, geninfo_arg], pState)
+ -> (geninfo_arg, pState)
_
| otherwise
-> (geninfo_arg, pState)
diff --git a/frontend/predef.dcl b/frontend/predef.dcl
index 8c45127..e649c95 100644
--- a/frontend/predef.dcl
+++ b/frontend/predef.dcl
@@ -170,35 +170,34 @@ PD_TypeEITHER :== 179
PD_TypePAIR :== 180
// for constructor info
PD_TypeCONS :== 181
-PD_TypeFIELD :== 182
-PD_TypeOBJECT :== 183
-PD_GenericInfo :== 184
-//PD_TGenericConsDescriptor :== 184
-PD_TGenericFieldDescriptor :== 185
-PD_TGenericTypeDefDescriptor :== 186
-PD_TGenConsPrio :== 187
-PD_TGenConsAssoc :== 188
-PD_TGenType :== 189
-
-PD_TypeGenericDict :== 190
+PD_TypeRECORD :== 182
+PD_TypeFIELD :== 183
+PD_TypeOBJECT :== 184
+PD_TGenericConsDescriptor :== 185
+PD_TGenericRecordDescriptor :== 186
+PD_TGenericFieldDescriptor :== 187
+PD_TGenericTypeDefDescriptor :== 188
+PD_TGenConsPrio :== 189
+PD_TGenConsAssoc :== 190
+PD_TGenType :== 191
+
+PD_TypeGenericDict :== 192
// Generics fields
-PD_map_to :== 191
-PD_map_from :== 192
+PD_map_to :== 193
+PD_map_from :== 194
// Generics expression
-PD_ConsBimap :== 193
-PD_ConsUNIT :== 194
-PD_ConsLEFT :== 195
-PD_ConsRIGHT :== 196
-PD_ConsPAIR :== 197
+PD_ConsBimap :== 195
+PD_ConsUNIT :== 196
+PD_ConsLEFT :== 197
+PD_ConsRIGHT :== 198
+PD_ConsPAIR :== 199
// for constructor info
-PD_ConsCONS :== 198
-PD_ConsFIELD :== 199
-PD_ConsOBJECT :== 200
-PD_NoGenericInfo :== 201
-PD_GenericConsInfo :== 202
-PD_GenericFieldInfo :== 203
-PD_GenericTypeInfo :== 204
-PD_CGenericConsDescriptor :== 205
+PD_ConsCONS :== 200
+PD_ConsRECORD :== 201
+PD_ConsFIELD :== 202
+PD_ConsOBJECT :== 203
+PD_CGenericConsDescriptor :== 204
+PD_CGenericRecordDescriptor :== 205
PD_CGenericFieldDescriptor :== 206
PD_CGenericTypeDefDescriptor :== 207
PD_CGenConsNoPrio :== 208
diff --git a/frontend/predef.icl b/frontend/predef.icl
index b7d51b6..75e372f 100644
--- a/frontend/predef.icl
+++ b/frontend/predef.icl
@@ -182,17 +182,16 @@ predefined_idents
[PD_ConsPAIR] = i "PAIR",
[PD_TypeCONS] = i "CONS",
[PD_ConsCONS] = i "CONS",
+ [PD_TypeRECORD] = i "RECORD",
+ [PD_ConsRECORD] = i "RECORD",
[PD_TypeFIELD] = i "FIELD",
[PD_ConsFIELD] = i "FIELD",
[PD_TypeOBJECT] = i "OBJECT",
[PD_ConsOBJECT] = i "OBJECT",
- [PD_GenericInfo] = i "GenericInfo",
- [PD_NoGenericInfo] = i "NoGenericInfo",
- [PD_GenericConsInfo] = i "GenericConsInfo",
- [PD_GenericFieldInfo] = i "GenericFieldInfo",
- [PD_GenericTypeInfo] = i "GenericTypeDefInfo",
-// [PD_TGenericConsDescriptor] = i "GenericConsDescriptor",
+ [PD_TGenericConsDescriptor] = i "GenericConsDescriptor",
[PD_CGenericConsDescriptor] = i "_GenericConsDescriptor",
+ [PD_TGenericRecordDescriptor] = i "GenericRecordDescriptor",
+ [PD_CGenericRecordDescriptor] = i "_GenericRecordDescriptor",
[PD_TGenericFieldDescriptor] = i "GenericFieldDescriptor",
[PD_CGenericFieldDescriptor] = i "_GenericFieldDescriptor",
[PD_TGenericTypeDefDescriptor] = i "GenericTypeDefDescriptor",
@@ -248,7 +247,6 @@ predefined_idents
[PD_FromThenToU]= i "_from_then_to_u",
[PD_FromThenToUTS]= i "_from_then_to_uts",
[PD_FromThenToO]= i "_from_then_to_o"
-
}
=: idents
where
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index c935783..a8cdd97 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -412,13 +412,14 @@ cNameLocationDependent :== True
:: GenericInfo =
{ gen_classes :: !GenericClassInfos
, gen_var_kinds :: ![TypeKind] // kinds of all st_vars of the gen_type
- , gen_OBJECT_CONS_FIELD_indices :: !{#OBJECT_CONS_FIELD_index}
+ , gen_rep_conses :: !{#GenericRepresentationConstructor}
+ // OBJECT, CONS, RECORD, FIELD
}
-:: OBJECT_CONS_FIELD_index =
- { ocf_module :: !Int
- , ocf_index :: !Int
- , ocf_ident :: !Ident
+:: GenericRepresentationConstructor =
+ { gcf_module :: !Int
+ , gcf_index :: !Int
+ , gcf_ident :: !Ident
}
:: GenericInfoPtr :== Ptr GenericInfo
@@ -576,6 +577,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
| GTSAppVar TypeVar [GenTypeStruct]
| GTSVar TypeVar
| GTSCons DefinedSymbol GenTypeStruct
+ | GTSRecord DefinedSymbol GenTypeStruct
| GTSField DefinedSymbol GenTypeStruct
| GTSObject DefinedSymbol GenTypeStruct
| GTSPair !GenTypeStruct !GenTypeStruct // for optimizing bimaps