Add class instance methods (procedure, inline body, Self, method calls)
Lexer:
- Added tkProcedure keyword token.
AST:
- TMethodParam: stores parameter name, type string, and resolved type.
- TMethodDecl: method declaration with name, param list, and inline body
(TBlock). Avoids TObject.MethodName collision by naming the field Name.
- TClassTypeDef.Methods: owned TObjectList of TMethodDecl.
- TMethodCallStmt: statement node for obj.Method(args) calls; ObjectName
and Name fields; ResolvedClassType and ResolvedMethod set by semantic.
- TBlock forward-declared before TMethodDecl to break circular dependency.
Parser:
- ParseMethodDecl: parses 'procedure Name [(ParamList)] ; Block ;' inside
a class body.
- ParseParamList: handles 'Name : Type [; Name : Type ...]' param groups.
- ParseClassDef: field parsing followed by method parsing before 'end'.
- ParseStmt: after 'IDENT.IDENT', dispatches to TFieldAssignment (':=')
or TMethodCallStmt (everything else, optionally with arg list).
- ParseMethodCallArgList: argument list for method call statements.
Semantic:
- FMethodIndex: TStringList mapping 'TypeName.Name' -> TMethodDecl for
O(log n) dispatch lookup.
- AnalyseTypeDecls: indexes methods and resolves param types after fields.
- AnalyseMethodBodies: analyses each method body after type registration.
- AnalyseMethodDecl: pushes a scope with Self (class type) and explicit
params, then calls AnalyseBlock for the method body.
- AnalyseMethodCall: resolves object type, looks up method, checks arg
count and types; sets ResolvedClassType and ResolvedMethod on the node.
Code generator:
- EmitMethodDefs: emits a QBE function for every method in every class
type before the main function.
- EmitMethodDef: emits 'function $TypeName_Name(l %_par_Self, ...) {'.
- EmitParamAllocs: allocates stack slots for Self and explicit params.
- EmitMethodCall: loads Self from the caller's var slot, then emits
'call $TypeName_Name(l selfTemp, ...)'.
Tests: 204 unit tests (24 new method tests), 0 failures.
Grammar: docs/grammar.ebnf updated with MethodDecl, ParamList, MethodCall.
This commit is contained in:
Graeme Geldenhuys
parent
0df5514623
commit
313619511c
|
|
@ -90,6 +90,18 @@ type
|
|||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TMethodCallStmt = class(TASTStmt)
|
||||
public
|
||||
ObjectName: string;
|
||||
Name: string; { method name }
|
||||
Args: TObjectList; { owned TASTExpr items }
|
||||
{ Set by uSemantic: }
|
||||
ResolvedClassType: TTypeDesc; { not owned }
|
||||
ResolvedMethod: TObject; { TMethodDecl — not owned; avoids forward ref }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Declarations }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
@ -126,10 +138,29 @@ type
|
|||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TBlock = class; { forward — defined below after all declarations }
|
||||
|
||||
TMethodParam = class(TASTNode)
|
||||
public
|
||||
ParamName: string;
|
||||
TypeName: string;
|
||||
ResolvedType: TTypeDesc; { set by uSemantic }
|
||||
end;
|
||||
|
||||
TMethodDecl = class(TASTNode)
|
||||
public
|
||||
Name: string; { method name }
|
||||
Params: TObjectList; { owned TMethodParam }
|
||||
Body: TBlock; { owned }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
||||
TClassTypeDef = class(TASTTypeDef)
|
||||
public
|
||||
ParentName: string;
|
||||
Fields: TObjectList; { owned TFieldDecl }
|
||||
Methods: TObjectList; { owned TMethodDecl }
|
||||
constructor Create;
|
||||
destructor Destroy; override;
|
||||
end;
|
||||
|
|
@ -219,6 +250,20 @@ begin
|
|||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TMethodCallStmt }
|
||||
|
||||
constructor TMethodCallStmt.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Args := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TMethodCallStmt.Destroy;
|
||||
begin
|
||||
Args.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TVarDecl }
|
||||
|
||||
constructor TVarDecl.Create;
|
||||
|
|
@ -261,16 +306,33 @@ begin
|
|||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TMethodDecl }
|
||||
|
||||
constructor TMethodDecl.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Params := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TMethodDecl.Destroy;
|
||||
begin
|
||||
Params.Free;
|
||||
Body.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
||||
{ TClassTypeDef }
|
||||
|
||||
constructor TClassTypeDef.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
Fields := TObjectList.Create(True);
|
||||
Fields := TObjectList.Create(True);
|
||||
Methods := TObjectList.Create(True);
|
||||
end;
|
||||
|
||||
destructor TClassTypeDef.Destroy;
|
||||
begin
|
||||
Methods.Free;
|
||||
Fields.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
|
|
|||
|
|
@ -27,12 +27,16 @@ type
|
|||
procedure EmitDataSection;
|
||||
procedure EmitMainHeader;
|
||||
procedure EmitMainFooter;
|
||||
procedure EmitMethodDefs(AProg: TProgram);
|
||||
procedure EmitMethodDef(const ATypeName: string; AMethod: TMethodDecl);
|
||||
procedure EmitBlock(ABlock: TBlock);
|
||||
procedure EmitVarAllocs(ABlock: TBlock);
|
||||
procedure EmitParamAllocs(AMethod: TMethodDecl; AClassType: TRecordTypeDesc);
|
||||
procedure EmitStringCleanup(ABlock: TBlock);
|
||||
procedure EmitStmt(AStmt: TASTStmt);
|
||||
procedure EmitAssignment(AAssign: TAssignment);
|
||||
procedure EmitFieldAssignment(AAssign: TFieldAssignment);
|
||||
procedure EmitMethodCall(ACall: TMethodCallStmt);
|
||||
procedure EmitProcCall(ACall: TProcCall);
|
||||
procedure EmitWrite(ACall: TProcCall; ANewline: Boolean);
|
||||
function EmitExpr(AExpr: TASTExpr): string;
|
||||
|
|
@ -223,6 +227,8 @@ begin
|
|||
EmitFieldAssignment(TFieldAssignment(AStmt))
|
||||
else if AStmt is TAssignment then
|
||||
EmitAssignment(TAssignment(AStmt))
|
||||
else if AStmt is TMethodCallStmt then
|
||||
EmitMethodCall(TMethodCallStmt(AStmt))
|
||||
else if AStmt is TProcCall then
|
||||
EmitProcCall(TProcCall(AStmt))
|
||||
else
|
||||
|
|
@ -306,6 +312,129 @@ begin
|
|||
EmitLine(Format(' %s %s, %s', [StoreInstr, ValTemp, Ptr]));
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitMethodCall(ACall: TMethodCallStmt);
|
||||
var
|
||||
RT: TRecordTypeDesc;
|
||||
MDecl: TMethodDecl;
|
||||
SelfTemp: string;
|
||||
Par: TMethodParam;
|
||||
ArgTemp: string;
|
||||
ArgLine: string;
|
||||
I: Integer;
|
||||
QType: string;
|
||||
FuncName: string;
|
||||
begin
|
||||
RT := TRecordTypeDesc(ACall.ResolvedClassType);
|
||||
MDecl := TMethodDecl(ACall.ResolvedMethod);
|
||||
|
||||
{ Load the object pointer (Self) from the caller's variable slot }
|
||||
SelfTemp := AllocTemp;
|
||||
EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, ACall.ObjectName]));
|
||||
|
||||
FuncName := '$' + RT.Name + '_' + ACall.Name;
|
||||
|
||||
{ Build argument string: l Self, then each explicit arg }
|
||||
ArgLine := Format('l %s', [SelfTemp]);
|
||||
for I := 0 to ACall.Args.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(MDecl.Params[I]);
|
||||
ArgTemp := EmitExpr(TASTExpr(ACall.Args[I]));
|
||||
QType := QbeTypeOf(Par.ResolvedType);
|
||||
ArgLine := ArgLine + Format(', %s %s', [QType, ArgTemp]);
|
||||
end;
|
||||
|
||||
EmitLine(Format(' call %s(%s)', [FuncName, ArgLine]));
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitParamAllocs(AMethod: TMethodDecl;
|
||||
AClassType: TRecordTypeDesc);
|
||||
var
|
||||
I: Integer;
|
||||
Par: TMethodParam;
|
||||
begin
|
||||
{ Self: store incoming pointer into a local slot }
|
||||
EmitLine(' %_var_Self =l alloc8 1');
|
||||
EmitLine(' storel %_par_Self, %_var_Self');
|
||||
|
||||
{ Explicit params }
|
||||
for I := 0 to AMethod.Params.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(AMethod.Params[I]);
|
||||
case Par.ResolvedType.Kind of
|
||||
tyInteger, tyUInt32, tyBoolean, tyByte:
|
||||
begin
|
||||
EmitLine(Format(' %%_var_%s =l alloc4 1', [Par.ParamName]));
|
||||
EmitLine(Format(' storew %%_par_%s, %%_var_%s',
|
||||
[Par.ParamName, Par.ParamName]));
|
||||
end;
|
||||
tyInt64, tyString, tyClass:
|
||||
begin
|
||||
EmitLine(Format(' %%_var_%s =l alloc8 1', [Par.ParamName]));
|
||||
EmitLine(Format(' storel %%_par_%s, %%_var_%s',
|
||||
[Par.ParamName, Par.ParamName]));
|
||||
end;
|
||||
else
|
||||
EmitLine(Format(' %%_var_%s =l alloc8 1', [Par.ParamName]));
|
||||
EmitLine(Format(' storel %%_par_%s, %%_var_%s',
|
||||
[Par.ParamName, Par.ParamName]));
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitMethodDef(const ATypeName: string;
|
||||
AMethod: TMethodDecl);
|
||||
var
|
||||
Sig: string;
|
||||
I: Integer;
|
||||
Par: TMethodParam;
|
||||
FuncName: string;
|
||||
Sym: TSymbol;
|
||||
RT: TRecordTypeDesc;
|
||||
begin
|
||||
FuncName := '$' + ATypeName + '_' + AMethod.Name;
|
||||
|
||||
{ Build parameter signature: l %_par_Self [, qtype %_par_Name ...] }
|
||||
Sig := 'l %_par_Self';
|
||||
for I := 0 to AMethod.Params.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(AMethod.Params[I]);
|
||||
Sig := Sig + Format(', %s %%_par_%s',
|
||||
[QbeTypeOf(Par.ResolvedType), Par.ParamName]);
|
||||
end;
|
||||
|
||||
EmitLine(Format('function %s(%s) {', [FuncName, Sig]));
|
||||
EmitLine('@start');
|
||||
|
||||
{ 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). }
|
||||
EmitParamAllocs(AMethod, nil);
|
||||
EmitBlock(AMethod.Body);
|
||||
|
||||
EmitLine(' ret');
|
||||
EmitLine('}');
|
||||
EmitLine('');
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitMethodDefs(AProg: TProgram);
|
||||
var
|
||||
I, J: Integer;
|
||||
TD: TTypeDecl;
|
||||
CD: TClassTypeDef;
|
||||
begin
|
||||
for I := 0 to AProg.Block.TypeDecls.Count - 1 do
|
||||
begin
|
||||
TD := TTypeDecl(AProg.Block.TypeDecls[I]);
|
||||
if not (TD.Def is TClassTypeDef) then
|
||||
Continue;
|
||||
CD := TClassTypeDef(TD.Def);
|
||||
for J := 0 to CD.Methods.Count - 1 do
|
||||
EmitMethodDef(TD.Name, TMethodDecl(CD.Methods[J]));
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TCodeGenQBE.EmitProcCall(ACall: TProcCall);
|
||||
var
|
||||
UCaseName: string;
|
||||
|
|
@ -488,6 +617,7 @@ begin
|
|||
SavedOutput := FOutput;
|
||||
FOutput := Body;
|
||||
try
|
||||
EmitMethodDefs(AProg);
|
||||
EmitMainHeader;
|
||||
EmitBlock(AProg.Block);
|
||||
EmitMainFooter;
|
||||
|
|
@ -495,7 +625,7 @@ begin
|
|||
FOutput := SavedOutput;
|
||||
end;
|
||||
|
||||
EmitLine('# Generated by Blaise Compiler (Phase 1)');
|
||||
EmitLine('# Generated by Blaise Compiler (Phase 2)');
|
||||
EmitLine('# Source: ' + AProg.Name);
|
||||
EmitLine('');
|
||||
EmitDataSection;
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@ type
|
|||
tkType,
|
||||
tkRecord,
|
||||
tkClass,
|
||||
tkProcedure,
|
||||
tkVar,
|
||||
tkBegin,
|
||||
tkEnd,
|
||||
|
|
@ -88,8 +89,9 @@ begin
|
|||
else if AUpper = 'END' then Result := tkEnd
|
||||
else if AUpper = 'TYPE' then Result := tkType
|
||||
else if AUpper = 'RECORD' then Result := tkRecord
|
||||
else if AUpper = 'CLASS' then Result := tkClass
|
||||
else if AUpper = 'DIV' then Result := tkDiv
|
||||
else if AUpper = 'CLASS' then Result := tkClass
|
||||
else if AUpper = 'PROCEDURE' then Result := tkProcedure
|
||||
else if AUpper = 'DIV' then Result := tkDiv
|
||||
else
|
||||
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
|
||||
end;
|
||||
|
|
|
|||
|
|
@ -3,32 +3,37 @@ unit uParser;
|
|||
{$mode objfpc}{$H+}
|
||||
|
||||
// Recursive-descent parser for the Blaise grammar:
|
||||
// Program ::= 'program' Ident ';' [Uses] Block '.'
|
||||
// Uses ::= 'uses' Ident {',' Ident} ';'
|
||||
// Block ::= [TypeSection] [VarSection] 'begin' StmtList 'end'
|
||||
// TypeSection ::= 'type' TypeDecl {TypeDecl}
|
||||
// TypeDecl ::= Ident '=' (RecordDef | ClassDef) ';'
|
||||
// RecordDef ::= 'record' FieldList 'end'
|
||||
// ClassDef ::= 'class' ['(' Ident ')'] FieldList 'end'
|
||||
// FieldList ::= FieldDecl {FieldDecl}
|
||||
// FieldDecl ::= IdentList ':' TypeName ';'
|
||||
// VarSection ::= 'var' VarDecl {VarDecl}
|
||||
// VarDecl ::= IdentList ':' TypeName ';'
|
||||
// StmtList ::= Stmt {';' Stmt} [';']
|
||||
// Stmt ::= FieldAssignment | Assignment | ProcCall | empty
|
||||
// FieldAssign ::= Ident '.' Ident ':=' Expr
|
||||
// Assignment ::= Ident ':=' Expr
|
||||
// ProcCall ::= Ident ['(' [ExprList] ')']
|
||||
// ExprList ::= Expr {',' Expr}
|
||||
// Expr ::= Term (('+' | '-') Term)*
|
||||
// Term ::= Factor (('*' | '/' | 'div') Factor)*
|
||||
// Factor ::= IntLit | StringLit | Ident '.' Ident | Ident | '(' Expr ')'
|
||||
// TypeName ::= Ident
|
||||
// Program ::= 'program' Ident ';' [Uses] Block '.'
|
||||
// Uses ::= 'uses' Ident {',' Ident} ';'
|
||||
// Block ::= [TypeSection] [VarSection] 'begin' StmtList 'end'
|
||||
// TypeSection ::= 'type' TypeDecl {TypeDecl}
|
||||
// TypeDecl ::= Ident '=' (RecordDef | ClassDef) ';'
|
||||
// RecordDef ::= 'record' FieldList 'end'
|
||||
// ClassDef ::= 'class' ['(' Ident ')'] FieldList MethodList 'end'
|
||||
// FieldList ::= {FieldDecl}
|
||||
// FieldDecl ::= IdentList ':' TypeName ';'
|
||||
// MethodList ::= {MethodDecl}
|
||||
// MethodDecl ::= 'procedure' Ident ['(' ParamList ')'] ';' Block ';'
|
||||
// ParamList ::= ParamGroup {';' ParamGroup}
|
||||
// ParamGroup ::= IdentList ':' TypeName
|
||||
// VarSection ::= 'var' VarDecl {VarDecl}
|
||||
// VarDecl ::= IdentList ':' TypeName ';'
|
||||
// StmtList ::= Stmt {';' Stmt} [';']
|
||||
// Stmt ::= FieldAssignment | MethodCall | Assignment | ProcCall | empty
|
||||
// FieldAssign ::= Ident '.' Ident ':=' Expr
|
||||
// MethodCall ::= Ident '.' Ident ['(' [ExprList] ')']
|
||||
// Assignment ::= Ident ':=' Expr
|
||||
// ProcCall ::= Ident ['(' [ExprList] ')']
|
||||
// ExprList ::= Expr {',' Expr}
|
||||
// Expr ::= Term (('+' | '-') Term)*
|
||||
// Term ::= Factor (('*' | '/' | 'div') Factor)*
|
||||
// Factor ::= IntLit | StringLit | Ident '.' Ident | Ident | '(' Expr ')'
|
||||
// TypeName ::= Ident
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, contnrs, uLexer, uAST;
|
||||
SysUtils, Classes, contnrs, uLexer, uAST;
|
||||
|
||||
type
|
||||
EParseError = class(Exception);
|
||||
|
|
@ -50,6 +55,8 @@ type
|
|||
function ParseRecordDef: TRecordTypeDef;
|
||||
function ParseClassDef: TClassTypeDef;
|
||||
procedure ParseFieldDecl(AFields: TObjectList);
|
||||
function ParseMethodDecl: TMethodDecl;
|
||||
procedure ParseParamList(AParams: TObjectList);
|
||||
procedure ParseVarBlock(ABlock: TBlock);
|
||||
procedure ParseVarDecl(ABlock: TBlock);
|
||||
procedure ParseStmtList(ABlock: TBlock);
|
||||
|
|
@ -58,6 +65,7 @@ type
|
|||
function ParseTerm: TASTExpr;
|
||||
function ParseFactor: TASTExpr;
|
||||
procedure ParseArgList(ACall: TProcCall);
|
||||
procedure ParseMethodCallArgList(ACall: TMethodCallStmt);
|
||||
public
|
||||
constructor Create(ALexer: TLexer);
|
||||
function Parse: TProgram;
|
||||
|
|
@ -252,6 +260,8 @@ begin
|
|||
end;
|
||||
while Check(tkIdent) do
|
||||
ParseFieldDecl(Result.Fields);
|
||||
while Check(tkProcedure) do
|
||||
Result.Methods.Add(ParseMethodDecl);
|
||||
Expect(tkEnd);
|
||||
except
|
||||
Result.Free;
|
||||
|
|
@ -259,6 +269,81 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
function TParser.ParseMethodDecl: TMethodDecl;
|
||||
begin
|
||||
Result := TMethodDecl.Create;
|
||||
try
|
||||
Result.Line := FCurrent.Line;
|
||||
Result.Col := FCurrent.Col;
|
||||
Expect(tkProcedure);
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected method name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Result.Name := FCurrent.Value;
|
||||
Advance;
|
||||
if Check(tkLParen) then
|
||||
begin
|
||||
Advance;
|
||||
if not Check(tkRParen) then
|
||||
ParseParamList(Result.Params);
|
||||
Expect(tkRParen);
|
||||
end;
|
||||
Expect(tkSemicolon);
|
||||
Result.Body := ParseBlock;
|
||||
Expect(tkSemicolon);
|
||||
except
|
||||
Result.Free;
|
||||
raise;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.ParseParamList(AParams: TObjectList);
|
||||
var
|
||||
Par: TMethodParam;
|
||||
I: Integer;
|
||||
Names: TStringList;
|
||||
TypeN: string;
|
||||
begin
|
||||
repeat
|
||||
Names := TStringList.Create;
|
||||
try
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected parameter name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Names.Add(FCurrent.Value);
|
||||
Advance;
|
||||
while Check(tkComma) do
|
||||
begin
|
||||
Advance;
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected parameter name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
Names.Add(FCurrent.Value);
|
||||
Advance;
|
||||
end;
|
||||
Expect(tkColon);
|
||||
if not Check(tkIdent) then
|
||||
raise EParseError.CreateFmt('Expected type name at line %d col %d',
|
||||
[FCurrent.Line, FCurrent.Col]);
|
||||
TypeN := FCurrent.Value;
|
||||
Advance;
|
||||
for I := 0 to Names.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam.Create;
|
||||
Par.ParamName := Names[I];
|
||||
Par.TypeName := TypeN;
|
||||
AParams.Add(Par);
|
||||
end;
|
||||
finally
|
||||
Names.Free;
|
||||
end;
|
||||
if Check(tkSemicolon) then
|
||||
Advance
|
||||
else
|
||||
Break;
|
||||
until False;
|
||||
end;
|
||||
|
||||
procedure TParser.ParseFieldDecl(AFields: TObjectList);
|
||||
var
|
||||
Fld: TFieldDecl;
|
||||
|
|
@ -364,11 +449,13 @@ end;
|
|||
|
||||
function TParser.ParseStmt: TASTStmt;
|
||||
var
|
||||
Name: string;
|
||||
Line, Col: Integer;
|
||||
Call: TProcCall;
|
||||
Assign: TAssignment;
|
||||
FldAssign: TFieldAssignment;
|
||||
Name: string;
|
||||
Line, Col: Integer;
|
||||
Call: TProcCall;
|
||||
Assign: TAssignment;
|
||||
FldAssign: TFieldAssignment;
|
||||
MCall: TMethodCallStmt;
|
||||
SecondIdent: string;
|
||||
begin
|
||||
Result := nil;
|
||||
|
||||
|
|
@ -387,20 +474,42 @@ begin
|
|||
|
||||
if Check(tkDot) then
|
||||
begin
|
||||
{ Field assignment: Ident '.' Ident ':=' Expr }
|
||||
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]);
|
||||
FldAssign := TFieldAssignment.Create;
|
||||
FldAssign.Line := Line;
|
||||
FldAssign.Col := Col;
|
||||
FldAssign.RecordName := Name;
|
||||
FldAssign.FieldName := FCurrent.Value;
|
||||
SecondIdent := FCurrent.Value;
|
||||
Advance;
|
||||
Expect(tkAssign);
|
||||
FldAssign.Expr := ParseExpr;
|
||||
Result := FldAssign;
|
||||
|
||||
if Check(tkAssign) then
|
||||
begin
|
||||
{ Field assignment: Ident '.' Ident ':=' Expr }
|
||||
FldAssign := TFieldAssignment.Create;
|
||||
FldAssign.Line := Line;
|
||||
FldAssign.Col := Col;
|
||||
FldAssign.RecordName := Name;
|
||||
FldAssign.FieldName := SecondIdent;
|
||||
Expect(tkAssign);
|
||||
FldAssign.Expr := ParseExpr;
|
||||
Result := FldAssign;
|
||||
end
|
||||
else
|
||||
begin
|
||||
{ Method call: Ident '.' Ident ['(' [args] ')'] }
|
||||
MCall := TMethodCallStmt.Create;
|
||||
MCall.Line := Line;
|
||||
MCall.Col := Col;
|
||||
MCall.ObjectName := Name;
|
||||
MCall.Name := SecondIdent;
|
||||
if Check(tkLParen) then
|
||||
begin
|
||||
Advance;
|
||||
if not Check(tkRParen) then
|
||||
ParseMethodCallArgList(MCall);
|
||||
Expect(tkRParen);
|
||||
end;
|
||||
Result := MCall;
|
||||
end;
|
||||
end
|
||||
else if Check(tkAssign) then
|
||||
begin
|
||||
|
|
@ -439,6 +548,16 @@ begin
|
|||
end;
|
||||
end;
|
||||
|
||||
procedure TParser.ParseMethodCallArgList(ACall: TMethodCallStmt);
|
||||
begin
|
||||
ACall.Args.Add(ParseExpr);
|
||||
while Check(tkComma) do
|
||||
begin
|
||||
Advance;
|
||||
ACall.Args.Add(ParseExpr);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Expression parsing — standard precedence climbing }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
|
|
|||
|
|
@ -3,37 +3,45 @@ unit uSemantic;
|
|||
{$mode objfpc}{$H+}
|
||||
|
||||
// Semantic analysis pass — walks the AST produced by uParser and:
|
||||
// 1. Resolves record type declarations and registers them in the symbol table.
|
||||
// 2. Resolves every identifier to a TSymbol in the symbol table.
|
||||
// 3. Infers and annotates every expression node with ResolvedType.
|
||||
// 4. Type-checks assignments and field assignments.
|
||||
// 5. Validates procedure/function calls.
|
||||
// 6. Raises ESemanticError with source position on any violation.
|
||||
// 1. Resolves record/class type declarations and registers them in the symbol table.
|
||||
// 2. Indexes class methods for dispatch lookup.
|
||||
// 3. Analyses method bodies with Self and explicit params in scope.
|
||||
// 4. Resolves every identifier to a TSymbol in the symbol table.
|
||||
// 5. Infers and annotates every expression node with ResolvedType.
|
||||
// 6. Type-checks assignments, field assignments, and method calls.
|
||||
// 7. Validates procedure/function calls.
|
||||
// 8. Raises ESemanticError with source position on any violation.
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
SysUtils, contnrs, uAST, uSymbolTable;
|
||||
SysUtils, Classes, contnrs, uAST, uSymbolTable;
|
||||
|
||||
type
|
||||
ESemanticError = class(Exception);
|
||||
|
||||
TSemanticAnalyser = class
|
||||
private
|
||||
FTable: TSymbolTable;
|
||||
FTable: TSymbolTable;
|
||||
FMethodIndex: TStringList; { 'TypeName.MethodName' → TMethodDecl (not owned) }
|
||||
|
||||
procedure AnalyseBlock(ABlock: TBlock);
|
||||
procedure AnalyseTypeDecls(ABlock: TBlock);
|
||||
procedure AnalyseMethodBodies(ABlock: TBlock);
|
||||
procedure AnalyseMethodDecl(AMethod: TMethodDecl; AClassType: TRecordTypeDesc);
|
||||
procedure AnalyseVarDecls(ABlock: TBlock);
|
||||
procedure AnalyseStmts(ABlock: TBlock);
|
||||
procedure AnalyseStmt(AStmt: TASTStmt);
|
||||
procedure AnalyseAssignment(AAssign: TAssignment);
|
||||
procedure AnalyseFieldAssignment(AAssign: TFieldAssignment);
|
||||
procedure AnalyseProcCall(ACall: TProcCall);
|
||||
procedure AnalyseMethodCall(ACall: TMethodCallStmt);
|
||||
function AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
|
||||
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
|
||||
function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
|
||||
|
||||
function FindMethodDecl(const ATypeName, AMethodName: string): TMethodDecl;
|
||||
|
||||
procedure SemanticError(const AMsg: string; ALine, ACol: Integer);
|
||||
procedure CheckTypesMatch(AExpected, AActual: TTypeDesc;
|
||||
const AContext: string; ALine, ACol: Integer);
|
||||
|
|
@ -48,11 +56,14 @@ implementation
|
|||
constructor TSemanticAnalyser.Create;
|
||||
begin
|
||||
inherited Create;
|
||||
FTable := TSymbolTable.Create;
|
||||
FTable := TSymbolTable.Create;
|
||||
FMethodIndex := TStringList.Create;
|
||||
FMethodIndex.CaseSensitive := False;
|
||||
end;
|
||||
|
||||
destructor TSemanticAnalyser.Destroy;
|
||||
begin
|
||||
FMethodIndex.Free;
|
||||
FTable.Free;
|
||||
inherited Destroy;
|
||||
end;
|
||||
|
|
@ -88,6 +99,7 @@ begin
|
|||
after the block scope is popped — needed for var declarations and the
|
||||
transferred symbol table used by codegen. }
|
||||
AnalyseTypeDecls(ABlock);
|
||||
AnalyseMethodBodies(ABlock);
|
||||
FTable.PushScope;
|
||||
try
|
||||
AnalyseVarDecls(ABlock);
|
||||
|
|
@ -99,14 +111,19 @@ end;
|
|||
|
||||
procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock);
|
||||
var
|
||||
I, J, K: Integer;
|
||||
TD: TTypeDecl;
|
||||
FieldList: TObjectList;
|
||||
FDecl: TFieldDecl;
|
||||
RT: TRecordTypeDesc;
|
||||
FldType: TTypeDesc;
|
||||
FldName: string;
|
||||
Sym: TSymbol;
|
||||
I, J, K: Integer;
|
||||
TD: TTypeDecl;
|
||||
FieldList: TObjectList;
|
||||
MethodList: TObjectList;
|
||||
FDecl: TFieldDecl;
|
||||
MDecl: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
ParType: TTypeDesc;
|
||||
RT: TRecordTypeDesc;
|
||||
FldType: TTypeDesc;
|
||||
FldName: string;
|
||||
Sym: TSymbol;
|
||||
Key: string;
|
||||
begin
|
||||
for I := 0 to ABlock.TypeDecls.Count - 1 do
|
||||
begin
|
||||
|
|
@ -114,13 +131,15 @@ begin
|
|||
|
||||
if TD.Def is TRecordTypeDef then
|
||||
begin
|
||||
RT := FTable.NewRecordType(TD.Name);
|
||||
FieldList := TRecordTypeDef(TD.Def).Fields;
|
||||
RT := FTable.NewRecordType(TD.Name);
|
||||
FieldList := TRecordTypeDef(TD.Def).Fields;
|
||||
MethodList := nil;
|
||||
end
|
||||
else if TD.Def is TClassTypeDef then
|
||||
begin
|
||||
RT := FTable.NewClassType(TD.Name);
|
||||
FieldList := TClassTypeDef(TD.Def).Fields;
|
||||
RT := FTable.NewClassType(TD.Name);
|
||||
FieldList := TClassTypeDef(TD.Def).Fields;
|
||||
MethodList := TClassTypeDef(TD.Def).Methods;
|
||||
end
|
||||
else
|
||||
begin
|
||||
|
|
@ -156,9 +175,105 @@ begin
|
|||
Format('Duplicate type name ''%s''', [TD.Name]),
|
||||
TD.Line, TD.Col);
|
||||
end;
|
||||
|
||||
{ Index class methods and resolve param types }
|
||||
if MethodList <> nil then
|
||||
for J := 0 to MethodList.Count - 1 do
|
||||
begin
|
||||
MDecl := TMethodDecl(MethodList[J]);
|
||||
Key := TD.Name + '.' + MDecl.Name;
|
||||
FMethodIndex.AddObject(Key, MDecl);
|
||||
|
||||
for K := 0 to MDecl.Params.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(MDecl.Params[K]);
|
||||
ParType := FTable.FindType(Par.TypeName);
|
||||
if ParType = nil then
|
||||
SemanticError(
|
||||
Format('Unknown type ''%s'' for parameter ''%s''',
|
||||
[Par.TypeName, Par.ParamName]),
|
||||
MDecl.Line, MDecl.Col);
|
||||
Par.ResolvedType := ParType;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseMethodBodies(ABlock: TBlock);
|
||||
var
|
||||
I, J: Integer;
|
||||
TD: TTypeDecl;
|
||||
CD: TClassTypeDef;
|
||||
RT: TRecordTypeDesc;
|
||||
Sym: TSymbol;
|
||||
begin
|
||||
for I := 0 to ABlock.TypeDecls.Count - 1 do
|
||||
begin
|
||||
TD := TTypeDecl(ABlock.TypeDecls[I]);
|
||||
if not (TD.Def is TClassTypeDef) then
|
||||
Continue;
|
||||
CD := TClassTypeDef(TD.Def);
|
||||
Sym := FTable.Lookup(TD.Name);
|
||||
if (Sym = nil) or not (Sym.TypeDesc is TRecordTypeDesc) then
|
||||
Continue;
|
||||
RT := TRecordTypeDesc(Sym.TypeDesc);
|
||||
for J := 0 to CD.Methods.Count - 1 do
|
||||
AnalyseMethodDecl(TMethodDecl(CD.Methods[J]), RT);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseMethodDecl(
|
||||
AMethod: TMethodDecl; AClassType: TRecordTypeDesc);
|
||||
var
|
||||
I: Integer;
|
||||
Par: TMethodParam;
|
||||
Sym: TSymbol;
|
||||
begin
|
||||
FTable.PushScope;
|
||||
try
|
||||
{ Define Self as a variable of the class type }
|
||||
Sym := TSymbol.Create('Self', skVariable, AClassType);
|
||||
FTable.Define(Sym);
|
||||
|
||||
{ Define explicit parameters }
|
||||
for I := 0 to AMethod.Params.Count - 1 do
|
||||
begin
|
||||
Par := TMethodParam(AMethod.Params[I]);
|
||||
if Par.ResolvedType = nil then
|
||||
SemanticError(
|
||||
Format('Parameter ''%s'' has unresolved type', [Par.ParamName]),
|
||||
AMethod.Line, AMethod.Col);
|
||||
Sym := TSymbol.Create(Par.ParamName, skParameter, Par.ResolvedType);
|
||||
if not FTable.Define(Sym) then
|
||||
begin
|
||||
Sym.Free;
|
||||
SemanticError(
|
||||
Format('Duplicate parameter name ''%s''', [Par.ParamName]),
|
||||
AMethod.Line, AMethod.Col);
|
||||
end;
|
||||
end;
|
||||
|
||||
{ Analyse the method body block (pushes its own inner scope) }
|
||||
AnalyseBlock(AMethod.Body);
|
||||
finally
|
||||
FTable.PopScope;
|
||||
end;
|
||||
end;
|
||||
|
||||
function TSemanticAnalyser.FindMethodDecl(
|
||||
const ATypeName, AMethodName: string): TMethodDecl;
|
||||
var
|
||||
Idx: Integer;
|
||||
Key: string;
|
||||
begin
|
||||
Key := ATypeName + '.' + AMethodName;
|
||||
Idx := FMethodIndex.IndexOf(Key);
|
||||
if Idx >= 0 then
|
||||
Result := TMethodDecl(FMethodIndex.Objects[Idx])
|
||||
else
|
||||
Result := nil;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseVarDecls(ABlock: TBlock);
|
||||
var
|
||||
I, J: Integer;
|
||||
|
|
@ -208,10 +323,61 @@ begin
|
|||
AnalyseFieldAssignment(TFieldAssignment(AStmt))
|
||||
else if AStmt is TAssignment then
|
||||
AnalyseAssignment(TAssignment(AStmt))
|
||||
else if AStmt is TMethodCallStmt then
|
||||
AnalyseMethodCall(TMethodCallStmt(AStmt))
|
||||
else if AStmt is TProcCall then
|
||||
AnalyseProcCall(TProcCall(AStmt));
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseMethodCall(ACall: TMethodCallStmt);
|
||||
var
|
||||
ObjSym: TSymbol;
|
||||
RT: TRecordTypeDesc;
|
||||
MDecl: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
ArgType: TTypeDesc;
|
||||
I: Integer;
|
||||
begin
|
||||
ObjSym := FTable.Lookup(ACall.ObjectName);
|
||||
if ObjSym = nil then
|
||||
SemanticError(
|
||||
Format('Undeclared variable ''%s''', [ACall.ObjectName]),
|
||||
ACall.Line, ACall.Col);
|
||||
if ObjSym.Kind <> skVariable then
|
||||
SemanticError(
|
||||
Format('''%s'' is not a variable', [ACall.ObjectName]),
|
||||
ACall.Line, ACall.Col);
|
||||
if ObjSym.TypeDesc.Kind <> tyClass then
|
||||
SemanticError(
|
||||
Format('''%s'' is not a class variable', [ACall.ObjectName]),
|
||||
ACall.Line, ACall.Col);
|
||||
|
||||
RT := TRecordTypeDesc(ObjSym.TypeDesc);
|
||||
MDecl := FindMethodDecl(RT.Name, ACall.Name);
|
||||
if MDecl = nil then
|
||||
SemanticError(
|
||||
Format('Class ''%s'' has no method ''%s''', [RT.Name, ACall.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
|
||||
if ACall.Args.Count <> MDecl.Params.Count then
|
||||
SemanticError(
|
||||
Format('Method ''%s.%s'' expects %d argument(s) but got %d',
|
||||
[RT.Name, ACall.Name, MDecl.Params.Count, ACall.Args.Count]),
|
||||
ACall.Line, ACall.Col);
|
||||
|
||||
for I := 0 to ACall.Args.Count - 1 do
|
||||
begin
|
||||
ArgType := AnalyseExpr(TASTExpr(ACall.Args[I]));
|
||||
Par := TMethodParam(MDecl.Params[I]);
|
||||
CheckTypesMatch(Par.ResolvedType, ArgType,
|
||||
Format('argument %d of ''%s''', [I + 1, ACall.Name]),
|
||||
ACall.Line, ACall.Col);
|
||||
end;
|
||||
|
||||
ACall.ResolvedClassType := RT;
|
||||
ACall.ResolvedMethod := MDecl;
|
||||
end;
|
||||
|
||||
procedure TSemanticAnalyser.AnalyseAssignment(AAssign: TAssignment);
|
||||
var
|
||||
VarSym: TSymbol;
|
||||
|
|
|
|||
|
|
@ -17,7 +17,8 @@ uses
|
|||
cp.test.semantic,
|
||||
cp.test.records,
|
||||
cp.test.classes,
|
||||
cp.test.arc;
|
||||
cp.test.arc,
|
||||
cp.test.methods;
|
||||
|
||||
var
|
||||
Application: TTestRunner;
|
||||
|
|
|
|||
519
compiler/src/test/pascal/cp.test.methods.pas
Normal file
519
compiler/src/test/pascal/cp.test.methods.pas
Normal file
|
|
@ -0,0 +1,519 @@
|
|||
unit cp.test.methods;
|
||||
|
||||
{$mode objfpc}{$H+}
|
||||
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, fpcunit, testregistry,
|
||||
uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE;
|
||||
|
||||
type
|
||||
TMethodTests = 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_Procedure_Keyword;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestParse_Method_InClass;
|
||||
procedure TestParse_Method_Name;
|
||||
procedure TestParse_Method_NoParams;
|
||||
procedure TestParse_Method_WithParams;
|
||||
procedure TestParse_Method_ParamName;
|
||||
procedure TestParse_Method_ParamTypeName;
|
||||
procedure TestParse_Method_Body_HasStmt;
|
||||
procedure TestParse_MethodCall_Stmt;
|
||||
procedure TestParse_MethodCall_WithArgs;
|
||||
procedure TestParse_MethodCall_NoArgs;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestSemantic_MethodCall_Resolves;
|
||||
procedure TestSemantic_MethodCall_UnknownMethod_RaisesError;
|
||||
procedure TestSemantic_MethodCall_ArgTypeMismatch_RaisesError;
|
||||
procedure TestSemantic_MethodCall_WrongArgCount_RaisesError;
|
||||
procedure TestSemantic_Method_SelfIsClassType;
|
||||
procedure TestSemantic_Method_SelfFieldWrite_OK;
|
||||
procedure TestSemantic_Method_ParamResolved;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Code generation }
|
||||
{ ------------------------------------------------------------------ }
|
||||
procedure TestCodegen_Method_EmitsFunction;
|
||||
procedure TestCodegen_Method_FuncHasSelfParam;
|
||||
procedure TestCodegen_Method_FuncHasExplicitParam;
|
||||
procedure TestCodegen_MethodCall_EmitsCall;
|
||||
procedure TestCodegen_MethodCall_PassesSelf;
|
||||
procedure TestCodegen_Method_SelfFieldWrite;
|
||||
end;
|
||||
|
||||
implementation
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Helpers }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
function TMethodTests.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 TMethodTests.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 TMethodTests.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 TMethodTests.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
|
||||
SrcCounter =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TCounter = class' + LineEnding +
|
||||
' Value: Integer;' + LineEnding +
|
||||
' procedure SetValue(AVal: Integer);' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Self.Value := AVal' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var C: TCounter;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' C := TCounter.Create;' + LineEnding +
|
||||
' C.SetValue(42)' + LineEnding +
|
||||
'end.';
|
||||
|
||||
SrcNoParamMethod =
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' X: Integer;' + LineEnding +
|
||||
' procedure Reset;' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Self.X := 0' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' F.Reset' + LineEnding +
|
||||
'end.';
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Lexer }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TMethodTests.TestLexer_Procedure_Keyword;
|
||||
var
|
||||
L: TLexer;
|
||||
T: TToken;
|
||||
begin
|
||||
L := TLexer.Create('procedure');
|
||||
try
|
||||
T := L.Next;
|
||||
AssertEquals('procedure token', Ord(tkProcedure), Ord(T.Kind));
|
||||
finally
|
||||
L.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Parser }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TMethodTests.TestParse_Method_InClass;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
AssertEquals('one method', 1, CD.Methods.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_Name;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
AssertEquals('method name', 'SetValue', MD.Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_NoParams;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcNoParamMethod);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
AssertEquals('zero params', 0, MD.Params.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_WithParams;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
AssertEquals('one param', 1, MD.Params.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_ParamName;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
Par := TMethodParam(MD.Params[0]);
|
||||
AssertEquals('param name', 'AVal', Par.ParamName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_ParamTypeName;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
Par := TMethodParam(MD.Params[0]);
|
||||
AssertEquals('param type', 'Integer', Par.TypeName);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_Method_Body_HasStmt;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
AssertEquals('body has 1 stmt', 1, MD.Body.Stmts.Count);
|
||||
AssertTrue('stmt is TFieldAssignment', MD.Body.Stmts[0] is TFieldAssignment);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_MethodCall_Stmt;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Stmt: TMethodCallStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
{ second stmt after C := TCounter.Create }
|
||||
AssertTrue('second stmt is TMethodCallStmt',
|
||||
Prog.Block.Stmts[1] is TMethodCallStmt);
|
||||
Stmt := TMethodCallStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('object name', 'C', Stmt.ObjectName);
|
||||
AssertEquals('method name', 'SetValue', Stmt.Name);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_MethodCall_WithArgs;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Stmt: TMethodCallStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcCounter);
|
||||
try
|
||||
Stmt := TMethodCallStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('one arg', 1, Stmt.Args.Count);
|
||||
AssertTrue('arg is TIntLiteral', Stmt.Args[0] is TIntLiteral);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestParse_MethodCall_NoArgs;
|
||||
var
|
||||
Prog: TProgram;
|
||||
Stmt: TMethodCallStmt;
|
||||
begin
|
||||
Prog := ParseSrc(SrcNoParamMethod);
|
||||
try
|
||||
Stmt := TMethodCallStmt(Prog.Block.Stmts[1]);
|
||||
AssertEquals('method name', 'Reset', Stmt.Name);
|
||||
AssertEquals('zero args', 0, Stmt.Args.Count);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Semantic }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TMethodTests.TestSemantic_MethodCall_Resolves;
|
||||
begin
|
||||
AnalyseSrc(SrcCounter).Free;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_MethodCall_UnknownMethod_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' X: Integer;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' F.NoSuchMethod' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_MethodCall_ArgTypeMismatch_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' X: Integer;' + LineEnding +
|
||||
' procedure SetX(AVal: Integer);' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Self.X := AVal' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' F.SetX(''not an int'')' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_MethodCall_WrongArgCount_RaisesError;
|
||||
begin
|
||||
AnalyseExpectError(
|
||||
'program P;' + LineEnding +
|
||||
'type' + LineEnding +
|
||||
' TFoo = class' + LineEnding +
|
||||
' X: Integer;' + LineEnding +
|
||||
' procedure SetX(AVal: Integer);' + LineEnding +
|
||||
' begin' + LineEnding +
|
||||
' Self.X := AVal' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
' end;' + LineEnding +
|
||||
'var F: TFoo;' + LineEnding +
|
||||
'begin' + LineEnding +
|
||||
' F := TFoo.Create;' + LineEnding +
|
||||
' F.SetX(1, 2)' + LineEnding +
|
||||
'end.');
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_Method_SelfIsClassType;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
Stmt: TFieldAssignment;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
Stmt := TFieldAssignment(MD.Body.Stmts[0]);
|
||||
AssertTrue('Self.Value is class access', Stmt.IsClassAccess);
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_Method_SelfFieldWrite_OK;
|
||||
begin
|
||||
AnalyseSrc(SrcCounter).Free;
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestSemantic_Method_ParamResolved;
|
||||
var
|
||||
Prog: TProgram;
|
||||
CD: TClassTypeDef;
|
||||
MD: TMethodDecl;
|
||||
Par: TMethodParam;
|
||||
begin
|
||||
Prog := AnalyseSrc(SrcCounter);
|
||||
try
|
||||
CD := TClassTypeDef(TTypeDecl(Prog.Block.TypeDecls[0]).Def);
|
||||
MD := TMethodDecl(CD.Methods[0]);
|
||||
Par := TMethodParam(MD.Params[0]);
|
||||
AssertNotNull('param type resolved', Par.ResolvedType);
|
||||
AssertEquals('param type is Integer',
|
||||
Ord(tyInteger), Ord(Par.ResolvedType.Kind));
|
||||
finally
|
||||
Prog.Free;
|
||||
end;
|
||||
end;
|
||||
|
||||
{ ------------------------------------------------------------------ }
|
||||
{ Code generation }
|
||||
{ ------------------------------------------------------------------ }
|
||||
|
||||
procedure TMethodTests.TestCodegen_Method_EmitsFunction;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
AssertTrue('emits TCounter_SetValue function',
|
||||
Pos('$TCounter_SetValue', IR) > 0);
|
||||
AssertTrue('function keyword present',
|
||||
Pos('function $TCounter_SetValue', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestCodegen_Method_FuncHasSelfParam;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
AssertTrue('Self is first l param',
|
||||
Pos('function $TCounter_SetValue(l', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestCodegen_Method_FuncHasExplicitParam;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
AssertTrue('explicit param in signature',
|
||||
Pos('%_par_AVal', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestCodegen_MethodCall_EmitsCall;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
AssertTrue('call to TCounter_SetValue',
|
||||
Pos('call $TCounter_SetValue', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestCodegen_MethodCall_PassesSelf;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
AssertTrue('Self (C pointer) passed to method',
|
||||
Pos('call $TCounter_SetValue(l', IR) > 0);
|
||||
end;
|
||||
|
||||
procedure TMethodTests.TestCodegen_Method_SelfFieldWrite;
|
||||
var
|
||||
IR: string;
|
||||
begin
|
||||
IR := GenIR(SrcCounter);
|
||||
{ Inside the method, Self.Value := AVal should load Self ptr and store }
|
||||
AssertTrue('method body loads Self pointer',
|
||||
Pos('%_var_Self', IR) > 0);
|
||||
AssertTrue('method body stores to field',
|
||||
Pos('storew', IR) > 0);
|
||||
end;
|
||||
|
||||
initialization
|
||||
RegisterTest(TMethodTests);
|
||||
|
||||
end.
|
||||
|
|
@ -99,11 +99,30 @@ RecordDef
|
|||
;
|
||||
|
||||
ClassDef
|
||||
= CLASS [ LPAREN IDENT RPAREN ] FieldList END
|
||||
= CLASS [ LPAREN IDENT RPAREN ] FieldList MethodList END
|
||||
;
|
||||
|
||||
(* LPAREN IDENT RPAREN — optional parent class name, e.g. class(TObject) *)
|
||||
|
||||
MethodList
|
||||
= { MethodDecl }
|
||||
;
|
||||
|
||||
MethodDecl
|
||||
= PROCEDURE IDENT [ LPAREN ParamList RPAREN ] SEMICOLON Block SEMICOLON
|
||||
;
|
||||
|
||||
(* Body is declared inline in the class definition.
|
||||
* An implicit 'Self' parameter of the class type is available inside the body. *)
|
||||
|
||||
ParamList
|
||||
= ParamGroup { SEMICOLON ParamGroup }
|
||||
;
|
||||
|
||||
ParamGroup
|
||||
= IdentList COLON TypeName
|
||||
;
|
||||
|
||||
FieldList
|
||||
= { FieldDecl }
|
||||
;
|
||||
|
|
@ -140,6 +159,7 @@ StmtList
|
|||
|
||||
Stmt
|
||||
= FieldAssignment
|
||||
| MethodCall
|
||||
| Assignment
|
||||
| ProcCall
|
||||
| (* empty *)
|
||||
|
|
@ -149,6 +169,14 @@ FieldAssignment
|
|||
= IDENT DOT IDENT ASSIGN Expr
|
||||
;
|
||||
|
||||
MethodCall
|
||||
= IDENT DOT IDENT [ LPAREN [ ArgList ] RPAREN ]
|
||||
;
|
||||
|
||||
(* Semantic disambiguation of IDENT DOT IDENT in Stmt:
|
||||
* - Followed by := → FieldAssignment
|
||||
* - Otherwise → MethodCall *)
|
||||
|
||||
(* Resolved by semantic analysis:
|
||||
* - If IDENT names a record variable → record field write
|
||||
* - If IDENT names a class variable → heap pointer deref + field write *)
|
||||
|
|
|
|||
Loading…
Reference in a new issue