Michael Schimmel
933 lines
27 KiB
ObjectPascal
933 lines
27 KiB
ObjectPascal
unit Myc.Ast.Script;
|
|
|
|
interface
|
|
|
|
uses
|
|
System.SysUtils,
|
|
Myc.Ast.Nodes,
|
|
Myc.Ast.Visitor;
|
|
|
|
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<IIdentifierNode>;
|
|
end;
|
|
|
|
TParser = class
|
|
private
|
|
FLexer: TLexer;
|
|
FCurrentToken: TToken;
|
|
procedure Consume(AExpectedKind: TTokenKind);
|
|
procedure NextToken;
|
|
function ParseList: IAstNode;
|
|
function ParseParameterList: TArray<IIdentifierNode>;
|
|
function ParseExpression: TExpr;
|
|
public
|
|
constructor Create(const ASource: string);
|
|
destructor Destroy; override;
|
|
function Parse: IAstNode;
|
|
end;
|
|
|
|
// --- Internal Printer Implementation ---
|
|
|
|
TPrettyPrintVisitor = class(TAstVisitor)
|
|
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; override;
|
|
function VisitIdentifier(const Node: IIdentifierNode): TDataValue; override;
|
|
function VisitBinaryExpression(const Node: IBinaryExpressionNode): TDataValue; override;
|
|
function VisitUnaryExpression(const Node: IUnaryExpressionNode): TDataValue; override;
|
|
function VisitIfExpression(const Node: IIfExpressionNode): TDataValue; override;
|
|
function VisitTernaryExpression(const Node: ITernaryExpressionNode): TDataValue; override;
|
|
function VisitLambdaExpression(const Node: ILambdaExpressionNode): TDataValue; override;
|
|
function VisitMacroDefinition(const Node: IMacroDefinitionNode): TDataValue; override;
|
|
function VisitQuasiquote(const Node: IQuasiquoteNode): TDataValue; override;
|
|
function VisitUnquote(const Node: IUnquoteNode): TDataValue; override;
|
|
function VisitUnquoteSplicing(const Node: IUnquoteSplicingNode): TDataValue; override;
|
|
function VisitFunctionCall(const Node: IFunctionCallNode): TDataValue; override;
|
|
function VisitMacroExpansionNode(const Node: IMacroExpansionNode): TDataValue; override;
|
|
function VisitBlockExpression(const Node: IBlockExpressionNode): TDataValue; override;
|
|
function VisitVariableDeclaration(const Node: IVariableDeclarationNode): TDataValue; override;
|
|
function VisitAssignment(const Node: IAssignmentNode): TDataValue; override;
|
|
function VisitIndexer(const Node: IIndexerNode): TDataValue; override;
|
|
function VisitMemberAccess(const Node: IMemberAccessNode): TDataValue; override;
|
|
function VisitCreateSeries(const Node: ICreateSeriesNode): TDataValue; override;
|
|
function VisitAddSeriesItem(const Node: IAddSeriesItemNode): TDataValue; override;
|
|
function VisitSeriesLength(const Node: ISeriesLengthNode): TDataValue; override;
|
|
function VisitRecurNode(const Node: IRecurNode): TDataValue; override;
|
|
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<IIdentifierNode>;
|
|
var
|
|
params: TList<IIdentifierNode>;
|
|
begin
|
|
Consume(tkLeftBracket);
|
|
params := TList<IIdentifierNode>.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<TExpr>;
|
|
head: TExpr;
|
|
tailTokens: TArray<TToken>;
|
|
tailNodes: TArray<IAstNode>;
|
|
begin
|
|
Consume(tkLeftParen);
|
|
if FCurrentToken.Kind = tkRightParen then
|
|
raise Exception.Create('Syntax Error: Empty list () is not a valid expression.');
|
|
|
|
elements := TList<TExpr>.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.VisitMacroExpansionNode(const Node: IMacroExpansionNode): TDataValue;
|
|
begin
|
|
// For pretty-printing, show the original macro call, not the expanded body.
|
|
// Delegate to the regular VisitFunctionCall to print it as such.
|
|
Result := VisitFunctionCall(Node);
|
|
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 := '<identifier>';
|
|
tkNumber: Result := '<number>';
|
|
tkString: Result := '<string>';
|
|
tkEOF: Result := '<EOF>';
|
|
else
|
|
Result := '<error>';
|
|
end;
|
|
end;
|
|
|
|
end.
|