diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 6cdd4d0..93ed645 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -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; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 61f786b..c930037 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -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; diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index 7299d58..065263f 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 8c0a068..1d2f04f 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -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 } { ------------------------------------------------------------------ } diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index bcbab8e..c6a64fa 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -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; diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index feb0cbb..a79e090 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -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; diff --git a/compiler/src/test/pascal/cp.test.methods.pas b/compiler/src/test/pascal/cp.test.methods.pas new file mode 100644 index 0000000..2a0ab8c --- /dev/null +++ b/compiler/src/test/pascal/cp.test.methods.pas @@ -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. diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf index 25bf2e0..a196ede 100644 --- a/docs/grammar.ebnf +++ b/docs/grammar.ebnf @@ -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 *)