diff options
| -rw-r--r-- | frontend/postparse.icl | 1015 |
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 |