Add function methods with Result variable and call expressions
Lexer:
- Added tkFunction keyword token.
AST:
- TMethodDecl gains ReturnTypeName (string) and ResolvedReturnType
(TTypeDesc, nil = procedure).
- TMethodCallExpr: new expression node for obj.Method(args) in rvalue
context; carries ObjectName, Name, Args, ResolvedClassType,
ResolvedMethod — set by uSemantic.
Parser:
- ParseMethodDecl(IsFunction): dispatches on tkFunction vs tkProcedure;
for functions, consumes ': ReturnType' after the parameter list.
- ParseClassDef: loops on tkProcedure or tkFunction tokens.
- ParseFactor: IDENT.IDENT followed by '(' now produces TMethodCallExpr
with an inline arg list; without '(' stays TFieldAccessExpr.
Semantic:
- AnalyseTypeDecls: resolves ReturnTypeName → ResolvedReturnType for
each function method alongside param type resolution.
- AnalyseMethodDecl: for function methods, defines 'Result' as a
skVariable of the return type in the method scope, making it
assignable inside the body.
- AnalyseMethodCallExpr: validates object type, looks up method,
verifies the method has a return type (not a procedure), checks arg
count and types; sets ResolvedClassType and ResolvedMethod.
- AnalyseExpr: handles TMethodCallExpr before TFieldAccessExpr.
Code generator:
- EmitMethodDef: emits 'function <qtype> $T_M(...)' for function
methods; allocates and zero-inits %_var_Result; after EmitBlock,
loads Result and emits 'ret <temp>'.
- EmitExpr: handles TMethodCallExpr — loads Self, builds arg list,
emits 'call $T_M(...)' into a typed temp, returns the temp.
Tests: 226 unit tests (22 new function-method tests), 0 failures.
This commit is contained in:
Graeme Geldenhuys
parent
313619511c
commit
0fbeea1f9e
|
|
@ -149,9 +149,22 @@ type
|
|||
|
||||
TMethodDecl = class(TASTNode)
|
||||
public
|
||||
Name: string; { method name }
|
||||
Params: TObjectList; { owned TMethodParam }
|
||||
Body: TBlock; { owned }
|
||||
Name: string; { method name }
|
||||
Params: TObjectList; { owned TMethodParam }
|
||||
ReturnTypeName: string; { empty = procedure }
|
||||
ResolvedReturnType: TTypeDesc; { set by uSemantic; nil = procedure }
|
||||
Body: TBlock; { owned }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TMethodCallExpr = class(TASTExpr)
|
||||
public
|
||||
ObjectName: string;
|
||||
Name: string; { method name }
|
||||
Args: TObjectList; { owned TASTExpr }
|
||||
ResolvedClassType: TTypeDesc; { not owned; set by uSemantic }
|
||||
ResolvedMethod: TObject; { TMethodDecl — not owned }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
|
@ -321,6 +334,20 @@ begin
|
|||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TMethodCallExpr }
|
||||
|
||||
constructor TMethodCallExpr.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Args := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TMethodCallExpr.Destroy;
|
||||
begin
|
||||
Args.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TClassTypeDef }
|
||||
|
||||
constructor TClassTypeDef.Create;
|
||||
|
|
|
|||
|
|
@ -388,10 +388,12 @@ var
|
|||
I: Integer;
|
||||
Par: TMethodParam;
|
||||
FuncName: string;
|
||||
Sym: TSymbol;
|
||||
RT: TRecordTypeDesc;
|
||||
IsFunc: Boolean;
|
||||
RetQType: string;
|
||||
RetTemp: string;
|
||||
begin
|
||||
FuncName := '$' + ATypeName + '_' + AMethod.Name;
|
||||
IsFunc := AMethod.ResolvedReturnType <> nil;
|
||||
|
||||
{ Build parameter signature: l %_par_Self [, qtype %_par_Name ...] }
|
||||
Sig := 'l %_par_Self';
|
||||
|
|
@ -402,18 +404,46 @@ begin
|
|||
[QbeTypeOf(Par.ResolvedType), Par.ParamName]);
|
||||
end;
|
||||
|
||||
EmitLine(Format('function %s(%s) {', [FuncName, Sig]));
|
||||
EmitLine('@start');
|
||||
if IsFunc then
|
||||
begin
|
||||
RetQType := QbeTypeOf(AMethod.ResolvedReturnType);
|
||||
EmitLine(Format('function %s %s(%s) {', [RetQType, FuncName, Sig]));
|
||||
end
|
||||
else
|
||||
EmitLine(Format('function %s(%s) {', [FuncName, Sig]));
|
||||
|
||||
{ Allocate stack slots for Self and params, then emit body }
|
||||
RT := nil;
|
||||
{ We need the class type descriptor for EmitParamAllocs — obtain from AMethod }
|
||||
{ AMethod.Body is already resolved; RT is referenced via Self symbol in the body.
|
||||
We pass nil for RT here since EmitParamAllocs only needs it for Self size (always l). }
|
||||
EmitLine('@start');
|
||||
EmitParamAllocs(AMethod, nil);
|
||||
|
||||
{ For function methods, allocate a zero-initialised Result slot }
|
||||
if IsFunc then
|
||||
begin
|
||||
if RetQType = 'w' then
|
||||
begin
|
||||
EmitLine(' %_var_Result =l alloc4 1');
|
||||
EmitLine(' storew 0, %_var_Result');
|
||||
end
|
||||
else
|
||||
begin
|
||||
EmitLine(' %_var_Result =l alloc8 1');
|
||||
EmitLine(' storel 0, %_var_Result');
|
||||
end;
|
||||
end;
|
||||
|
||||
EmitBlock(AMethod.Body);
|
||||
|
||||
EmitLine(' ret');
|
||||
if IsFunc then
|
||||
begin
|
||||
RetTemp := AllocTemp;
|
||||
if RetQType = 'w' then
|
||||
EmitLine(Format(' %s =w loadw %%_var_Result', [RetTemp]))
|
||||
else
|
||||
EmitLine(Format(' %s =l loadl %%_var_Result', [RetTemp]));
|
||||
EmitLine(Format(' ret %s', [RetTemp]));
|
||||
end
|
||||
else
|
||||
EmitLine(' ret');
|
||||
|
||||
EmitLine('}');
|
||||
EmitLine('');
|
||||
end;
|
||||
|
|
@ -488,10 +518,46 @@ var
|
|||
Op: string;
|
||||
BinExpr: TBinaryExpr;
|
||||
FldAccess: TFieldAccessExpr;
|
||||
MCallExpr: TMethodCallExpr;
|
||||
Ptr: string;
|
||||
QType: string;
|
||||
LoadInstr: string;
|
||||
SelfTemp: string;
|
||||
ArgLine: string;
|
||||
ArgTemp: string;
|
||||
Par: TMethodParam;
|
||||
MDecl: TMethodDecl;
|
||||
RT: TRecordTypeDesc;
|
||||
FuncName: string;
|
||||
I: Integer;
|
||||
begin
|
||||
if AExpr is TMethodCallExpr then
|
||||
begin
|
||||
MCallExpr := TMethodCallExpr(AExpr);
|
||||
RT := TRecordTypeDesc(MCallExpr.ResolvedClassType);
|
||||
MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
|
||||
FuncName := '$' + RT.Name + '_' + MCallExpr.Name;
|
||||
QType := QbeTypeOf(MDecl.ResolvedReturnType);
|
||||
|
||||
{ Load the object pointer (Self) }
|
||||
SelfTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, MCallExpr.ObjectName]));
|
||||
|
||||
{ Build argument string }
|
||||
ArgLine := Format('l %s', [SelfTemp]);
|
||||
for I := 0 to MCallExpr.Args.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(MDecl.Params[I]);
|
||||
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args[I]));
|
||||
ArgLine := ArgLine + Format(', %s %s', [QbeTypeOf(Par.ResolvedType), ArgTemp]);
|
||||
end;
|
||||
|
||||
T := AllocTemp;
|
||||
EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FuncName, ArgLine]));
|
||||
Result := T;
|
||||
Exit;
|
||||
end;
|
||||
|
||||
if AExpr is TIntLiteral then
|
||||
begin
|
||||
T := AllocTemp;
|
||||
|
|
|
|||
|
|
@ -24,6 +24,7 @@ type
|
|||
tkRecord,
|
||||
tkClass,
|
||||
tkProcedure,
|
||||
tkFunction,
|
||||
tkVar,
|
||||
tkBegin,
|
||||
tkEnd,
|
||||
|
|
@ -91,6 +92,7 @@ begin
|
|||
else if AUpper = 'RECORD' then Result := tkRecord
|
||||
else if AUpper = 'CLASS' then Result := tkClass
|
||||
else if AUpper = 'PROCEDURE' then Result := tkProcedure
|
||||
else if AUpper = 'FUNCTION' then Result := tkFunction
|
||||
else if AUpper = 'DIV' then Result := tkDiv
|
||||
else
|
||||
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ type
|
|||
function ParseRecordDef: TRecordTypeDef;
|
||||
function ParseClassDef: TClassTypeDef;
|
||||
procedure ParseFieldDecl(AFields: TObjectList);
|
||||
function ParseMethodDecl: TMethodDecl;
|
||||
function ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
|
||||
procedure ParseParamList(AParams: TObjectList);
|
||||
procedure ParseVarBlock(ABlock: TBlock);
|
||||
procedure ParseVarDecl(ABlock: TBlock);
|
||||
|
|
@ -260,8 +260,13 @@ begin
|
|||
end;
|
||||
while Check(tkIdent) do
|
||||
ParseFieldDecl(Result.Fields);
|
||||
while Check(tkProcedure) do
|
||||
Result.Methods.Add(ParseMethodDecl);
|
||||
while Check(tkProcedure) or Check(tkFunction) do
|
||||
begin
|
||||
if Check(tkFunction) then
|
||||
Result.Methods.Add(ParseMethodDecl(True))
|
||||
else
|
||||
Result.Methods.Add(ParseMethodDecl(False));
|
||||
end;
|
||||
Expect(tkEnd);
|
||||
except
|
||||
Result.Free;
|
||||
|
|
@ -269,13 +274,16 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseMethodDecl: TMethodDecl;
|
||||
function TParser.ParseMethodDecl(IsFunction: Boolean): TMethodDecl;
|
||||
begin
|
||||
Result := TMethodDecl.Create;
|
||||
try
|
||||
Result.Line := FCurrent.Line;
|
||||
Result.Col := FCurrent.Col;
|
||||
Expect(tkProcedure);
|
||||
if IsFunction then
|
||||
Expect(tkFunction)
|
||||
else
|
||||
Expect(tkProcedure);
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected method name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
|
|
@ -288,6 +296,15 @@ begin
|
|||
ParseParamList(Result.Params);
|
||||
Expect(tkRParen);
|
||||
end;
|
||||
if IsFunction then
|
||||
begin
|
||||
Expect(tkColon);
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected return type at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Result.ReturnTypeName := FCurrent.Value;
|
||||
Advance;
|
||||
end;
|
||||
Expect(tkSemicolon);
|
||||
Result.Body := ParseBlock;
|
||||
Expect(tkSemicolon);
|
||||
|
|
@ -608,8 +625,10 @@ var
|
|||
StrNode: TStringLiteral;
|
||||
IdNode: TIdentExpr;
|
||||
FldNode: TFieldAccessExpr;
|
||||
MCallNode: TMethodCallExpr;
|
||||
Inner: TASTExpr;
|
||||
Name: string;
|
||||
SecondName: string;
|
||||
Line, Col: Integer;
|
||||
begin
|
||||
case FCurrent.Kind of
|
||||
|
|
@ -639,18 +658,43 @@ begin
|
|||
Advance;
|
||||
if Check(tkDot) then
|
||||
begin
|
||||
{ Field access: Ident '.' Ident }
|
||||
Advance;
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected field name at line %d col %d',
|
||||
raise EParseError.CreateFmt('Expected field or method name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
FldNode := TFieldAccessExpr.Create;
|
||||
FldNode.Line := Line;
|
||||
FldNode.Col := Col;
|
||||
FldNode.RecordName := Name;
|
||||
FldNode.FieldName := FCurrent.Value;
|
||||
SecondName := FCurrent.Value;
|
||||
Advance;
|
||||
Result := FldNode;
|
||||
if Check(tkLParen) then
|
||||
begin
|
||||
{ IDENT '.' IDENT '(' ... ')' — method call expression }
|
||||
MCallNode := TMethodCallExpr.Create;
|
||||
MCallNode.Line := Line;
|
||||
MCallNode.Col := Col;
|
||||
MCallNode.ObjectName := Name;
|
||||
MCallNode.Name := SecondName;
|
||||
Advance;
|
||||
if not Check(tkRParen) then
|
||||
begin
|
||||
MCallNode.Args.Add(ParseExpr);
|
||||
while Check(tkComma) do
|
||||
begin
|
||||
Advance;
|
||||
MCallNode.Args.Add(ParseExpr);
|
||||
end;
|
||||
end;
|
||||
Expect(tkRParen);
|
||||
Result := MCallNode;
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ IDENT '.' IDENT — field access or constructor call }
|
||||
FldNode := TFieldAccessExpr.Create;
|
||||
FldNode.Line := Line;
|
||||
FldNode.Col := Col;
|
||||
FldNode.RecordName := Name;
|
||||
FldNode.FieldName := SecondName;
|
||||
Result := FldNode;
|
||||
end;
|
||||
end
|
||||
else
|
||||
begin
|
||||
|
|
|
|||
|
|
@ -36,6 +36,7 @@ type
|
|||
procedure AnalyseFieldAssignment(AAssign: TFieldAssignment);
|
||||
procedure AnalyseProcCall(ACall: TProcCall);
|
||||
procedure AnalyseMethodCall(ACall: TMethodCallStmt);
|
||||
function AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc;
|
||||
function AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
|
||||
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
|
||||
function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
|
||||
|
|
@ -176,7 +177,7 @@ begin
|
|||
TD.Line, TD.Col);
|
||||
end;
|
||||
|
||||
{ Index class methods and resolve param types }
|
||||
{ Index class methods and resolve param/return types }
|
||||
if MethodList <> nil then
|
||||
for J := 0 to MethodList.Count - 1 do
|
||||
begin
|
||||
|
|
@ -195,6 +196,17 @@ begin
|
|||
MDecl.Line, MDecl.Col);
|
||||
Par.ResolvedType := ParType;
|
||||
end;
|
||||
|
||||
if MDecl.ReturnTypeName <> '' then
|
||||
begin
|
||||
ParType := FTable.FindType(MDecl.ReturnTypeName);
|
||||
if ParType = nil then
|
||||
SemanticError(
|
||||
Format('Unknown return type ''%s'' for method ''%s''',
|
||||
[MDecl.ReturnTypeName, MDecl.Name]),
|
||||
MDecl.Line, MDecl.Col);
|
||||
MDecl.ResolvedReturnType := ParType;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
|
@ -235,6 +247,13 @@ begin
|
|||
Sym := TSymbol.Create('Self', skVariable, AClassType);
|
||||
FTable.Define(Sym);
|
||||
|
||||
{ For function methods, define Result as a writable variable }
|
||||
if AMethod.ResolvedReturnType <> nil then
|
||||
begin
|
||||
Sym := TSymbol.Create('Result', skVariable, AMethod.ResolvedReturnType);
|
||||
FTable.Define(Sym);
|
||||
end;
|
||||
|
||||
{ Define explicit parameters }
|
||||
for I := 0 to AMethod.Params.Count - 1 do
|
||||
begin
|
||||
|
|
@ -453,6 +472,61 @@ begin
|
|||
AnalyseExpr(TASTExpr(ACall.Args[I]));
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc;
|
||||
var
|
||||
ObjSym: TSymbol;
|
||||
RT: TRecordTypeDesc;
|
||||
MDecl: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
ArgType: TTypeDesc;
|
||||
I: Integer;
|
||||
begin
|
||||
ObjSym := FTable.Lookup(AExpr.ObjectName);
|
||||
if ObjSym = nil then
|
||||
SemanticError(
|
||||
Format('Undeclared variable ''%s''', [AExpr.ObjectName]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
if ObjSym.Kind <> skVariable then
|
||||
SemanticError(
|
||||
Format('''%s'' is not a variable', [AExpr.ObjectName]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
if ObjSym.TypeDesc.Kind <> tyClass then
|
||||
SemanticError(
|
||||
Format('''%s'' is not a class variable', [AExpr.ObjectName]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
|
||||
RT := TRecordTypeDesc(ObjSym.TypeDesc);
|
||||
MDecl := FindMethodDecl(RT.Name, AExpr.Name);
|
||||
if MDecl = nil then
|
||||
SemanticError(
|
||||
Format('Class ''%s'' has no method ''%s''', [RT.Name, AExpr.Name]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
if MDecl.ResolvedReturnType = nil then
|
||||
SemanticError(
|
||||
Format('Method ''%s.%s'' is a procedure (no return value)',
|
||||
[RT.Name, AExpr.Name]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
|
||||
if AExpr.Args.Count <> MDecl.Params.Count then
|
||||
SemanticError(
|
||||
Format('Method ''%s.%s'' expects %d argument(s) but got %d',
|
||||
[RT.Name, AExpr.Name, MDecl.Params.Count, AExpr.Args.Count]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
|
||||
for I := 0 to AExpr.Args.Count - 1 do
|
||||
begin
|
||||
ArgType := AnalyseExpr(TASTExpr(AExpr.Args[I]));
|
||||
Par := TMethodParam(MDecl.Params[I]);
|
||||
CheckTypesMatch(Par.ResolvedType, ArgType,
|
||||
Format('argument %d of ''%s''', [I + 1, AExpr.Name]),
|
||||
AExpr.Line, AExpr.Col);
|
||||
end;
|
||||
|
||||
AExpr.ResolvedClassType := RT;
|
||||
AExpr.ResolvedMethod := MDecl;
|
||||
Result := MDecl.ResolvedReturnType;
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
|
||||
var
|
||||
Sym: TSymbol;
|
||||
|
|
@ -470,6 +544,8 @@ begin
|
|||
AExpr.Line, AExpr.Col);
|
||||
Result := Sym.TypeDesc;
|
||||
end
|
||||
else if AExpr is TMethodCallExpr then
|
||||
Result := AnalyseMethodCallExpr(TMethodCallExpr(AExpr))
|
||||
else if AExpr is TFieldAccessExpr then
|
||||
Result := AnalyseFieldAccess(TFieldAccessExpr(AExpr))
|
||||
else if AExpr is TBinaryExpr then
|
||||
|
|
|
|||
|
|
@ -18,7 +18,8 @@ uses
|
|||
cp.test.records,
|
||||
cp.test.classes,
|
||||
cp.test.arc,
|
||||
cp.test.methods;
|
||||
cp.test.methods,
|
||||
cp.test.functions;
|
||||
|
||||
var
|
||||
Application: TTestRunner;
|
||||
|
|
|
|||
479
compiler/src/test/pascal/cp.test.functions.pas
Normal file
479
compiler/src/test/pascal/cp.test.functions.pas
Normal file
|
|
@ -0,0 +1,479 @@
|
|||
unit cp.test.functions;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TFunctionTests = class(TTestCase)
|
||||
private
|
||||
function ParseSrc(const ASrc: string): TProgram;
|
||||
function AnalyseSrc(const ASrc: string): TProgram;
|
||||
function GenIR(const ASrc: string): string;
|
||||
procedure AnalyseExpectError(const ASrc: string);
|
||||
published
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Lexer }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestLexer_Function_Keyword;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_FunctionMethod_InClass;
|
||||
procedure TestParse_FunctionMethod_Name;
|
||||
procedure TestParse_FunctionMethod_ReturnTypeName;
|
||||
procedure TestParse_FunctionMethod_WithParams;
|
||||
procedure TestParse_FunctionCall_Expr;
|
||||
procedure TestParse_FunctionCall_Expr_ObjectName;
|
||||
procedure TestParse_FunctionCall_Expr_WithArgs;
|
||||
procedure TestParse_FunctionCall_Expr_ArgCount;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_FunctionReturn_TypeResolved;
|
||||
procedure TestSemantic_FunctionCall_Resolves;
|
||||
procedure TestSemantic_FunctionCall_ReturnTypeAssign_OK;
|
||||
procedure TestSemantic_FunctionCall_ReturnTypeMismatch_RaisesError;
|
||||
procedure TestSemantic_FunctionCall_WrongArgCount_RaisesError;
|
||||
procedure TestSemantic_Result_AvailableInBody;
|
||||
procedure TestSemantic_Result_WrongType_RaisesError;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Code generation }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_Function_EmitsReturnType;
|
||||
procedure TestCodegen_Function_ReturnTypeW;
|
||||
procedure TestCodegen_Function_HasResultVar;
|
||||
procedure TestCodegen_FunctionCall_EmitsCall;
|
||||
procedure TestCodegen_FunctionCall_ResultLoaded;
|
||||
procedure TestCodegen_Function_ReturnsResult;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TFunctionTests.ParseSrc(const ASrc: string): TProgram;
|
||||
var
|
||||
L: TLexer;
|
||||
P: TParser;
|
||||
begin
|
||||
L := TLexer.Create(ASrc);
|
||||
P := TParser.Create(L);
|
||||
try
|
||||
Result := P.Parse;
|
||||
finally
|
||||
P.Free;
|
||||
L.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFunctionTests.AnalyseSrc(const ASrc: string): TProgram;
|
||||
var
|
||||
A: TSemanticAnalyser;
|
||||
begin
|
||||
Result := ParseSrc(ASrc);
|
||||
A := TSemanticAnalyser.Create;
|
||||
try
|
||||
A.Analyse(Result);
|
||||
finally
|
||||
A.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TFunctionTests.GenIR(const ASrc: string): string;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CG: TCodeGenQBE;
|
||||
begin
|
||||
Prog := AnalyseSrc(ASrc);
|
||||
try
|
||||
CG := TCodeGenQBE.Create;
|
||||
try
|
||||
CG.Generate(Prog);
|
||||
Result := CG.GetOutput;
|
||||
finally
|
||||
CG.Free;
|
||||
end;
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.AnalyseExpectError(const ASrc: string);
|
||||
var
|
||||
Prog: TProgram;
|
||||
begin
|
||||
try
|
||||
Prog := AnalyseSrc(ASrc);
|
||||
Prog.Free;
|
||||
Fail('Expected ESemanticError');
|
||||
except
|
||||
on E: ESemanticError do ;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Shared source snippets }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
const
|
||||
SrcGetterClass =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TBox = class' + LineEnding +
|
||||
' Value: Integer;' + LineEnding +
|
||||
' procedure SetValue(AVal: Integer);' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Self.Value := AVal' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' function GetValue: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := Self.Value' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var B: TBox; N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' B := TBox.Create;' + LineEnding +
|
||||
' B.SetValue(42);' + LineEnding +
|
||||
' N := B.GetValue()' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcAdderClass =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TCalc = class' + LineEnding +
|
||||
' function Add(A: Integer; B: Integer): Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := A + B' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var C: TCalc; N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' C := TCalc.Create;' + LineEnding +
|
||||
' N := C.Add(3, 4)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Lexer }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TFunctionTests.TestLexer_Function_Keyword;
|
||||
var
|
||||
L: TLexer;
|
||||
T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('function');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('function token', Ord(tkFunction), Ord(T.Kind));
|
||||
finally
|
||||
L.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionMethod_InClass;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcGetterClass);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
AssertEquals('two methods (proc + func)', 2, CD.Methods.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionMethod_Name;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcGetterClass);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[1]); { second method = GetValue }
|
||||
AssertEquals('func name', 'GetValue', MD.Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionMethod_ReturnTypeName;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcGetterClass);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[1]);
|
||||
AssertEquals('return type name', 'Integer', MD.ReturnTypeName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionMethod_WithParams;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcAdderClass);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
AssertEquals('two params', 2, MD.Params.Count);
|
||||
AssertEquals('return type', 'Integer', MD.ReturnTypeName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionCall_Expr;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
begin
|
||||
Prog := ParseSrc(SrcGetterClass);
|
||||
try
|
||||
{ third stmt: N := B.GetValue() }
|
||||
Assign := TAssignment(Prog.Block.Stmts[2]);
|
||||
AssertTrue('RHS is TMethodCallExpr', Assign.Expr is TMethodCallExpr);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionCall_Expr_ObjectName;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Expr: TMethodCallExpr;
|
||||
begin
|
||||
Prog := ParseSrc(SrcGetterClass);
|
||||
try
|
||||
Expr := TMethodCallExpr(TAssignment(Prog.Block.Stmts[2]).Expr);
|
||||
AssertEquals('object name', 'B', Expr.ObjectName);
|
||||
AssertEquals('method name', 'GetValue', Expr.Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionCall_Expr_WithArgs;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Assign: TAssignment;
|
||||
Expr: TMethodCallExpr;
|
||||
begin
|
||||
Prog := ParseSrc(SrcAdderClass);
|
||||
try
|
||||
{ second stmt: N := C.Add(3, 4) }
|
||||
Assign := TAssignment(Prog.Block.Stmts[1]);
|
||||
AssertTrue('RHS is TMethodCallExpr', Assign.Expr is TMethodCallExpr);
|
||||
Expr := TMethodCallExpr(Assign.Expr);
|
||||
AssertEquals('object', 'C', Expr.ObjectName);
|
||||
AssertEquals('method', 'Add', Expr.Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestParse_FunctionCall_Expr_ArgCount;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Expr: TMethodCallExpr;
|
||||
begin
|
||||
Prog := ParseSrc(SrcAdderClass);
|
||||
try
|
||||
Expr := TMethodCallExpr(TAssignment(Prog.Block.Stmts[1]).Expr);
|
||||
AssertEquals('two args', 2, Expr.Args.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TFunctionTests.TestSemantic_FunctionReturn_TypeResolved;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcGetterClass);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[1]);
|
||||
AssertNotNull('return type resolved', MD.ResolvedReturnType);
|
||||
AssertEquals('return type is Integer',
|
||||
Ord(tyInteger), Ord(MD.ResolvedReturnType.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_FunctionCall_Resolves;
|
||||
begin
|
||||
AnalyseSrc(SrcGetterClass).Free;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_FunctionCall_ReturnTypeAssign_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcGetterClass).Free;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_FunctionCall_ReturnTypeMismatch_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' function GetVal: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo; S: string;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' S := F.GetVal()' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_FunctionCall_WrongArgCount_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' function GetVal: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := 0' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo; N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' N := F.GetVal(1)' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_Result_AvailableInBody;
|
||||
begin
|
||||
{ If Result is not in scope, analysing it as an identifier would raise
|
||||
an ESemanticError. A clean pass proves Result is defined. }
|
||||
AnalyseSrc(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' function GetOne: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := 1' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo; N: Integer;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' N := F.GetOne()' + LineEnding +
|
||||
'end.'
|
||||
).Free;
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestSemantic_Result_WrongType_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' function GetInt: Integer;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Result := ''not an int''' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'begin end.');
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Code generation }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TFunctionTests.TestCodegen_Function_EmitsReturnType;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGetterClass);
|
||||
AssertTrue('function keyword with return type',
|
||||
Pos('function w $TBox_GetValue', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestCodegen_Function_ReturnTypeW;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcAdderClass);
|
||||
AssertTrue('Add returns w (Integer)',
|
||||
Pos('function w $TCalc_Add', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestCodegen_Function_HasResultVar;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGetterClass);
|
||||
AssertTrue('_var_Result allocated',
|
||||
Pos('%_var_Result', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestCodegen_FunctionCall_EmitsCall;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGetterClass);
|
||||
AssertTrue('call to TBox_GetValue',
|
||||
Pos('call $TBox_GetValue', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestCodegen_FunctionCall_ResultLoaded;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGetterClass);
|
||||
{ The call result is assigned into a temp and then stored into %_var_N }
|
||||
AssertTrue('result stored into N',
|
||||
Pos('%_var_N', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TFunctionTests.TestCodegen_Function_ReturnsResult;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcGetterClass);
|
||||
{ Function must emit 'ret %_tN' (not just 'ret') }
|
||||
AssertTrue('function has ret with value',
|
||||
Pos('ret %_t', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TFunctionTests);
|
||||
|
||||
end.
|
||||
Loading…
Reference in a new issue