unit Myc.Ast.Script; interface uses System.SysUtils, System.Classes, System.Generics.Collections, System.Character, System.Rtti, // Wichtig für die EBNF-Extraktion Myc.Data.Value, Myc.Ast.Nodes, Myc.Ast.Visitor, Myc.Ast.Script.Print, Myc.Ast; type EParserException = class(EAstException) strict private FLine: Integer; FCol: Integer; public constructor Create(const AMessage: string; ALine, ACol: Integer); property Line: Integer read FLine; property Col: Integer read FCol; end; { Attribut zur Dokumentation der Grammatik direkt am Code } EbnfAttribute = class(TCustomAttribute) private FRule: string; public constructor Create(const ARule: string); property Rule: string read FRule; end; TAstScript = record public class function Parse(const ASource: string): IAstNode; static; class function Print(const ANode: IAstNode): string; static; { Extrahiert die vollständige EBNF-Grammatik aus den Annotationen des Parsers } class function GetGrammar: string; static; end; implementation uses System.TypInfo, System.Generics.Defaults, Myc.Data.Scalar, Myc.Data.Keyword, Myc.Ast.Identities; { EbnfAttribute } constructor EbnfAttribute.Create(const ARule: string); begin inherited Create; FRule := ARule; end; type TTokenKind = ( tkLeftParen, // ( tkRightParen, // ) tkLeftBracket, // [ tkRightBracket, // ] tkLeftBrace, // { tkRightBrace, // } tkQuote, // ' tkBacktick, // ` tkTilde, // ~ tkAt, // @ tkIdentifier, // abc, +, .field tkKeyword, // :abc tkNumber, // 123, 12.34 tkString, // "..." tkEOF, tkError ); TToken = record Kind: TTokenKind; Text: string; Line: Integer; Col: Integer; function GetLocation: ISourceLocation; end; // ------------------------------------------------------------------------- // LEXER // ------------------------------------------------------------------------- TLexer = class private FSource: string; FCurrentPos: Integer; FLine: Integer; FLineStart: Integer; function Peek: Char; procedure Advance; function ReadNumber: string; function ReadString: string; function ReadIdentifier: string; function GetCurrentLine: Integer; function GetCurrentCol: Integer; procedure Error(const Msg: string); public constructor Create(const ASource: string); function GetNextToken: TToken; property CurrentLine: Integer read GetCurrentLine; property CurrentCol: Integer read GetCurrentCol; end; // ------------------------------------------------------------------------- // PARSER // ------------------------------------------------------------------------- // Wir erzwingen RTTI für private Methoden, damit wir die EbnfAttributes lesen können {$RTTI EXPLICIT METHODS([vcPrivate, vcProtected, vcPublic])} TParser = class private type TSpecialFormParser = function: IAstNode of object; private FLexer: TLexer; FCurrentToken: TToken; FSpecialForms: TDictionary; procedure Error(const Msg: string); procedure ErrorFmt(const Msg: string; const Args: array of const); procedure Consume(AExpectedKind: TTokenKind); procedure NextToken; function Match(AKind: TTokenKind): Boolean; // --- EBNF Non-Terminal Methods --- // Entry Point [Ebnf('script ::= expression EOF')] function ParseScript: IAstNode; // Core Expressions [Ebnf('expression ::= atom | list | vector | map | reader-macro')] function ParseExpression: IAstNode; [Ebnf('atom ::= identifier | keyword | number | string | nop')] function ParseAtom: IAstNode; [Ebnf('list ::= "(" list-content ")"')] function ParseList: IAstNode; [Ebnf('vector ::= "[" { expression } "]"')] function ParseVector: IAstNode; [Ebnf('map ::= "{" { keyword expression } "}"')] function ParseMap: IAstNode; [Ebnf('reader-macro ::= "''" expression | "`" expression | "~" expression | "~@" expression')] function ParseReaderMacro: IAstNode; // Atoms [Ebnf('identifier ::= ? defined by lexer ?')] function ParseIdentifier: IAstNode; [Ebnf('keyword ::= ":" identifier')] function ParseKeyword: IAstNode; [Ebnf('number ::= ? integer or float literal ?')] function ParseNumber: IAstNode; [Ebnf('string ::= """ ? characters ? """')] function ParseString: IAstNode; [Ebnf('nop ::= "..."')] function ParseNop: IAstNode; // List Content & Dispatch [Ebnf('list-content ::= special-form | member-access-sugar | function-call')] function ParseListContent: IAstNode; [Ebnf('special-form ::= form-if | form-cond | form-fn | ... (* dispatched by head identifier *)')] function ParseSpecialForm(const FormName: string): IAstNode; [Ebnf('member-access-sugar ::= dot-identifier expression')] function ParseMemberAccessSugar: IAstNode; [Ebnf('function-call ::= expression { expression }')] function ParseFunctionCall: IAstNode; // Special Forms (Sub-Rules) [Ebnf('form-if ::= "if" expression expression [ expression ]')] function ParseIf: IAstNode; [Ebnf('form-cond ::= "?" { expression expression } [ expression ]')] function ParseCond: IAstNode; [Ebnf('form-fn ::= "fn" vector expression')] function ParseFn: IAstNode; [Ebnf('form-defmacro ::= "defmacro" identifier vector expression')] function ParseDefMacro: IAstNode; [Ebnf('form-def ::= "def" expression [ expression ]')] function ParseDef: IAstNode; [Ebnf('form-assign ::= "assign" expression expression')] function ParseAssign: IAstNode; [Ebnf('form-do ::= "do" { expression }')] function ParseDo: IAstNode; [Ebnf('form-recur ::= "recur" { expression }')] function ParseRecur: IAstNode; [Ebnf('form-quote ::= "quote" expression')] function ParseQuoteForm: IAstNode; [Ebnf('form-pipe ::= "pipe" vector expression')] function ParsePipe: IAstNode; [Ebnf('form-series ::= "new-series" expression')] function ParseNewSeries: IAstNode; [Ebnf('form-add ::= "add-item" expression expression [ expression ]')] function ParseAddItem: IAstNode; [Ebnf('form-get ::= "get" expression expression')] function ParseGet: IAstNode; // Helpers function ParseTupleBody(StopToken: TTokenKind): TArray; function ExtractIdentifiers(const Node: IAstNode; const Context: string): TArray; public constructor Create(const ASource: string); destructor Destroy; override; function Parse: IAstNode; end; { EParserException } constructor EParserException.Create(const AMessage: string; ALine, ACol: Integer); begin inherited CreateFmt('[Line %d, Col %d] %s', [ALine, ACol, AMessage]); FLine := ALine; FCol := ACol; end; { TToken } function TToken.GetLocation: ISourceLocation; begin Result := TIdentities.Location(Line, Col); end; { TLexer } constructor TLexer.Create(const ASource: string); begin inherited Create; FSource := ASource; FCurrentPos := 1; FLine := 1; FLineStart := 1; end; function TLexer.GetCurrentLine: Integer; begin Result := FLine; end; function TLexer.GetCurrentCol: Integer; begin Result := FCurrentPos - FLineStart + 1; end; procedure TLexer.Error(const Msg: string); begin raise EParserException.Create(Msg, FLine, GetCurrentCol); end; function TLexer.Peek: Char; begin if FCurrentPos > Length(FSource) then Result := #0 else Result := FSource[FCurrentPos]; end; procedure TLexer.Advance; begin if FCurrentPos <= Length(FSource) then begin if FSource[FCurrentPos] = #10 then begin Inc(FLine); FLineStart := FCurrentPos + 1; end; end; Inc(FCurrentPos); end; function TLexer.ReadIdentifier: string; var startPos: Integer; begin startPos := FCurrentPos; // Identifiers can contain almost anything except structural chars and whitespace while (Peek <> #0) and (not (Peek.IsWhiteSpace or CharInSet(Peek, ['(', ')', '[', ']', '{', '}', '"', '''', '`', '~', ';', '@']))) do Advance; Result := Copy(FSource, startPos, FCurrentPos - startPos); end; function TLexer.ReadNumber: string; var startPos: Integer; begin startPos := FCurrentPos; if (Peek = '-') then Advance; while (Peek <> #0) and (Peek.IsDigit or (Peek = '.')) do Advance; Result := Copy(FSource, startPos, FCurrentPos - startPos); end; function TLexer.ReadString: string; var sb: TStringBuilder; c: Char; begin Advance; // Skip opening quote sb := TStringBuilder.Create; try while (FCurrentPos <= Length(FSource)) do begin c := Peek; if c = '"' then begin Advance; Result := sb.ToString; exit; end; if c = '\' then begin Advance; if FCurrentPos > Length(FSource) then Error('Unterminated string'); c := Peek; case c of 'n': sb.Append(#10); 'r': sb.Append(#13); 't': sb.Append(#9); '"': sb.Append('"'); '\': sb.Append('\'); else sb.Append(c); end; Advance; end else begin if c = #0 then break; sb.Append(c); Advance; end; end; Error('Unterminated string'); finally sb.Free; end; end; function TLexer.GetNextToken: TToken; begin while FCurrentPos <= Length(FSource) do begin // Skip Whitespace if Peek.IsWhiteSpace then begin Advance; continue; end; // Skip Comment if Peek = ';' then begin while (Peek <> #0) and (Peek <> #10) and (Peek <> #13) do Advance; continue; end; break; end; Result.Line := FLine; Result.Col := (FCurrentPos - FLineStart + 1); if FCurrentPos > Length(FSource) then begin Result.Kind := tkEOF; exit; end; var c := Peek; case c of '(': begin Result.Kind := tkLeftParen; Result.Text := '('; Advance; end; ')': begin Result.Kind := tkRightParen; Result.Text := ')'; Advance; end; '[': begin Result.Kind := tkLeftBracket; Result.Text := '['; Advance; end; ']': begin Result.Kind := tkRightBracket; Result.Text := ']'; Advance; end; '{': begin Result.Kind := tkLeftBrace; Result.Text := '{'; Advance; end; '}': begin Result.Kind := tkRightBrace; Result.Text := '}'; Advance; end; '''': begin Result.Kind := tkQuote; Result.Text := ''''; Advance; end; '`': begin Result.Kind := tkBacktick; Result.Text := '`'; Advance; end; '~': begin Result.Kind := tkTilde; Result.Text := '~'; Advance; end; '@': begin Result.Kind := tkAt; Result.Text := '@'; Advance; end; '"': begin Result.Kind := tkString; Result.Text := ReadString; end; ':': begin Advance; Result.Kind := tkKeyword; Result.Text := ReadIdentifier; end; else // Number detection: digit or minus followed by digit if c.IsDigit or ((c = '-') and (FCurrentPos < Length(FSource)) and FSource[FCurrentPos + 1].IsDigit) then begin Result.Kind := tkNumber; Result.Text := ReadNumber; end else begin Result.Kind := tkIdentifier; Result.Text := ReadIdentifier; end; end; end; { TParser } constructor TParser.Create(const ASource: string); begin inherited Create; FLexer := TLexer.Create(ASource); FSpecialForms := TDictionary.Create(TStringComparer.Ordinal); FSpecialForms.Add('if', ParseIf); FSpecialForms.Add('?', ParseCond); FSpecialForms.Add('fn', ParseFn); FSpecialForms.Add('defmacro', ParseDefMacro); FSpecialForms.Add('def', ParseDef); FSpecialForms.Add('assign', ParseAssign); FSpecialForms.Add('do', ParseDo); FSpecialForms.Add('recur', ParseRecur); FSpecialForms.Add('quote', ParseQuoteForm); FSpecialForms.Add('pipe', ParsePipe); FSpecialForms.Add('new-series', ParseNewSeries); FSpecialForms.Add('add-item', ParseAddItem); FSpecialForms.Add('get', ParseGet); NextToken; end; destructor TParser.Destroy; begin FSpecialForms.Free; FLexer.Free; inherited; end; procedure TParser.Error(const Msg: string); begin raise EParserException.Create(Msg, FCurrentToken.Line, FCurrentToken.Col); end; procedure TParser.ErrorFmt(const Msg: string; const Args: array of const); begin Error(Format(Msg, Args)); end; procedure TParser.NextToken; begin FCurrentToken := FLexer.GetNextToken; end; procedure TParser.Consume(AExpectedKind: TTokenKind); begin if FCurrentToken.Kind <> AExpectedKind then ErrorFmt('Expected %s but found %s', [GetEnumName(TypeInfo(TTokenKind), Ord(AExpectedKind)), FCurrentToken.Text]); NextToken; end; function TParser.Match(AKind: TTokenKind): Boolean; begin Result := FCurrentToken.Kind = AKind; if Result then NextToken; end; // ============================================================================= // EBNF Implementation // ============================================================================= function TParser.Parse: IAstNode; begin Result := ParseScript; end; function TParser.ParseScript: IAstNode; begin Result := ParseExpression; if FCurrentToken.Kind <> tkEOF then Error('Unexpected chars after end of expression (EOF expected).'); end; function TParser.ParseExpression: IAstNode; begin case FCurrentToken.Kind of tkLeftParen: Result := ParseList; tkLeftBracket: Result := ParseVector; tkLeftBrace: Result := ParseMap; tkQuote, tkBacktick, tkTilde: Result := ParseReaderMacro; else Result := ParseAtom; end; end; function TParser.ParseList: IAstNode; begin Consume(tkLeftParen); if FCurrentToken.Kind = tkRightParen then Error('Syntax Error: Empty list () is not a valid expression.'); Result := ParseListContent; Consume(tkRightParen); end; function TParser.ParseListContent: IAstNode; var headToken: TToken; headName: string; begin // Look ahead at the head of the list headToken := FCurrentToken; if headToken.Kind = tkIdentifier then begin headName := headToken.Text; // 1. Special Form? if FSpecialForms.ContainsKey(headName) then begin NextToken; // Consume Head Result := ParseSpecialForm(headName); Exit; end; // 2. Member Access Sugar (.prop obj)? if (headName.Length > 1) and (headName.StartsWith('.')) then begin Result := ParseMemberAccessSugar; Exit; end; end; // 3. Default: Function Call Result := ParseFunctionCall; end; function TParser.ParseSpecialForm(const FormName: string): IAstNode; var parser: TSpecialFormParser; begin parser := FSpecialForms[FormName]; Result := parser(); end; function TParser.ParseMemberAccessSugar: IAstNode; var loc: ISourceLocation; propName: string; propKey: IKeywordNode; baseObj: IAstNode; begin // Current Token is the dot-identifier (e.g. ".price") loc := FCurrentToken.GetLocation; propName := FCurrentToken.Text.Substring(1); // Strip dot NextToken; // Consume dot-identifier baseObj := ParseExpression; propKey := TAst.Keyword(propName, loc); Result := TAst.MemberAccess(baseObj, propKey, loc); end; function TParser.ParseFunctionCall: IAstNode; var loc: ISourceLocation; callee: IAstNode; args: TArray; argList: TList; begin loc := FCurrentToken.GetLocation; // First expression is the callee callee := ParseExpression; // Remaining expressions until ')' are arguments argList := TList.Create; try while FCurrentToken.Kind <> tkRightParen do begin if FCurrentToken.Kind = tkEOF then Error('Unexpected EOF in function call'); argList.Add(ParseExpression); end; args := argList.ToArray; finally argList.Free; end; Result := TAst.FunctionCall(callee, args, loc); end; function TParser.ParseAtom: IAstNode; begin case FCurrentToken.Kind of tkIdentifier: Result := ParseIdentifier; tkKeyword: Result := ParseKeyword; tkNumber: Result := ParseNumber; tkString: Result := ParseString; else ErrorFmt('Unexpected token for atom: %s', [FCurrentToken.Text]); Result := nil; // satisfy compiler end; end; function TParser.ParseIdentifier: IAstNode; var loc: ISourceLocation; name: string; begin loc := FCurrentToken.GetLocation; name := FCurrentToken.Text; NextToken; if name = '...' then Result := ParseNop else Result := TAst.Identifier(name, loc); end; function TParser.ParseNop: IAstNode; begin // Nop is handled via Identifier branch, but structurally it's an atom kind Result := TAst.Nop(FCurrentToken.GetLocation); end; function TParser.ParseKeyword: IAstNode; var loc: ISourceLocation; begin loc := FCurrentToken.GetLocation; Result := TAst.Keyword(FCurrentToken.Text, loc); NextToken; end; function TParser.ParseNumber: IAstNode; var loc: ISourceLocation; s: string; i64: Int64; dbl: Double; begin loc := FCurrentToken.GetLocation; s := FCurrentToken.Text; NextToken; if TryStrToInt64(s, i64) then Result := TAst.Constant(i64, loc) else if TryStrToFloat(s, dbl, TFormatSettings.Invariant) then Result := TAst.Constant(dbl, loc) else Error('Invalid number format'); end; function TParser.ParseString: IAstNode; var loc: ISourceLocation; begin loc := FCurrentToken.GetLocation; Result := TAst.Constant(FCurrentToken.Text, loc); NextToken; end; function TParser.ParseVector: IAstNode; var loc: ISourceLocation; elems: TArray; begin loc := FCurrentToken.GetLocation; Consume(tkLeftBracket); elems := ParseTupleBody(tkRightBracket); Result := TAst.Tuple(elems, loc); end; function TParser.ParseMap: IAstNode; var loc: ISourceLocation; fields: TList; keyNode: IAstNode; valNode: IAstNode; begin loc := FCurrentToken.GetLocation; Consume(tkLeftBrace); fields := TList.Create; try while FCurrentToken.Kind <> tkRightBrace do begin if FCurrentToken.Kind = tkEOF then Error('Unexpected EOF in map'); keyNode := ParseExpression; if keyNode.Kind <> akKeyword then Error('Map keys must be keywords'); if FCurrentToken.Kind = tkRightBrace then Error('Missing value in map'); valNode := ParseExpression; fields.Add(TAst.RecordField(keyNode.AsKeyword, valNode)); end; Consume(tkRightBrace); Result := TAst.RecordLiteral(fields.ToArray, loc); finally fields.Free; end; end; function TParser.ParseReaderMacro: IAstNode; var loc: ISourceLocation; begin loc := FCurrentToken.GetLocation; if Match(tkQuote) then begin // 'expr -> (quote expr) Result := TAst.FunctionCall(TAst.Identifier('quote', loc), [ParseExpression], loc); end else if Match(tkBacktick) then begin // `expr -> Quasiquote Result := TAst.Quasiquote(ParseExpression, loc); end else if Match(tkTilde) then begin if Match(tkAt) then // ~@expr -> UnquoteSplicing Result := TAst.UnquoteSplicing(ParseExpression.AsQuasiquote, loc) else // ~expr -> Unquote Result := TAst.Unquote(ParseExpression, loc); end else begin Error('Unknown reader macro'); Result := nil; end; end; // --- Special Forms Sub-Parsers --- function TParser.ParseIf: IAstNode; var cond, thenBr, elseBr: IAstNode; begin cond := ParseExpression; thenBr := ParseExpression; if FCurrentToken.Kind <> tkRightParen then elseBr := ParseExpression else elseBr := nil; Result := TAst.IfExpr(cond, thenBr, elseBr); end; function TParser.ParseCond: IAstNode; var pairs: TList; elseBr: IAstNode; cond, br: IAstNode; begin pairs := TList.Create; try while FCurrentToken.Kind <> tkRightParen do begin cond := ParseExpression; if FCurrentToken.Kind = tkRightParen then begin // Odd number of args -> Last one is Else elseBr := cond; Result := TAst.CondExpr(pairs.ToArray, elseBr); Exit; end; br := ParseExpression; pairs.Add(TCondPair.Create(cond, br)); end; // Even args -> No explicit else Result := TAst.CondExpr(pairs.ToArray, nil); finally pairs.Free; end; end; function TParser.ParseFn: IAstNode; var params, body: IAstNode; begin params := ParseVector; // Expects [ ... ] body := ParseExpression; Result := TAst.LambdaExpr(ExtractIdentifiers(params, 'fn'), body); end; function TParser.ParseDefMacro: IAstNode; var name, params, body: IAstNode; begin name := ParseExpression; if name.Kind <> akIdentifier then Error('defmacro name must be identifier'); params := ParseVector; body := ParseExpression; Result := TAst.MacroDef(name.AsIdentifier, ExtractIdentifiers(params, 'defmacro'), body); end; function TParser.ParseDef: IAstNode; var name, init: IAstNode; begin name := ParseExpression; if FCurrentToken.Kind <> tkRightParen then init := ParseExpression else init := nil; Result := TAst.VarDecl(name, init); end; function TParser.ParseAssign: IAstNode; var target, val: IAstNode; begin target := ParseExpression; val := ParseExpression; Result := TAst.Assign(target, val); end; function TParser.ParseDo: IAstNode; var list: TList; begin list := TList.Create; try while FCurrentToken.Kind <> tkRightParen do list.Add(ParseExpression); Result := TAst.Block(list.ToArray); finally list.Free; end; end; function TParser.ParseRecur: IAstNode; var list: TList; begin list := TList.Create; try while FCurrentToken.Kind <> tkRightParen do list.Add(ParseExpression); Result := TAst.Recur(list.ToArray); finally list.Free; end; end; function TParser.ParseQuoteForm: IAstNode; begin Result := TAst.Quasiquote(ParseExpression); end; function TParser.ParsePipe: IAstNode; var inputs, transform: IAstNode; begin inputs := ParseVector; transform := ParseExpression; if inputs.Kind <> akTuple then Error('Pipe inputs must be a vector'); if transform.Kind <> akLambdaExpression then Error('Pipe transform must be a fn'); Result := TAst.Pipe(inputs.AsTuple, transform.AsLambdaExpression); end; function TParser.ParseNewSeries: IAstNode; begin Result := TAst.CreateSeries(ParseExpression); end; function TParser.ParseAddItem: IAstNode; var s, v, lb: IAstNode; begin s := ParseExpression; if s.Kind <> akIdentifier then Error('Series argument must be an identifier'); v := ParseExpression; if FCurrentToken.Kind <> tkRightParen then lb := ParseExpression else lb := nil; Result := TAst.AddSeriesItem(s.AsIdentifier, v, lb); end; function TParser.ParseGet: IAstNode; var base, idx: IAstNode; begin base := ParseExpression; idx := ParseExpression; Result := TAst.Indexer(base, idx); end; // --- Helpers --- function TParser.ParseTupleBody(StopToken: TTokenKind): TArray; var list: TList; begin list := TList.Create; try while FCurrentToken.Kind <> StopToken do begin if FCurrentToken.Kind = tkEOF then Error('Unexpected EOF inside tuple/vector'); list.Add(ParseExpression); end; Result := list.ToArray; finally list.Free; end; Consume(StopToken); end; function TParser.ExtractIdentifiers(const Node: IAstNode; const Context: string): TArray; begin if Node.Kind <> akTuple then ErrorFmt('%s expects a vector of identifiers.', [Context]); var elements := Node.AsTuple.Elements; SetLength(Result, Length(elements)); for var i := 0 to High(elements) do begin if elements[i].Kind <> akIdentifier then ErrorFmt('Element at index %d in %s is not an identifier.', [i, Context]); Result[i] := elements[i].AsIdentifier; end; end; { TAstScript } class function TAstScript.Parse(const ASource: string): IAstNode; var p: TParser; begin p := TParser.Create(ASource); try Result := p.Parse; finally p.Free; end; end; class function TAstScript.Print(const ANode: IAstNode): string; var v: TPrettyPrintVisitor; begin v := TPrettyPrintVisitor.Create; try v.Execute(ANode); Result := v.GetResult; finally v.Free; end; end; class function TAstScript.GetGrammar: string; var ctx: TRttiContext; t: TRttiType; m: TRttiMethod; attr: TCustomAttribute; sb: TStringBuilder; rules: TList; begin ctx := TRttiContext.Create; rules := TList.Create; sb := TStringBuilder.Create; try t := ctx.GetType(TParser); for m in t.GetMethods do begin for attr in m.GetAttributes do begin if attr is EbnfAttribute then begin rules.Add(EbnfAttribute(attr).Rule); end; end; end; // Sort to ensure deterministic output (optional, but good for docs) rules.Sort; sb.AppendLine('(* Myc Script Grammar (Auto-Generated) *)'); sb.AppendLine; for var rule in rules do sb.AppendLine(rule); Result := sb.ToString; finally sb.Free; rules.Free; ctx.Free; end; end; end.