diff options
| -rw-r--r-- | frontend/postparse.icl | 1015 |
1 files changed, 0 insertions, 1015 deletions
diff --git a/frontend/postparse.icl b/frontend/postparse.icl deleted file mode 100644 index 51ebcf8..0000000 --- a/frontend/postparse.icl +++ /dev/null @@ -1,1015 +0,0 @@ -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 |