aboutsummaryrefslogtreecommitdiff
path: root/frontend
diff options
context:
space:
mode:
Diffstat (limited to 'frontend')
-rw-r--r--frontend/parse.icl140
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