unit Myc.Ast.Script; interface uses System.SysUtils, Myc.Ast.Nodes; type // Provides a high-level facade for parsing and printing the AST. TAstScript = record public class function Parse(const ASource: string): IAstNode; static; class function Print(const ANode: IAstNode): string; static; end; implementation uses System.Classes, System.Generics.Collections, System.Character, System.Math, Myc.Data.Scalar, Myc.Data.Value, Myc.Ast; type // --- Internal Parser Implementation --- TTokenKind = ( tkLeftParen, // ( tkRightParen, // ) tkLeftBracket, // [ tkRightBracket, // ] tkQuote, // ' tkBacktick, // ` tkTilde, // ~ tkIdentifier, tkNumber, tkString, tkEOF, tkError ); TTokenKindHelper = record helper for TTokenKind function ToString: String; end; TToken = record Kind: TTokenKind; Text: string; end; TLexer = class private FSource: string; FCurrentPos: Integer; function Peek: Char; procedure Advance; function ReadNumber: string; function ReadString: string; function ReadIdentifier: string; public constructor Create(const ASource: string); function GetNextToken: TToken; end; TExpr = record Token: TToken; Node: IAstNode; Params: TArray; end; TParser = class private FLexer: TLexer; FCurrentToken: TToken; procedure Consume(AExpectedKind: TTokenKind); procedure NextToken; function ParseList: IAstNode; function ParseParameterList: TArray; function ParseExpression: TExpr; public constructor Create(const ASource: string); destructor Destroy; override; function Parse: IAstNode; end; // --- Internal Printer Implementation --- TPrettyPrintVisitor = class(TInterfacedObject, IAstVisitor) private FBuilder: TStringBuilder; FIndentLevel: Integer; procedure Indent; procedure Unindent; procedure Append(const S: string); procedure NewLine; public constructor Create; destructor Destroy; override; function GetResult: string; // IAstVisitor function Execute(const RootNode: IAstNode): TDataValue; function VisitConstant(const Node: IConstantNode): TDataValue; function VisitIdentifier(const Node: IIdentifierNode): TDataValue; function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; function VisitMacroDefinition(const Node: IMacroDefinitionNode): TDataValue; function VisitQuasiquote(const Node: IQuasiquoteNode): TDataValue; function VisitUnquote(const Node: IUnquoteNode): TDataValue; function VisitUnquoteSplicing(const Node: IUnquoteSplicingNode): TDataValue; function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; function VisitAssignment(const Node: IAssignmentNode): TDataValue; function VisitIndexer(const Node: IIndexerNode): TDataValue; function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; function VisitRecurNode(const Node: IRecurNode): TDataValue; end; { TLexer } constructor TLexer.Create(const ASource: string); begin inherited Create; FSource := ASource; FCurrentPos := 1; end; function TLexer.Peek: Char; begin if FCurrentPos > Length(FSource) then Result := #0 else Result := FSource[FCurrentPos]; end; procedure TLexer.Advance; begin inc(FCurrentPos); end; function TLexer.ReadIdentifier: string; var startPos: Integer; begin startPos := FCurrentPos; // Reader macro characters are now also delimiters for identifiers. 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; while (Peek <> #0) and (Peek.IsDigit or (Peek = '.')) do Advance; Result := Copy(FSource, startPos, FCurrentPos - startPos); end; function TLexer.ReadString: string; var startPos: Integer; begin Advance; // Skip opening " startPos := FCurrentPos; while (Peek <> #0) and (Peek <> '"') do Advance; Result := Copy(FSource, startPos, FCurrentPos - startPos); if Peek = '"' then Advance; // Skip closing " end; function TLexer.GetNextToken: TToken; begin // Skip whitespace and comments while FCurrentPos <= Length(FSource) do begin if FSource[FCurrentPos].IsWhiteSpace then begin Advance; continue; end; if FSource[FCurrentPos] = ';' then begin // Comment found, skip to the end of the line while (FCurrentPos <= Length(FSource)) and (not CharInSet(FSource[FCurrentPos], [#10, #13])) do Advance; continue; end; // No whitespace or comment, so break out and process the token break; end; if FCurrentPos > Length(FSource) then begin Result.Kind := tkEOF; exit; end; var c := Peek; case c of '(': begin Result.Kind := tkLeftParen; Advance; end; ')': begin Result.Kind := tkRightParen; Advance; end; '[': begin Result.Kind := tkLeftBracket; Advance; end; ']': begin Result.Kind := tkRightBracket; Advance; end; '''': begin Result.Kind := tkQuote; Advance; end; '`': begin Result.Kind := tkBacktick; Advance; end; '~': begin Result.Kind := tkTilde; Advance; end; '"': begin Result.Kind := tkString; Result.Text := ReadString; end; else 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); NextToken; // Load the first token end; destructor TParser.Destroy; begin FLexer.Free; inherited; end; procedure TParser.NextToken; begin FCurrentToken := FLexer.GetNextToken; end; procedure TParser.Consume(AExpectedKind: TTokenKind); begin if FCurrentToken.Kind <> AExpectedKind then raise Exception.CreateFmt('Syntax Error: Expected token %s, but found %s', [AExpectedKind.ToString, FCurrentToken.Kind.ToString]); NextToken; end; function TParser.ParseParameterList: TArray; var params: TList; begin Consume(tkLeftBracket); params := TList.Create; try while FCurrentToken.Kind <> tkRightBracket do begin if FCurrentToken.Kind = tkEOF then raise Exception.Create('Syntax Error: Unexpected end of file.'); if FCurrentToken.Kind <> tkIdentifier then raise Exception.Create('Syntax Error: Expected identifier in parameter list.'); params.Add(TAst.Identifier(FCurrentToken.Text)); NextToken; end; Result := params.ToArray; finally params.Free; end; Consume(tkRightBracket); end; function TParser.ParseList: IAstNode; function IfThen(cond: Boolean; const TrueBranch, FalseBranch: IAstNode): IAstNode; begin if cond then exit(TrueBranch) else exit(FalseBranch); end; var elements: TList; head: TExpr; tailTokens: TArray; tailNodes: TArray; begin Consume(tkLeftParen); if FCurrentToken.Kind = tkRightParen then raise Exception.Create('Syntax Error: Empty list () is not a valid expression.'); elements := TList.Create; try while FCurrentToken.Kind <> tkRightParen do begin if FCurrentToken.Kind = tkEOF then raise Exception.Create('Syntax Error: Unexpected end of file.'); elements.Add(ParseExpression); end; head := elements[0]; // Convert the rest of the list to an array for the factory functions SetLength(tailTokens, elements.Count - 1); SetLength(tailNodes, elements.Count - 1); for var i := 0 to High(tailNodes) do begin tailTokens[i] := elements[i + 1].Token; tailNodes[i] := elements[i + 1].Node; end; if head.Token.Kind = tkIdentifier then begin // Handle special forms if SameText(head.Token.Text, 'if') then begin if not (Length(tailNodes) in [2, 3]) then raise Exception.Create('Syntax Error in if statement.'); Result := TAst.IfExpr( tailNodes[0], tailNodes[1], if Length(tailNodes) > 2 then tailNodes[2] else nil ) end else if SameText(head.Token.Text, '?') then begin if Length(tailNodes) <> 3 then raise Exception.Create('Syntax Error in ternary statement.'); Result := TAst.TernaryExpr(tailNodes[0], tailNodes[1], tailNodes[2]); end else if SameText(head.Token.Text, 'def') then begin if tailTokens[0].Kind <> tkIdentifier then raise Exception.Create('Syntax Error: Expected an identifier for def statement.'); Result := TAst.VarDecl(IIdentifierNode(tailNodes[0]), IfThen(Length(tailNodes) > 1, tailNodes[1], nil)); end else if SameText(head.Token.Text, 'defmacro') then begin // (defmacro name [params] body) if (Length(tailNodes) <> 3) or (tailTokens[0].Kind <> tkIdentifier) then raise Exception.Create('Syntax Error: ''defmacro'' requires a name, a parameter list, and a body.'); if elements[2].Params = nil then raise Exception.Create('Syntax Error: Expected a parameter list [...] after macro name.'); var macroName := IIdentifierNode(tailNodes[0]); var macroParams := elements[2].Params; var macroBody := tailNodes[2]; Result := TAst.MacroDef(macroName, macroParams, macroBody); end else if SameText(head.Token.Text, 'assign') then begin if tailTokens[0].Kind <> tkIdentifier then raise Exception.Create('Syntax Error: Expected an identifier for assignment.'); Result := TAst.Assign(IIdentifierNode(tailNodes[0]), tailNodes[1]); end else if SameText(head.Token.Text, 'fn') then begin if Length(tailNodes) <> 2 then raise Exception.Create('Syntax Error: ''fn'' requires a parameter list and a body.'); if elements[1].Params = nil then raise Exception.Create('Syntax Error: Expected a parameter list [...] after ''fn''.'); Result := TAst.LambdaExpr(elements[1].Params, tailNodes[1]); end else if SameText(head.Token.Text, 'do') then Result := TAst.Block(tailNodes) else if SameText(head.Token.Text, 'recur') then Result := TAst.Recur(tailNodes) else if SameText(head.Token.Text, 'get') then Result := TAst.Indexer(tailNodes[0], tailNodes[1]) else if (Length(head.Token.Text) > 1) and (head.Token.Text.StartsWith('.')) then Result := TAst.MemberAccess(tailNodes[0], TAst.Identifier(head.Token.Text.Substring(1))) else begin if Length(tailNodes) = 1 then begin for var op := Low(TScalar.TUnaryOp) to High(TScalar.TUnaryOp) do begin if head.Token.Text = op.ToString then begin Result := TAst.UnaryExpr(op, tailNodes[0]); break end; end; end else if Length(tailNodes) = 2 then begin for var op := Low(TScalar.TBinaryOp) to High(TScalar.TBinaryOp) do begin if head.Token.Text = op.ToString then begin Result := TAst.BinaryExpr(tailNodes[0], op, tailNodes[1]); break end; end; end; end; end; if Result = nil then Result := TAst.FunctionCall(head.Node, tailNodes); finally elements.Free; end; Consume(tkRightParen); end; function TParser.ParseExpression: TExpr; var i64: Int64; dbl: Double; expr: TExpr; begin // Handle reader macros. case FCurrentToken.Kind of tkBacktick: begin NextToken; expr := ParseExpression; Result.Node := TAst.Quasiquote(expr.Node); exit; end; tkTilde: begin NextToken; // Check for unquote-splicing ('~@') if (FCurrentToken.Kind = tkIdentifier) and (FCurrentToken.Text = '@') then begin NextToken; expr := ParseExpression; Result.Node := TAst.UnquoteSplicing(expr.Node); end else // It's a regular unquote ('~') begin expr := ParseExpression; Result.Node := TAst.Unquote(expr.Node); end; exit; end; tkQuote: begin NextToken; expr := ParseExpression; // A regular quote '(...) can be desugared into (quote (...)) Result.Node := TAst.FunctionCall(TAst.Identifier('quote'), [expr.Node]); exit; end; end; Result.Token := FCurrentToken; case FCurrentToken.Kind of tkNumber: begin if TryStrToInt64(FCurrentToken.Text, i64) then Result.Node := TAst.Constant(i64) else if TryStrToFloat(FCurrentToken.Text, dbl) then Result.Node := TAst.Constant(dbl) else raise Exception.CreateFmt('Syntax Error: Invalid number format "%s"', [FCurrentToken.Text]); NextToken; end; tkString: begin Result.Node := TAst.Constant(FCurrentToken.Text); NextToken; end; tkIdentifier: begin Result.Node := TAst.Identifier(FCurrentToken.Text); NextToken; end; tkLeftParen: Result.Node := ParseList; tkLeftBracket: Result.Params := ParseParameterList; tkEOF: {nop}; else raise Exception.CreateFmt('Syntax Error: Unexpected token %s', [FCurrentToken.Kind.ToString]); end; end; function TParser.Parse: IAstNode; begin var expr := ParseExpression; if FCurrentToken.Kind <> tkEOF then raise Exception.Create('Syntax Error: Unexpected characters after end of expression.'); Result := expr.Node; end; { TPrettyPrintVisitor } constructor TPrettyPrintVisitor.Create; begin inherited Create; FBuilder := TStringBuilder.Create; FIndentLevel := 0; end; destructor TPrettyPrintVisitor.Destroy; begin FBuilder.Free; inherited Destroy; end; function TPrettyPrintVisitor.GetResult: string; begin Result := FBuilder.ToString; end; procedure TPrettyPrintVisitor.Indent; begin inc(FIndentLevel, 2); end; procedure TPrettyPrintVisitor.Unindent; begin dec(FIndentLevel, 2); end; procedure TPrettyPrintVisitor.Append(const S: string); begin FBuilder.Append(S); end; procedure TPrettyPrintVisitor.NewLine; begin FBuilder.AppendLine; FBuilder.Append(''.PadLeft(FIndentLevel)); end; function TPrettyPrintVisitor.Execute(const RootNode: IAstNode): TDataValue; begin if Assigned(RootNode) then RootNode.Accept(Self); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitConstant(const Node: IConstantNode): TDataValue; var val: TDataValue; begin val := Node.Value; if val.Kind = vkText then Append('"' + val.AsText + '"') else Append(val.ToString); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitIdentifier(const Node: IIdentifierNode): TDataValue; begin Append(Node.Name); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; begin Append('(' + Node.Operator.ToString); Append(' '); Node.Left.Accept(Self); Append(' '); Node.Right.Accept(Self); Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; begin Append('(' + Node.Operator.ToString); Append(' '); Node.Right.Accept(Self); Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitIfExpression(const Node: IIfExpressionNode): TDataValue; begin Append('(if '); Node.Condition.Accept(Self); Indent; NewLine; Node.ThenBranch.Accept(Self); if Assigned(Node.ElseBranch) then begin NewLine; Node.ElseBranch.Accept(Self); end; Unindent; NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; begin Append('(? '); Node.Condition.Accept(Self); Indent; NewLine; Node.ThenBranch.Accept(Self); NewLine; Node.ElseBranch.Accept(Self); Unindent; NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; var param: IIdentifierNode; sb: TStringBuilder; begin sb := TStringBuilder.Create; try for param in Node.Parameters do sb.Append(param.Name + ' '); if sb.Length > 0 then sb.Remove(sb.Length - 1, 1); // remove trailing space Append('(fn [' + sb.ToString + ']'); finally sb.Free; end; Indent; NewLine; Node.Body.Accept(Self); Unindent; NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitMacroDefinition(const Node: IMacroDefinitionNode): TDataValue; var param: IIdentifierNode; sb: TStringBuilder; begin sb := TStringBuilder.Create; try for param in Node.Parameters do sb.Append(param.Name + ' '); if sb.Length > 0 then sb.Remove(sb.Length - 1, 1); Append('(defmacro ' + Node.Name.Name + ' [' + sb.ToString + ']'); finally sb.Free; end; Indent; NewLine; Node.Body.Accept(Self); Unindent; NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitQuasiquote(const Node: IQuasiquoteNode): TDataValue; begin Append('`'); Node.Expression.Accept(Self); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitUnquote(const Node: IUnquoteNode): TDataValue; begin Append('~'); Node.Expression.Accept(Self); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitUnquoteSplicing(const Node: IUnquoteSplicingNode): TDataValue; begin // To handle '~@', we need to check if the expression is an identifier '@'. // However, the parser logic now handles this, so we just print '~@'. Append('~@'); Node.Expression.Accept(Self); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; var arg: IAstNode; begin // Special case for (quote ...) to print it as '... if (Node.Callee is TIdentifierNode) and (TIdentifierNode(Node.Callee).Name = 'quote') and (Length(Node.Arguments) = 1) then begin Append(''''); Node.Arguments[0].Accept(Self); exit(TDataValue.Void); end; Append('('); Node.Callee.Accept(Self); Indent; for arg in Node.Arguments do begin NewLine; arg.Accept(Self); end; Unindent; if Length(Node.Arguments) > 0 then NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitRecurNode(const Node: IRecurNode): TDataValue; var arg: IAstNode; begin Append('(recur'); Indent; for arg in Node.Arguments do begin NewLine; arg.Accept(Self); end; Unindent; if Length(Node.Arguments) > 0 then NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; var expr: IAstNode; begin Append('(do'); Indent; for expr in Node.Expressions do begin NewLine; expr.Accept(Self); end; Unindent; NewLine; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; begin Append('(def '); Node.Identifier.Accept(Self); if Assigned(Node.Initializer) then begin Append(' '); Node.Initializer.Accept(Self); end; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitAssignment(const Node: IAssignmentNode): TDataValue; begin Append('(assign '); Node.Identifier.Accept(Self); Append(' '); Node.Value.Accept(Self); Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitIndexer(const Node: IIndexerNode): TDataValue; begin Append('(get '); Node.Base.Accept(Self); Append(' '); Node.Index.Accept(Self); Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; begin Append('(.'); Node.Member.Accept(Self); Append(' '); Node.Base.Accept(Self); Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; begin Append(Format('(new-series "%s")', [Node.Definition])); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; begin Append('(add-item '); Node.Series.Accept(Self); Append(' '); Node.Value.Accept(Self); if Assigned(Node.Lookback) then begin Append(' '); Node.Lookback.Accept(Self); end; Append(')'); Result := TDataValue.Void; end; function TPrettyPrintVisitor.VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; begin Append('(count '); Node.Series.Accept(Self); Append(')'); Result := TDataValue.Void; end; { TAstScript } class function TAstScript.Parse(const ASource: string): IAstNode; var p: TParser; begin if ASource.Trim.IsEmpty then exit(nil); p := TParser.Create(ASource); try Result := p.Parse; finally p.Free; end; end; class function TAstScript.Print(const ANode: IAstNode): string; var visitor: TPrettyPrintVisitor; begin if not Assigned(ANode) then exit(''); visitor := TPrettyPrintVisitor.Create; try visitor.Execute(ANode); Result := visitor.GetResult; finally visitor.Free; end; end; function TTokenKindHelper.ToString: String; begin case Self of tkLeftParen: Result := '('; tkRightParen: Result := ')'; tkLeftBracket: Result := '['; tkRightBracket: Result := ']'; tkQuote: Result := ''''; tkBacktick: Result := '`'; tkTilde: Result := '~'; tkIdentifier: Result := ''; tkNumber: Result := ''; tkString: Result := ''; tkEOF: Result := ''; else Result := ''; end; end; end.