aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/check.icl2
-rw-r--r--frontend/frontend.icl11
-rw-r--r--frontend/generics1.icl28
-rw-r--r--frontend/predef.dcl65
-rw-r--r--frontend/predef.icl7
-rw-r--r--frontend/syntax.dcl1
-rw-r--r--frontend/trans.icl16
7 files changed, 89 insertions, 41 deletions
diff --git a/frontend/check.icl b/frontend/check.icl
index 1315b06..0986851 100644
--- a/frontend/check.icl
+++ b/frontend/check.icl
@@ -3472,6 +3472,8 @@ where
<=< adjustPredefSymbol PD_ConsCONS mod_index STE_Constructor
<=< adjustPredefSymbol PD_TypeFIELD mod_index STE_Type
<=< adjustPredefSymbol PD_ConsFIELD mod_index STE_Constructor
+ <=< adjustPredefSymbol PD_TypeREC mod_index STE_Type
+ <=< adjustPredefSymbol PD_ConsREC 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
diff --git a/frontend/frontend.icl b/frontend/frontend.icl
index 66c1e6e..bf6f110 100644
--- a/frontend/frontend.icl
+++ b/frontend/frontend.icl
@@ -139,7 +139,7 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
# error = error_admin.ea_file
/*
- # (_,genout,files) = fopen "c:\\Generics\\genout.icl" FWriteText files
+ # (_,genout,files) = fopen "c:\\Clean\\Generics\\genout.icl" FWriteText files
# (fun_defs, genout) = printFunDefs fun_defs genout
# (ok,files) = fclose genout files
| not ok = abort "could not write genout.icl"
@@ -149,6 +149,15 @@ frontEndInterface options mod_ident search_paths cached_dcl_modules functions_an
| not ok
= (No,{},{},0,main_dcl_module_n,predef_symbols, hash_table, files, error, io, out, tcl_file, heaps)
+/*
+ # (components, fun_defs) = partitionateFunctions (fun_defs -*-> "partitionateFunctions") (icl_global_functions++icl_instances ++ [icl_specials] ++ icl_gencases ++ generic_ranges)
+ # (_,f,files) = fopen "components" FWriteText files
+ (components, fun_defs, f) = showComponents {x\\x<-:components} 0 True fun_defs f
+ (ok,files) = fclose f files
+ | ok<>ok
+ = abort "";
+*/
+
# (ok, fun_defs, array_instances, type_code_instances, common_defs, imported_funs, type_def_infos, heaps, predef_symbols, error,out)
= typeProgram (components -*-> "Typing") main_dcl_module_n fun_defs/*icl_functions*/ icl_specials list_inferred_types icl_common [a\\a<-:icl_import] dcl_mods icl_used_module_numbers td_infos heaps predef_symbols error out dcl_mods
diff --git a/frontend/generics1.icl b/frontend/generics1.icl
index de929f4..cd07fa2 100644
--- a/frontend/generics1.icl
+++ b/frontend/generics1.icl
@@ -564,8 +564,8 @@ buildTypeDefInfo1 td_module {td_name, td_pos, td_arity} alts fields main_module_
# (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_funs = field_dsc_funs ++ cons_dsc_funs ++ [type_def_dsc_fun] ++ funs
+ // 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
# funs_and_groups = (new_fun_index, new_group_index, new_funs, new_groups)
@@ -576,7 +576,7 @@ buildTypeDefInfo1 td_module {td_name, td_pos, td_arity} alts fields main_module_
= mapSt build_field_info field_dsc_dss (funs_and_groups, 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 = reverse field_infos}]
+ ([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"
@@ -586,18 +586,24 @@ where
build_type_def_dsc group_index cons_info_dss {ds_index, ds_ident} heaps
# td_name_expr = makeStringExpr td_name.id_name
# td_arity_expr = makeIntExpr td_arity
+ # num_conses_expr = makeIntExpr (length alts)
# (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, td_conses_expr]
+ [ td_name_expr
+ , td_arity_expr
+ , num_conses_expr
+ , td_conses_expr
+ ]
predefs heaps
# fun = makeFunction ds_ident ds_index 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)
- # ({cons_symb, cons_type, cons_priority}, modules) = modules! [td_module].com_cons_defs.[cons_ds.ds_index]
+ # ({cons_symb, cons_type, cons_priority,cons_index}, modules)
+ = modules! [td_module].com_cons_defs.[cons_ds.ds_index]
# name_expr = makeStringExpr cons_symb.id_name
# arity_expr = makeIntExpr cons_type.st_arity
# (prio_expr, heaps) = make_prio_expr cons_priority heaps
@@ -605,6 +611,7 @@ where
# (type_expr, heaps) = make_type_expr 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_index
# (body_expr, heaps)
= buildPredefConsApp PD_CGenericConsDescriptor
[ name_expr
@@ -613,6 +620,7 @@ where
, type_def_expr
, type_expr
, fields_expr
+ , cons_index_expr
]
predefs heaps
@@ -1066,6 +1074,12 @@ where
# case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
= build_case_expr case_patterns heaps
+ // REC case
+ build_case_field var body_expr heaps
+ # pat = buildPredefConsPattern PD_ConsREC [var] body_expr predefs
+ # {pds_module, pds_def} = predefs.[PD_TypeREC]
+ # case_patterns = AlgebraicPatterns {glob_module = pds_module, glob_object = pds_def} [pat]
+ = build_case_expr case_patterns heaps
// case with a variable as the selector expression
build_case_expr case_patterns heaps
@@ -3162,8 +3176,8 @@ makeFunction ident fun_index group_index arg_vars body_expr opt_sym_type main_dc
, fi_dynamics = []
, fi_properties = 0
}
- }
- //---> ("makeFunction", ident, fun_index)
+ }
+ //---> ("makeFunction", ident, fun_index, collectCalls main_dcl_module_n body_expr)
// build function and
buildFunAndGroup ::
diff --git a/frontend/predef.dcl b/frontend/predef.dcl
index f93cb84..70874f9 100644
--- a/frontend/predef.dcl
+++ b/frontend/predef.dcl
@@ -173,38 +173,39 @@ 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_ModuleConsSymbol :== 218
-
-PD_NrOfPredefSymbols :== 219
+PD_TypeREC :== 193
+PD_ConsREC :== 194
+PD_GenericInfo :== 195
+PD_NoGenericInfo :== 196
+PD_GenericConsInfo :== 197
+PD_GenericFieldInfo :== 198
+PD_TGenericConsDescriptor :== 199
+PD_CGenericConsDescriptor :== 200
+PD_TGenericFieldDescriptor :== 201
+PD_CGenericFieldDescriptor :== 202
+PD_TGenericTypeDefDescriptor :== 203
+PD_CGenericTypeDefDescriptor :== 204
+PD_TGenConsPrio :== 205
+PD_CGenConsNoPrio :== 206
+PD_CGenConsPrio :== 207
+PD_TGenConsAssoc :== 208
+PD_CGenConsAssocNone :== 209
+PD_CGenConsAssocLeft :== 210
+PD_CGenConsAssocRight :== 211
+PD_TGenType :== 212
+PD_CGenTypeCons :== 213
+PD_CGenTypeVar :== 214
+PD_CGenTypeArrow :== 215
+PD_CGenTypeApp :== 216
+
+
+PD_GenericBimap :== 217
+PD_bimapId :== 218
+
+PD_TypeGenericDict :== 219
+
+PD_ModuleConsSymbol :== 220
+PD_NrOfPredefSymbols :== 221
GetTupleConsIndex tup_arity :== PD_Arity2TupleSymbol + tup_arity - 2
GetTupleTypeIndex tup_arity :== PD_Arity2TupleType + tup_arity - 2
diff --git a/frontend/predef.icl b/frontend/predef.icl
index 10881a6..51c3931 100644
--- a/frontend/predef.icl
+++ b/frontend/predef.icl
@@ -2,6 +2,7 @@ implementation module predef
import syntax, hashtable, type_io_common
+
(<<=) infixl
(<<=) symbol_table val
:== let (predefined_idents, index) = val
@@ -135,6 +136,8 @@ predefined_idents
[PD_ConsCONS] = i "CONS",
[PD_TypeFIELD] = i "FIELD",
[PD_ConsFIELD] = i "FIELD",
+ [PD_TypeREC] = i "REC",
+ [PD_ConsREC] = i "REC",
[PD_GenericInfo] = i "GenericInfo",
[PD_NoGenericInfo] = i "NoGenericInfo",
[PD_GenericConsInfo] = i "GenericConsInfo",
@@ -317,7 +320,9 @@ where
<<- (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_Expression, PD_ConsREC)
+ <<- (local_predefined_idents, IC_Type, PD_TypeREC)
+ <<- (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)
diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl
index 602d822..99a579d 100644
--- a/frontend/syntax.dcl
+++ b/frontend/syntax.dcl
@@ -465,6 +465,7 @@ NoGlobalIndex :== {gi_module=NoIndex,gi_index=NoIndex}
| GTSVar TypeVar
| GTSCons DefinedSymbol GenTypeStruct
| GTSField DefinedSymbol GenTypeStruct
+ | GTSRec GenTypeStruct
| GTSE
:: GenericTypeRep =
diff --git a/frontend/trans.icl b/frontend/trans.icl
index cc7fed4..ff5728a 100644
--- a/frontend/trans.icl
+++ b/frontend/trans.icl
@@ -2594,6 +2594,18 @@ where
# (expr, st) = map_expr_st expr st
= f (Selection a expr b) st
+ // AA:
+ map_expr_st expr=:(BasicExpr _) st
+ = f expr st
+ map_expr_st (expr @ exprs) st
+ = abort "trans.icl: map_expr_st (expr @ exprs) not implemented\n"
+ map_expr_st (TupleSelect ds n expr) st
+ = abort "trans.icl: map_expr_st (TupleSelect ds n expr) not implemented\n"
+ map_expr_st (DynamicExpr dyn_expr) st
+ = abort "trans.icl: map_expr_st (DynamicExpr dyn_expr) not implemented\n"
+ map_expr_st _ st = abort "trans.icl: map_expr_st does not match !!!!!!!!!!!!\n"
+
+
foldrExprSt f expr st :== foldr_expr_st expr st
where
foldr_expr_st expr=:(Var _) st
@@ -2610,6 +2622,10 @@ foldrExprSt f expr st :== foldr_expr_st expr st
= f lad st
foldr_expr_st sel=:(Selection a expr b) st
= f sel (foldr_expr_st expr st)
+
+ // AA:
+ foldr_expr_st expr=:(BasicExpr _) st
+ = f expr st
add_let_binds :: [FreeVar] [Expression] [LetBind] -> [LetBind]
add_let_binds free_vars rhss original_binds
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-15 08:38:44 +0000