diff options
Diffstat (limited to 'frontend')
| -rw-r--r-- | frontend/parse.icl | 140 |
1 files changed, 99 insertions, 41 deletions
diff --git a/frontend/parse.icl b/frontend/parse.icl index 619e5b4..2d71a65 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -249,7 +249,7 @@ wantModule iclmodule file_id=:{id_name} hash_table error searchPaths pre_def_sym = case openScanner file_name searchPaths files of (Yes scanState, files) -> initModule file_name scanState pre_def_symbols files (No , files) -> let mod = { mod_name = file_id, mod_type = MK_None, mod_imports = [], mod_imported_objects = [], mod_defs = [] } in - (False, mod, hash_table, error <<< "Could not open: " <<< file_name, pre_def_symbols, files) + (False, mod, hash_table, error <<< "Could not open: " <<< file_name <<< "\n", pre_def_symbols, files) where initModule :: String ScanState !*PredefinedSymbols *Files -> (!Bool, !ParsedModule, !*HashTable, !*File, !*PredefinedSymbols, !*Files) initModule file_name scanState pre_def_symbols files @@ -362,32 +362,40 @@ tryDefinition context pState where try_definition :: !ParseContext !Token !Position !ParseState -> (!Bool, ParsedDefinition, !ParseState) try_definition context DoubleColonToken pos pState - # (def, pState) = wantTypeDef context pos pState - = (True, def, pState) + | ~(isGlobalContext context) + = (False,abort "no def(3)",parseError "definition" No "type definitions are only at the global level" pState) + # (def, pState) = wantTypeDef context pos pState + = (True, def, pState) try_definition _ ImportToken pos pState -// RWS ... + | ~(isGlobalContext context) + = (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState) # (token, pState) = nextToken FunctionContext pState | token == CodeToken && isIclContext context # (importedObjects, pState) = wantCodeImports pState = (True, PD_ImportedObjects importedObjects, pState) # pState = tokenBack pState -// ... RWS # (imports, pState) = wantImports pState = (True, PD_Import imports, pState) try_definition _ FromToken pos pState - # (imp, pState) = wantFromImports pState - = (True, PD_Import [imp], pState) -->> imp + | ~(isGlobalContext context) + = (False,abort "no def(3)",parseError "definition" No "imports are only at the global level" pState) + # (imp, pState) = wantFromImports pState + = (True, PD_Import [imp], pState) -->> imp /* try_definition _ ExportToken pos pState # (exports, pState) = wantExportDef pState = (True, PD_Export exports, pState) try_definition _ ExportAllToken pos pState = (True, PD_Export ExportAll, pState) */ try_definition context ClassToken pos pState - # (classdef, pState) = wantClassDefinition context pos pState - = (True, classdef, pState) + | ~(isGlobalContext context) + = (False,abort "no def(2)",parseError "definition" No "class definitions are only at the global level" pState) + # (classdef, pState) = wantClassDefinition context pos pState + = (True, classdef, pState) try_definition context InstanceToken pos pState - # (instdef, pState) = wantInstanceDeclaration context pos pState - = (True, instdef, pState) + | ~(isGlobalContext context) + = (False,abort "no def(2)",parseError "definition" No "instance declarations are only at the global level" pState) + # (instdef, pState) = wantInstanceDeclaration context pos pState + = (True, instdef, pState) try_definition context token pos pState | isLhsStartToken token # (lhs, pState) = want_lhs_of_def token pState @@ -445,8 +453,9 @@ where = (PD_TypeSpec pos name prio (Yes tspec) SP_None, wantEndOfDefinition "type definition (4)" pState) = (PD_TypeSpec pos name prio No SP_None, wantEndOfDefinition "type defenition (5)" (tokenBack pState)) want_rhs_of_def context (No, args) token pos pState - # pState = want_node_def_token pState token - (rhs, pState) = wantRhs isEqualToken (tokenBack pState) + # pState = want_node_def_token pState token + localsExpected = isNotEmpty args || isGlobalContext context + (rhs, pState) = wantRhs isEqualToken localsExpected (tokenBack pState) | isGlobalContext context = (PD_NodeDef pos (combine_args args) rhs, parseError "RHS" No "<global definition>" pState) = (PD_NodeDef pos (combine_args args) rhs, pState) @@ -459,7 +468,7 @@ where combine_args args = PE_List args want_rhs_of_def context (Yes (name, False), []) token pos pState | isIclContext context && isLocalContext context && (token == DefinesColonToken || token == EqualToken) - # (rhs, pState) = wantRhs (\_ -> True) (tokenBack pState) + # (rhs, pState) = wantRhs (\_ -> True) False (tokenBack pState) = (PD_NodeDef pos (PE_Ident name) rhs, pState) want_rhs_of_def context (Yes (name, is_infix), args) token pos pState # (fun_kind, code_allowed, pState) = token_to_fun_kind pState token @@ -471,11 +480,12 @@ where // otherwise // ~ code_allowed = (PD_Function pos name is_infix args rhs fun_kind, parseError "rhs of def" No "no code" pState) # pState = tokenBack (tokenBack pState) - (rhs, pState) = wantRhs isRhsStartToken pState + localsExpected = isNotEmpty args || isGlobalContext context + (rhs, pState) = wantRhs isRhsStartToken localsExpected pState = case fun_kind of FK_Function | isDclContext context -> (PD_Function pos name is_infix args rhs fun_kind, parseError "RHS" No "<type specification>" pState) - FK_Caf | ~(isEmpty args) + FK_Caf | isNotEmpty args -> (PD_Function pos name is_infix [] rhs fun_kind, parseError "CAF" No "No arguments for a CAF" pState) _ -> (PD_Function pos name is_infix args rhs fun_kind, pState) where @@ -614,10 +624,10 @@ where ExprWithLocals = [ LetBefore ] sep RootExpression endOfDefinition [ LocalFunctionDefs ] */ -wantRhs :: !(!Token -> Bool) !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs -wantRhs separator pState +wantRhs :: !(!Token -> Bool) !Bool !ParseState -> (Rhs, !ParseState) // FunctionAltDefRhs +wantRhs separator localsExpected pState # (alts, pState) = want_LetsFunctionBody separator pState - (locals, pState) = optionalLocals WhereToken pState + (locals, pState) = optionalLocals WhereToken localsExpected pState = ({ rhs_alts = alts, rhs_locals = locals}, pState) where want_LetsFunctionBody :: !(!Token -> Bool) !ParseState -> (!OptGuardedAlts, !ParseState) @@ -684,7 +694,7 @@ where | sep token # (expr, pState) = wantExpression cIsNotAPattern pState pState = wantEndRootExpression pState - (locals,pState) = optionalLocals WithToken pState + (locals,pState) = optionalLocals WithToken localsExpected pState = ( Yes { ewl_nodes = nodeDefs , ewl_expr = expr , ewl_locals = locals @@ -729,7 +739,7 @@ where # pState = wantToken FunctionContext "let definition" EqualToken pState (rhs_exp, pState) = wantExpression cIsNotAPattern pState pState = wantEndRootExpression pState -->> ("#",lhs_exp,"=",rhs_exp) - (locals , pState) = optionalLocals WithToken pState + (locals , pState) = optionalLocals WithToken localsExpected pState = ( True , { ndwl_strict = strict , ndwl_def = { bind_dst = lhs_exp @@ -742,13 +752,13 @@ where // otherwise // ~ succ = (False, abort "no definition", pState) -optionalLocals :: !Token !ParseState -> (!LocalDefs, !ParseState) -optionalLocals dem_token pState +optionalLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState) +optionalLocals dem_token localsExpected pState # (off_token, pState) = nextToken FunctionContext pState | dem_token == off_token = wantLocals pState # (ss_useLayout, pState) = accScanState UseLayout pState - | off_token == CurlyOpenToken && ~ ss_useLayout + | off_token == CurlyOpenToken && ~ ss_useLayout && localsExpected = wantLocals (tokenBack pState) // otherwise = (LocalParsedDefs [], tokenBack pState) @@ -904,13 +914,15 @@ wantClassDefinition context pos pState | token == DoubleColonToken = want_overloaded_function pos class_or_member_name prio class_arity class_args class_cons_vars contexts pState | might_be_a_class - | token == WhereToken + # (begin_members, pState) = begin_member_group token pState + | begin_members # (class_id, pState) = stringToIdent class_or_member_name IC_Class pState - (members, pState) = wantDefinitions context pState + (members, pState) = wantDefinitions (SetLocalContext context) pState class_def = { class_name = class_id, class_arity = class_arity, class_args = class_args, class_context = contexts, class_pos = pos, class_members = {}, class_cons_vars = class_cons_vars, class_dictionary = { ds_ident = { class_id & id_info = nilPtr }, ds_arity = 0, ds_index = NoIndex }} - = (PD_Class class_def members, wantEndGroup "class" pState) + pState = wantEndGroup "class" pState + = (PD_Class class_def members, pState) | isEmpty contexts = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>: contexts" pState) // otherwise @@ -923,6 +935,25 @@ wantClassDefinition context pos pState = (PD_Class class_def [], pState) = (PD_Erroneous, parseError "Class Definition" (Yes token) "<class definition>" pState) where + begin_member_group token pState // For JvG layout + # (token, pState) + = case token of + SemicolonToken -> nextToken TypeContext pState + _ -> (token, pState) + # (ss_useLayout, pState) = accScanState UseLayout pState + | token == WhereToken + # (token, pState) = nextToken TypeContext pState + | token == CurlyOpenToken + | ss_useLayout + = (True, parseError "class definition" No "No { in layout mode" pState) + = (True, pState) + = (True, tokenBack pState) + | token == CurlyOpenToken + | ss_useLayout + = (True, parseError "class definition" (Yes CurlyOpenToken) "in layout mode the keyword where is" pState) + = (True, pState) + = (False, pState) // token is still known: no tokenBack + want_class_or_member_name pState # (token, pState) = nextToken TypeContext pState | token == OpenToken @@ -966,7 +997,6 @@ wantClassDefinition context pos pState = (arity, [var : class_vars], cons_vars bitor (1 << arg_nr)) = (arity, [var : class_vars], cons_vars) -// Sjaak ... wantInstanceDeclaration :: !ParseContext !Position !ParseState -> (!ParsedDefinition, !ParseState) wantInstanceDeclaration context pi_pos pState # (class_name, pState) = want pState @@ -974,10 +1004,9 @@ wantInstanceDeclaration context pi_pos pState ((pi_types, pi_context), pState) = want_instance_type pState (pi_ident, pState) = stringToIdent class_name (IC_Instance pi_types) pState | isIclContext context - # pState = wantToken FunctionContext "instance declaration" WhereToken pState - pState = wantBeginGroup "instance" pState + # pState = want_begin_group pState (pi_members, pState) = wantDefinitions context pState - pState = wantEndLocals pState + pState = wantEndGroup "instance" pState = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, pi_members = pi_members, pi_specials = SP_None, pi_pos = pi_pos }, pState) @@ -1000,8 +1029,25 @@ wantInstanceDeclaration context pi_pos pState pState = wantEndOfDefinition "instance declaration" pState = (PD_Instance {pi_class = pi_class, pi_ident = pi_ident, pi_types = pi_types, pi_context = pi_context, pi_members = [], pi_specials = specials, pi_pos = pi_pos}, pState) -// ... Sjaak where + want_begin_group pState // For JvG layout + # (token, pState) = nextToken TypeContext pState + (token, pState) + = case token of + SemicolonToken -> nextToken TypeContext pState + _ -> (token, pState) + = case token of + WhereToken -> wantBeginGroup "instance declaration" pState + CurlyOpenToken + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + -> parseError "instance declaration" (Yes token) "where" pState + -> pState + _ # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + -> parseError "instance declaration" (Yes token) "where" pState + -> parseError "instance declaration" (Yes token) "where or {" pState + want_instance_type pState # (pi_types, pState) = wantList "instance types" tryBrackType pState // # (pi_types, pState) = wantList "instance types" tryType pState // This accepts 1.3 syntax, but is wrong for multiparameter classes @@ -1717,8 +1763,8 @@ combineExpressions expr exprs where make_app_exp exp [] = exp - make_app_exp (PE_Bound be=:{ bind_src}) exps - = PE_Bound { be & bind_src = make_app_exp bind_src exps } +// make_app_exp (PE_Bound be=:{ bind_src}) exps +// = PE_Bound { be & bind_src = make_app_exp bind_src exps } make_app_exp exp exprs = PE_List [exp : exprs] @@ -2053,7 +2099,7 @@ where tryCaseAlt pState # (succ, pattern, pState) = try_pattern pState | succ - # (rhs, pState) = wantRhs caseSeperator pState + # (rhs, pState) = wantRhs caseSeperator True pState = (True, { calt_pattern = pattern, calt_rhs = rhs }, pState) // -->> ("case alt", pattern) // otherwise // ~ succ = (False, abort "no case alt", pState) @@ -2063,13 +2109,13 @@ where # (token, pState) = nextToken FunctionContext pState | caseSeperator token # pState = tokenBack pState - (rhs, pState) = wantRhs caseSeperator pState + (rhs, pState) = wantRhs caseSeperator True pState = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") | token == OtherwiseToken # (token, pState) = nextToken FunctionContext pState pState = tokenBack pState | caseSeperator token - # (rhs, pState) = wantRhs caseSeperator pState + # (rhs, pState) = wantRhs caseSeperator True pState = (True, { calt_pattern = PE_WildCard, calt_rhs = rhs }, pState) // -->> ("default case alt") = (False, abort "no case alt", pState) = (False, abort "no case alt", tokenBack pState) @@ -2243,7 +2289,8 @@ where = equal_selectors a.nu_selectors b.nu_selectors where equal_selectors :: [ParsedSelection] [ParsedSelection] -> Bool - equal_selectors [PS_Record ident1 _ : [_]] [PS_Record ident2 _ : [_]] + equal_selectors [PS_Record ident1 _ ,_ : _] [PS_Record ident2 _ ,_: _] + // equal_selectors [PS_Record ident1 _ : [_]] [PS_Record ident2 _ : [_]] = ident1.id_name == ident2.id_name equal_selectors _ _ = False @@ -2258,7 +2305,7 @@ where is_record_select _ = False - transform_record_update :: (Optional Ident) ParsedExpr ![[NestedUpdate]] !Int ParseState -> (ParsedExpr, ParseState) +/* transform_record_update :: (Optional Ident) ParsedExpr ![[NestedUpdate]] !Int ParseState -> (ParsedExpr, ParseState) transform_record_update record_type expr groupedUpdates level pState # (assignments, (optionalIdent, record_type,pState)) = mapSt (transform_update level) groupedUpdates (No, record_type,pState) @@ -2266,6 +2313,16 @@ where = build_update record_type optionalIdent expr assignments = (updateExpr, pState) where +*/ + transform_record_update :: (Optional Ident) ParsedExpr ![[NestedUpdate]] !Int ParseState -> (ParsedExpr, ParseState) + transform_record_update record_type expr groupedUpdates level pState + = (updateExpr, pState2) + where + /* final_record_type on a cycle */ + (assignments, (optionalIdent, final_record_type,pState2)) + = mapSt (transform_update level) groupedUpdates (No, record_type,pState) + updateExpr + = build_update record_type optionalIdent expr assignments // transform one group of nested updates with the same first field // for example: f.g1 = e1, f.g2 = e2 -> f = {id.f & g1 = e1, g2 = e2}, // (id is ident to shared expression that's being updated) @@ -2278,7 +2335,8 @@ where # (shareIdent, pState) = make_ident optionalIdent level pState select - = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent /*JVG No */ field_record_type] + = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent final_record_type] + // = PE_Selection cNonUniqueSelection (PE_Ident shareIdent) [PS_Record fieldIdent field_record_type] (update_expr, pState) = transform_record_or_array_update No select (map sub_update updates) (level+1) pState = ({bind_dst = fieldIdent, bind_src = update_expr}, (Yes shareIdent,record_type,pState)) @@ -2585,7 +2643,7 @@ wantEndLocals :: !ParseState -> ParseState wantEndLocals pState # (ss_useLayout, pState) = accScanState UseLayout pState (token, pState) = nextToken FunctionContext pState - | token == EndOfFileToken + | token == EndOfFileToken && ss_useLayout = tokenBack pState | ss_useLayout = case token of |