aboutsummaryrefslogtreecommitdiff
path: root/frontend/postparse.icl
diff options
context:
space:
mode:
Diffstat (limited to 'frontend/postparse.icl')
-rw-r--r--frontend/postparse.icl1015
1 files changed, 1015 insertions, 0 deletions
diff --git a/frontend/postparse.icl b/frontend/postparse.icl
new file mode 100644
index 0000000..51ebcf8
--- /dev/null
+++ b/frontend/postparse.icl
@@ -0,0 +1,1015 @@
+implementation module postparse
+
+import StdEnv
+import syntax, parse, predef, utilities, StdCompare
+import RWSDebug
+
+/**
+
+**/
+
+:: *CollectAdmin =
+ { ca_error :: !*ParseErrorAdmin
+ , ca_fun_count :: !Int
+ , ca_rev_fun_defs :: ![FunDef]
+ , ca_predefs :: !PredefinedIdents
+ , ca_u_predefs :: !*PredefinedSymbols
+ , ca_hash_table :: !*HashTable
+ }
+
+cIsAGlobalDef :== True
+cIsNotAGlobalDef :== False
+
+:: PredefinedIdents :== {!Ident}
+
+SelectPredefinedIdents :: *PredefinedSymbols -> (!PredefinedIdents, !*PredefinedSymbols)
+SelectPredefinedIdents predefs
+ = selectIdents 0 (createArray PD_NrOfPredefSymbols {id_name="", id_info = nilPtr}) predefs
+ where
+ selectIdents :: Int *PredefinedIdents *PredefinedSymbols -> (*PredefinedIdents, *PredefinedSymbols)
+ selectIdents i idents symbols
+ | i == PD_NrOfPredefSymbols
+ = (idents, symbols)
+ // otherwise
+ # (symbol, symbols) = symbols![i]
+ = selectIdents (i+1) {idents & [i] = symbol.pds_ident} symbols
+
+predef :: Int PredefinedIdents -> ParsedExpr
+predef index ids
+ = PE_Ident ids.[index]
+
+optGuardedAltToRhs :: OptGuardedAlts -> Rhs
+optGuardedAltToRhs optGuardedAlt
+ = { rhs_alts = optGuardedAlt
+ , rhs_locals = LocalParsedDefs []
+ }
+
+exprToRhs expr
+ :== { rhs_alts = UnGuardedExpr
+ { ewl_nodes = []
+ , ewl_expr = expr
+ , ewl_locals = LocalParsedDefs []
+ }
+ , rhs_locals = LocalParsedDefs []
+ }
+
+prefixAndPositionToIdent :: !String !LineAndColumn !*CollectAdmin -> (!Ident, !*CollectAdmin)
+prefixAndPositionToIdent prefix {lc_line, lc_column} ca=:{ca_hash_table}
+ # (ident, ca_hash_table)
+ = putIdentInHashTable (prefix +++ ";" +++ toString lc_line +++ ";" +++ toString lc_column) IC_Expression ca_hash_table
+ = (ident, { ca & ca_hash_table = ca_hash_table } )
+
+(`) infixl 9
+(`) f a
+ :== \idents -> apply (f idents) (toParsedExpr a idents)
+
+// apply :: ParsedExpr ParsedExpr -> ParsedExpr
+
+apply :: ParsedExpr ParsedExpr -> ParsedExpr
+apply (PE_List application) a
+ = PE_List (application ++ [a])
+apply f a
+ = PE_List [f, a]
+
+class toParsedExpr a :: !a -> !PredefinedIdents -> ParsedExpr
+
+instance toParsedExpr [a] | toParsedExpr a where
+ toParsedExpr []
+ = predef PD_NilSymbol
+ toParsedExpr [hd:tl]
+ = predef PD_ConsSymbol ` hd ` tl
+
+instance toParsedExpr ParsedExpr where
+ toParsedExpr x
+ = const x
+
+instance toParsedExpr Int where
+ toParsedExpr x
+ = const (PE_Basic (BVI (toString x)))
+
+postParseError :: Position {#Char} *CollectAdmin -> *CollectAdmin
+postParseError pos msg ps=:{ca_error={pea_file}}
+ # (filename, line, funname) = get_file_and_line_nr pos
+ pea_file = pea_file <<< "Post Parse Error [" <<< filename <<< "," <<< line
+ pea_file = case funname of
+ Yes name -> pea_file <<< "," <<< name
+ No -> pea_file
+ pea_file = pea_file <<< "]: " <<< msg <<< ".\n"
+ = {ps & ca_error = { pea_file = pea_file, pea_ok = False }}
+where
+ get_file_and_line_nr :: Position -> (FileName, LineNr, Optional FunctName)
+ get_file_and_line_nr (FunPos filename linenr funname)
+ = (filename, linenr, Yes funname)
+ get_file_and_line_nr (LinePos filename linenr)
+ = (filename, linenr, No)
+
+class collectFunctions a :: a !*CollectAdmin -> (a, !*CollectAdmin)
+
+addFunctionsRange :: [FunDef] *CollectAdmin -> (IndexRange, *CollectAdmin)
+addFunctionsRange fun_defs ca
+ # (frm, ca)
+ = ca!ca_fun_count
+ ca
+ = foldSt add_function fun_defs ca
+ (to, ca)
+ = ca!ca_fun_count
+ = ({ir_from = frm, ir_to = to}, ca)
+ where
+ add_function :: FunDef !*CollectAdmin -> !*CollectAdmin
+ add_function fun_def ca=:{ca_fun_count, ca_rev_fun_defs}
+ = {ca & ca_fun_count = ca.ca_fun_count + 1
+ , ca_rev_fun_defs = [fun_def : ca.ca_rev_fun_defs]
+ }
+
+instance collectFunctions ParsedExpr
+where
+ collectFunctions (PE_List exprs) ca
+ # (exprs, ca) = collectFunctions exprs ca
+ = (PE_List exprs, ca)
+ collectFunctions (PE_Bound bound_expr) ca
+ # (bound_expr, ca) = collectFunctions bound_expr ca
+ = (PE_Bound bound_expr, ca)
+// MW was: collectFunctions (PE_Lambda lam_ident args res) ca
+ collectFunctions (PE_Lambda lam_ident args res pos) ca
+ # ((args,res), ca) = collectFunctions (args,res) ca
+// MW was: # (range, ca) = addFunctionsRange [transformLambda lam_ident args res] ca
+ # (range, ca) = addFunctionsRange [transformLambda lam_ident args res pos] ca
+ = (PE_Let cIsStrict (CollectedLocalDefs { loc_functions = range, loc_nodes = [] })
+ (PE_Ident lam_ident), ca)
+ collectFunctions (PE_Record rec_expr type_name fields) ca
+ # ((rec_expr,fields), ca) = collectFunctions (rec_expr,fields) ca
+ = (PE_Record rec_expr type_name fields, ca)
+ collectFunctions (PE_Tuple exprs) ca
+ # (exprs, ca) = collectFunctions exprs ca
+ = (PE_Tuple exprs, ca)
+ collectFunctions (PE_Selection is_unique expr selectors) ca
+ # ((expr, selectors), ca) = collectFunctions (expr, selectors) ca
+ = (PE_Selection is_unique expr selectors, ca)
+ collectFunctions (PE_Update expr1 updates expr2) ca
+ # ((expr1, (updates, expr2)), ca) = collectFunctions (expr1, (updates, expr2)) ca
+ = (PE_Update expr1 updates expr2, ca)
+ collectFunctions (PE_Case case_ident pattern_expr case_alts) ca
+ # ((pattern_expr,case_alts), ca) = collectFunctions (pattern_expr,case_alts) ca
+ = (PE_Case case_ident pattern_expr case_alts, ca)
+ collectFunctions (PE_If if_ident c t e) ca
+ # true_pattern = PE_Basic (BVB True)
+ false_pattern = PE_WildCard // PE_Basic (BVB False)
+ = collectFunctions (PE_Case if_ident c
+ [ {calt_pattern = true_pattern , calt_rhs = exprToRhs t}
+ , {calt_pattern = false_pattern, calt_rhs = exprToRhs e}
+ ]) ca
+ collectFunctions (PE_Let strict locals in_expr) ca
+ # ((node_defs,in_expr), ca) = collectFunctions (locals,in_expr) ca
+ = (PE_Let strict node_defs in_expr, ca)
+ collectFunctions (PE_Compr gen_kind expr qualifiers) ca
+ # (compr, ca)
+ = transformComprehension gen_kind expr qualifiers ca
+ = collectFunctions compr ca
+ collectFunctions (PE_UpdateComprehension expr updateExpr identExpr qualifiers) ca
+ # (compr, ca)
+ = transformUpdateComprehension expr updateExpr identExpr qualifiers ca
+ = collectFunctions compr ca
+ collectFunctions (PE_Sequ sequence) ca=:{ca_predefs}
+ = collectFunctions (transformSequence sequence ca_predefs) ca
+ collectFunctions (PE_ArrayDenot exprs) ca=:{ca_predefs}
+ = collectFunctions (transformArrayDenot exprs ca_predefs) ca
+// MV ..
+ collectFunctions (PE_Dynamic exprs opt_dyn_type) ca
+ # (exprs, ca) = collectFunctions exprs ca
+ = (PE_Dynamic exprs opt_dyn_type, ca)
+// .. MV
+ collectFunctions expr ca
+ = (expr, ca)
+
+instance collectFunctions [a] | collectFunctions a
+where
+ collectFunctions l ca
+ = mapSt collectFunctions l ca
+
+instance collectFunctions (a,b) | collectFunctions a & collectFunctions b
+where
+ collectFunctions (x,y) ca
+ # (x, ca) = collectFunctions x ca
+ (y, ca) = collectFunctions y ca
+ = ((x,y), ca)
+
+instance collectFunctions Qualifier
+where
+ collectFunctions qual=:{qual_generators, qual_filter} ca
+ # ((qual_generators, qual_filter), ca) = collectFunctions (qual_generators, qual_filter) ca
+ = ({ qual & qual_generators = qual_generators, qual_filter = qual_filter }, ca)
+
+instance collectFunctions Generator
+where
+ collectFunctions gen=:{gen_pattern,gen_expr} ca
+ # ((gen_pattern,gen_expr), ca) = collectFunctions (gen_pattern,gen_expr) ca
+ = ({gen & gen_pattern = gen_pattern, gen_expr = gen_expr}, ca)
+
+instance collectFunctions (Optional a) | collectFunctions a
+where
+ collectFunctions (Yes expr) ca
+ # (expr, ca) = collectFunctions expr ca
+ = (Yes expr, ca)
+ collectFunctions No ca
+ = (No, ca)
+
+instance collectFunctions ParsedSelection
+where
+ collectFunctions (PS_Array index_expr) ca
+ # (index_expr, ca) = collectFunctions index_expr ca
+ = (PS_Array index_expr, ca)
+ collectFunctions expr ca
+ = (expr, ca)
+
+instance collectFunctions CaseAlt
+where
+ collectFunctions calt=:{calt_pattern,calt_rhs} ca
+ # ((calt_pattern,calt_rhs), ca) = collectFunctions (calt_pattern,calt_rhs) ca
+ = ({calt & calt_pattern = calt_pattern, calt_rhs = calt_rhs}, ca)
+
+instance collectFunctions (Bind a b) | collectFunctions a & collectFunctions b
+where
+ collectFunctions bind=:{bind_src,bind_dst} ca
+ # ((bind_src,bind_dst), ca) = collectFunctions (bind_src,bind_dst) ca
+ = ({bind & bind_src = bind_src, bind_dst = bind_dst }, ca)
+
+instance collectFunctions OptGuardedAlts
+where
+ collectFunctions (GuardedAlts guarded_exprs (Yes def_expr)) ca
+ # ((guarded_exprs, def_expr), ca) = collectFunctions (guarded_exprs, def_expr) ca
+ = (GuardedAlts guarded_exprs (Yes def_expr), ca)
+ collectFunctions (GuardedAlts guarded_exprs No) ca
+ # (guarded_exprs, ca) = collectFunctions guarded_exprs ca
+ = (GuardedAlts guarded_exprs No, ca)
+ collectFunctions (UnGuardedExpr unguarded_expr) ca
+ # (unguarded_expr, ca) = collectFunctions unguarded_expr ca
+ = (UnGuardedExpr unguarded_expr, ca)
+
+instance collectFunctions GuardedExpr
+where
+ collectFunctions alt=:{alt_nodes,alt_guard,alt_expr} ca
+ # ((alt_nodes, (alt_guard, alt_expr)), ca) =
+ collectFunctions (alt_nodes, (alt_guard, alt_expr)) ca
+ = ({alt & alt_nodes = alt_nodes, alt_guard = alt_guard, alt_expr = alt_expr}, ca)
+
+instance collectFunctions ExprWithLocalDefs
+where
+ collectFunctions expr=:{ewl_nodes, ewl_expr,ewl_locals} ca
+ # ((ewl_nodes, (ewl_expr, ewl_locals)), ca) = collectFunctions (ewl_nodes, (ewl_expr, ewl_locals)) ca
+ = ({expr & ewl_nodes = ewl_nodes, ewl_expr = ewl_expr, ewl_locals = ewl_locals}, ca)
+
+instance collectFunctions NodeDefWithLocals
+where
+ collectFunctions node_def=:{ndwl_def, ndwl_locals} ca
+ # (( ndwl_def, ndwl_locals), ca) = collectFunctions (ndwl_def, ndwl_locals) ca
+ = ({node_def & ndwl_def = ndwl_def, ndwl_locals = ndwl_locals}, ca)
+
+instance collectFunctions Rhs
+where
+ collectFunctions {rhs_alts, rhs_locals} ca
+ # ((rhs_alts, rhs_locals), ca) = collectFunctions (rhs_alts, rhs_locals) ca
+ = ({rhs_alts = rhs_alts, rhs_locals = rhs_locals}, ca)
+
+instance collectFunctions LocalDefs
+where
+ collectFunctions (LocalParsedDefs locals) ca
+ # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions locals ca
+ (node_defs, ca) = collect_functions_in_node_defs node_defs ca
+ (fun_defs, ca) = collectFunctions fun_defs ca
+ (range, ca) = addFunctionsRange fun_defs ca
+ = (CollectedLocalDefs { loc_functions = range, loc_nodes = node_defs }, ca)
+ where
+ collect_functions_in_node_defs :: [(Optional SymbolType,NodeDef ParsedExpr)] *CollectAdmin -> ([(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin)
+ collect_functions_in_node_defs [ (node_def_type, bind) : node_defs ] ca
+ # (bind, ca) = collectFunctions bind ca
+ (node_defs, ca) = collect_functions_in_node_defs node_defs ca
+ = ([(node_def_type, bind):node_defs], ca)
+ collect_functions_in_node_defs [] ca
+ = ([], ca)
+// RWS ... +++ remove recollection
+ collectFunctions locals ca
+ = (locals, ca)
+// ... RWS
+
+instance collectFunctions (NodeDef a) | collectFunctions a
+where
+ collectFunctions node_def=:{nd_dst,nd_alts,nd_locals} ca
+ # ((nd_dst,(nd_alts,nd_locals)), ca) = collectFunctions (nd_dst,(nd_alts,nd_locals)) ca
+ = ({ node_def & nd_dst = nd_dst, nd_alts = nd_alts, nd_locals = nd_locals }, ca)
+
+instance collectFunctions Ident
+where
+ collectFunctions e ca
+ = (e, ca)
+
+NoCollectedLocalDefs :== CollectedLocalDefs { loc_functions = { ir_from = 0, ir_to = 0 }, loc_nodes = [] }
+
+// MW was:transformLambda :: Ident [ParsedExpr] ParsedExpr -> FunDef
+transformLambda :: Ident [ParsedExpr] ParsedExpr Position -> FunDef
+// MW was:transformLambda lam_ident args result
+transformLambda lam_ident args result pos
+ # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs },
+ rhs_locals = NoCollectedLocalDefs }
+ lam_body = [{pb_args = args, pb_rhs = lam_rhs }]
+// MW was: fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No NoPos
+ fun_def = MakeNewFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No pos
+ = fun_def
+
+makeNilExpression :: *CollectAdmin -> (ParsedExpr,*CollectAdmin)
+makeNilExpression ca=:{ca_predefs}
+ #! nil_id = ca_predefs.[PD_NilSymbol]
+ = (PE_List [PE_Ident nil_id], ca)
+
+makeConsExpression :: ParsedExpr ParsedExpr *CollectAdmin -> (ParsedExpr,*CollectAdmin)
+makeConsExpression a1 a2 ca=:{ca_predefs}
+ #! cons_id = ca_predefs.[PD_ConsSymbol]
+ = (PE_List [PE_Ident cons_id, a1, a2], ca)
+
+// +++ change to accessor functions
+:: TransformedGenerator =
+ { tg_expr :: ParsedExpr
+ , tg_lhs_arg :: ParsedExpr
+ , tg_case_end_expr :: ParsedExpr
+ , tg_case_end_pattern :: ParsedExpr
+ , tg_element :: ParsedExpr
+ , tg_pattern :: ParsedExpr
+ , tg_case1 :: Ident
+ , tg_case2 :: Ident
+ , tg_rhs_continuation :: ParsedExpr
+ }
+
+transformGenerator :: Generator *CollectAdmin -> (TransformedGenerator, *CollectAdmin)
+transformGenerator {gen_kind, gen_expr, gen_pattern, gen_position} ca
+ | gen_kind == cIsListGenerator
+ # (gen_var, ca) = prefixAndPositionToIdent "g_l" gen_position ca
+ (gen_var_i, ca) = prefixAndPositionToIdent "g_h" gen_position ca
+ (gen_var_n, ca) = prefixAndPositionToIdent "g_t" gen_position ca
+ (gen_var_case1, ca) = prefixAndPositionToIdent "g_c1" gen_position ca
+ (gen_var_case2, ca) = prefixAndPositionToIdent "g_c2" gen_position ca
+ # list
+ = PE_Ident gen_var
+ hd
+ = PE_Ident gen_var_i
+ tl
+ = PE_Ident gen_var_n
+ # (cons, ca)
+ = makeConsExpression hd tl ca
+ transformed_generator
+ = { tg_expr = gen_expr
+ , tg_lhs_arg = list
+ , tg_case_end_expr = list
+ , tg_case_end_pattern = cons
+ , tg_element = hd
+ , tg_case1 = gen_var_case1
+ , tg_case2 = gen_var_case2
+ , tg_pattern = gen_pattern
+ , tg_rhs_continuation = PE_Ident gen_var_n
+ }
+ = (transformed_generator, ca)
+ // gen_kind == cIsArrayGenerator
+ # (gen_var, ca) = prefixAndPositionToIdent "g_a" gen_position ca
+ (gen_var_i, ca) = prefixAndPositionToIdent "g_i" gen_position ca
+ (gen_var_n, ca) = prefixAndPositionToIdent "g_s" gen_position ca
+ (gen_var_case1, ca) = prefixAndPositionToIdent "g_c1" gen_position ca
+ (gen_var_case2, ca) = prefixAndPositionToIdent "g_c2" gen_position ca
+ # (inc, ca)
+ = get_predef_id PD_IncFun ca
+ (smaller, ca)
+ = get_predef_id PD_SmallerFun ca
+ (usize, ca)
+ = get_predef_id PD_UnqArraySizeFun ca
+ (uselect, ca)
+ = get_predef_id PD_UnqArraySelectFun ca
+ # array
+ = PE_Ident gen_var
+ i
+ = PE_Ident gen_var_i
+ n
+ = PE_Ident gen_var_n
+ transformed_generator
+ = { tg_expr = PE_Tuple [PE_Basic (BVI "0"), PE_List [PE_Ident usize, gen_expr]]
+ , tg_lhs_arg = PE_Tuple [i, PE_Tuple [n, array]]
+ , tg_case_end_expr = PE_List [PE_Ident smaller, i, n]
+ , tg_case_end_pattern = PE_Basic (BVB True)
+ , tg_element = PE_List [PE_Ident uselect, array, i]
+ , tg_case1 = gen_var_case1
+ , tg_case2 = gen_var_case2
+ , tg_pattern = PE_Tuple [gen_pattern, array]
+ , tg_rhs_continuation = PE_Tuple [PE_List [PE_Ident inc, i], PE_Tuple [n, array]]
+ }
+ = (transformed_generator, ca)
+
+:: TransformedQualifier =
+ { tq_generators :: [TransformedGenerator]
+ , tq_call :: ParsedExpr
+ , tq_lhs_args :: [ParsedExpr]
+ , tq_filter :: Optional ParsedExpr
+ , tq_continue :: ParsedExpr
+ , tq_success :: ParsedExpr
+ , tq_end :: ParsedExpr
+ , tq_fun_id :: Ident
+ }
+
+transformQualifier :: Qualifier *CollectAdmin -> (TransformedQualifier, *CollectAdmin)
+transformQualifier {qual_generators, qual_filter, qual_position} ca
+ # (transformedGenerators, ca)
+ = mapSt transformGenerator qual_generators ca
+ # (qual_fun_id, ca)
+ = prefixAndPositionToIdent "c" qual_position ca
+ = ({ tq_generators = transformedGenerators
+ , tq_call = PE_List [PE_Ident qual_fun_id : [generator.tg_expr \\ generator <- transformedGenerators]]
+ , tq_lhs_args = [generator.tg_lhs_arg \\ generator <- transformedGenerators]
+ , tq_filter = qual_filter
+ , tq_continue = PE_List [PE_Ident qual_fun_id : [generator.tg_rhs_continuation \\ generator <- transformedGenerators]]
+ , tq_success = PE_Empty
+ , tq_end = PE_Empty
+ , tq_fun_id = qual_fun_id
+ }, ca)
+
+// =array&callArray are misnomers (can also be records)
+transformUpdateQualifier :: ParsedExpr ParsedExpr Qualifier *CollectAdmin -> (TransformedQualifier, *CollectAdmin)
+transformUpdateQualifier array callArray {qual_generators, qual_filter, qual_position} ca
+ # (transformedGenerators, ca)
+ = mapSt transformGenerator qual_generators ca
+ # (qual_fun_id, ca)
+ = prefixAndPositionToIdent "cu" qual_position ca
+ = ({ tq_generators = transformedGenerators
+ , tq_call = PE_List [PE_Ident qual_fun_id, callArray : [generator.tg_expr \\ generator <- transformedGenerators]]
+ , tq_lhs_args = [array : [generator.tg_lhs_arg \\ generator <- transformedGenerators]]
+ , tq_filter = qual_filter
+ , tq_continue = PE_List [PE_Ident qual_fun_id, array : [generator.tg_rhs_continuation \\ generator <- transformedGenerators]]
+ , tq_success = PE_Empty
+ , tq_end = PE_Empty
+ , tq_fun_id = qual_fun_id
+ }, ca)
+
+transformComprehension :: Bool ParsedExpr [Qualifier] *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+transformComprehension gen_kind expr qualifiers ca
+ | gen_kind == cIsListGenerator
+ # (transformed_qualifiers, ca)
+ = mapSt transformQualifier qualifiers ca
+ (success, ca)
+ = makeConsExpression expr (last transformed_qualifiers).tq_continue ca
+ (nil, ca)
+ = makeNilExpression ca
+ transformed_qualifiers
+ = [ {qual & tq_success = success, tq_end = end}
+ \\ qual <- transformed_qualifiers
+ & success <- [qual.tq_call \\ qual <- tl transformed_qualifiers] ++ [success]
+ & end <- [nil : [qual.tq_continue \\ qual <- transformed_qualifiers]]
+ ]
+ = makeComprehensions transformed_qualifiers success No ca
+ // gen_kin == cIsArrayGenerator
+ # [hd_qualifier : tl_qualifiers] = qualifiers
+ qual_position = hd_qualifier.qual_position
+ (c_i, ca) = prefixAndPositionToIdent "c_i" qual_position ca
+ (c_a, ca) = prefixAndPositionToIdent "c_a" qual_position ca
+ (frm, ca)
+ = get_predef_id PD_From ca
+ index_range
+ = PE_List [PE_Ident frm, PE_Basic (BVI "0")]
+ index_generator = {gen_kind=cIsListGenerator, gen_pattern=PE_Ident c_i, gen_expr=index_range, gen_position=qual_position}
+ (create_array, ca)
+ = get_predef_id PD__CreateArrayFun ca
+ (length, ca)
+ = computeLength qualifiers qual_position ca
+ new_array
+ = PE_List [PE_Ident create_array, length]
+ update
+ = PE_Update (PE_Ident c_a) [PS_Array (PE_Ident c_i)] expr
+ qualifiers
+ = [{hd_qualifier & qual_generators = [index_generator : hd_qualifier.qual_generators] } : tl_qualifiers]
+ = transformUpdateComprehension new_array update (PE_Ident c_a) qualifiers ca
+
+computeLength :: [Qualifier] LineAndColumn *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+computeLength qualifiers qual_position ca
+ # (fun_ident, ca)
+ = prefixAndPositionToIdent "c_l" qual_position ca
+ (tail_ident, ca)
+ = prefixAndPositionToIdent "c_l_t" qual_position ca
+ (i_ident, ca)
+ = prefixAndPositionToIdent "c_l_i" qual_position ca
+ (list, ca)
+ = transformComprehension cIsListGenerator (PE_Basic (BVI "0")) qualifiers ca
+ (cons, ca)
+ = makeConsExpression PE_WildCard (PE_Ident tail_ident) ca
+ (inc, ca)
+ = get_predef_id PD_IncFun ca
+ parsedFunction1
+ = MakeNewParsedDef fun_ident [cons, PE_Ident i_ident] (exprToRhs (PE_List [PE_Ident fun_ident, PE_Ident tail_ident, PE_List [PE_Ident inc, PE_Ident i_ident]]))
+ parsedFunction2
+ = MakeNewParsedDef fun_ident [PE_WildCard, PE_Ident i_ident] (exprToRhs (PE_Ident i_ident))
+ = (PE_Let cIsStrict (LocalParsedDefs [parsedFunction1, parsedFunction2])
+ (PE_List [PE_Ident fun_ident, list, PE_Basic (BVI "0")]), ca)
+
+transformUpdateComprehension :: ParsedExpr ParsedExpr ParsedExpr [Qualifier] *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+transformUpdateComprehension expr updateExpr identExpr [qualifier:qualifiers] ca
+ # (transformed_first_qualifier, ca)
+ = transformUpdateQualifier identExpr expr qualifier ca
+ (transformed_rest_qualifiers, ca)
+ = mapSt (transformUpdateQualifier identExpr identExpr) qualifiers ca
+ transformed_qualifiers
+ = [transformed_first_qualifier : transformed_rest_qualifiers]
+ success
+ // +++ remove hack
+ = this_is_definitely_a_hack (last transformed_qualifiers).tq_continue updateExpr
+ with
+ this_is_definitely_a_hack (PE_List [f, a : args]) updateExpr
+ = PE_List [f, updateExpr : args]
+ transformed_qualifiers
+ = [ {qual & tq_success = success, tq_end = end}
+ \\ qual <- transformed_qualifiers
+ & success <- [qual.tq_call \\ qual <- tl transformed_qualifiers] ++ [success]
+ & end <- [identExpr : [qual.tq_continue \\ qual <- transformed_qualifiers]]
+ ]
+ = makeComprehensions transformed_qualifiers success (Yes identExpr) ca
+
+// +++ rewrite threading
+makeComprehensions :: [TransformedQualifier] ParsedExpr (Optional ParsedExpr) *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+makeComprehensions [] success _ ca
+ = (success, ca)
+makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_fun_id} : qualifiers] success threading ca
+ # (success, ca)
+ = makeComprehensions qualifiers success threading ca
+ = make_list_comprehension tq_generators tq_lhs_args success tq_end tq_filter tq_call tq_fun_id ca
+ where
+ make_list_comprehension :: [TransformedGenerator] [ParsedExpr] ParsedExpr ParsedExpr (Optional ParsedExpr) ParsedExpr Ident *CollectAdmin -> (ParsedExpr, *CollectAdmin)
+ make_list_comprehension generators lhsArgs success end optional_filter call_comprehension fun_ident ca
+ # continue
+ = PE_List (thread (PE_Ident fun_ident) threading [generator.tg_rhs_continuation \\ generator <- generators])
+ with
+ thread ident No args
+ = [ident : args]
+ thread ident (Yes thread) args
+ = [ident, thread : args]
+ failure
+ = continue
+ rhs
+ = build_rhs generators success optional_filter failure end
+ parsed_def
+ = MakeNewParsedDef fun_ident lhsArgs rhs
+ = (PE_Let cIsStrict (LocalParsedDefs [parsed_def]) call_comprehension, ca)
+
+ build_rhs :: [TransformedGenerator] ParsedExpr (Optional ParsedExpr) ParsedExpr ParsedExpr -> Rhs
+ build_rhs [generator : generators] success optional_filter failure end
+ = case_with_default generator.tg_case1 generator.tg_case_end_expr generator.tg_case_end_pattern
+ (foldr (case_end end)
+ (case_with_default generator.tg_case2 generator.tg_element generator.tg_pattern
+ (foldr (case_pattern failure) rhs generators) failure)
+ generators)
+ end
+ where
+ rhs
+ = case optional_filter of
+ Yes filter
+ -> optGuardedAltToRhs (GuardedAlts [
+ {alt_nodes = [], alt_guard = filter, alt_expr = UnGuardedExpr
+ {ewl_nodes = [], ewl_expr = success, ewl_locals = LocalParsedDefs []}}] No)
+ No
+ -> exprToRhs success
+
+ /* +++ remove code duplication (bug in 2.0 with nested cases)
+ case_end :: TransformedGenerator Rhs -> Rhs
+ case_end {tg_case1, tg_case_end_expr, tg_case_end_pattern} rhs
+ = single_case tg_case1 tg_case_end_expr tg_case_end_pattern rhs
+
+ case_pattern :: TransformedGenerator Rhs -> Rhs
+ case_pattern {tg_case2, tg_element, tg_pattern} rhs
+ = single_case tg_case2 tg_element tg_pattern rhs
+ */
+
+ case_end :: ParsedExpr TransformedGenerator Rhs -> Rhs
+ case_end end {tg_case1, tg_case_end_expr, tg_case_end_pattern} rhs
+ = case_with_default tg_case1 tg_case_end_expr tg_case_end_pattern rhs end
+
+ case_pattern :: ParsedExpr TransformedGenerator Rhs -> Rhs
+ case_pattern failure {tg_case2, tg_element, tg_pattern} rhs
+ = case_with_default tg_case2 tg_element tg_pattern rhs failure
+
+ single_case :: Ident ParsedExpr ParsedExpr Rhs -> Rhs
+ single_case case_ident expr pattern rhs
+ = exprToRhs (PE_Case case_ident expr
+ [ {calt_pattern = pattern, calt_rhs = rhs}
+ ])
+
+ case_with_default :: Ident ParsedExpr ParsedExpr Rhs ParsedExpr -> Rhs
+ case_with_default case_ident expr pattern rhs default_rhs
+ = exprToRhs (PE_Case case_ident expr
+ [ {calt_pattern = pattern, calt_rhs = rhs}
+ , {calt_pattern = PE_WildCard, calt_rhs = exprToRhs default_rhs}
+ ])
+
+get_predef_id :: Int *CollectAdmin -> (Ident, *CollectAdmin)
+get_predef_id predef_index ca=:{ca_predefs}
+ = ca!ca_predefs.[predef_index]
+
+transformSequence :: Sequence -> PredefinedIdents -> ParsedExpr
+transformSequence (SQ_FromThen frm then)
+ = predef PD_FromThen ` frm ` then
+transformSequence (SQ_FromThenTo frm then to)
+ = predef PD_FromThenTo ` frm ` then ` to
+transformSequence (SQ_From frm)
+ = predef PD_From ` frm
+transformSequence (SQ_FromTo frm to)
+ = predef PD_FromTo ` frm ` to
+
+transformArrayUpdate :: ParsedExpr [Bind ParsedExpr ParsedExpr] PredefinedIdents -> ParsedExpr
+transformArrayUpdate expr updates pi
+ = foldr (update pi (predef PD_ArrayUpdateFun)) expr updates
+ where
+ update :: PredefinedIdents (PredefinedIdents -> ParsedExpr) (Bind ParsedExpr ParsedExpr) ParsedExpr -> ParsedExpr
+ update pi updateIdent {bind_src=value, bind_dst=index} expr
+ = (updateIdent ` expr ` index ` value) pi
+
+transformArrayDenot :: [ParsedExpr] PredefinedIdents -> ParsedExpr
+transformArrayDenot exprs pi
+ = transformArrayUpdate
+ ((predef PD__CreateArrayFun ` length exprs) pi)
+ [{bind_dst=toParsedExpr i pi, bind_src=expr} \\ expr <- exprs & i <- [0..]]
+ pi
+
+scanModules :: [ParsedImport] [ScannedModule] SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin)
+scanModules [] parsed_modules searchPaths files ca
+ = (True, parsed_modules, files, ca)
+scanModules [{import_module,import_symbols} : mods] parsed_modules searchPaths files ca
+ # (found, mod) = try_to_find import_module parsed_modules
+ | found
+ = scanModules mods parsed_modules searchPaths files ca
+ # (succ, parsed_modules, files, ca)
+ = parseAndScanDclModule import_module parsed_modules searchPaths files ca
+ (mods_succ, parsed_modules, files, ca)
+ = scanModules mods parsed_modules searchPaths files ca
+ = (succ && mods_succ, parsed_modules, files, ca)
+where
+ try_to_find :: Ident [ScannedModule] -> (Bool, ScannedModule)
+ try_to_find mod_id []
+ = (False, abort "module not found")
+ try_to_find mod_id [pmod : pmods]
+ | mod_id == pmod.mod_name
+ = (True, pmod)
+ = try_to_find mod_id pmods
+
+MakeEmptyModule name :== { mod_name = name, mod_type = MK_None, mod_imports = [], mod_imported_objects = [],
+ mod_defs = { def_types = [], def_constructors = [], def_selectors = [], def_classes = [], def_macros = { ir_from = 0, ir_to = 0 },
+ def_members = [], def_funtypes = [], def_instances = [] } }
+
+parseAndScanDclModule :: !Ident ![ScannedModule] !SearchPaths !*Files !*CollectAdmin
+ -> *(!Bool, ![ScannedModule], !*Files, !*CollectAdmin)
+parseAndScanDclModule dcl_module parsed_modules searchPaths files ca
+ # {ca_error, ca_fun_count, ca_rev_fun_defs, ca_predefs, ca_u_predefs, ca_hash_table}
+ = ca
+ hash_table = ca_hash_table
+ pea_file = ca_error.pea_file
+ predefs = ca_u_predefs
+ # (parse_ok, mod, hash_table, err_file, predefs, files) = wantModule cWantDclFile dcl_module hash_table pea_file searchPaths predefs files
+ # ca = {ca_hash_table=hash_table, ca_error={pea_file=err_file,pea_ok=True}, ca_u_predefs=predefs, ca_fun_count=ca_fun_count, ca_rev_fun_defs=ca_rev_fun_defs, ca_predefs=ca_predefs}
+ | parse_ok
+ = scan_dcl_module mod parsed_modules searchPaths files ca
+ = (False, [MakeEmptyModule mod.mod_name : parsed_modules], files, ca)
+where
+ scan_dcl_module :: ParsedModule [ScannedModule] !SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin)
+ scan_dcl_module mod=:{mod_defs = pdefs} parsed_modules searchPaths files ca
+ # (_, defs, imports, imported_objects, ca)
+ = reorganiseDefinitions False pdefs 0 0 0 ca
+ (macro_defs, ca)
+ = collectFunctions defs.def_macros ca
+ (range, ca)
+ = addFunctionsRange macro_defs ca
+ (pea_ok,ca)
+ = ca!ca_error.pea_ok
+ mod
+ = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_macros = range }}
+ (import_ok, parsed_modules, files, ca)
+ = scanModules imports [mod : parsed_modules] searchPaths files ca
+ = (pea_ok && import_ok, parsed_modules, files, ca)
+
+scanModule :: !ParsedModule !*HashTable !*File !SearchPaths !*PredefinedSymbols !*Files
+ -> (!Bool, !ScannedModule, !IndexRange, ![FunDef], !ScannedModule, !ScannedModule, ![ScannedModule], !*HashTable, !*File, !*PredefinedSymbols, !*Files)
+scanModule mod=:{mod_name,mod_type,mod_defs = pdefs} hash_table err_file searchPaths predefs files
+ # (predefIdents, predefs) = SelectPredefinedIdents predefs
+ # ca = { ca_error = {pea_file = err_file, pea_ok = True}
+ , ca_fun_count = 0
+ , ca_rev_fun_defs = []
+ , ca_predefs = predefIdents
+ , ca_u_predefs = predefs
+ , ca_hash_table = hash_table
+ }
+ (fun_defs, defs, imports, imported_objects, ca) = reorganiseDefinitions True pdefs 0 0 0 ca
+ fun_count = length fun_defs
+ (fun_defs, ca) = collectFunctions fun_defs ca
+ (fun_range, ca) = addFunctionsRange fun_defs ca
+ (macro_defs, ca) = collectFunctions defs.def_macros ca
+ (macro_range, ca) = addFunctionsRange macro_defs ca
+ (def_instances, ca)
+ = collectFunctions defs.def_instances ca
+ (pea_ok, ca) = ca!ca_error.pea_ok
+ (import_dcl_ok, parsed_modules, files, ca)
+ = scan_dcl_module mod_name mod_type searchPaths files ca
+ (import_dcls_ok, parsed_modules, files, ca)
+ = scanModules imports parsed_modules searchPaths files ca
+ { ca_error = {pea_file = err_file}
+ , ca_predefs = predefs
+ , ca_rev_fun_defs
+ , ca_u_predefs
+ , ca_hash_table = hash_table
+ }
+ = ca
+ mod = { mod & mod_imports = imports, mod_imported_objects = imported_objects, mod_defs = { defs & def_instances = def_instances,
+ def_macros = macro_range }}
+ [dcl_mod : modules] = reverse parsed_modules
+ (pre_def_mod, ca_u_predefs) = buildPredefinedModule ca_u_predefs
+ = (pea_ok && import_dcl_ok && import_dcls_ok, mod, fun_range, reverse ca_rev_fun_defs, dcl_mod, pre_def_mod, modules, hash_table, err_file, ca_u_predefs, files)
+where
+ scan_dcl_module :: Ident ModuleKind SearchPaths *Files *CollectAdmin -> (Bool, [ScannedModule], *Files, *CollectAdmin)
+ scan_dcl_module mod_name MK_Main searchPaths files ca
+ = (True, [MakeEmptyModule mod_name], files, ca)
+ scan_dcl_module mod_name MK_None searchPaths files ca
+ = (True, [MakeEmptyModule mod_name], files, ca)
+ scan_dcl_module mod_name kind searchPaths files ca
+ = parseAndScanDclModule mod_name [] searchPaths files ca
+
+instance collectFunctions (ParsedInstance a) | collectFunctions a where
+ collectFunctions inst=:{pi_members} ca
+ # (pi_members, ca) = collectFunctions pi_members ca
+ = ({inst & pi_members = pi_members }, ca)
+
+instance collectFunctions FunDef where
+ collectFunctions fun_def=:{fun_body = ParsedBody bodies} ca
+ # (bodies, ca) = collectFunctions bodies ca
+ = ({fun_def & fun_body = ParsedBody bodies}, ca)
+
+instance collectFunctions ParsedBody where
+ collectFunctions pb=:{pb_rhs} ca
+ # (pb_rhs, ca) = collectFunctions pb_rhs ca
+ = ({ pb & pb_rhs = pb_rhs }, ca)
+
+MakeNewFunction name arity body kind prio opt_type pos
+ :== { fun_symb = name, fun_arity = arity, fun_priority = prio, fun_type = opt_type, fun_kind = kind,
+ fun_body = ParsedBody body, fun_pos = pos, fun_lifted = 0, fun_index = NoIndex, fun_info = EmptyFunInfo }
+
+// +++ position
+MakeNewParsedDef ident args rhs
+ :== PD_Function NoPos ident False args rhs (FK_Function cNameLocationDependent)
+
+collectFunctionBodies :: !Ident !Int !Priority !FunKind ![ParsedDefinition] !*CollectAdmin
+ -> (![ParsedBody], !FunKind, ![ParsedDefinition], !*CollectAdmin)
+collectFunctionBodies fun_name fun_arity fun_prio fun_kind all_defs=:[PD_Function pos name is_infix args rhs new_fun_kind : defs] ca
+ | belongsToTypeSpec fun_name fun_prio name is_infix
+ # (new_fun_kind, ca) = combine_fun_kinds pos fun_kind new_fun_kind ca
+ (bodies, new_fun_kind, rest_defs, ca) = collectFunctionBodies fun_name fun_arity fun_prio new_fun_kind defs ca
+ act_arity = length args
+ | fun_arity == act_arity
+ = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs, ca)
+ = ([{ pb_args = args, pb_rhs = rhs } : bodies ], new_fun_kind, rest_defs,
+ postParseError pos ("This alternative has " + toString act_arity +
+ (if (act_arity == 1)" argument instead of " " arguments instead of ") + toString fun_arity
+ ) ca
+ )
+ = ([], fun_kind, all_defs, ca)
+ where
+ combine_fun_kinds :: Position FunKind FunKind *CollectAdmin -> (FunKind, *CollectAdmin)
+ combine_fun_kinds pos FK_Unknown fun_kind ca
+ = (fun_kind, ca)
+ combine_fun_kinds pos fun_kind new_fun_kind ca
+ | fun_kind == new_fun_kind
+ = (fun_kind, ca)
+ = (fun_kind, postParseError pos "illegal combination of function alternatives" ca)
+collectFunctionBodies fun_name fun_arity fun_prio fun_kind defs ca
+ = ([], fun_kind, defs, ca)
+
+reorganiseDefinitions :: Bool [ParsedDefinition] Index Index Index *CollectAdmin -> ([FunDef],CollectedDefinitions (ParsedInstance FunDef) [FunDef], [ParsedImport], [ImportedObject], *CollectAdmin)
+reorganiseDefinitions icl_module [PD_Function pos name is_infix args rhs fun_kind : defs] cons_count sel_count mem_count ca
+ # prio = if is_infix (Prio NoAssoc 9) NoPrio
+ fun_arity = length args
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] fun_kind prio No pos
+ | fun_kind == FK_Macro
+ = (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros ]}, imports, imported_objects, ca)
+ = ([ fun : fun_defs ], c_defs, imports, imported_objects, ca)
+reorganiseDefinitions icl_module [PD_TypeSpec fun_pos fun_name prio No specials : defs] cons_count sel_count mem_count ca
+ = case defs of
+ [PD_Function pos name is_infix args rhs fun_kind : defs]
+ | fun_name <> name
+ -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos ("function alternative for "+++fun_name.id_name+++" expected") ca)
+ | not (sameFixity prio is_infix)
+ -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "infix of type specification and alternative should match" ca)
+ // | belongsToTypeSpec fun_name prio name is_infix
+ # fun_arity = length args
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos
+ | fun_kind == FK_Macro
+ -> (fun_defs, { c_defs & def_macros = [ fun : c_defs.def_macros]}, imports, imported_objects, ca)
+ -> ([ fun : fun_defs ], c_defs, imports, imported_objects, ca)
+ // -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function body expected (1)" ca)
+ _
+ -> reorganiseDefinitions icl_module defs cons_count sel_count mem_count (postParseError fun_pos "function alternative expected (2)" ca)
+reorganiseDefinitions icl_module [PD_TypeSpec pos name prio (Yes fun_type=:{st_arity}) specials : defs] cons_count sel_count mem_count ca
+ # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ | isEmpty bodies
+ # fun_type = MakeNewFunctionType name st_arity prio fun_type pos specials nilPtr
+ c_defs = { c_defs & def_funtypes = [ fun_type : c_defs.def_funtypes ]}
+ | icl_module
+ = (fun_defs, c_defs, imports, imported_objects, postParseError pos "function body expected" ca)
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+ # fun = MakeNewFunction name fun_type.st_arity bodies fun_kind prio (Yes fun_type) pos
+ | icl_module
+ = ([fun : fun_defs], c_defs, imports, imported_objects, ca)
+ = ([fun : fun_defs], c_defs, imports, imported_objects, postParseError pos "function body not allowed in definition module" ca)
+reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = ConsList cons_defs} : defs] cons_count sel_count mem_count ca
+ # (cons_symbs, cons_count) = determine_symbols_of_conses cons_defs cons_count
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ type_def = { type_def & td_rhs = AlgType cons_symbs }
+ c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = mapAppend ParsedConstructorToConsDef cons_defs c_defs.def_constructors }
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+where
+ determine_symbols_of_conses :: [ParsedConstructor] Index -> ([DefinedSymbol], Index)
+ determine_symbols_of_conses [{pc_cons_name,pc_cons_arity} : conses] next_cons_index
+ # cons = { ds_ident = pc_cons_name, ds_arity = pc_cons_arity, ds_index = next_cons_index }
+ (conses, next_cons_index) = determine_symbols_of_conses conses (inc next_cons_index)
+ = ([cons : conses], next_cons_index)
+ determine_symbols_of_conses [] next_cons_index
+ = ([], next_cons_index)
+reorganiseDefinitions icl_module [PD_Type type_def=:{td_name, td_rhs = SelectorList rec_cons_id exivars sel_defs, td_pos } : defs] cons_count sel_count mem_count ca
+ # (sel_syms, new_count) = determine_symbols_of_selectors sel_defs sel_count
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs (inc cons_count) new_count mem_count ca
+ cons_arity = new_count - sel_count
+ cons_def = { pc_cons_name = rec_cons_id, pc_cons_prio = NoPrio, pc_cons_arity = cons_arity, pc_cons_pos = td_pos,
+ pc_arg_types = [ ps_field_type \\ {ps_field_type} <- sel_defs ], pc_exi_vars = exivars }
+ type_def = { type_def & td_rhs = RecordType {rt_constructor = { ds_ident = rec_cons_id, ds_arity = cons_arity, ds_index = cons_count },
+ rt_fields = { sel \\ sel <- sel_syms }}}
+ c_defs = { c_defs & def_types = [type_def : c_defs.def_types], def_constructors = [ParsedConstructorToConsDef cons_def : c_defs.def_constructors],
+ def_selectors = mapAppend ParsedSelectorToSelectorDef sel_defs c_defs.def_selectors }
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+where
+ determine_symbols_of_selectors :: [ParsedSelector] Index -> ([FieldSymbol], Index)
+ determine_symbols_of_selectors [{ps_field_name,ps_field_var} : sels] next_selector_index
+ # field = { fs_name = ps_field_name, fs_var = ps_field_var, fs_index = next_selector_index }
+ (fields, next_selector_index) = determine_symbols_of_selectors sels (inc next_selector_index)
+ = ([field : fields], next_selector_index)
+ determine_symbols_of_selectors [] next_selector_index
+ = ([], next_selector_index)
+
+reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = TypeSpec type} : defs] cons_count sel_count mem_count ca
+ # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ type_def = { type_def & td_rhs = SynType type }
+ c_defs = { c_defs & def_types = [type_def : c_defs.def_types] }
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+reorganiseDefinitions icl_module [PD_Type type_def=:{td_rhs = EmptyRhs properties} : defs] cons_count sel_count mem_count ca
+ # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ type_def = { type_def & td_rhs = AbstractType properties }
+ c_defs = { c_defs & def_types = [type_def : c_defs.def_types] }
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+reorganiseDefinitions icl_module [PD_Class class_def=:{class_name,class_arity,class_args} members : defs] cons_count sel_count mem_count ca
+ # type_context = { tc_class = {glob_module = NoIndex, glob_object = {ds_ident = class_name, ds_arity = class_arity, ds_index = NoIndex }},
+ tc_types = [ TV tv \\ tv <- class_args ], tc_var = nilPtr }
+ (mem_defs, mem_macros, ca) = check_symbols_of_class_members members type_context ca
+ (mem_symbs, mem_defs, class_size) = reorganise_member_defs mem_defs mem_count
+ (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count (mem_count + class_size) ca
+ class_def = { class_def & class_members = { member \\ member <- mem_symbs }}
+ c_defs = { c_defs & def_classes = [class_def : c_defs.def_classes], def_macros = mem_macros ++ c_defs.def_macros,
+ def_members = mem_defs ++ c_defs.def_members }
+ = (fun_defs, c_defs, imports, imported_objects, ca)
+where
+ check_symbols_of_class_members :: ![ParsedDefinition] !TypeContext !*CollectAdmin -> (![MemberDef], ![FunDef], !*CollectAdmin)
+ check_symbols_of_class_members [PD_TypeSpec pos name prio opt_type=:(Yes type=:{st_context,st_arity}) specials : defs] type_context ca
+ # (bodies, fun_kind, defs, ca) = collectFunctionBodies name st_arity prio FK_Unknown defs ca
+ | isEmpty bodies
+ # mem_def = { me_symb = name, me_type = { type & st_context = [type_context : st_context ]}, me_pos = pos, me_priority = prio,
+ me_offset = NoIndex, me_class_vars = [], me_class = { glob_module = NoIndex, glob_object = NoIndex}, me_type_ptr = nilPtr }
+ ( mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
+ = ([mem_def : mem_defs], mem_macros, ca)
+ # macro = MakeNewFunction name st_arity bodies FK_Macro prio opt_type pos
+ (mem_defs, mem_macros,ca) = check_symbols_of_class_members defs type_context ca
+ = (mem_defs, [macro : mem_macros], ca)
+ check_symbols_of_class_members [PD_TypeSpec fun_pos fun_name prio No specials : defs] type_context ca
+ = case defs of
+ [PD_Function pos name is_infix args rhs fun_kind : defs]
+ | belongsToTypeSpec fun_name prio name is_infix
+ # fun_arity = length args
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
+ macro = MakeNewFunction name fun_arity bodies FK_Macro prio No pos
+ -> (mem_defs, [macro : mem_macros], ca)
+ -> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca)
+ _
+ -> check_symbols_of_class_members defs type_context (postParseError fun_pos "macro body expected" ca)
+ check_symbols_of_class_members [PD_Function fun_pos name is_infix args rhs fun_kind : defs] type_context ca
+ # prio = if is_infix (Prio NoAssoc 9) NoPrio
+ fun_arity = length args
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (mem_defs, mem_macros, ca) = check_symbols_of_class_members defs type_context ca
+ macro = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies] FK_Macro prio No fun_pos
+ = (mem_defs, [macro : mem_macros], ca)
+ check_symbols_of_class_members [def : _] type_context ca
+ = abort "postparse.check_symbols_of_class_members: unknown def" <<- def
+ check_symbols_of_class_members [] type_context ca
+ = ([], [], ca)
+
+ reorganise_member_defs :: [MemberDef] Index -> ([DefinedSymbol], [MemberDef], Index)
+ reorganise_member_defs mem_defs first_mem_index
+ # mem_defs = sort mem_defs
+ = determine_indexes_of_class_members mem_defs first_mem_index 0
+
+ determine_indexes_of_class_members :: [MemberDef] Index Index -> ([DefinedSymbol], [MemberDef], Index)
+ determine_indexes_of_class_members [member=:{me_symb,me_type}:members] first_mem_index mem_offset
+ #! (member_symbols, member_defs, last_mem_offset) = determine_indexes_of_class_members members first_mem_index (inc mem_offset)
+ = ([{ds_ident = me_symb, ds_index = first_mem_index + mem_offset, ds_arity = me_type.st_arity } : member_symbols],
+ [ { member & me_offset = mem_offset } : member_defs], last_mem_offset)
+ determine_indexes_of_class_members [] first_mem_index last_mem_offset
+ = ([], [], last_mem_offset)
+
+reorganiseDefinitions icl_module [PD_Instance class_instance=:{pi_members,pi_pos} : defs] cons_count sel_count mem_count ca
+ # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ (mem_defs, ca) = collect_member_instances pi_members ca
+ | icl_module || isEmpty mem_defs
+ = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = mem_defs} : c_defs.def_instances] }, imports, imported_objects, ca)
+ = (fun_defs, { c_defs & def_instances = [{class_instance & pi_members = []} : c_defs.def_instances] }, imports, imported_objects,
+ postParseError pi_pos "instance specifications of members not allowed" ca)
+where
+ collect_member_instances :: [ParsedDefinition] *CollectAdmin -> ([FunDef], *CollectAdmin)
+ collect_member_instances [PD_Function pos name is_infix args rhs fun_kind : defs] ca
+ # fun_arity = length args
+ prio = if is_infix (Prio NoAssoc 9) NoPrio
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (fun_defs, ca) = collect_member_instances defs ca
+ fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos
+ = ([ fun : fun_defs ], ca)
+ collect_member_instances [PD_TypeSpec fun_pos fun_name prio type specials : defs] ca
+ = case defs of
+ [PD_Function pos name is_infix args rhs fun_kind : _]
+ | belongsToTypeSpec fun_name prio name is_infix
+ # fun_arity = determineArity args type
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (fun_defs, ca) = collect_member_instances defs ca
+ fun = MakeNewFunction name fun_arity bodies fun_kind prio type pos
+ -> ([ fun : fun_defs ], ca)
+ _
+ -> collect_member_instances defs (postParseError fun_pos "function body expected" ca)
+ collect_member_instances [] ca
+ = ([], ca)
+reorganiseDefinitions icl_module [PD_Instances class_instances : defs] cons_count sel_count mem_count ca
+ = reorganiseDefinitions icl_module ([PD_Instance class_instance \\ class_instance <- class_instances] ++ defs) cons_count sel_count mem_count ca
+reorganiseDefinitions icl_module [PD_Import new_imports : defs] cons_count sel_count mem_count ca
+ # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ = (fun_defs, c_defs, new_imports ++ imports, imported_objects, ca)
+reorganiseDefinitions icl_module [PD_ImportedObjects new_imported_objects : defs] cons_count sel_count mem_count ca
+ # (fun_defs, c_defs, imports, imported_objects, ca) = reorganiseDefinitions icl_module defs cons_count sel_count mem_count ca
+ = (fun_defs, c_defs, imports, new_imported_objects ++ imported_objects, ca)
+reorganiseDefinitions icl_module [def:defs] _ _ _ ca
+ = abort ("reorganiseDefinitions does not match" ---> def)
+
+reorganiseDefinitions icl_module [] _ _ _ ca
+ = ([], { def_types = [], def_constructors = [], def_selectors = [], def_macros = [], def_classes = [], def_members = [],
+ def_instances = [], def_funtypes = [] }, [], [], ca)
+
+reorganiseLocalDefinitions :: [ParsedDefinition] *CollectAdmin -> ([FunDef],[(Optional SymbolType,NodeDef ParsedExpr)],*CollectAdmin)
+reorganiseLocalDefinitions [PD_NodeDef pos pattern {rhs_alts,rhs_locals} : defs] ca
+ # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
+ = (fun_defs, [(No, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca)
+reorganiseLocalDefinitions [PD_Function pos name is_infix args rhs fun_kind : defs] ca
+ # prio = if is_infix (Prio NoAssoc 9) NoPrio
+ fun_arity = length args
+ (bodies, fun_kind, defs, ca) = collectFunctionBodies name fun_arity prio fun_kind defs ca
+ (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
+ fun = MakeNewFunction name fun_arity [{ pb_args = args, pb_rhs = rhs } : bodies ] fun_kind prio No pos
+ = ([ fun : fun_defs ], node_defs, ca)
+reorganiseLocalDefinitions [PD_TypeSpec pos1 name1 prio type specials : defs] ca
+ = case defs of
+ [PD_Function pos name is_infix args rhs fun_kind : _]
+ | belongsToTypeSpec name1 prio name is_infix
+ # fun_arity = determineArity args type
+ # (bodies, fun_kind, defs, ca) = collectFunctionBodies name1 fun_arity prio fun_kind defs ca
+ (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
+ fun = MakeNewFunction name fun_arity bodies fun_kind prio type pos
+ -> ([fun : fun_defs], node_defs, ca)
+ -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca)
+ [PD_NodeDef pos pattern=:(PE_Ident id) {rhs_alts,rhs_locals} : defs]
+ | belongsToTypeSpec name1 prio id False
+ # (fun_defs, node_defs, ca) = reorganiseLocalDefinitions defs ca
+ -> (fun_defs, [(type, { nd_dst = pattern, nd_alts = rhs_alts, nd_locals = rhs_locals }) : node_defs], ca)
+ -> reorganiseLocalDefinitions defs (postParseError pos "function body expected" ca)
+ _
+ -> reorganiseLocalDefinitions defs (postParseError pos1 "function body expected" ca)
+reorganiseLocalDefinitions [] ca
+ = ([], [], ca)
+
+
+belongsToTypeSpec name prio new_name is_infix :==
+ name == new_name && sameFixity prio is_infix
+
+
+determineArity :: [ParsedExpr] (Optional SymbolType) -> Int
+determineArity args (Yes {st_arity})
+ = st_arity
+determineArity args No
+ = length args
+
+
+sameFixity :: Priority Bool -> Bool
+sameFixity (Prio _ _) is_infix
+ = is_infix
+sameFixity NoPrio is_infix
+ = not is_infix
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-20 21:52:49 +0000