diff options
| -rw-r--r-- | frontend/parse.icl | 178 | ||||
| -rw-r--r-- | frontend/postparse.icl | 14 | ||||
| -rw-r--r-- | frontend/syntax.dcl | 2 | ||||
| -rw-r--r-- | frontend/syntax.icl | 2 |
4 files changed, 130 insertions, 66 deletions
diff --git a/frontend/parse.icl b/frontend/parse.icl index 55720e4..be4cbaa 100644 --- a/frontend/parse.icl +++ b/frontend/parse.icl @@ -1049,6 +1049,72 @@ definingTokenToFunKind DefinesColonToken definingTokenToFunKind _ = FK_Unknown +wantRhs_without_where :: !Token !Bool !RhsDefiningSymbol !ParseState -> (!Rhs, !RhsDefiningSymbol, !ParseState) // FunctionAltDefRhs +wantRhs_without_where token localsExpected definingSymbol pState + # (nodeDefs, token, pState) = want_LetBefores token localsExpected pState + (alts, definingSymbol, pState) = want_FunctionBody token nodeDefs [] definingSymbol pState + = ({ rhs_alts = alts, rhs_locals = LocalParsedDefs []}, definingSymbol, pState) +where + want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) + want_FunctionBody BarToken nodeDefs alts definingSymbol pState + # (file_name, line_nr, pState)= getFileAndLineNr pState + (token, pState) = nextToken FunctionContext pState + | token == OtherwiseToken + # (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token localsExpected pState + = want_FunctionBody token (nodeDefs ++ nodeDefs2) alts definingSymbol pState // to allow | otherwise | c1 = .. | c2 = .. + | token == LetToken True + # pState = parseError "RHS" No "No 'let!' in this version of Clean" pState + = root_expression token nodeDefs (reverse alts) definingSymbol pState + # (guard, pState) = wantExpressionT token pState + (token, pState) = nextToken FunctionContext pState + (nodeDefs2, token, pState) = want_LetBefores token localsExpected pState + | token == BarToken // nested guard + # (position, pState) = getPosition pState + offside = position.fp_col + (expr, definingSymbol, pState) + = want_FunctionBody token nodeDefs2 [] definingSymbol pState + pState = wantEndNestedGuard (default_found expr) offside pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, + alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token localsExpected pState + = want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState + // otherwise + # (expr, definingSymbol, pState) + = root_expression token nodeDefs2 [] definingSymbol pState + alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, + alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } + (token, pState) = nextToken FunctionContext pState + (nodeDefs, token, pState) = want_LetBefores token localsExpected pState + = want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState + where + guard_ident line_nr + = { id_name = "_g;" +++ toString line_nr +++ ";", id_info = nilPtr } + want_FunctionBody token nodeDefs alts definingSymbol pState + = root_expression token nodeDefs (reverse alts) definingSymbol pState + + root_expression :: !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) + root_expression token nodeDefs alts definingSymbol pState + # (optional_expr,definingSymbol,pState) = want_OptExprWithLocals token nodeDefs definingSymbol pState + = build_root token optional_expr alts nodeDefs definingSymbol pState + + want_OptExprWithLocals :: !Token ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!Optional ExprWithLocalDefs, !RhsDefiningSymbol, !ParseState) + want_OptExprWithLocals token nodeDefs definingSymbol pState + | isDefiningSymbol definingSymbol token + # (file_name, line_nr, pState) = getFileAndLineNr pState + (expr, pState) = wantExpression pState + locals = LocalParsedDefs [] + = ( Yes { ewl_nodes = nodeDefs + , ewl_expr = expr + , ewl_locals = locals + , ewl_position = LinePos file_name line_nr + } + , RhsDefiningSymbolExact token + , pState + ) + = (No, definingSymbol, tokenBack pState) + wantRhs :: !Bool !RhsDefiningSymbol !ParseState -> (!Rhs, !RhsDefiningSymbol, !ParseState) // FunctionAltDefRhs wantRhs localsExpected definingSymbol pState # (alts, definingSymbol, pState) = want_LetsFunctionBody definingSymbol pState @@ -1058,7 +1124,7 @@ where want_LetsFunctionBody :: !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) want_LetsFunctionBody definingSymbol pState # (token, pState) = nextToken FunctionContext pState - (nodeDefs, token, pState) = want_LetBefores token pState + (nodeDefs, token, pState) = want_LetBefores token localsExpected pState = want_FunctionBody token nodeDefs [] definingSymbol pState want_FunctionBody :: !Token ![NodeDefWithLocals] ![GuardedExpr] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) @@ -1068,14 +1134,14 @@ where (token, pState) = nextToken FunctionContext pState | token == OtherwiseToken # (token, pState) = nextToken FunctionContext pState - (nodeDefs2, token, pState) = want_LetBefores token pState + (nodeDefs2, token, pState) = want_LetBefores token localsExpected pState = want_FunctionBody token (nodeDefs ++ nodeDefs2) alts definingSymbol pState // to allow | otherwise | c1 = .. | c2 = .. | token == LetToken True # pState = parseError "RHS" No "No 'let!' in this version of Clean" pState = root_expression True token nodeDefs (reverse alts) definingSymbol pState # (guard, pState) = wantExpressionT token pState (token, pState) = nextToken FunctionContext pState - (nodeDefs2, token, pState) = want_LetBefores token pState + (nodeDefs2, token, pState) = want_LetBefores token localsExpected pState | token == BarToken // nested guard # (position, pState) = getPosition pState offside = position.fp_col @@ -1085,7 +1151,7 @@ where alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } (token, pState) = nextToken FunctionContext pState - (nodeDefs, token, pState) = want_LetBefores token pState + (nodeDefs, token, pState) = want_LetBefores token localsExpected pState = want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState // otherwise # (expr, definingSymbol, pState) @@ -1093,7 +1159,7 @@ where alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr, alt_ident = guard_ident line_nr, alt_position = LinePos file_name line_nr } (token, pState) = nextToken FunctionContext pState - (nodeDefs, token, pState) = want_LetBefores token pState + (nodeDefs, token, pState) = want_LetBefores token localsExpected pState = want_FunctionBody token nodeDefs [alt:alts] definingSymbol pState where guard_ident line_nr @@ -1105,24 +1171,6 @@ where root_expression withExpected token nodeDefs alts definingSymbol pState # (optional_expr,definingSymbol,pState) = want_OptExprWithLocals withExpected token nodeDefs definingSymbol pState = build_root token optional_expr alts nodeDefs definingSymbol pState - where - build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) - build_root _ (Yes expr) [] _ definingSymbol pState - = ( UnGuardedExpr expr, definingSymbol, pState) - build_root _ No alts=:[_:_] [] definingSymbol pState - = (GuardedAlts alts No, definingSymbol, pState) - build_root _ optional_expr alts=:[_:_] _ definingSymbol pState - = (GuardedAlts alts optional_expr, definingSymbol, pState) - build_root token _ _ _ definingSymbol pState - # (file_name, line_nr, pState) = getFileAndLineNr pState - = (UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [], - ewl_position = LinePos file_name line_nr} - , definingSymbol - , parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState - ) - - default_found (GuardedAlts _ No) = False - default_found _ = True want_OptExprWithLocals :: !Bool !Token ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!Optional ExprWithLocalDefs, !RhsDefiningSymbol, !ParseState) // want_OptExprWithLocals withExpected DoubleArrowToken nodeDefs pState @@ -1143,6 +1191,23 @@ where ) = (No, definingSymbol, tokenBack pState) +build_root :: !Token !(Optional ExprWithLocalDefs) ![GuardedExpr] ![NodeDefWithLocals] !RhsDefiningSymbol !ParseState -> (!OptGuardedAlts, !RhsDefiningSymbol, !ParseState) +build_root _ (Yes expr) [] _ definingSymbol pState + = ( UnGuardedExpr expr, definingSymbol, pState) +build_root _ No alts=:[_:_] [] definingSymbol pState + = (GuardedAlts alts No, definingSymbol, pState) +build_root _ optional_expr alts=:[_:_] _ definingSymbol pState + = (GuardedAlts alts optional_expr, definingSymbol, pState) +build_root token _ _ _ definingSymbol pState + # (file_name, line_nr, pState) = getFileAndLineNr pState + = (UnGuardedExpr {ewl_nodes = [], ewl_expr = PE_Empty, ewl_locals = LocalParsedDefs [], + ewl_position = LinePos file_name line_nr} + , definingSymbol + , parseError "RHS: root expression" (Yes token) "= <ExprWithLocals>" pState + ) + +default_found (GuardedAlts _ No) = False +default_found _ = True /* want_StrictLet :: !ParseState -> ([NodeDefWithLocals] , !ParseState) // Removed from the language !? want_StrictLet pState @@ -1152,26 +1217,24 @@ where pState = wantToken FunctionContext "strict let" InToken pState = (let_defs, pState) = ([], tokenBack pState) -*/ - want_LetBefores :: !Token !ParseState -> (![NodeDefWithLocals], !Token, !ParseState) - want_LetBefores (SeqLetToken strict) pState - # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef strict) pState - (token, pState) = nextToken FunctionContext pState - (token, pState) = opt_End_Group token pState - (more_let_defs, token, pState) = want_LetBefores token pState - = (let_defs ++ more_let_defs, token, pState) - where - opt_End_Group token pState - # (ss_useLayout, pState) = accScanState UseLayout pState - | ss_useLayout - | token == EndGroupToken - = nextToken FunctionContext pState - // otherwise // token <> EndGroupToken - = (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState) - | otherwise // not ss_useLayout - = (token, pState) - want_LetBefores token pState - = ([], token, pState) +*/ +want_LetBefores :: !Token !Bool !ParseState -> (![NodeDefWithLocals], !Token, !ParseState) +want_LetBefores (SeqLetToken strict) localsExpected pState + # (let_defs, pState) = wantList "<sequential node defs>" (try_LetDef strict) pState + (token, pState) = nextToken FunctionContext pState + (token, pState) = opt_End_Group token pState + (more_let_defs, token, pState) = want_LetBefores token localsExpected pState + = (let_defs ++ more_let_defs, token, pState) +where + opt_End_Group token pState + # (ss_useLayout, pState) = accScanState UseLayout pState + | ss_useLayout + | token == EndGroupToken + = nextToken FunctionContext pState + // otherwise // token <> EndGroupToken + = (ErrorToken "End group missing in let befores", parseError "RHS: Let befores" (Yes token) "Generated End Group (due to layout)" pState) + | otherwise // not ss_useLayout + = (token, pState) try_LetDef :: !Bool !ParseState -> (!Bool, NodeDefWithLocals, !ParseState) try_LetDef strict pState @@ -1232,6 +1295,8 @@ where } , pState ) +want_LetBefores token localsExpected pState + = ([], token, pState) optionalLocals :: !Token !Bool !ParseState -> (!LocalDefs, !ParseState) optionalLocals dem_token localsExpected pState @@ -3610,21 +3675,22 @@ string_to_int s trySimpleNonLhsExpressionT :: !Token *ParseState -> *(!Bool,!ParsedExpr,!*ParseState) trySimpleNonLhsExpressionT BackSlashToken pState # (lam_ident, pState) = internalIdent (toString backslash) pState - (file_name, line_nr, pState) + (file_name, line_nr, pState) = getFileAndLineNr pState - (lam_args, pState) = wantList "arguments" trySimplePattern pState - pState = want_lambda_sep pState - (exp, pState) = wantExpression pState position = FunPos file_name line_nr lam_ident.id_name - = (True, PE_Lambda lam_ident lam_args exp position, pState) - where - want_lambda_sep pState - # (token, pState) = nextToken FunctionContext pState - = case token of - ArrowToken -> pState - EqualToken -> pState - DotToken -> pState - _ -> parseError "lambda expression" (Yes token) "-> or =" (tokenBack pState) + (lam_args, pState) = wantList "arguments" trySimplePattern pState + (token, pState) = nextToken FunctionContext pState + = case token of + DotToken + # (file_name, line_nr, pState) = getFileAndLineNr pState + (expr, pState) = wantExpression pState + ewl = {ewl_nodes = [], ewl_expr = expr, ewl_locals = LocalParsedDefs [], ewl_position = LinePos file_name line_nr} + rhs = {rhs_alts = UnGuardedExpr ewl, rhs_locals = LocalParsedDefs []} + -> (True, PE_Lambda lam_ident lam_args rhs position, pState) + _ + # (rhs, defining_symbol, pState) + = wantRhs_without_where token True RhsDefiningSymbolCase pState + -> (True, PE_Lambda lam_ident lam_args rhs position, pState) trySimpleNonLhsExpressionT (LetToken strict) pState // let! is not supported in Clean 2.0 | strict = (False, PE_Empty, parseError "Expression" No "let! (strict let) not supported in this version of Clean, expression" pState) // otherwise diff --git a/frontend/postparse.icl b/frontend/postparse.icl index 7443610..0108f3d 100644 --- a/frontend/postparse.icl +++ b/frontend/postparse.icl @@ -117,9 +117,9 @@ where collectFunctions (PE_Bound bound_expr) icl_module ca # (bound_expr, ca) = collectFunctions bound_expr icl_module ca = (PE_Bound bound_expr, ca) - collectFunctions (PE_Lambda lam_ident args res pos) icl_module ca - # ((args,res), ca) = collectFunctions (args,res) icl_module ca - # (range, ca) = addFunctionsRange [transformLambda lam_ident args res pos] ca + collectFunctions (PE_Lambda lam_ident args rhs pos) icl_module ca + # ((args,rhs), ca) = collectFunctions (args,rhs) icl_module ca + # (range, ca) = addFunctionsRange [transformLambda lam_ident args rhs pos] ca = (PE_Let (CollectedLocalDefs { loc_functions = range, loc_nodes = [], loc_in_icl_module=icl_module }) (PE_Ident lam_ident), ca) collectFunctions (PE_Record rec_expr type_ident fields) icl_module ca @@ -380,11 +380,9 @@ instance collectFunctions ParsedBody where NoCollectedLocalDefs :== CollectedLocalDefs { loc_functions = { ir_from = 0, ir_to = 0 }, loc_nodes = [], loc_in_icl_module=True } -transformLambda :: Ident [ParsedExpr] ParsedExpr Position -> FunDef -transformLambda lam_ident args result pos - # lam_rhs = { rhs_alts = UnGuardedExpr { ewl_nodes = [], ewl_expr = result, ewl_locals = NoCollectedLocalDefs, ewl_position = NoPos }, - rhs_locals = NoCollectedLocalDefs } - lam_body = [{pb_args = args, pb_rhs = lam_rhs, pb_position = pos }] +transformLambda :: Ident [ParsedExpr] Rhs Position -> FunDef +transformLambda lam_ident args rhs pos + # lam_body = [{pb_args = args, pb_rhs = rhs, pb_position = pos }] = MakeNewImpOrDefFunction lam_ident (length args) lam_body (FK_Function cNameLocationDependent) NoPrio No pos makeConsExpressionForGenerator :: GeneratorKind ParsedExpr ParsedExpr -> ParsedExpr diff --git a/frontend/syntax.dcl b/frontend/syntax.dcl index 139f869..a64a78d 100644 --- a/frontend/syntax.dcl +++ b/frontend/syntax.dcl @@ -1281,7 +1281,7 @@ instance toString KindInfo | PE_Ident !Ident | PE_Basic !BasicValue | PE_Bound !BoundExpr - | PE_Lambda !Ident ![ParsedExpr] !ParsedExpr !Position + | PE_Lambda !Ident ![ParsedExpr] !Rhs !Position | PE_Tuple ![ParsedExpr] | PE_Record !ParsedExpr !OptionalRecordName ![FieldAssignment] | PE_ArrayPattern ![ElemAssignment] diff --git a/frontend/syntax.icl b/frontend/syntax.icl index 900cc3d..f0cf4b1 100644 --- a/frontend/syntax.icl +++ b/frontend/syntax.icl @@ -502,7 +502,7 @@ where (<<<) file PE_Empty = file <<< "** E **" (<<<) file (PE_Ident symb) = file <<< symb (<<<) file PE_WildCard = file <<< '_' - (<<<) file (PE_Lambda _ exprs expr _) = file <<< '\\' <<< exprs <<< " -> " <<< expr + (<<<) file (PE_Lambda _ exprs rhs _) = file <<< '\\' <<< exprs <<< rhs (<<<) file (PE_Bound bind) = file <<< bind (<<<) file (PE_Case _ expr alts) = file <<< "case " <<< expr <<< " of\n" <<< alts (<<<) file (PE_Let defs expr) = file <<< "let " <<< defs <<< " in\n" <<< expr |