From f66260093e746d8cb60332a364d80f9f95080872 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Fri, 24 Apr 2026 00:21:43 +0100 Subject: [PATCH] Achieve self-hosting for hello-world compilation MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The blaise compiler now compiles its own source (tests/blaise-compiler.pas) into a second-stage binary that successfully compiles and runs a hello-world program. All 834 compiler tests still pass. Codegen and RTL fixes that unblocked self-hosting: - String literal interning (uCodeGenQBE): set FStrLits.CaseSensitive := True. FPC's TStringList.IndexOf is case-insensitive by default, so distinct literals like 'WRITELN' and 'WriteLn' collapsed to the same label. - ARC on implicit Self.Field assignments (uCodeGenQBE): EmitAssignment's implicit-Self branch did a raw storel for class/string fields. Fresh _ClassAlloc'ed objects start at refcnt 0, so without the addref they were freed by later local releases. Now addrefs new value and releases old. - #nn character literals (uLexer): UnescapeString handled only 'text'. Extended to decode #nn decimal literals and concatenated forms like 'abc'#13#10'def'. Local OrdAt helper lets the body parse under FPC and the self-hosted compiler. - Chr() builtin: registered in uSymbolTable, handled in uSemantic, emitted in uCodeGenQBE as _Chr, implemented in rtl/blaise_str.c. - LF line separator (Classes.pas): TStringList.GetText used #13#10; QBE rejects CR in its input. Changed to #10. Self-hosting source (tests/blaise-compiler.pas) — needs a virtual Destroy on TASTNode and Exception (post-TObject-stripping they became root classes without a vtable, breaking `is` checks and exception message layout). TAST* descendants chain `override`. Migration tooling: add tools/migrate_full.py — the script that generates tests/blaise-compiler.pas by flattening the eight compiler units and RTL Classes unit into a single self-contained Pascal source. The postprocess() step injects virtual Destroy on TASTNode / TTypeDesc and strips `override` from non-vtable root classes. --- compiler/src/main/pascal/uAST.pas | 33 +- compiler/src/main/pascal/uCodeGenQBE.pas | 1136 +- compiler/src/main/pascal/uLexer.pas | 73 +- compiler/src/main/pascal/uParser.pas | 367 +- compiler/src/main/pascal/uSemantic.pas | 571 +- compiler/src/main/pascal/uSymbolTable.pas | 15 +- compiler/src/test/pascal/cp.test.classes.pas | 15 +- compiler/src/test/pascal/cp.test.codegen.pas | 13 +- .../src/test/pascal/cp.test.functions.pas | 4 +- compiler/src/test/pascal/cp.test.inherit.pas | 5 +- .../src/test/pascal/cp.test.interfaces.pas | 22 +- compiler/src/test/pascal/cp.test.records.pas | 12 +- .../src/test/pascal/cp.test.varparams.pas | 10 +- rtl/src/main/c/blaise_exc.c | 27 + rtl/src/main/c/blaise_io.c | 10 + rtl/src/main/c/blaise_str.c | 31 + rtl/src/main/pascal/Classes.pas | 72 +- tests/blaise-compiler.pas | 11675 +++++++++++++++- tools/migrate_full.py | 1365 ++ 19 files changed, 15103 insertions(+), 353 deletions(-) create mode 100644 tools/migrate_full.py diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 09494bb..ef360b0 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -49,10 +49,15 @@ type Name: string; IsVarParam: Boolean; { set by uSemantic — True if this ident is a var parameter } IsConstant: Boolean; { set by uSemantic — True if this ident is a skConstant symbol } - ConstValue: Int64; { valid when IsConstant = True } + ConstValue: Int64; { valid when IsConstant = True; integer/bool/enum value } + ConstString: string; { valid when IsConstant = True and type is tyString } IsNoArgFuncCall: Boolean; { set by uSemantic — bare ident that resolves to a 0-arg function } + NoArgFuncDecl: TObject; { TMethodDecl — not owned; valid when IsNoArgFuncCall and user-defined } + IsGlobal: Boolean; { set by uSemantic — this ident is a program-level global var } IsImplicitSelf: Boolean; { set by uSemantic — bare field name implicitly referencing Self } ImplicitFieldInfo: TObject; { TFieldInfo — not owned; valid when IsImplicitSelf } + IsImplicitSelfMethod: Boolean; { set by uSemantic — bare zero-arg method call on Self } + ImplicitMethodDecl: TObject; { TMethodDecl — not owned; set when IsImplicitSelfMethod } end; TFieldAccessExpr = class(TASTExpr) @@ -65,6 +70,11 @@ type IsClassAccess: Boolean; { set by uSemantic — pointer deref needed } PropRead: TPropertyInfo; { non-nil if this is a method-backed property read } PropOwnerType: string; { class type name for method-backed property calls } + IsImplicitSelf: Boolean; { set by uSemantic — RecordName is a field of Self } + ImplicitBaseInfo: TFieldInfo; { non-owned — the field of Self holding the record/class } + IsMethodCall: Boolean; { set by uSemantic — FieldName is a zero-arg method } + ResolvedMethod: TObject; { TMethodDecl — not owned; set when IsMethodCall } + IsGlobal: Boolean; { set by uSemantic — RecordName is a program-level global } destructor Destroy; override; end; @@ -111,6 +121,7 @@ type Name: string; Expr: TASTExpr; { owned } IsVarParam: Boolean; { set by uSemantic — True if target is a var parameter } + IsGlobal: Boolean; { set by uSemantic — True if target is a program-level global } ResolvedLhsType: TTypeDesc; { set by uSemantic — type of the target variable } IsWeakLhs: Boolean; { set by uSemantic — True if the LHS symbol was declared [Weak]; codegen emits a @@ -145,6 +156,7 @@ type TForStmt = class(TASTStmt) public VarName: string; + IsGlobal: Boolean; { set by uSemantic — VarName is a program-level global } StartExpr: TASTExpr; { owned } EndExpr: TASTExpr; { owned } IsDownTo: Boolean; @@ -178,6 +190,9 @@ type { 'break' statement — exits the innermost loop. } TBreakStmt = class(TASTStmt); + { 'continue' statement — jumps to next iteration of the innermost loop. } + TContinueStmt = class(TASTStmt); + { One arm of a case statement: one or more ordinal values → body } TCaseBranch = class public @@ -201,8 +216,12 @@ type RecordName: string; FieldName: string; Expr: TASTExpr; { owned } + ObjExpr: TASTExpr; { owned — when non-nil, receiver is this expression (e.g. typecast) } FieldInfo: TFieldInfo; { set by uSemantic — carries offset + type } IsClassAccess: Boolean; { set by uSemantic — pointer deref needed } + IsImplicitSelf: Boolean; { set by uSemantic — RecordName is a field of Self } + ImplicitBaseInfo: TFieldInfo; { non-owned — the field of Self that holds the record/class } + IsGlobal: Boolean; { set by uSemantic — RecordName is a program-level global } destructor Destroy; override; end; @@ -220,6 +239,7 @@ type Name: string; Args: TObjectList; { owned TASTExpr items } ResolvedDecl: TObject; { TMethodDecl — not owned; set by uSemantic for user-defined procs } + IsImplicitSelfMethod: Boolean; { set by uSemantic — call is on Self } constructor Create; destructor Destroy; override; end; @@ -229,6 +249,7 @@ type Name: string; Args: TObjectList; { owned TASTExpr items } ResolvedDecl: TObject; { TMethodDecl — not owned; set by uSemantic } + IsImplicitSelfMethod: Boolean; { set by uSemantic — call is on Self } constructor Create; destructor Destroy; override; end; @@ -245,9 +266,13 @@ type ObjectName: string; Name: string; { method name } Args: TObjectList; { owned TASTExpr items } + ObjExpr: TASTExpr; { owned — when non-nil, receiver is this expression } { Set by uSemantic: } ResolvedClassType: TTypeDesc; { not owned } ResolvedMethod: TObject; { TMethodDecl — not owned; avoids forward ref } + IsImplicitSelf: Boolean; { ObjectName is a field of Self } + ImplicitBaseInfo: TFieldInfo; { not owned — the field of Self } + IsGlobal: Boolean; { set by uSemantic — ObjectName is a program-level global } constructor Create; destructor Destroy; override; end; @@ -283,6 +308,7 @@ type IsWeak: Boolean; { set by uSemantic when [Weak] is resolved on this declaration. Codegen keys off this instead of walking Attributes. } + IsGlobal: Boolean; { set by uSemantic when this is a program-level global variable } constructor Create; destructor Destroy; override; end; @@ -355,9 +381,11 @@ type ObjectName: string; Name: string; { method name } Args: TObjectList; { owned TASTExpr } + ObjExpr: TASTExpr; { owned — receiver expression when ObjectName = '' } ResolvedClassType: TTypeDesc; { not owned; set by uSemantic } ResolvedMethod: TObject; { TMethodDecl — not owned } IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create(args) } + IsGlobal: Boolean; { set by uSemantic — ObjectName is a program-level global } constructor Create; destructor Destroy; override; end; @@ -648,6 +676,7 @@ end; destructor TFieldAssignment.Destroy; begin Expr.Free; + ObjExpr.Free; inherited Destroy; end; @@ -707,6 +736,7 @@ end; destructor TMethodCallStmt.Destroy; begin Args.Free; + ObjExpr.Free; inherited Destroy; end; @@ -803,6 +833,7 @@ end; destructor TMethodCallExpr.Destroy; begin Args.Free; + ObjExpr.Free; inherited Destroy; end; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 31c4b76..941eba6 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -29,7 +29,8 @@ type FTempCount: Integer; FLabelCount: Integer; FCurrentBlock: TBlock; { block currently being emitted; set by EmitBlock } - FBreakLabels: TStringList; { stack of active loop-end labels; top = innermost } + FBreakLabels: TStringList; { stack of active loop-end labels; top = innermost } + FContinueLabels: TStringList; { stack of active loop-continue labels; top = innermost } FExitLabel: string; { label to jmp to for 'exit'; '' = main program } function AllocTemp: string; @@ -52,6 +53,7 @@ type procedure EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean); procedure EmitBlock(ABlock: TBlock); procedure EmitVarAllocs(ABlock: TBlock); + procedure EmitGlobalVarData(ABlock: TBlock); procedure EmitParamAllocs(AMethod: TMethodDecl; AClassType: TRecordTypeDesc); procedure EmitArcCleanup(ABlock: TBlock); procedure EmitExcPathArcCleanup(ABlock: TBlock); @@ -79,6 +81,25 @@ type base nodes without loading record aggregates as scalars. } function EmitInstancePtr(AExpr: TASTExpr): string; function FieldPtr(const ARecordVar: string; AOffset: Integer): string; + { Returns the QBE address token for a variable: '$Name' for globals, + '%_var_Name' for locals. } + function VarRef(const AName: string; AIsGlobal: Boolean): string; + { Emit a record-returning function/method call with an explicit sret address. + The callee receives ASretAddr as its first (hidden) parameter and writes + the result there instead of returning it. Handles TFuncCallExpr, + TMethodCallExpr, and TFieldAccessExpr.IsMethodCall. } + procedure EmitRecordCallSret(AExpr: TASTExpr; const ASretAddr: string); + { Emit a field-by-field ARC-aware copy from ASrcAddr to ADestAddr for a + record described by ARec. String fields use AddRef/Release; class fields + use ClassAddRef/ClassRelease; other fields are copied with a plain store. } + procedure EmitRecordCopy(ARec: TRecordTypeDesc; + const ADestAddr, ASrcAddr: string); + { Returns True if AExpr is a function or method call that returns a record. + Used in EmitAssignment to choose the sret path over a storel. } + function IsRecordCall(AExpr: TASTExpr): Boolean; + { Release every ARC-managed field of a record at AAddr in-line (no copy). + Used before overwriting a record slot to prevent reference leaks. } + procedure EmitRecordReleaseFields(ARec: TRecordTypeDesc; const AAddr: string); function QbeTypeOf(AType: TTypeDesc): string; function QbeEscapeString(const AStr: string): string; { Mangle a type name for use in QBE symbols: '<' → '_', '>' → '', ',' → '_' } @@ -98,13 +119,16 @@ begin inherited Create; FOutput := TStringList.Create; FStrLits := TStringList.Create; - FBreakLabels := TStringList.Create; - FTempCount := 0; + FStrLits.CaseSensitive := True; + FBreakLabels := TStringList.Create; + FContinueLabels := TStringList.Create; + FTempCount := 0; end; destructor TCodeGenQBE.Destroy; begin FBreakLabels.Free; + FContinueLabels.Free; FOutput.Free; FStrLits.Free; inherited Destroy; @@ -209,6 +233,8 @@ begin raise ECodeGenError.CreateFmt( 'Variable ''%s'' has no resolved type — semantic pass required', [Decl.Names[0]]); + if Decl.IsGlobal then + Continue; { global vars are emitted in the data section, not as stack allocs } for J := 0 to Decl.Names.Count - 1 do begin @@ -281,6 +307,52 @@ begin end; end; +procedure TCodeGenQBE.EmitGlobalVarData(ABlock: TBlock); +{ Emit QBE data-section entries for program-level global variables. + These live at $Name (pointer-sized slots, zero-initialised) rather than + as per-function stack allocs. Called once from Generate before the + function bodies are written. } +var + I, J: Integer; + Decl: TVarDecl; + VarName: string; + RT: TRecordTypeDesc; +begin + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls[I]); + if not Decl.IsGlobal then Continue; + if Decl.ResolvedType = nil then Continue; + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names[J]; + case Decl.ResolvedType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: + EmitLine(Format('data $%s = { w 0 }', [VarName])); + tyInt64: + EmitLine(Format('data $%s = { l 0 }', [VarName])); + tyString, tyClass, tyPointer: + EmitLine(Format('data $%s = { l 0 }', [VarName])); + tyInterface: + begin + EmitLine(Format('data $%s_obj = { l 0 }', [VarName])); + EmitLine(Format('data $%s_itab = { l 0 }', [VarName])); + end; + tyRecord: + begin + RT := TRecordTypeDesc(Decl.ResolvedType); + if RT.TotalSize > 0 then + EmitLine(Format('data $%s = { z %d }', [VarName, RT.TotalSize])) + else + EmitLine(Format('data $%s = { l 0 }', [VarName])); + end; + else + EmitLine(Format('data $%s = { l 0 }', [VarName])); + end; + end; + end; +end; + procedure TCodeGenQBE.EmitArcCleanup(ABlock: TBlock); { Release every ARC-managed local variable (string, class, or interface) at block exit. Mirrors the insertion pattern used at assignment sites: each @@ -310,9 +382,9 @@ begin begin VarName := Decl.Names[J]; if IsIntf then - EmitLine(Format(' call $_WeakClear(l %%_var_%s_obj)', [VarName])) + EmitLine(Format(' call $_WeakClear(l %s_obj)', [VarRef(VarName, Decl.IsGlobal)])) else - EmitLine(Format(' call $_WeakClear(l %%_var_%s)', [VarName])); + EmitLine(Format(' call $_WeakClear(l %s)', [VarRef(VarName, Decl.IsGlobal)])); end; Continue; end; @@ -322,6 +394,17 @@ begin RelFn := '$_ClassRelease' else if IsIntf then RelFn := '$_ClassRelease' { obj slot release; itab is static } + else if Decl.ResolvedType.Kind = tyRecord then + begin + { Record local: release each ARC-managed field at scope exit } + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names[J]; + EmitRecordReleaseFields(TRecordTypeDesc(Decl.ResolvedType), + VarRef(VarName, Decl.IsGlobal)); + end; + Continue; + end else Continue; for J := 0 to Decl.Names.Count - 1 do @@ -329,9 +412,9 @@ begin VarName := Decl.Names[J]; ValTemp := AllocTemp; if IsIntf then - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [ValTemp, VarName])) + EmitLine(Format(' %s =l loadl %s_obj', [ValTemp, VarRef(VarName, Decl.IsGlobal)])) else - EmitLine(Format(' %s =l loadl %%_var_%s', [ValTemp, VarName])); + EmitLine(Format(' %s =l loadl %s', [ValTemp, VarRef(VarName, Decl.IsGlobal)])); EmitLine(Format(' call %s(l %s)', [RelFn, ValTemp])); end; end; @@ -377,9 +460,9 @@ begin begin VarName := Decl.Names[J]; if IsIntf then - EmitLine(Format(' call $_WeakClear(l %%_var_%s_obj)', [VarName])) + EmitLine(Format(' call $_WeakClear(l %s_obj)', [VarRef(VarName, Decl.IsGlobal)])) else - EmitLine(Format(' call $_WeakClear(l %%_var_%s)', [VarName])); + EmitLine(Format(' call $_WeakClear(l %s)', [VarRef(VarName, Decl.IsGlobal)])); end; Continue; end; @@ -389,6 +472,17 @@ begin RelFn := '$_ClassRelease' else if IsIntf then RelFn := '$_ClassRelease' + else if Decl.ResolvedType.Kind = tyRecord then + begin + { Record local on exception path: release ARC fields } + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names[J]; + EmitRecordReleaseFields(TRecordTypeDesc(Decl.ResolvedType), + VarRef(VarName, Decl.IsGlobal)); + end; + Continue; + end else Continue; for J := 0 to Decl.Names.Count - 1 do @@ -397,18 +491,15 @@ begin ValTemp := AllocTemp; if IsIntf then begin - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [ValTemp, VarName])); + EmitLine(Format(' %s =l loadl %s_obj', [ValTemp, VarRef(VarName, Decl.IsGlobal)])); EmitLine(Format(' call %s(l %s)', [RelFn, ValTemp])); - { Zero only the obj slot; the itab slot holds a static pointer - and nilling it would break a subsequent method call on this - variable if it survives the unwind. } - EmitLine(Format(' storel 0, %%_var_%s_obj', [VarName])); + EmitLine(Format(' storel 0, %s_obj', [VarRef(VarName, Decl.IsGlobal)])); end else begin - EmitLine(Format(' %s =l loadl %%_var_%s', [ValTemp, VarName])); + EmitLine(Format(' %s =l loadl %s', [ValTemp, VarRef(VarName, Decl.IsGlobal)])); EmitLine(Format(' call %s(l %s)', [RelFn, ValTemp])); - EmitLine(Format(' storel 0, %%_var_%s', [VarName])); + EmitLine(Format(' storel 0, %s', [VarRef(VarName, Decl.IsGlobal)])); end; end; end; @@ -418,6 +509,8 @@ procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt); var DeadLbl: string; begin + if AStmt = nil then + raise ECodeGenError.Create('EmitStmt called with nil statement'); if AStmt is TTryFinallyStmt then EmitTryFinallyStmt(TTryFinallyStmt(AStmt)) else if AStmt is TTryExceptStmt then @@ -465,8 +558,17 @@ begin DeadLbl := AllocLabel('after_break'); EmitLine('@' + DeadLbl); end + else if AStmt is TContinueStmt then + begin + if FContinueLabels.Count = 0 then + raise ECodeGenError.Create('continue outside loop'); + EmitLine(Format(' jmp @%s', + [FContinueLabels[FContinueLabels.Count - 1]])); + DeadLbl := AllocLabel('after_continue'); + EmitLine('@' + DeadLbl); + end else - raise ECodeGenError.Create('Unknown statement node type'); + raise ECodeGenError.CreateFmt('Unknown statement node type at line %d', [AStmt.Line]); end; procedure TCodeGenQBE.EmitIfStmt(AStmt: TIfStmt); @@ -611,6 +713,7 @@ procedure TCodeGenQBE.EmitForStmt(AStmt: TForStmt); var LblCond: string; LblBody: string; + LblNext: string; { continue target — increment step } LblEnd: string; StartT: string; EndT: string; @@ -622,11 +725,12 @@ var begin LblCond := AllocLabel('for_cond'); LblBody := AllocLabel('for_body'); + LblNext := AllocLabel('for_next'); LblEnd := AllocLabel('for_end'); { Evaluate start and store into loop variable } StartT := EmitExpr(AStmt.StartExpr); - EmitLine(Format(' storew %s, %%_var_%s', [StartT, AStmt.VarName])); + EmitLine(Format(' storew %s, %s', [StartT, VarRef(AStmt.VarName, AStmt.IsGlobal)])); { Evaluate end value once into a temp } EndT := EmitExpr(AStmt.EndExpr); @@ -637,7 +741,7 @@ begin { Condition block: test loop variable against end value } EmitLine('@' + LblCond); CurT := AllocTemp; - EmitLine(Format(' %s =w loadw %%_var_%s', [CurT, AStmt.VarName])); + EmitLine(Format(' %s =w loadw %s', [CurT, VarRef(AStmt.VarName, AStmt.IsGlobal)])); CmpT := AllocTemp; if AStmt.IsDownTo then CmpOp := 'csgew' { I >= End } @@ -649,22 +753,26 @@ begin { Body block } EmitLine('@' + LblBody); FBreakLabels.Add(LblEnd); + FContinueLabels.Add(LblNext); try EmitStmt(AStmt.Body); finally FBreakLabels.Delete(FBreakLabels.Count - 1); + FContinueLabels.Delete(FContinueLabels.Count - 1); end; + EmitLine(Format(' jmp @%s', [LblNext])); - { Increment or decrement loop variable } + { Increment or decrement loop variable (continue target) } + EmitLine('@' + LblNext); CurT := AllocTemp; StepT := AllocTemp; - EmitLine(Format(' %s =w loadw %%_var_%s', [CurT, AStmt.VarName])); + EmitLine(Format(' %s =w loadw %s', [CurT, VarRef(AStmt.VarName, AStmt.IsGlobal)])); if AStmt.IsDownTo then StepOp := 'sub' else StepOp := 'add'; EmitLine(Format(' %s =w %s %s, 1', [StepT, StepOp, CurT])); - EmitLine(Format(' storew %s, %%_var_%s', [StepT, AStmt.VarName])); + EmitLine(Format(' storew %s, %s', [StepT, VarRef(AStmt.VarName, AStmt.IsGlobal)])); EmitLine(Format(' jmp @%s', [LblCond])); { Continuation block } @@ -693,10 +801,12 @@ begin { Loop body block } EmitLine('@' + LblBody); FBreakLabels.Add(LblEnd); + FContinueLabels.Add(LblCond); try EmitStmt(AStmt.Body); finally FBreakLabels.Delete(FBreakLabels.Count - 1); + FContinueLabels.Delete(FContinueLabels.Count - 1); end; EmitLine(Format(' jmp @%s', [LblCond])); @@ -727,6 +837,7 @@ var LblEnd: string; ISFld: TFieldInfo; ISAddrT: string; + ExtTemp: string; begin if AAssign.Expr.ResolvedType = nil then raise ECodeGenError.CreateFmt( @@ -736,7 +847,7 @@ begin if AAssign.ImplicitSelfField <> nil then begin ISFld := TFieldInfo(AAssign.ImplicitSelfField); - ValTemp := EmitExpr(AAssign.Expr); + { Compute destination address = Self + field offset } ObjTemp := AllocTemp; EmitLine(Format(' %s =l loadl %%_var_Self', [ObjTemp])); if ISFld.Offset > 0 then @@ -745,11 +856,52 @@ begin EmitLine(Format(' %s =l add %s, %d', [ISAddrT, ObjTemp, ISFld.Offset])); ObjTemp := ISAddrT; end; + { Record field: ARC-correct copy or direct sret } + if ISFld.TypeDesc.Kind = tyRecord then + begin + ClassRT := TRecordTypeDesc(ISFld.TypeDesc); + if IsRecordCall(AAssign.Expr) then + begin + EmitRecordReleaseFields(ClassRT, ObjTemp); + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [ObjTemp, ClassRT.TotalSize])); + EmitRecordCallSret(AAssign.Expr, ObjTemp); + end + else + begin + ValTemp := EmitExpr(AAssign.Expr); + EmitRecordCopy(ClassRT, ObjTemp, ValTemp); + end; + Exit; + end; + ValTemp := EmitExpr(AAssign.Expr); QType := QbeTypeOf(ISFld.TypeDesc); if QType = 'w' then EmitLine(Format(' storew %s, %s', [ValTemp, ObjTemp])) else + begin + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end; + { ARC for class/string field stored via implicit Self.Field } + if ISFld.TypeDesc.IsString then + begin + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [OldTemp, ObjTemp])); + EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp])); + EmitLine(Format(' call $_StringRelease(l %s)', [OldTemp])); + end + else if ISFld.TypeDesc.Kind = tyClass then + begin + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [OldTemp, ObjTemp])); + EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); + EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); + end; EmitLine(Format(' storel %s, %s', [ValTemp, ObjTemp])); + end; Exit; end; @@ -780,17 +932,17 @@ begin EmitLine(Format(' jmp @%s', [LblEnd])); EmitLine('@' + LblOk); if AAssign.IsWeakLhs then - EmitLine(Format(' call $_WeakAssign(l %%_var_%s_obj, l %s)', - [AAssign.Name, ObjTemp])) + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', + [VarRef(AAssign.Name, AAssign.IsGlobal), ObjTemp])) else begin OldTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [OldTemp, AAssign.Name])); + EmitLine(Format(' %s =l loadl %s_obj', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); EmitLine(Format(' call $_ClassAddRef(l %s)', [ObjTemp])); EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); - EmitLine(Format(' storel %s, %%_var_%s_obj', [ObjTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s_obj', [ObjTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); end; - EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s_itab', [ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); EmitLine('@' + LblEnd); Exit; end; @@ -808,17 +960,17 @@ begin ItabName := '$itab_' + ClassRT.Name + '_' + IntfDesc.Name; ValTemp := EmitExpr(AAssign.Expr); if AAssign.IsWeakLhs then - EmitLine(Format(' call $_WeakAssign(l %%_var_%s_obj, l %s)', - [AAssign.Name, ValTemp])) + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', + [VarRef(AAssign.Name, AAssign.IsGlobal), ValTemp])) else begin OldTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [OldTemp, AAssign.Name])); + EmitLine(Format(' %s =l loadl %s_obj', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); - EmitLine(Format(' storel %s, %%_var_%s_obj', [ValTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s_obj', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); end; - EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabName, AAssign.Name])); + EmitLine(Format(' storel %s, %s_itab', [ItabName, VarRef(AAssign.Name, AAssign.IsGlobal)])); Exit; end; @@ -833,23 +985,23 @@ begin begin ObjTemp := AllocTemp; ItabTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', - [ObjTemp, TIdentExpr(AAssign.Expr).Name])); - EmitLine(Format(' %s =l loadl %%_var_%s_itab', - [ItabTemp, TIdentExpr(AAssign.Expr).Name])); + EmitLine(Format(' %s =l loadl %s_obj', + [ObjTemp, VarRef(TIdentExpr(AAssign.Expr).Name, TIdentExpr(AAssign.Expr).IsGlobal)])); + EmitLine(Format(' %s =l loadl %s_itab', + [ItabTemp, VarRef(TIdentExpr(AAssign.Expr).Name, TIdentExpr(AAssign.Expr).IsGlobal)])); if AAssign.IsWeakLhs then begin - EmitLine(Format(' call $_WeakAssign(l %%_var_%s_obj, l %s)', - [AAssign.Name, ObjTemp])); - EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabTemp, AAssign.Name])); + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', + [VarRef(AAssign.Name, AAssign.IsGlobal), ObjTemp])); + EmitLine(Format(' storel %s, %s_itab', [ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); Exit; end; OldTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [OldTemp, AAssign.Name])); + EmitLine(Format(' %s =l loadl %s_obj', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); EmitLine(Format(' call $_ClassAddRef(l %s)', [ObjTemp])); EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); - EmitLine(Format(' storel %s, %%_var_%s_obj', [ObjTemp, AAssign.Name])); - EmitLine(Format(' storel %s, %%_var_%s_itab', [ItabTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s_obj', [ObjTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + EmitLine(Format(' storel %s, %s_itab', [ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); Exit; end; @@ -864,15 +1016,35 @@ begin else StoreInstr := 'storel'; EmitLine(Format(' %s %s, %s', [StoreInstr, ValTemp, PtrTemp])); end + else if (AAssign.ResolvedLhsType <> nil) and + (AAssign.ResolvedLhsType.Kind = tyRecord) then + begin + { Record assignment: use sret (directly into dest) or field-by-field copy } + ClassRT := TRecordTypeDesc(AAssign.ResolvedLhsType); + if IsRecordCall(AAssign.Expr) then + begin + { Release old ARC fields, zero the slot, then call function with dest as sret } + EmitRecordReleaseFields(ClassRT, VarRef(AAssign.Name, AAssign.IsGlobal)); + EmitLine(Format(' call $memset(l %s, w 0, l %d)', + [VarRef(AAssign.Name, AAssign.IsGlobal), ClassRT.TotalSize])); + EmitRecordCallSret(AAssign.Expr, VarRef(AAssign.Name, AAssign.IsGlobal)); + end + else + begin + { RHS is a record variable: get its address then ARC-copy field-by-field } + ValTemp := EmitExpr(AAssign.Expr); + EmitRecordCopy(ClassRT, VarRef(AAssign.Name, AAssign.IsGlobal), ValTemp); + end; + end else if AAssign.Expr.ResolvedType.IsString then begin { ARC: load old, compute new, retain new, release old, store new } OldTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [OldTemp, AAssign.Name])); + EmitLine(Format(' %s =l loadl %s', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); ValTemp := EmitExpr(AAssign.Expr); EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp])); EmitLine(Format(' call $_StringRelease(l %s)', [OldTemp])); - EmitLine(Format(' storel %s, %%_var_%s', [ValTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); end else if AAssign.IsWeakLhs and (AAssign.Expr.ResolvedType.Kind = tyClass) then begin @@ -881,27 +1053,44 @@ begin the target is released) and the new value; it handles unregistering any prior registration for this slot. } ValTemp := EmitExpr(AAssign.Expr); - EmitLine(Format(' call $_WeakAssign(l %%_var_%s, l %s)', - [AAssign.Name, ValTemp])); + EmitLine(Format(' call $_WeakAssign(l %s, l %s)', + [VarRef(AAssign.Name, AAssign.IsGlobal), ValTemp])); end else if AAssign.Expr.ResolvedType.Kind = tyClass then begin { ARC: load old class reference, evaluate new, retain new, release old, store new. Matches the string ARC idiom one-for-one. } OldTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [OldTemp, AAssign.Name])); + EmitLine(Format(' %s =l loadl %s', [OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); ValTemp := EmitExpr(AAssign.Expr); EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); - EmitLine(Format(' storel %s, %%_var_%s', [ValTemp, AAssign.Name])); + EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); end else begin - QType := QbeTypeOf(AAssign.Expr.ResolvedType); - ValTemp := EmitExpr(AAssign.Expr); - if QType = 'w' then StoreInstr := 'storew' - else StoreInstr := 'storel'; - EmitLine(Format(' %s %s, %%_var_%s', [StoreInstr, ValTemp, AAssign.Name])); + { Use LHS type (if known) for the store instruction, so that assigning a + small int to an Int64 variable uses storel rather than storew. } + if (AAssign.ResolvedLhsType <> nil) and + (QbeTypeOf(AAssign.ResolvedLhsType) = 'l') then + begin + ValTemp := EmitExpr(AAssign.Expr); + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end; + EmitLine(Format(' storel %s, %s', [ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + end + else + begin + QType := QbeTypeOf(AAssign.Expr.ResolvedType); + ValTemp := EmitExpr(AAssign.Expr); + if QType = 'w' then StoreInstr := 'storew' + else StoreInstr := 'storel'; + EmitLine(Format(' %s %s, %s', [StoreInstr, ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal)])); + end; end; end; @@ -912,18 +1101,37 @@ var Base: string; Ptr: string; Loaded: string; + SelfT: string; + ImplFld: TFieldInfo; begin if AExpr is TIdentExpr then begin Id := TIdentExpr(AExpr); + { Implicit Self field used as a chain base: load value through Self } + if Id.IsImplicitSelf then + begin + ImplFld := TFieldInfo(Id.ImplicitFieldInfo); + SelfT := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [SelfT])); + if ImplFld.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [Ptr, SelfT, ImplFld.Offset])); + SelfT := Ptr; + end; + Loaded := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [Loaded, SelfT])); + Result := Loaded; + Exit; + end; if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyClass) then begin Loaded := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [Loaded, Id.Name])); + EmitLine(Format(' %s =l loadl %s', [Loaded, VarRef(Id.Name, Id.IsGlobal)])); Result := Loaded; end else - Result := Format('%%_var_%s', [Id.Name]); { inline record } + Result := VarRef(Id.Name, Id.IsGlobal); { inline record } Exit; end; @@ -940,11 +1148,11 @@ begin if Fld.IsClassAccess then begin Loaded := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [Loaded, Fld.RecordName])); + EmitLine(Format(' %s =l loadl %s', [Loaded, VarRef(Fld.RecordName, Fld.IsGlobal)])); Base := Loaded; end else - Base := Format('%%_var_%s', [Fld.RecordName]); + Base := VarRef(Fld.RecordName, Fld.IsGlobal); end; if Fld.FieldInfo = nil then raise ECodeGenError.Create( @@ -970,6 +1178,14 @@ begin Exit; end; + { Other expression shapes (method calls, typecasts, etc.) — evaluate the + expression and use the resulting value as the pointer. } + if (AExpr.ResolvedType <> nil) and + (AExpr.ResolvedType.Kind in [tyClass, tyInterface, tyPointer, tyRecord]) then + begin + Result := EmitExpr(AExpr); + Exit; + end; raise ECodeGenError.Create('EmitInstancePtr: unsupported base expression'); end; @@ -989,9 +1205,245 @@ begin end; end; +function TCodeGenQBE.VarRef(const AName: string; AIsGlobal: Boolean): string; +begin + if AIsGlobal then + Result := '$' + AName + else + Result := '%_var_' + AName; +end; + +function TCodeGenQBE.IsRecordCall(AExpr: TASTExpr): Boolean; +var + MDecl: TMethodDecl; + FldA: TFieldAccessExpr; +begin + Result := False; + if AExpr is TFuncCallExpr then + begin + if TFuncCallExpr(AExpr).ResolvedDecl = nil then Exit; + MDecl := TMethodDecl(TFuncCallExpr(AExpr).ResolvedDecl); + Result := (MDecl.ResolvedReturnType <> nil) and + (MDecl.ResolvedReturnType.Kind = tyRecord); + end + else if AExpr is TMethodCallExpr then + begin + if TMethodCallExpr(AExpr).ResolvedMethod = nil then Exit; + MDecl := TMethodDecl(TMethodCallExpr(AExpr).ResolvedMethod); + Result := (MDecl.ResolvedReturnType <> nil) and + (MDecl.ResolvedReturnType.Kind = tyRecord); + end + else if AExpr is TFieldAccessExpr then + begin + FldA := TFieldAccessExpr(AExpr); + if not FldA.IsMethodCall then Exit; + if FldA.ResolvedMethod = nil then Exit; + MDecl := TMethodDecl(FldA.ResolvedMethod); + Result := (MDecl.ResolvedReturnType <> nil) and + (MDecl.ResolvedReturnType.Kind = tyRecord); + end; +end; + +procedure TCodeGenQBE.EmitRecordCopy(ARec: TRecordTypeDesc; + const ADestAddr, ASrcAddr: string); +var + I: Integer; + F: TFieldInfo; + SrcField: string; + DstField: string; + ValTemp: string; + OldTemp: string; +begin + for I := 0 to ARec.Fields.Count - 1 do + begin + F := TFieldInfo(ARec.Fields[I]); + if F.TypeDesc = nil then Continue; + if F.Offset > 0 then + begin + SrcField := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [SrcField, ASrcAddr, F.Offset])); + DstField := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [DstField, ADestAddr, F.Offset])); + end + else + begin + SrcField := ASrcAddr; + DstField := ADestAddr; + end; + if F.TypeDesc.IsString then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [ValTemp, SrcField])); + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [OldTemp, DstField])); + EmitLine(Format(' call $_StringAddRef(l %s)', [ValTemp])); + EmitLine(Format(' call $_StringRelease(l %s)', [OldTemp])); + EmitLine(Format(' storel %s, %s', [ValTemp, DstField])); + end + else if F.TypeDesc.Kind = tyClass then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [ValTemp, SrcField])); + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [OldTemp, DstField])); + EmitLine(Format(' call $_ClassAddRef(l %s)', [ValTemp])); + EmitLine(Format(' call $_ClassRelease(l %s)', [OldTemp])); + EmitLine(Format(' storel %s, %s', [ValTemp, DstField])); + end + else if QbeTypeOf(F.TypeDesc) = 'w' then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =w loadw %s', [ValTemp, SrcField])); + EmitLine(Format(' storew %s, %s', [ValTemp, DstField])); + end + else + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [ValTemp, SrcField])); + EmitLine(Format(' storel %s, %s', [ValTemp, DstField])); + end; + end; +end; + +procedure TCodeGenQBE.EmitRecordCallSret(AExpr: TASTExpr; + const ASretAddr: string); +var + FCallExpr: TFuncCallExpr; + MCallExpr: TMethodCallExpr; + FldAccess: TFieldAccessExpr; + MDecl: TMethodDecl; + ArgLine: string; + ArgTemp: string; + SelfTemp: string; + Par: TMethodParam; + I: Integer; + FuncName: string; + Ptr: string; +begin + if AExpr is TFuncCallExpr then + begin + FCallExpr := TFuncCallExpr(AExpr); + MDecl := TMethodDecl(FCallExpr.ResolvedDecl); + if FCallExpr.IsImplicitSelfMethod then + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp])); + FuncName := '$' + QBEMangle(MDecl.OwnerTypeName + '_' + FCallExpr.Name); + ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]); + end + else + begin + FuncName := '$' + QBEMangle(FCallExpr.Name); + ArgLine := Format('l %s', [ASretAddr]); + end; + for I := 0 to FCallExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + if Par.IsVarParam then + ArgLine := ArgLine + Format(', l %s', + [VarRef(TIdentExpr(TASTExpr(FCallExpr.Args[I])).Name, + TIdentExpr(TASTExpr(FCallExpr.Args[I])).IsGlobal)]) + else + begin + ArgTemp := EmitExpr(TASTExpr(FCallExpr.Args[I])); + ArgLine := ArgLine + Format(', %s %s', + [QbeTypeOf(Par.ResolvedType), ArgTemp]); + end; + end; + EmitLine(Format(' call %s(%s)', [FuncName, ArgLine])); + end + else if AExpr is TMethodCallExpr then + begin + MCallExpr := TMethodCallExpr(AExpr); + MDecl := TMethodDecl(MCallExpr.ResolvedMethod); + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', + [SelfTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal)])); + FuncName := '$' + QBEMangle(MDecl.OwnerTypeName + '_' + MCallExpr.Name); + ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]); + for I := 0 to MCallExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + if Par.IsVarParam then + ArgLine := ArgLine + Format(', l %s', + [VarRef(TIdentExpr(TASTExpr(MCallExpr.Args[I])).Name, + TIdentExpr(TASTExpr(MCallExpr.Args[I])).IsGlobal)]) + else + begin + ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args[I])); + ArgLine := ArgLine + Format(', %s %s', + [QbeTypeOf(Par.ResolvedType), ArgTemp]); + end; + end; + EmitLine(Format(' call %s(%s)', [FuncName, ArgLine])); + end + else if AExpr is TFieldAccessExpr then + begin + FldAccess := TFieldAccessExpr(AExpr); + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + if FldAccess.IsImplicitSelf then + begin + { FLexer.Next from inside a TParser method: load Self, add offset, load class ptr } + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp])); + if FldAccess.ImplicitBaseInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [Ptr, SelfTemp, FldAccess.ImplicitBaseInfo.Offset])); + SelfTemp := Ptr; + end; + if FldAccess.IsClassAccess then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [Ptr, SelfTemp])); + SelfTemp := Ptr; + end; + end + else + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', + [SelfTemp, VarRef(FldAccess.RecordName, FldAccess.IsGlobal)])); + end; + FuncName := '$' + QBEMangle(MDecl.OwnerTypeName + '_' + FldAccess.FieldName); + ArgLine := Format('l %s, l %s', [ASretAddr, SelfTemp]); + EmitLine(Format(' call %s(%s)', [FuncName, ArgLine])); + end; +end; + +procedure TCodeGenQBE.EmitRecordReleaseFields(ARec: TRecordTypeDesc; + const AAddr: string); +var + I: Integer; + F: TFieldInfo; + FldAddr: string; + ValT: string; +begin + for I := 0 to ARec.Fields.Count - 1 do + begin + F := TFieldInfo(ARec.Fields[I]); + if F.TypeDesc = nil then Continue; + if not (F.TypeDesc.IsString or (F.TypeDesc.Kind = tyClass)) then Continue; + if F.Offset > 0 then + begin + FldAddr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [FldAddr, AAddr, F.Offset])); + end + else + FldAddr := AAddr; + ValT := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [ValT, FldAddr])); + if F.TypeDesc.IsString then + EmitLine(Format(' call $_StringRelease(l %s)', [ValT])) + else + EmitLine(Format(' call $_ClassRelease(l %s)', [ValT])); + end; +end; + procedure TCodeGenQBE.EmitFieldAssignment(AAssign: TFieldAssignment); var - Ptr, PtrTemp, ValTemp, OldTemp, QType, StoreInstr: string; + Ptr, PtrTemp, ValTemp, OldTemp, QType, StoreInstr, ExtTemp: string; IsArc: Boolean; IsStr: Boolean; begin @@ -1002,11 +1454,57 @@ begin ValTemp := EmitExpr(AAssign.Expr); - if AAssign.IsClassAccess then + if AAssign.ObjExpr <> nil then + begin + { Receiver is an arbitrary expression — emit it, then offset to the field } + PtrTemp := EmitExpr(AAssign.ObjExpr); + if AAssign.IsClassAccess then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [Ptr, PtrTemp])); + PtrTemp := Ptr; + end; + if AAssign.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [Ptr, PtrTemp, AAssign.FieldInfo.Offset])); + end + else + Ptr := PtrTemp; + end + else if AAssign.IsImplicitSelf then + begin + { Implicit Self.Base.Field — Base is a field of Self } + PtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [PtrTemp])); + if AAssign.ImplicitBaseInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [Ptr, PtrTemp, AAssign.ImplicitBaseInfo.Offset])); + PtrTemp := Ptr; + end; + if AAssign.IsClassAccess then + begin + { Base field holds a class pointer; load it } + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [Ptr, PtrTemp])); + PtrTemp := Ptr; + end; + if AAssign.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [Ptr, PtrTemp, AAssign.FieldInfo.Offset])); + end + else + Ptr := PtrTemp; + end + else if AAssign.IsClassAccess then begin { Load the heap pointer stored in the class variable } PtrTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [PtrTemp, AAssign.RecordName])); + EmitLine(Format(' %s =l loadl %s', [PtrTemp, VarRef(AAssign.RecordName, AAssign.IsGlobal)])); if AAssign.FieldInfo.Offset > 0 then begin Ptr := AllocTemp; @@ -1048,7 +1546,17 @@ begin begin QType := QbeTypeOf(AAssign.FieldInfo.TypeDesc); if QType = 'w' then StoreInstr := 'storew' - else StoreInstr := 'storel'; + else + begin + StoreInstr := 'storel'; + { Sign-extend if the value is word-typed but the field needs l } + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', [ExtTemp, ValTemp])); + ValTemp := ExtTemp; + end; + end; EmitLine(Format(' %s %s, %s', [StoreInstr, ValTemp, Ptr])); end; end; @@ -1075,9 +1583,9 @@ begin begin IntfDesc := TInterfaceTypeDesc(ACall.ResolvedClassType); SelfTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', [SelfTemp, ACall.ObjectName])); + EmitLine(Format(' %s =l loadl %s_obj', [SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal)])); VTblTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_itab', [VTblTemp, ACall.ObjectName])); + EmitLine(Format(' %s =l loadl %s_itab', [VTblTemp, VarRef(ACall.ObjectName, ACall.IsGlobal)])); SlotOff := IntfDesc.MethodIndex(ACall.Name) * 8; FPtrTemp := AllocTemp; if SlotOff = 0 then @@ -1092,6 +1600,40 @@ begin Exit; end; + { Call on an arbitrary receiver expression: evaluate and use as Self } + if ACall.ObjExpr <> nil then + begin + SelfTemp := EmitExpr(ACall.ObjExpr); + RT := TRecordTypeDesc(ACall.ResolvedClassType); + MDecl := TMethodDecl(ACall.ResolvedMethod); + if (MDecl = nil) and SameText(ACall.Name, 'Free') then + begin + EmitLine(Format(' call $_ClassRelease(l %s)', [SelfTemp])); + Exit; + end; + ArgLine := Format('l %s', [SelfTemp]); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + if Par.IsVarParam then + ArgLine := ArgLine + Format(', l %s', + [VarRef(TIdentExpr(TASTExpr(ACall.Args[I])).Name, + TIdentExpr(TASTExpr(ACall.Args[I])).IsGlobal)]) + else + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args[I])); + QType := QbeTypeOf(Par.ResolvedType); + ArgLine := ArgLine + Format(', %s %s', [QType, ArgTemp]); + end; + end; + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + ACall.Name + else + FuncName := '$' + RT.Name + '_' + ACall.Name; + EmitLine(Format(' call %s(%s)', [FuncName, ArgLine])); + Exit; + end; + { Built-in Free: release the instance (decrement refcount; free at zero) and nil out the slot. Under universal ARC, Free is a sanctioned synonym for immediate release — if other references remain, the block survives @@ -1100,9 +1642,28 @@ begin if (ACall.ResolvedMethod = nil) and SameText(ACall.Name, 'Free') then begin SelfTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, ACall.ObjectName])); + if ACall.IsImplicitSelf then + begin + { Free called on Self.Field: load Self, get field slot address, load value, + release, then zero the slot. } + EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp])); + if ACall.ImplicitBaseInfo.Offset > 0 then + begin + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [FPtrTemp, SelfTemp, ACall.ImplicitBaseInfo.Offset])); + end + else + FPtrTemp := SelfTemp; + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [ArgTemp, FPtrTemp])); + EmitLine(Format(' call $_ClassRelease(l %s)', [ArgTemp])); + EmitLine(Format(' storel 0, %s', [FPtrTemp])); + Exit; + end; + EmitLine(Format(' %s =l loadl %s', [SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal)])); EmitLine(Format(' call $_ClassRelease(l %s)', [SelfTemp])); - EmitLine(Format(' storel 0, %%_var_%s', [ACall.ObjectName])); + EmitLine(Format(' storel 0, %s', [VarRef(ACall.ObjectName, ACall.IsGlobal)])); Exit; end; @@ -1111,16 +1672,39 @@ begin { Load the object pointer (Self) from the caller's variable slot } SelfTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, ACall.ObjectName])); + if ACall.IsImplicitSelf then + begin + { Load Self, add field offset, load the class pointer from there } + EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp])); + if ACall.ImplicitBaseInfo.Offset > 0 then + begin + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [FPtrTemp, SelfTemp, ACall.ImplicitBaseInfo.Offset])); + SelfTemp := FPtrTemp; + end; + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [FPtrTemp, SelfTemp])); + SelfTemp := FPtrTemp; + end + else + EmitLine(Format(' %s =l loadl %s', [SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal)])); { 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]); + Par := TMethodParam(MDecl.Params[I]); + if Par.IsVarParam then + ArgLine := ArgLine + Format(', l %s', + [VarRef(TIdentExpr(TASTExpr(ACall.Args[I])).Name, + TIdentExpr(TASTExpr(ACall.Args[I])).IsGlobal)]) + else + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args[I])); + QType := QbeTypeOf(Par.ResolvedType); + ArgLine := ArgLine + Format(', %s %s', [QType, ArgTemp]); + end; end; if MDecl.VTableSlot >= 0 then @@ -1298,8 +1882,13 @@ begin FuncName := '$' + ATypeName + '_' + AMethod.Name; IsFunc := AMethod.ResolvedReturnType <> nil; - { Build parameter signature: l %_par_Self [, qtype %_par_Name ...] } - Sig := 'l %_par_Self'; + { Build parameter signature. + sret functions: l %_par__sret comes first, then l %_par_Self. + Regular methods: just l %_par_Self first. } + if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then + Sig := 'l %_par__sret, l %_par_Self' + else + Sig := 'l %_par_Self'; for I := 0 to AMethod.Params.Count - 1 do begin Par := TMethodParam(AMethod.Params[I]); @@ -1313,7 +1902,11 @@ begin if IsFunc then begin RetQType := QbeTypeOf(AMethod.ResolvedReturnType); - EmitLine(Format('function %s %s(%s) {', [RetQType, FuncName, Sig])); + if AMethod.ResolvedReturnType.Kind = tyRecord then + { sret: function becomes void } + EmitLine(Format('function %s(%s) {', [FuncName, Sig])) + else + EmitLine(Format('function %s %s(%s) {', [RetQType, FuncName, Sig])); end else EmitLine(Format('function %s(%s) {', [FuncName, Sig])); @@ -1337,10 +1930,13 @@ begin end; end; - { For function methods, allocate a zero-initialised Result slot } + { For function methods, allocate/alias a zero-initialised Result slot } if IsFunc then begin - if RetQType = 'w' then + if AMethod.ResolvedReturnType.Kind = tyRecord then + { sret: Result IS the caller's buffer — no allocation needed } + EmitLine(' %_var_Result =l copy %_par__sret') + else if RetQType = 'w' then begin EmitLine(' %_var_Result =l alloc4 1'); EmitLine(' storew 0, %_var_Result'); @@ -1375,12 +1971,17 @@ begin if IsFunc then begin - RetTemp := AllocTemp; - if RetQType = 'w' then - EmitLine(Format(' %s =w loadw %%_var_Result', [RetTemp])) + if AMethod.ResolvedReturnType.Kind = tyRecord then + EmitLine(' ret') { sret: caller's buffer already holds result } else - EmitLine(Format(' %s =l loadl %%_var_Result', [RetTemp])); - EmitLine(Format(' ret %s', [RetTemp])); + 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; end else EmitLine(' ret'); @@ -1731,7 +2332,15 @@ begin if IsFunc then begin RetQType := QbeTypeOf(ADecl.ResolvedReturnType); - EmitLine(Format('%sfunction %s %s(%s) {', [Prefix, RetQType, FuncName, Sig])); + if ADecl.ResolvedReturnType.Kind = tyRecord then + begin + { sret: prepend hidden result-buffer pointer; function becomes void } + if Sig <> '' then Sig := 'l %_par__sret, ' + Sig + else Sig := 'l %_par__sret'; + EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig])); + end + else + EmitLine(Format('%sfunction %s %s(%s) {', [Prefix, RetQType, FuncName, Sig])); end else EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig])); @@ -1787,7 +2396,10 @@ begin if IsFunc then begin - if RetQType = 'w' then + if ADecl.ResolvedReturnType.Kind = tyRecord then + { sret: Result IS the caller's buffer — no allocation needed } + EmitLine(' %_var_Result =l copy %_par__sret') + else if RetQType = 'w' then begin EmitLine(' %_var_Result =l alloc4 1'); EmitLine(' storew 0, %_var_Result'); @@ -1829,12 +2441,17 @@ begin if IsFunc then begin - RetTemp := AllocTemp; - if RetQType = 'w' then - EmitLine(Format(' %s =w loadw %%_var_Result', [RetTemp])) + if ADecl.ResolvedReturnType.Kind = tyRecord then + EmitLine(' ret') { sret: caller's buffer already holds result } else - EmitLine(Format(' %s =l loadl %%_var_Result', [RetTemp])); - EmitLine(Format(' ret %s', [RetTemp])); + 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; end else EmitLine(' ret'); @@ -1860,6 +2477,8 @@ begin if Decl.OwnerTypeName <> '' then Continue; { Generic templates — concrete instances are emitted via GenericFuncInstances. } if Decl.TypeParams <> nil then Continue; + { Forward declarations — impl appears later in ProcDecls } + if Decl.Body = nil then Continue; EmitStandaloneDef(Decl); end; { Emit each concrete generic function instance } @@ -1882,16 +2501,35 @@ begin { User-defined procedure } if ACall.ResolvedDecl <> nil then begin - MDecl := TMethodDecl(ACall.ResolvedDecl); + MDecl := TMethodDecl(ACall.ResolvedDecl); + if ACall.IsImplicitSelfMethod then + begin + { Implicit Self.Method — load Self pointer and pass as first arg } + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [ArgTemp])); + ArgLine := Format('l %s', [ArgTemp]); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + ArgTemp := EmitExpr(TASTExpr(ACall.Args[I])); + ArgLine := ArgLine + Format(', %s %s', + [QbeTypeOf(Par.ResolvedType), ArgTemp]); + end; + EmitLine(Format(' call $%s_%s(%s)', + [MDecl.OwnerTypeName, ACall.Name, ArgLine])); + Exit; + end; ArgLine := ''; for I := 0 to ACall.Args.Count - 1 do begin Par := TMethodParam(MDecl.Params[I]); if ArgLine <> '' then ArgLine := ArgLine + ', '; if Par.IsVarParam then - { Pass address of the variable — skip the load } - ArgLine := ArgLine + Format('l %%_var_%s', - [TIdentExpr(TASTExpr(ACall.Args[I])).Name]) + { Pass address of the variable — global vars: $Name is the address; + local vars: %_var_Name is the alloc'd slot address } + ArgLine := ArgLine + Format('l %s', + [VarRef(TIdentExpr(TASTExpr(ACall.Args[I])).Name, + TIdentExpr(TASTExpr(ACall.Args[I])).IsGlobal)]) else begin ArgTemp := EmitExpr(TASTExpr(ACall.Args[I])); @@ -1948,6 +2586,11 @@ begin ArgTemp := EmitExpr(TASTExpr(ACall.Args[0])); EmitLine(Format(' call $exit(w %s)', [ArgTemp])); end + else if UCaseName = 'DELETEFILE' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args[0])); + EmitLine(Format(' call $_DeleteFile(l %s)', [ArgTemp])); + end else raise ECodeGenError.CreateFmt( 'Unknown procedure ''%s'' at line %d', [ACall.Name, ACall.Line]); @@ -2044,6 +2687,8 @@ var ImplFld: TFieldInfo; SelfT: string; PtrT: string; + StrLabel: string; + SretBuf: string; begin if AExpr is TFuncCallExpr then begin @@ -2136,6 +2781,15 @@ begin Exit; end; + if SameText(Name, 'Trim') then + begin + L := EmitExpr(TASTExpr(Args[0])); + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringTrim(l %s)', [T, L])); + Result := T; + Exit; + end; + if SameText(Name, 'SameText') then begin L := EmitExpr(TASTExpr(Args[0])); @@ -2197,6 +2851,15 @@ begin Exit; end; + if SameText(Name, 'Chr') then + begin + L := EmitExpr(TASTExpr(Args[0])); + T := AllocTemp; + EmitLine(Format(' %s =l call $_Chr(w %s)', [T, L])); + Result := T; + Exit; + end; + if SameText(Name, 'CompareStr') then begin L := EmitExpr(TASTExpr(Args[0])); @@ -2264,6 +2927,14 @@ begin Exit; end; + if SameText(Name, 'CurrentExceptionMessage') then + begin + T := AllocTemp; + EmitLine(Format(' %s =l call $_CurrentExceptionMessage()', [T])); + Result := T; + Exit; + end; + if SameText(Name, 'Exec') then begin L := EmitExpr(TASTExpr(Args[0])); @@ -2289,14 +2960,55 @@ begin MDecl := TMethodDecl(ResolvedDecl); QType := QbeTypeOf(MDecl.ResolvedReturnType); + { sret: record-returning function — caller allocates a zero-init buffer + and passes its address as the first (hidden) parameter. } + if MDecl.ResolvedReturnType.Kind = tyRecord then + begin + RT := TRecordTypeDesc(MDecl.ResolvedReturnType); + SretBuf := AllocTemp; + if RT.MaxAlign >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretBuf, RT.TotalSize])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretBuf, RT.TotalSize])); + if RT.TotalSize > 0 then + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [SretBuf, RT.TotalSize])); + EmitRecordCallSret(AExpr, SretBuf); + Result := SretBuf; + Exit; + end; + if IsImplicitSelfMethod then + begin + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [ArgTemp])); + ArgLine := Format('l %s', [ArgTemp]); + FuncName := '$' + MDecl.OwnerTypeName + '_' + Name; + for I := 0 to Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + ArgTemp := EmitExpr(TASTExpr(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; FuncName := '$' + QBEMangle(Name); ArgLine := ''; for I := 0 to Args.Count - 1 do begin - Par := TMethodParam(MDecl.Params[I]); - ArgTemp := EmitExpr(TASTExpr(Args[I])); + Par := TMethodParam(MDecl.Params[I]); if ArgLine <> '' then ArgLine := ArgLine + ', '; - ArgLine := ArgLine + Format('%s %s', [QbeTypeOf(Par.ResolvedType), ArgTemp]); + if Par.IsVarParam then + ArgLine := ArgLine + Format('l %s', + [VarRef(TIdentExpr(TASTExpr(Args[I])).Name, + TIdentExpr(TASTExpr(Args[I])).IsGlobal)]) + else + begin + ArgTemp := EmitExpr(TASTExpr(Args[I])); + ArgLine := ArgLine + Format('%s %s', [QbeTypeOf(Par.ResolvedType), ArgTemp]); + end; end; T := AllocTemp; EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FuncName, ArgLine])); @@ -2315,11 +3027,11 @@ begin begin IntfDesc := TInterfaceTypeDesc(MCallExpr.ResolvedClassType); SelfTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_obj', - [SelfTemp, MCallExpr.ObjectName])); + EmitLine(Format(' %s =l loadl %s_obj', + [SelfTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal)])); VTblTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s_itab', - [VTblTemp, MCallExpr.ObjectName])); + EmitLine(Format(' %s =l loadl %s_itab', + [VTblTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal)])); SlotOff := IntfDesc.MethodIndex(MCallExpr.Name) * 8; FPtrTemp := AllocTemp; if SlotOff = 0 then @@ -2364,9 +3076,9 @@ begin ArgLine := ArgLine + Format(', %s %s', [QbeTypeOf(Par.ResolvedType), ArgTemp]); end; if MDecl.OwnerTypeName <> '' then - FuncName := '$' + MDecl.OwnerTypeName + '_Create' + FuncName := '$' + MDecl.OwnerTypeName + '_' + MCallExpr.Name else - FuncName := '$' + RT.Name + '_Create'; + FuncName := '$' + RT.Name + '_' + MCallExpr.Name; EmitLine(Format(' call %s(%s)', [FuncName, ArgLine])); end; Result := SelfTemp; @@ -2379,10 +3091,31 @@ begin else FuncName := '$' + RT.Name + '_' + MCallExpr.Name; QType := QbeTypeOf(MDecl.ResolvedReturnType); + { sret: record-returning method } + if MDecl.ResolvedReturnType.Kind = tyRecord then + begin + RT := TRecordTypeDesc(MDecl.ResolvedReturnType); + SretBuf := AllocTemp; + if RT.MaxAlign >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretBuf, RT.TotalSize])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretBuf, RT.TotalSize])); + if RT.TotalSize > 0 then + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [SretBuf, RT.TotalSize])); + EmitRecordCallSret(AExpr, SretBuf); + Result := SretBuf; + Exit; + end; - { Load the object pointer (Self) } - SelfTemp := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [SelfTemp, MCallExpr.ObjectName])); + { Load the object pointer (Self): either from a named variable or from + evaluating the receiver expression (e.g. a typecast). } + if MCallExpr.ObjExpr <> nil then + SelfTemp := EmitExpr(MCallExpr.ObjExpr) + else + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [SelfTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal)])); + end; { Build argument string } ArgLine := Format('l %s', [SelfTemp]); @@ -2391,8 +3124,9 @@ begin Par := TMethodParam(MDecl.Params[I]); if Par.IsVarParam then { Pass address of the variable directly — do not load through it } - ArgLine := ArgLine + Format(', l %%_var_%s', - [TIdentExpr(TASTExpr(MCallExpr.Args[I])).Name]) + ArgLine := ArgLine + Format(', l %s', + [VarRef(TIdentExpr(TASTExpr(MCallExpr.Args[I])).Name, + TIdentExpr(TASTExpr(MCallExpr.Args[I])).IsGlobal)]) else begin ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args[I])); @@ -2444,6 +3178,35 @@ begin (base_ptr + offset) using the field's QBE type. } if FldAccess.Base <> nil then begin + if FldAccess.IsMethodCall then + begin + { Zero-arg method on chained base } + L := EmitInstancePtr(FldAccess.Base); + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + if MDecl.ResolvedReturnType.Kind = tyRecord then + begin + RT := TRecordTypeDesc(MDecl.ResolvedReturnType); + SretBuf := AllocTemp; + if RT.MaxAlign >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretBuf, RT.TotalSize])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretBuf, RT.TotalSize])); + if RT.TotalSize > 0 then + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [SretBuf, RT.TotalSize])); + EmitLine(Format(' call $%s_%s(l %s, l %s)', + [MDecl.OwnerTypeName, FldAccess.FieldName, SretBuf, L])); + Result := SretBuf; + end + else + begin + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', + [T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L])); + Result := T; + end; + Exit; + end; L := EmitInstancePtr(FldAccess.Base); if FldAccess.FieldInfo = nil then raise ECodeGenError.CreateFmt( @@ -2464,7 +3227,97 @@ begin Result := T; Exit; end; - if FldAccess.IsConstructorCall then + if FldAccess.IsImplicitSelf then + begin + { Implicit Self.Base.Field — Base is a field of Self } + L := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', [L])); + if FldAccess.ImplicitBaseInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [Ptr, L, FldAccess.ImplicitBaseInfo.Offset])); + L := Ptr; + end; + if FldAccess.IsClassAccess then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', [Ptr, L])); + L := Ptr; + end; + if FldAccess.IsMethodCall then + begin + { Zero-arg method on implicit-Self field: emit call(L) } + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + if MDecl.ResolvedReturnType.Kind = tyRecord then + begin + RT := TRecordTypeDesc(MDecl.ResolvedReturnType); + SretBuf := AllocTemp; + if RT.MaxAlign >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretBuf, RT.TotalSize])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretBuf, RT.TotalSize])); + if RT.TotalSize > 0 then + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [SretBuf, RT.TotalSize])); + EmitLine(Format(' call $%s_%s(l %s, l %s)', + [MDecl.OwnerTypeName, FldAccess.FieldName, SretBuf, L])); + Result := SretBuf; + end + else + begin + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', + [T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L])); + Result := T; + end; + Exit; + end; + if FldAccess.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', + [Ptr, L, FldAccess.FieldInfo.Offset])); + end + else + Ptr := L; + QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc); + T := AllocTemp; + if QType = 'w' then LoadInstr := 'loadw' + else LoadInstr := 'loadl'; + EmitLine(Format(' %s =%s %s %s', [T, QType, LoadInstr, Ptr])); + Result := T; + end + else if FldAccess.IsMethodCall then + begin + { Zero-arg method call on a variable: Obj.Method } + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + if MDecl.ResolvedReturnType.Kind = tyRecord then + begin + RT := TRecordTypeDesc(MDecl.ResolvedReturnType); + SretBuf := AllocTemp; + if RT.MaxAlign >= 8 then + EmitLine(Format(' %s =l alloc8 %d', [SretBuf, RT.TotalSize])) + else + EmitLine(Format(' %s =l alloc4 %d', [SretBuf, RT.TotalSize])); + if RT.TotalSize > 0 then + EmitLine(Format(' call $memset(l %s, w 0, l %d)', [SretBuf, RT.TotalSize])); + EmitRecordCallSret(AExpr, SretBuf); + Result := SretBuf; + end + else + begin + L := AllocTemp; + EmitLine(Format(' %s =l loadl %s', + [L, VarRef(FldAccess.RecordName, FldAccess.IsGlobal)])); + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', + [T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L])); + Result := T; + end; + end + else if FldAccess.IsConstructorCall then begin { TypeName.Create — allocate zeroed instance on heap. _ClassAlloc prefixes a 16-byte header (refcount + field-cleanup fn pointer) @@ -2481,13 +3334,23 @@ begin if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable then EmitLine(Format(' storel $vtable_%s, %s', [QBEMangle(FldAccess.ResolvedType.Name), T])); + { Call user-defined Create body if one exists } + if FldAccess.ResolvedMethod <> nil then + begin + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + FldAccess.FieldName + else + FuncName := '$' + QBEMangle(FldAccess.ResolvedType.Name) + '_' + FldAccess.FieldName; + EmitLine(Format(' call %s(l %s)', [FuncName, T])); + end; Result := T; end else if FldAccess.PropRead <> nil then begin { Method-backed property read: load Self pointer and call getter } L := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [L, FldAccess.RecordName])); + EmitLine(Format(' %s =l loadl %s', [L, VarRef(FldAccess.RecordName, FldAccess.IsGlobal)])); T := AllocTemp; QType := QbeTypeOf(FldAccess.PropRead.TypeDesc); EmitLine(Format(' %s =%s call $%s_%s(l %s)', @@ -2499,7 +3362,7 @@ begin begin { Load heap pointer, then load field } L := AllocTemp; - EmitLine(Format(' %s =l loadl %%_var_%s', [L, FldAccess.RecordName])); + EmitLine(Format(' %s =l loadl %s', [L, VarRef(FldAccess.RecordName, FldAccess.IsGlobal)])); if FldAccess.FieldInfo.Offset > 0 then begin Ptr := AllocTemp; @@ -2539,6 +3402,19 @@ begin ImplFld := TFieldInfo(TIdentExpr(AExpr).ImplicitFieldInfo); SelfT := AllocTemp; EmitLine(Format(' %s =l loadl %%_var_Self', [SelfT])); + { Record-typed field: return the field's storage address, not a loaded value } + if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyRecord) then + begin + if ImplFld.Offset > 0 then + begin + PtrT := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', [PtrT, SelfT, ImplFld.Offset])); + Result := PtrT; + end + else + Result := SelfT; + Exit; + end; T := AllocTemp; QType := QbeTypeOf(AExpr.ResolvedType); if ImplFld.Offset > 0 then @@ -2561,7 +3437,22 @@ begin Exit; end; - if TIdentExpr(AExpr).IsNoArgFuncCall then + if TIdentExpr(AExpr).IsImplicitSelfMethod then + begin + { Bare zero-arg method call on Self — emit direct call } + NoArgCall := TFuncCallExpr.Create; + try + NoArgCall.Name := TIdentExpr(AExpr).Name; + NoArgCall.ResolvedType := AExpr.ResolvedType; + NoArgCall.ResolvedDecl := TIdentExpr(AExpr).ImplicitMethodDecl; + NoArgCall.IsImplicitSelfMethod := True; + Result := EmitExpr(NoArgCall); + finally + NoArgCall.Free; + end; + Exit; + end + else if TIdentExpr(AExpr).IsNoArgFuncCall then begin { Bare identifier resolving to a zero-arg function (no parens in source). Synthesise a temporary TFuncCallExpr so existing builtin dispatch @@ -2570,6 +3461,7 @@ begin try NoArgCall.Name := TIdentExpr(AExpr).Name; NoArgCall.ResolvedType := AExpr.ResolvedType; + NoArgCall.ResolvedDecl := TIdentExpr(AExpr).NoArgFuncDecl; Result := EmitExpr(NoArgCall); finally NoArgCall.Free; @@ -2578,7 +3470,14 @@ begin end else if TIdentExpr(AExpr).IsConstant then begin - EmitLine(Format(' %s =w copy %d', [T, TIdentExpr(AExpr).ConstValue])); + if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyString) then + begin + { String constant — emit as a string literal data label (l-typed pointer) } + StrLabel := EmitStrLit(TIdentExpr(AExpr).ConstString); + EmitLine(Format(' %s =l copy %s', [T, StrLabel])); + end + else + EmitLine(Format(' %s =w copy %d', [T, TIdentExpr(AExpr).ConstValue])); end else if TIdentExpr(AExpr).IsVarParam then begin @@ -2591,6 +3490,20 @@ begin else EmitLine(Format(' %s =w loadw %s', [T, Ptr])); end + else if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyRecord) then + begin + { Record variable — return its storage address directly (no load). } + Result := VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal); + Exit; + end + else if TIdentExpr(AExpr).IsGlobal then + begin + { Global program-level variable: address is $Name in data section } + if (AExpr.ResolvedType <> nil) and (QbeTypeOf(AExpr.ResolvedType) = 'w') then + EmitLine(Format(' %s =w loadw $%s', [T, TIdentExpr(AExpr).Name])) + else + EmitLine(Format(' %s =l loadl $%s', [T, TIdentExpr(AExpr).Name])); + end else if (AExpr.ResolvedType <> nil) and (QbeTypeOf(AExpr.ResolvedType) = 'l') then begin EmitLine(Format(' %s =l loadl %%_var_%s', [T, TIdentExpr(AExpr).Name])); @@ -2832,6 +3745,7 @@ begin EmitLine('# Source: ' + AProg.Name); EmitLine(''); EmitDataSection; + EmitGlobalVarData(AProg.Block); EmitInterfaceDefs(AProg); EmitTypeInfoDefs(AProg); EmitVTableDefs(AProg); diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index 1e29716..2ee87b5 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -60,6 +60,7 @@ type tkNot, tkExit, tkBreak, + tkContinue, tkInherited, tkCase, tkOf, @@ -112,6 +113,14 @@ type implementation +{ Local helper matching the Blaise builtin — lets UnescapeString share one + body under FPC and the self-hosted compiler. The migration tool strips + this declaration; self-hosted builds resolve OrdAt to the builtin. } +function OrdAt(const S: string; I: Integer): Integer; +begin + Result := Ord(S[I]); +end; + constructor TLexer.Create(const ASource: string); begin inherited Create; @@ -163,6 +172,7 @@ begin else if AUpper = 'NOT' then Result := tkNot else if AUpper = 'EXIT' then Result := tkExit else if AUpper = 'BREAK' then Result := tkBreak + else if AUpper = 'CONTINUE' then Result := tkContinue else if AUpper = 'CASE' then Result := tkCase else if AUpper = 'OF' then Result := tkOf else if AUpper = 'CONST' then Result := tkConst @@ -172,36 +182,60 @@ begin end; function TLexer.UnescapeString(const ARaw: string): string; -{ ARaw is the full source span including surrounding quotes. - Handles: 'text' with '' → ' escaping. - Phase 1 supports only single-quoted string literals; #nn and ^X forms - are not yet part of the Clean Pascal spec. } +{ ARaw is the full source span. Handles: 'text' with '' → ' escaping, + #nn numeric char literals (decimal), and concatenated runs like + 'abc'#13#10'def'. Uses OrdAt so the body parses under both FPC and + the self-hosted Blaise compiler. } var - I, Len: Integer; + I, Len, N, C: Integer; begin Result := ''; Len := Length(ARaw); - if (Len >= 2) and (ARaw[1] = '''') then + I := 1; + while I <= Len do begin - I := 2; - while I <= Len do + C := OrdAt(ARaw, I); + if C = 39 then { single quote } begin - if ARaw[I] = '''' then + I := I + 1; + while I <= Len do begin - if (I < Len) and (ARaw[I + 1] = '''') then + C := OrdAt(ARaw, I); + if C = 39 then begin - Result := Result + ''''; - Inc(I, 2); + if (I < Len) and (OrdAt(ARaw, I + 1) = 39) then + begin + Result := Result + ''''; + I := I + 2; + end + else + begin + I := I + 1; + Break; + end; end else - Inc(I); { closing quote } - end - else - begin - Result := Result + ARaw[I]; - Inc(I); + begin + Result := Result + Chr(C); + I := I + 1; + end; end; - end; + end + else if C = 35 then { '#' } + begin + I := I + 1; + N := 0; + while I <= Len do + begin + C := OrdAt(ARaw, I); + if (C < 48) or (C > 57) then Break; + N := N * 10 + (C - 48); + I := I + 1; + end; + Result := Result + Chr(N); + end + else + I := I + 1; end; end; @@ -239,6 +273,7 @@ begin else if text = 'OVERRIDE' then Result.Kind := tkOverride else if text = 'EXIT' then Result.Kind := tkExit else if text = 'BREAK' then Result.Kind := tkBreak + else if text = 'CONTINUE' then Result.Kind := tkContinue else if text = 'CASE' then Result.Kind := tkCase else if text = 'OF' then Result.Kind := tkOf else if text = 'CONST' then Result.Kind := tkConst diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 3cb4a55..7b6b357 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -1015,9 +1015,13 @@ var Assign: TAssignment; FldAssign: TFieldAssignment; MCall: TMethodCallStmt; + MCallExpr: TMethodCallExpr; PtrWrite: TPointerWriteStmt; PtrIdNode: TIdentExpr; SecondIdent: string; + FldNode: TFieldAccessExpr; + CastRcv: TASTExpr; + FCallNode: TFuncCallExpr; begin Result := nil; @@ -1072,6 +1076,15 @@ begin Exit; end; + if Check(tkContinue) then + begin + Result := TContinueStmt.Create; + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Advance; + Exit; + end; + if Check(tkInherited) then begin Result := ParseInheritedStmt; @@ -1139,20 +1152,138 @@ begin 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 + { Method call: Ident '.' Ident ['(' [args] ')'] — may chain to + Ident.Ident.Ident... with further '.' before the final method call. } + if Check(tkDot) then begin - Advance; - if not Check(tkRParen) then - ParseMethodCallArgList(MCall); - Expect(tkRParen); + { Chained: AProg.UsedUnits.Add(...) — build a field-access chain as + the receiver expression. } + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + { Build chain: AProg -> AProg.UsedUnits } + PtrIdNode := TIdentExpr.Create; + PtrIdNode.Line := Line; + PtrIdNode.Col := Col; + PtrIdNode.Name := Name; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := PtrIdNode; + FldNode.FieldName:= SecondIdent; + MCall.ObjExpr := FldNode; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected field or method name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkDot) then + begin + { Still more chain — extend field access path } + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := MCall.ObjExpr; + FldNode.FieldName:= SecondIdent; + MCall.ObjExpr := FldNode; + end + else + begin + MCall.Name := SecondIdent; + if Check(tkLParen) then + begin + Advance; + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + end; + Break; + end; + end; + Result := MCall; + end + else + begin + 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; + { Post-method chain: Name.Method(args).Field := value or .Method2(args) } + if Check(tkDot) then + begin + MCallExpr := TMethodCallExpr.Create; + MCallExpr.Line := Line; + MCallExpr.Col := Col; + MCallExpr.ObjectName := MCall.ObjectName; + MCallExpr.Name := MCall.Name; + while MCall.Args.Count > 0 do + MCallExpr.Args.Add(MCall.Args.Extract(MCall.Args.Items[0])); + MCall.Free; + MCall := nil; + CastRcv := MCallExpr; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.CreateFmt( + 'Expected identifier after ''.'' at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + MCall.Name := SecondIdent; + MCall.ObjExpr := CastRcv; + Advance; + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + Result := MCall; + Exit; + end; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := CastRcv; + FldNode.FieldName := SecondIdent; + CastRcv := FldNode; + end; + if Check(tkAssign) and (CastRcv is TFieldAccessExpr) then + begin + Advance; + FldAssign := TFieldAssignment.Create; + FldAssign.Line := Line; + FldAssign.Col := Col; + FldAssign.FieldName := TFieldAccessExpr(CastRcv).FieldName; + FldAssign.ObjExpr := TFieldAccessExpr(CastRcv).Base; + TFieldAccessExpr(CastRcv).Base := nil; + CastRcv.Free; + FldAssign.Expr := ParseExpr; + Result := FldAssign; + Exit; + end; + raise EParseError.CreateFmt( + 'Expected method call or assignment after chain at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + end; + Result := MCall; end; - Result := MCall; end; end else if Check(tkAssign) then @@ -1167,17 +1298,97 @@ begin end else begin + { Typecast-then-method-call statement: TCast(expr).Method(args) + or chained Ident(arg).Field.Method(args). Detect by peeking for + '(' followed by a '.' after the paren closure — parse directly + into a TFuncCallExpr receiver so the inner arg lives on. } + if Check(tkLParen) then + begin + FCallNode := TFuncCallExpr.Create; + FCallNode.Line := Line; + FCallNode.Col := Col; + FCallNode.Name := Name; + Advance; { '(' } + if not Check(tkRParen) then + begin + FCallNode.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + FCallNode.Args.Add(ParseExpr); + end; + end; + Expect(tkRParen); + if Check(tkDot) then + begin + CastRcv := FCallNode; + { Chain parse: each step reads '.Ident', then either '(' (call) or + more '.'. The final method call terminates as TMethodCallStmt. } + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.CreateFmt('Expected field or method name at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + MCall.Name := SecondIdent; + MCall.ObjExpr := CastRcv; + Advance; { consume '(' } + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + Result := MCall; + Exit; + end; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := CastRcv; + FldNode.FieldName := SecondIdent; + CastRcv := FldNode; + end; + { Field assignment through typecast/chain: TCast(expr).Field := value } + if Check(tkAssign) and (CastRcv is TFieldAccessExpr) then + begin + Advance; { consume ':=' } + FldAssign := TFieldAssignment.Create; + FldAssign.Line := Line; + FldAssign.Col := Col; + FldAssign.FieldName := TFieldAccessExpr(CastRcv).FieldName; + FldAssign.ObjExpr := TFieldAccessExpr(CastRcv).Base; + TFieldAccessExpr(CastRcv).Base := nil; { transfer ownership } + CastRcv.Free; + FldAssign.Expr := ParseExpr; + Result := FldAssign; + Exit; + end; + raise EParseError.CreateFmt( + 'Expected method call after typecast at line %d col %d', + [FCurrent.Line, FCurrent.Col]); + end; + { No '.': it was a plain procedure/function call. Move args to a + fresh TProcCall using FPC-style Extract (removes without freeing). } + Call := TProcCall.Create; + Call.Line := Line; + Call.Col := Col; + Call.Name := Name; + while FCallNode.Args.Count > 0 do + Call.Args.Add(FCallNode.Args.Extract(FCallNode.Args.Items[0])); + FCallNode.Free; + Result := Call; + Exit; + end; Call := TProcCall.Create; Call.Line := Line; Call.Col := Col; Call.Name := Name; - if Check(tkLParen) then - begin - Advance; - if not Check(tkRParen) then - ParseArgList(Call); - Expect(tkRParen); - end; Result := Call; end; end; @@ -1424,8 +1635,9 @@ end; function TParser.ParseCaseStmt: TCaseStmt; var - Branch: TCaseBranch; - Stmt: TASTStmt; + Branch: TCaseBranch; + Stmt: TASTStmt; + CmpElse: TCompoundStmt; begin Result := TCaseStmt.Create; try @@ -1457,7 +1669,28 @@ begin if Check(tkElse) then begin Advance; { consume 'else' } - Result.ElseStmt := ParseStmt; + if Check(tkBegin) then + Result.ElseStmt := ParseCompoundStmt + else + begin + { Collect all statements until 'end' — FPC allows multi-stmt else without begin..end } + CmpElse := TCompoundStmt.Create; + CmpElse.Stmts.Add(ParseStmt); + if Check(tkSemicolon) then Advance; + while not (Check(tkEnd) or Check(tkEOF)) do + begin + CmpElse.Stmts.Add(ParseStmt); + if Check(tkSemicolon) then Advance; + end; + if CmpElse.Stmts.Count = 1 then + begin + { Unwrap single-item compound for simplicity } + Result.ElseStmt := TASTStmt(CmpElse.Stmts.Extract(CmpElse.Stmts.Items[0])); + CmpElse.Free; + end + else + Result.ElseStmt := CmpElse; + end; if Check(tkSemicolon) then Advance; end; Expect(tkEnd); @@ -1611,8 +1844,10 @@ begin end else if Check(tkIs) then begin - Advance; IsNode := TIsExpr.Create; + IsNode.Line := FCurrent.Line; + IsNode.Col := FCurrent.Col; + Advance; IsNode.Obj := Result; IsNode.TypeName := FCurrent.Value; Expect(tkIdent); @@ -1815,13 +2050,39 @@ begin while Check(tkDot) and (PeekKind = tkIdent) do begin Advance; { consume '.' } - FldNode := TFieldAccessExpr.Create; - FldNode.Line := FCurrent.Line; - FldNode.Col := FCurrent.Col; - FldNode.Base := Result; - FldNode.FieldName := FCurrent.Value; - Advance; { consume field name } - Result := FldNode; + SecondName := FCurrent.Value; + Advance; { consume field/method name } + if Check(tkLParen) then + begin + { Chained method call on expression } + MCallNode := TMethodCallExpr.Create; + MCallNode.Line := FCurrent.Line; + MCallNode.Col := FCurrent.Col; + MCallNode.ObjectName := ''; + MCallNode.Name := SecondName; + MCallNode.ObjExpr := Result; + Advance; { consume '(' } + 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 + FldNode := TFieldAccessExpr.Create; + FldNode.Line := FCurrent.Line; + FldNode.Col := FCurrent.Col; + FldNode.Base := Result; + FldNode.FieldName := SecondName; + Result := FldNode; + end; end; end; end @@ -1844,6 +2105,52 @@ begin end; Expect(tkRParen); Result := FCallNode; + { Postfix chained field/method access: FuncOrCast(...).Member ... } + while Check(tkDot) and (PeekKind = tkIdent) do + begin + Advance; { consume '.' } + SecondName := FCurrent.Value; + Advance; { consume field/method name } + FldNode := TFieldAccessExpr.Create; + FldNode.Line := FCurrent.Line; + FldNode.Col := FCurrent.Col; + FldNode.Base := Result; + FldNode.FieldName := SecondName; + Result := FldNode; + if Check(tkLParen) then + begin + { Method call with args on the chained expression — represent + by marking the access as a method call and parsing an arg list + into a synthesised TMethodCallExpr with Obj=Base. } + { We convert the TFieldAccessExpr into an arg-bearing method call. } + Advance; { consume '(' } + if not Check(tkRParen) then + begin + FldNode.ResolvedType := nil; { placeholder to note args } + end; + { Lift the FldNode to a method call by storing args via a + temporary TMethodCallExpr and using Base for the receiver. } + MCallNode := TMethodCallExpr.Create; + MCallNode.Line := FldNode.Line; + MCallNode.Col := FldNode.Col; + MCallNode.ObjectName := ''; { empty — receiver is Base expr } + MCallNode.Name := SecondName; + MCallNode.ObjExpr := FldNode.Base; + FldNode.Base := nil; { transfer ownership } + FldNode.Free; + 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; + end; end else begin diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index d477a58..7f6a5e2 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -35,6 +35,7 @@ type FProcIndex: TStringList; { 'ProcName' → TMethodDecl (not owned) } FGenericFuncTemplates: TStringList; { base name → TMethodDecl template (not owned) } FLoopDepth: Integer; { depth of enclosing while/for — Break only legal if > 0 } + FScopeDepth: Integer; { mirrors FTable scope depth; used to detect main-level globals } FCurrentClass: TRecordTypeDesc; { class being analysed (set in AnalyseMethodDecl) } { Generic type instantiation: resolves 'TBox' on demand. } @@ -277,9 +278,15 @@ begin enum ↔ integer: allow assignment between enum and integer types } if (AExpected.Kind = tyEnum) and AActual.IsNumeric then Exit; if (AActual.Kind = tyEnum) and AExpected.IsNumeric then Exit; + { Numeric widening/narrowing: allow between the integer family members } + if AExpected.IsNumeric and AActual.IsNumeric then Exit; { subtype assignment: TDerived → TBase is allowed } if IsSubtypeOf(AActual, AExpected) then Exit; + { TObject accepts any class — universal base class } + if (AExpected.Kind = tyClass) and (AExpected.Name = 'TObject') and + (AActual.Kind = tyClass) then + Exit; { class → interface: allowed when the class implements that interface } if (AExpected.Kind = tyInterface) and (AActual.Kind = tyClass) then begin @@ -288,6 +295,15 @@ begin if RT.ImplementsIntfAt(I) = AExpected then Exit; end; + { Untyped pointer accepts any class/interface/string reference and vice-versa } + if (AExpected.Kind = tyPointer) and + (TPointerTypeDesc(AExpected).BaseType = nil) and + (AActual.Kind in [tyClass, tyInterface, tyString, tyPointer]) then + Exit; + if (AActual.Kind = tyPointer) and + (TPointerTypeDesc(AActual).BaseType = nil) and + (AExpected.Kind in [tyClass, tyInterface, tyString, tyPointer]) then + Exit; SemanticError( Format('Type mismatch in %s: expected ''%s'' but got ''%s''', [AContext, AExpected.Name, AActual.Name]), @@ -1005,16 +1021,18 @@ begin declarations, transferring the body so AnalyseMethodBodies can process it. } LinkClassMethodImpls(ABlock); LinkGenericClassMethodImpls(ABlock); + { Register standalone proc/func signatures before class method bodies so that + methods can call free functions declared in the same block. } + AnalyseStandaloneDecls(ABlock); AnalyseMethodBodies(ABlock); FTable.PushScope; + Inc(FScopeDepth); try AnalyseVarDecls(ABlock); - { Register standalone proc/func signatures before analysing bodies so that - mutually-recursive calls resolve correctly. } - AnalyseStandaloneDecls(ABlock); AnalyseStandaloneBodies(ABlock); AnalyseStmts(ABlock); finally + Dec(FScopeDepth); FTable.PopScope; end; end; @@ -1033,8 +1051,9 @@ begin TD := FTable.TypeString else TD := FTable.TypeInteger; - Sym := TSymbol.Create(CD.Name, skConstant, TD); - Sym.ConstValue := CD.IntVal; + Sym := TSymbol.Create(CD.Name, skConstant, TD); + Sym.ConstValue := CD.IntVal; + Sym.ConstString := CD.StrVal; if not FTable.Define(Sym) then Sym.Free; { duplicate const — silently ignore } end; @@ -1434,6 +1453,7 @@ begin SavedClass := FCurrentClass; FCurrentClass := AClassType; FTable.PushScope; + Inc(FScopeDepth); try { Define Self as a variable of the class type } Sym := TSymbol.Create('Self', skVariable, AClassType); @@ -1468,8 +1488,10 @@ begin end; { Analyse the method body block (pushes its own inner scope) } - AnalyseBlock(AMethod.Body); + if AMethod.Body <> nil then + AnalyseBlock(AMethod.Body); finally + Dec(FScopeDepth); FTable.PopScope; FCurrentClass := SavedClass; end; @@ -1556,6 +1578,15 @@ begin ADecl.ResolvedReturnType := RetType; end; + { If an earlier forward declaration exists, update the index to point to + this implementation and skip re-registering the symbol. } + J := FProcIndex.IndexOf(ADecl.Name); + if (J >= 0) and (TMethodDecl(FProcIndex.Objects[J]).Body = nil) then + begin + FProcIndex.Objects[J] := ADecl; + Continue; + end; + { Index for call resolution } FProcIndex.AddObject(ADecl.Name, ADecl); @@ -1582,6 +1613,7 @@ var Sym: TSymbol; begin FTable.PushScope; + Inc(FScopeDepth); try { Define Result for functions } if ADecl.ResolvedReturnType <> nil then @@ -1609,6 +1641,7 @@ begin AnalyseBlock(ADecl.Body); finally + Dec(FScopeDepth); FTable.PopScope; end; end; @@ -1625,6 +1658,8 @@ begin if ADecl.OwnerTypeName <> '' then Continue; { Generic templates are instantiated on demand — skip until first call } if ADecl.TypeParams <> nil then Continue; + { Forward declarations have no body; the later impl handles analysis } + if ADecl.Body = nil then Continue; AnalyseStandaloneDecl(ADecl); end; end; @@ -1663,11 +1698,14 @@ begin Decl.IsWeak := True; end; + { Depth 2 = inside the top-level program block — these are global variables. } + Decl.IsGlobal := (FScopeDepth = 1); { depth 1 = main program block (global scope) } for J := 0 to Decl.Names.Count - 1 do begin VarName := Decl.Names[J]; Sym := TSymbol.Create(VarName, skVariable, Typ); - Sym.IsWeak := Decl.IsWeak; + Sym.IsWeak := Decl.IsWeak; + Sym.IsGlobal := Decl.IsGlobal; if not FTable.Define(Sym) then begin Sym.Free; @@ -1714,6 +1752,7 @@ begin SemanticError( Format('Undeclared loop variable ''%s''', [ForS.VarName]), ForS.Line, ForS.Col); + ForS.IsGlobal := (VarSym <> nil) and VarSym.IsGlobal; if VarSym.Kind <> skVariable then SemanticError( Format('''%s'' is not a variable', [ForS.VarName]), @@ -1763,6 +1802,11 @@ begin if FLoopDepth = 0 then SemanticError('''break'' is not inside a loop', AStmt.Line, AStmt.Col); end + else if AStmt is TContinueStmt then + begin + if FLoopDepth = 0 then + SemanticError('''continue'' is not inside a loop', AStmt.Line, AStmt.Col); + end else if AStmt is TIfStmt then begin IfS := TIfStmt(AStmt); @@ -1836,13 +1880,93 @@ var Par: TMethodParam; ArgType: TTypeDesc; I: Integer; + ObjType: TTypeDesc; begin + { Call on a receiver expression: AProg.UsedUnits.Add(UName) } + if ACall.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(ACall.ObjExpr); + if not (ObjType.Kind in [tyClass, tyInterface]) then + SemanticError( + Format('Receiver of ''.%s'' must be a class or interface', [ACall.Name]), + ACall.Line, ACall.Col); + RT := TRecordTypeDesc(ObjType); + MDecl := FindMethodDecl(RT.Name, ACall.Name); + if (MDecl = nil) and SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; + Exit; + end; + 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; + Exit; + end; + ObjSym := FTable.Lookup(ACall.ObjectName); if ObjSym = nil then + begin + { Implicit Self.Field.Method — ObjectName is a field of current class } + if FCurrentClass <> nil then + begin + ACall.ImplicitBaseInfo := + FCurrentClass.FindField(ACall.ObjectName); + if (ACall.ImplicitBaseInfo <> nil) and + (ACall.ImplicitBaseInfo.TypeDesc.Kind in [tyClass, tyInterface]) then + begin + ACall.IsImplicitSelf := True; + RT := TRecordTypeDesc(ACall.ImplicitBaseInfo.TypeDesc); + MDecl := FindMethodDecl(RT.Name, ACall.Name); + if (MDecl = nil) and SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; + Exit; + end; + 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; + Exit; + end; + end; SemanticError( Format('Undeclared variable ''%s''', [ACall.ObjectName]), ACall.Line, ACall.Col); - if ObjSym.Kind <> skVariable then + end; + if not (ObjSym.Kind in [skVariable, skParameter, skVarParameter]) then SemanticError( Format('''%s'' is not a variable', [ACall.ObjectName]), ACall.Line, ACall.Col); @@ -1862,6 +1986,7 @@ begin { Args for interface methods not checked in Phase 3 (no param info stored) } ACall.ResolvedClassType := ObjSym.TypeDesc; ACall.ResolvedMethod := nil; { nil = interface dispatch, not class dispatch } + ACall.IsGlobal := ObjSym.IsGlobal; Exit; end; @@ -1874,6 +1999,7 @@ begin begin ACall.ResolvedClassType := RT; ACall.ResolvedMethod := nil; { nil signals built-in Free to codegen } + ACall.IsGlobal := ObjSym.IsGlobal; Exit; end; SemanticError( @@ -1898,6 +2024,7 @@ begin ACall.ResolvedClassType := RT; ACall.ResolvedMethod := MDecl; + ACall.IsGlobal := ObjSym.IsGlobal; end; procedure TSemanticAnalyser.AnalyseAssignment(AAssign: TAssignment); @@ -1934,6 +2061,7 @@ begin AAssign.IsVarParam := (VarSym.Kind = skVarParameter); AAssign.ResolvedLhsType := VarSym.TypeDesc; AAssign.IsWeakLhs := VarSym.IsWeak; + AAssign.IsGlobal := VarSym.IsGlobal; ExprType := AnalyseExpr(AAssign.Expr); CheckTypesMatch(VarSym.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col); @@ -1989,15 +2117,85 @@ var RecSym: TSymbol; RT: TRecordTypeDesc; FldInfo: TFieldInfo; + BaseInfo: TFieldInfo; + BaseType: TTypeDesc; PropInfo: TPropertyInfo; ExprType: TTypeDesc; + ObjType: TTypeDesc; begin + { ObjExpr path: receiver is an arbitrary expression (e.g. typecast result) } + if AAssign.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(AAssign.ObjExpr); + if not (ObjType.Kind in [tyRecord, tyClass]) then + SemanticError( + Format('Field assignment: expression is not a record or class (got %s)', + [ObjType.Name]), + AAssign.Line, AAssign.Col); + RT := TRecordTypeDesc(ObjType); + FldInfo := RT.FindField(AAssign.FieldName); + if FldInfo = nil then + begin + PropInfo := RT.FindProperty(AAssign.FieldName); + if (PropInfo <> nil) and (PropInfo.WriteField <> '') then + begin + AAssign.FieldName := PropInfo.WriteField; + FldInfo := RT.FindField(PropInfo.WriteField); + end + else + SemanticError( + Format('Type ''%s'' has no field ''%s''', [ObjType.Name, AAssign.FieldName]), + AAssign.Line, AAssign.Col); + end; + AAssign.IsClassAccess := ObjType.Kind = tyClass; + AAssign.FieldInfo := FldInfo; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment', + AAssign.Line, AAssign.Col); + Exit; + end; RecSym := FTable.Lookup(AAssign.RecordName); if RecSym = nil then + begin + { Implicit Self.Field.Subfield — RecordName is a field of current class } + if FCurrentClass <> nil then + begin + BaseInfo := FCurrentClass.FindField(AAssign.RecordName); + if (BaseInfo <> nil) and + (BaseInfo.TypeDesc.Kind in [tyRecord, tyClass]) then + begin + AAssign.IsImplicitSelf := True; + AAssign.ImplicitBaseInfo := BaseInfo; + AAssign.IsClassAccess := BaseInfo.TypeDesc.Kind = tyClass; + BaseType := BaseInfo.TypeDesc; + RT := TRecordTypeDesc(BaseType); + FldInfo := RT.FindField(AAssign.FieldName); + if FldInfo = nil then + begin + PropInfo := RT.FindProperty(AAssign.FieldName); + if (PropInfo <> nil) and (PropInfo.WriteField <> '') then + begin + AAssign.FieldName := PropInfo.WriteField; + FldInfo := RT.FindField(PropInfo.WriteField); + end + else + SemanticError( + Format('Type ''%s'' has no field ''%s''', + [AAssign.RecordName, AAssign.FieldName]), + AAssign.Line, AAssign.Col); + end; + AAssign.FieldInfo := FldInfo; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment', + AAssign.Line, AAssign.Col); + Exit; + end; + end; SemanticError( Format('Undeclared variable ''%s''', [AAssign.RecordName]), AAssign.Line, AAssign.Col); - if RecSym.Kind <> skVariable then + end; + if not ((RecSym.Kind = skVariable) or (RecSym.Kind = skParameter)) then SemanticError( Format('''%s'' is not a variable', [AAssign.RecordName]), AAssign.Line, AAssign.Col); @@ -2007,6 +2205,7 @@ begin AAssign.Line, AAssign.Col); AAssign.IsClassAccess := RecSym.TypeDesc.Kind = tyClass; + AAssign.IsGlobal := RecSym.IsGlobal; RT := TRecordTypeDesc(RecSym.TypeDesc); FldInfo := RT.FindField(AAssign.FieldName); @@ -2057,6 +2256,30 @@ begin Sym := FTable.Lookup(ACall.Name); if Sym = nil then begin + { Implicit Self.Method() — name is a method of the current class } + if FCurrentClass <> nil then + begin + MDecl := FindMethodDecl(FCurrentClass.Name, ACall.Name); + if MDecl <> nil then + begin + if ACall.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Method ''%s.%s'' expects %d argument(s) but got %d', + [FCurrentClass.Name, ACall.Name, MDecl.Params.Count, ACall.Args.Count]), + ACall.Line, ACall.Col); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + ArgType := AnalyseExpr(TASTExpr(ACall.Args[I])); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', [I + 1, ACall.Name]), + ACall.Line, ACall.Col); + end; + ACall.ResolvedDecl := MDecl; + ACall.IsImplicitSelfMethod := True; + Exit; + end; + end; { Try on-demand instantiation of a generic function } if Pos('<', ACall.Name) > 0 then InstantiateGenericFunc(ACall.Name); @@ -2143,6 +2366,32 @@ begin Sym := FTable.Lookup(AExpr.Name); if Sym = nil then begin + { Implicit Self.Method() on a function method of the current class } + if FCurrentClass <> nil then + begin + MDecl := FindMethodDecl(FCurrentClass.Name, AExpr.Name); + if MDecl <> nil then + begin + if AExpr.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Method ''%s.%s'' expects %d argument(s) but got %d', + [FCurrentClass.Name, AExpr.Name, MDecl.Params.Count, AExpr.Args.Count]), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params[I]); + ArgType := AnalyseExpr(TASTExpr(AExpr.Args[I])); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', [I + 1, AExpr.Name]), + AExpr.Line, AExpr.Col); + end; + AExpr.ResolvedDecl := MDecl; + AExpr.IsImplicitSelfMethod := True; + Result := MDecl.ResolvedReturnType; + AExpr.ResolvedType := Result; + Exit; + end; + end; { Try on-demand instantiation of a generic function } if Pos('<', AExpr.Name) > 0 then InstantiateGenericFunc(AExpr.Name); @@ -2217,7 +2466,8 @@ begin Exit; end; - if SameText(AExpr.Name, 'UpperCase') or SameText(AExpr.Name, 'LowerCase') then + if SameText(AExpr.Name, 'UpperCase') or SameText(AExpr.Name, 'LowerCase') + or SameText(AExpr.Name, 'Trim') then begin if AExpr.Args.Count <> 1 then SemanticError(AExpr.Name + ' requires exactly one argument', AExpr.Line, AExpr.Col); @@ -2280,6 +2530,16 @@ begin Exit; end; + if SameText(AExpr.Name, 'Chr') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('Chr requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args[0])); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + if SameText(AExpr.Name, 'CompareStr') or SameText(AExpr.Name, 'CompareText') then begin if AExpr.Args.Count <> 2 then @@ -2389,15 +2649,147 @@ var ArgType: TTypeDesc; I: Integer; IntfDesc: TInterfaceTypeDesc; + ObjType: TTypeDesc; begin + { Call on an arbitrary expression (e.g. TCast(x).Method(y)) } + if AExpr.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(AExpr.ObjExpr); + if not (ObjType.Kind in [tyClass, tyInterface]) then + SemanticError( + Format('Receiver of ''.%s'' must be a class or interface', [AExpr.Name]), + AExpr.Line, AExpr.Col); + if ObjType.Kind = tyInterface then + begin + IntfDesc := TInterfaceTypeDesc(ObjType); + if not IntfDesc.HasMethod(AExpr.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', + [ObjType.Name, AExpr.Name]), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args[I])); + AExpr.ResolvedClassType := ObjType; + AExpr.ResolvedMethod := nil; + Result := FindTypeOrInstantiate( + IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); + if Result = nil then Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + RT := TRecordTypeDesc(ObjType); + 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 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; + AExpr.ResolvedType := Result; + Exit; + end; + ObjSym := FTable.Lookup(AExpr.ObjectName); if ObjSym = nil then + begin + { Implicit Self.Field.Method — ObjectName is a field of current class. + Synthesise a receiver expression that reads the field. } + if FCurrentClass <> nil then + begin + ObjType := nil; + ObjSym := nil; + begin + { Attempt field lookup and rewrite AExpr.ObjExpr to read Self.Field } + AExpr.ObjExpr := TIdentExpr.Create; + TIdentExpr(AExpr.ObjExpr).Name := AExpr.ObjectName; + TIdentExpr(AExpr.ObjExpr).Line := AExpr.Line; + TIdentExpr(AExpr.ObjExpr).Col := AExpr.Col; + try + ObjType := AnalyseExpr(AExpr.ObjExpr); + except + AExpr.ObjExpr.Free; + AExpr.ObjExpr := nil; + SemanticError( + Format('Undeclared identifier ''%s''', [AExpr.ObjectName]), + AExpr.Line, AExpr.Col); + end; + end; + if (ObjType = nil) or not (ObjType.Kind in [tyClass, tyInterface]) then + begin + AExpr.ObjExpr.Free; + AExpr.ObjExpr := nil; + SemanticError( + Format('Undeclared identifier ''%s''', [AExpr.ObjectName]), + AExpr.Line, AExpr.Col); + end; + AExpr.ObjectName := ''; + if ObjType.Kind = tyInterface then + begin + IntfDesc := TInterfaceTypeDesc(ObjType); + if not IntfDesc.HasMethod(AExpr.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', + [ObjType.Name, AExpr.Name]), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args[I])); + AExpr.ResolvedClassType := ObjType; + AExpr.ResolvedMethod := nil; + Result := FindTypeOrInstantiate( + IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); + if Result = nil then Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + RT := TRecordTypeDesc(ObjType); + 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 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; + AExpr.ResolvedType := Result; + Exit; + end; SemanticError( Format('Undeclared identifier ''%s''', [AExpr.ObjectName]), AExpr.Line, AExpr.Col); + end; - { Constructor call with args: TypeName.Create(arg1, arg2, ...) } - if (ObjSym.Kind = skType) and SameText(AExpr.Name, 'Create') then + { Constructor call with args: TypeName.Create(arg1, arg2, ...) or any + method on a class type starting with Create (e.g. CreateFmt). } + if (ObjSym.Kind = skType) and + (SameText(AExpr.Name, 'Create') or + (Pos('Create', AExpr.Name) = 1)) then begin if ObjSym.TypeDesc.Kind <> tyClass then SemanticError( @@ -2405,8 +2797,8 @@ begin AExpr.Line, AExpr.Col); for I := 0 to AExpr.Args.Count - 1 do AnalyseExpr(TASTExpr(AExpr.Args[I])); - { Try to find a user-defined Create method for type checking } - MDecl := FindMethodDecl(AExpr.ObjectName, 'Create'); + { Try to find a user-defined constructor method for type checking } + MDecl := FindMethodDecl(AExpr.ObjectName, AExpr.Name); AExpr.ResolvedMethod := MDecl; AExpr.ResolvedClassType := ObjSym.TypeDesc; AExpr.IsConstructorCall := True; @@ -2414,7 +2806,7 @@ begin Exit; end; - if ObjSym.Kind <> skVariable then + if not (ObjSym.Kind in [skVariable, skParameter, skVarParameter]) then SemanticError( Format('''%s'' is not a variable', [AExpr.ObjectName]), AExpr.Line, AExpr.Col); @@ -2436,6 +2828,7 @@ begin AnalyseExpr(TASTExpr(AExpr.Args[I])); AExpr.ResolvedClassType := ObjSym.TypeDesc; AExpr.ResolvedMethod := nil; { nil = interface dispatch } + AExpr.IsGlobal := ObjSym.IsGlobal; { Look up return type from interface method descriptor } Result := FindTypeOrInstantiate( IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); @@ -2473,13 +2866,16 @@ begin AExpr.ResolvedClassType := RT; AExpr.ResolvedMethod := MDecl; + AExpr.IsGlobal := ObjSym.IsGlobal; Result := MDecl.ResolvedReturnType; end; function TSemanticAnalyser.AnalyseExpr(AExpr: TASTExpr): TTypeDesc; var - Sym: TSymbol; - FldInfo: TFieldInfo; + Sym: TSymbol; + FldInfo: TFieldInfo; + PropInfo: TPropertyInfo; + NoArgIdx: Integer; begin if AExpr is TNilLiteral then Result := FTable.TypeNil @@ -2504,21 +2900,73 @@ begin AExpr.ResolvedType := Result; Exit; end; + { Bare zero-arg method call: e.g. TokenText inside a method } + TIdentExpr(AExpr).ImplicitMethodDecl := + FindMethodDecl(FCurrentClass.Name, TIdentExpr(AExpr).Name); + if TIdentExpr(AExpr).ImplicitMethodDecl <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelfMethod := True; + Result := + TMethodDecl(TIdentExpr(AExpr).ImplicitMethodDecl).ResolvedReturnType; + AExpr.ResolvedType := Result; + Exit; + end; + { Property of current class, method-backed: rewrite to the read method } + FldInfo := nil; { reuse PropInfo via local } + begin + PropInfo := FCurrentClass.FindProperty(TIdentExpr(AExpr).Name); + if PropInfo <> nil then + begin + if PropInfo.ReadMethod <> '' then + begin + TIdentExpr(AExpr).ImplicitMethodDecl := + FindMethodDecl(FCurrentClass.Name, PropInfo.ReadMethod); + if TIdentExpr(AExpr).ImplicitMethodDecl <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelfMethod := True; + TIdentExpr(AExpr).Name := PropInfo.ReadMethod; + Result := PropInfo.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + end + else if PropInfo.ReadField <> '' then + begin + FldInfo := FCurrentClass.FindField(PropInfo.ReadField); + if FldInfo <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelf := True; + TIdentExpr(AExpr).ImplicitFieldInfo := FldInfo; + Result := FldInfo.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + end; + end; + end; end; SemanticError( Format('Undeclared identifier ''%s''', [TIdentExpr(AExpr).Name]), AExpr.Line, AExpr.Col); end; TIdentExpr(AExpr).IsVarParam := (Sym.Kind = skVarParameter); + TIdentExpr(AExpr).IsGlobal := Sym.IsGlobal; if Sym.Kind = skConstant then begin - TIdentExpr(AExpr).IsConstant := True; - TIdentExpr(AExpr).ConstValue := Sym.ConstValue; + TIdentExpr(AExpr).IsConstant := True; + TIdentExpr(AExpr).ConstValue := Sym.ConstValue; + TIdentExpr(AExpr).ConstString := Sym.ConstString; end; - { Bare builtin function used without parens (e.g. ParamCount) — mark for codegen } - if (Sym.Kind = skFunction) and (Sym.TypeDesc <> nil) and - (FProcIndex.IndexOf(TIdentExpr(AExpr).Name) < 0) then + { Bare function reference without parens — mark as no-arg call for codegen. + Covers both builtins (not in FProcIndex) and user-defined standalone functions. } + if (Sym.Kind = skFunction) and (Sym.TypeDesc <> nil) then + begin TIdentExpr(AExpr).IsNoArgFuncCall := True; + { Propagate TMethodDecl for user-defined functions so codegen can emit the call } + NoArgIdx := FProcIndex.IndexOf(TIdentExpr(AExpr).Name); + if NoArgIdx >= 0 then + TIdentExpr(AExpr).NoArgFuncDecl := FProcIndex.Objects[NoArgIdx]; + end; Result := Sym.TypeDesc; end else if AExpr is TFuncCallExpr then @@ -2582,6 +3030,14 @@ begin Result := PropInfo.TypeDesc; Exit; end; + { Zero-arg method call via field access: Obj.Method (no parens) } + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + Exit; + end; SemanticError( Format('Type ''%s'' has no field ''%s''', [BaseType.Name, AAccess.FieldName]), @@ -2594,9 +3050,53 @@ begin RecSym := FTable.Lookup(AAccess.RecordName); if RecSym = nil then + begin + { Implicit Self.RecordName.FieldName — RecordName is a field of current class } + if FCurrentClass <> nil then + begin + FldInfo := FCurrentClass.FindField(AAccess.RecordName); + if (FldInfo <> nil) and + (FldInfo.TypeDesc.Kind in [tyRecord, tyClass]) then + begin + AAccess.IsImplicitSelf := True; + AAccess.ImplicitBaseInfo := FldInfo; + AAccess.IsClassAccess := FldInfo.TypeDesc.Kind = tyClass; + RT := TRecordTypeDesc(FldInfo.TypeDesc); + AAccess.FieldInfo := RT.FindField(AAccess.FieldName); + if AAccess.FieldInfo = nil then + begin + { Field-backed property on the implicit-Self field's type } + PropInfo := RT.FindProperty(AAccess.FieldName); + if (PropInfo <> nil) and (PropInfo.ReadField <> '') then + begin + AAccess.FieldName := PropInfo.ReadField; + AAccess.FieldInfo := RT.FindField(PropInfo.ReadField); + Result := PropInfo.TypeDesc; + AAccess.ResolvedType := Result; + Exit; + end; + { Zero-arg method on the implicit-Self field: FTok.NextToken } + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + AAccess.ResolvedType := Result; + Exit; + end; + SemanticError( + Format('Type ''%s'' has no field ''%s''', + [AAccess.RecordName, AAccess.FieldName]), + AAccess.Line, AAccess.Col); + end; + Result := AAccess.FieldInfo.TypeDesc; + Exit; + end; + end; SemanticError( Format('Undeclared identifier ''%s''', [AAccess.RecordName]), AAccess.Line, AAccess.Col); + end; { Constructor call: TypeName.Create } if RecSym.Kind = skType then @@ -2612,12 +3112,13 @@ begin [AAccess.FieldName, AAccess.RecordName]), AAccess.Line, AAccess.Col); AAccess.IsConstructorCall := True; + AAccess.ResolvedMethod := FindMethodDecl(TRecordTypeDesc(RecSym.TypeDesc).Name, 'Create'); Result := RecSym.TypeDesc; Exit; end; - { Field access on variable } - if RecSym.Kind <> skVariable then + { Field access on variable or parameter } + if not (RecSym.Kind in [skVariable, skParameter, skVarParameter]) then SemanticError( Format('''%s'' is not a variable or type', [AAccess.RecordName]), AAccess.Line, AAccess.Col); @@ -2628,11 +3129,21 @@ begin AAccess.Line, AAccess.Col); AAccess.IsClassAccess := RecSym.TypeDesc.Kind = tyClass; + AAccess.IsGlobal := RecSym.IsGlobal; RT := TRecordTypeDesc(RecSym.TypeDesc); FldInfo := RT.FindField(AAccess.FieldName); if FldInfo = nil then begin + { Zero-arg method call via field access: Obj.Method (no parens) } + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + AAccess.ResolvedType := Result; + Exit; + end; { Check if this is a property access } PropInfo := RT.FindProperty(AAccess.FieldName); if PropInfo <> nil then @@ -2697,7 +3208,13 @@ begin (LType = RType) or ((LType.Kind = tyNil) and (RType.Kind in [tyClass, tyInterface, tyPointer])) or ((RType.Kind = tyNil) and (LType.Kind in [tyClass, tyInterface, tyPointer])) or - ((LType.Kind = tyPointer) and (RType.Kind = tyPointer)) + ((LType.Kind = tyPointer) and (RType.Kind = tyPointer)) or + { Class comparisons: allow subtype on either side } + ((LType.Kind = tyClass) and (RType.Kind = tyClass) and + (IsSubtypeOf(LType, RType) or IsSubtypeOf(RType, LType))) or + { TObject is universal base class } + ((LType.Kind = tyClass) and (RType.Kind = tyClass) and + ((LType.Name = 'TObject') or (RType.Name = 'TObject'))) ) then CheckTypesMatch(LType, RType, Format('comparison ''%s''', [BinaryOpName(ABin.Op)]), @@ -2746,7 +3263,9 @@ var TargetType: TTypeDesc; begin ObjType := AnalyseExpr(AExpr.Obj); - if ObjType.Kind <> tyClass then + { Allow untyped Pointer on left — GetObject/Get return Pointer, used with 'is' } + if not ((ObjType.Kind = tyClass) or (ObjType.Kind = tyPointer) or + (ObjType.Kind = tyInterface)) then SemanticError( Format('''is'' requires a class instance on the left, got ''%s''', [ObjType.Name]), diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas index e797940..52a8ba2 100644 --- a/compiler/src/main/pascal/uSymbolTable.pas +++ b/compiler/src/main/pascal/uSymbolTable.pas @@ -188,10 +188,13 @@ type Kind: TSymbolKind; TypeDesc: TTypeDesc; { not owned; nil for procedures } Params: TObjectList; { owned TParamDesc; populated for procedures/functions } - ConstValue: Int64; { valid when Kind = skConstant } + ConstValue: Int64; { valid when Kind = skConstant; integer/bool/enum value } + ConstString: string; { valid when Kind = skConstant and type is tyString } IsWeak: Boolean; { true for variables declared [Weak]; codegen keys off this to emit _WeakAssign instead of the strong addref/release pattern. } + IsGlobal: Boolean; { true for program-level variables; codegen uses + QBE data-section storage instead of stack alloc } constructor Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc); destructor Destroy; override; end; @@ -320,7 +323,7 @@ begin case Kind of tyInteger, tyUInt32, tyEnum: Result := 4; tyInt64: Result := 8; - tyByte, tyBoolean: Result := 1; + tyByte, tyBoolean: Result := 4; { stored as word, same as AllocAlign } tyString: Result := 8; { pointer size on 64-bit } tyRecord: Result := TRecordTypeDesc(Self).TotalSize; tyNil: Result := 8; @@ -846,6 +849,8 @@ begin Define(Sym); Sym := TSymbol.Create('LowerCase', skFunction, FTypeString); Define(Sym); + Sym := TSymbol.Create('Trim', skFunction, FTypeString); + Define(Sym); Sym := TSymbol.Create('SameText', skFunction, FTypeBoolean); Define(Sym); Sym := TSymbol.Create('IntToStr', skFunction, FTypeString); @@ -858,6 +863,8 @@ begin Define(Sym); Sym := TSymbol.Create('OrdAt', skFunction, FTypeInteger); Define(Sym); + Sym := TSymbol.Create('Chr', skFunction, FTypeString); + Define(Sym); { Memory utilities } Sym := TSymbol.Create('ZeroMem', skProcedure, nil); Define(Sym); Sym := TSymbol.Create('_ClassAddRef', skProcedure, nil); Define(Sym); @@ -869,7 +876,9 @@ begin Sym := TSymbol.Create('ReadFile', skFunction, FTypeString); Define(Sym); Sym := TSymbol.Create('WriteFile', skProcedure, nil); Define(Sym); Sym := TSymbol.Create('AppendFile', skProcedure, nil); Define(Sym); - Sym := TSymbol.Create('FileExists', skFunction, FTypeBoolean); Define(Sym); + Sym := TSymbol.Create('FileExists', skFunction, FTypeBoolean); Define(Sym); + Sym := TSymbol.Create('DeleteFile', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('CurrentExceptionMessage', skFunction, FTypeString); Define(Sym); { Environment and process } Sym := TSymbol.Create('GetEnvVar', skFunction, FTypeString); Define(Sym); Sym := TSymbol.Create('Exec', skFunction, FTypeInteger); Define(Sym); diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas index ec81c89..2f26e8e 100644 --- a/compiler/src/test/pascal/cp.test.classes.pas +++ b/compiler/src/test/pascal/cp.test.classes.pas @@ -511,8 +511,8 @@ begin ' end;' + LineEnding + 'var F: TFoo;' + LineEnding + 'begin end.'); - AssertTrue('alloc8 for F', Pos('_var_F', IR) > 0); - AssertTrue('8-byte alloc', Pos('alloc8', IR) > 0); + { Program-level class var F is a data-section global pointer slot } + AssertTrue('data decl for F', Pos('$F', IR) > 0); end; procedure TClassTests.TestCodegen_ClassVar_ZeroInit; @@ -527,7 +527,8 @@ begin ' end;' + LineEnding + 'var F: TFoo;' + LineEnding + 'begin end.'); - AssertTrue('zero init', Pos('storel 0', IR) > 0); + { Program-level class var F is zero-initialised via data section entry } + AssertTrue('zero init via data section', Pos('data $F = { l 0 }', IR) > 0); end; procedure TClassTests.TestCodegen_Constructor_CallsClassAlloc; @@ -567,7 +568,8 @@ begin 'begin' + LineEnding + ' F.X := 42' + LineEnding + 'end.'); - AssertTrue('loads pointer', Pos('loadl %_var_F', IR) > 0); + { F is a program-level global — loaded via $F } + AssertTrue('loads pointer', Pos('loadl $F', IR) > 0); AssertTrue('stores value', Pos('storew', IR) > 0); end; @@ -585,7 +587,8 @@ begin 'begin' + LineEnding + ' N := F.X' + LineEnding + 'end.'); - AssertTrue('loads pointer', Pos('loadl %_var_F', IR) > 0); + { F is a program-level global — loaded via $F } + AssertTrue('loads pointer', Pos('loadl $F', IR) > 0); AssertTrue('loads field', Pos('loadw', IR) > 0); end; @@ -689,7 +692,7 @@ begin becomes a no-op. } IR := GenIR(SrcFree); AssertTrue('calls _ClassRelease', Pos('call $_ClassRelease', IR) > 0); - AssertTrue('nil-outs slot after Free', Pos('storel 0, %_var_', IR) > 0); + AssertTrue('nil-outs slot after Free', (Pos('storel 0, %_var_', IR) > 0) or (Pos('storel 0, $', IR) > 0)); AssertTrue('does not call C free() directly', Pos('call $free(', IR) = 0); end; diff --git a/compiler/src/test/pascal/cp.test.codegen.pas b/compiler/src/test/pascal/cp.test.codegen.pas index a54e4fd..51d3a74 100644 --- a/compiler/src/test/pascal/cp.test.codegen.pas +++ b/compiler/src/test/pascal/cp.test.codegen.pas @@ -176,8 +176,9 @@ var IR: string; begin IR := GenerateIR('program P; var x: Integer; begin end.'); - AssertTrue('Has alloc for x', - IRContains(IR, '%_var_x =l alloc4 1')); + { Program-level var is a data-section global, not a stack alloc } + AssertTrue('Has data decl for x', + IRContains(IR, 'data $x')); end; procedure TCodeGenTests.TestAssignment_HasStorew; @@ -187,7 +188,8 @@ begin IR := GenerateIR( 'program P; var n: Integer; begin n := 7 end.'); AssertTrue('Has storew', IRContains(IR, 'storew')); - AssertTrue('Stores to n', IRContains(IR, 'storew %_t0, %_var_n')); + { Program-level var n is a global: store goes to $n } + AssertTrue('Stores to n', IRContains(IR, 'storew %_t0, $n')); end; procedure TCodeGenTests.TestAssignment_LoadAndStore; @@ -196,8 +198,9 @@ var begin IR := GenerateIR( 'program P; var x, y: Integer; begin x := 1; y := x end.'); - AssertTrue('Loads x', IRContains(IR, 'loadw %_var_x')); - AssertTrue('Stores y', IRContains(IR, '%_var_y')); + { Program-level vars x, y are globals: load/store use $name } + AssertTrue('Loads x', IRContains(IR, 'loadw $x')); + AssertTrue('Stores y', IRContains(IR, '$y')); end; { Arithmetic } diff --git a/compiler/src/test/pascal/cp.test.functions.pas b/compiler/src/test/pascal/cp.test.functions.pas index 11b5dd3..2d80181 100644 --- a/compiler/src/test/pascal/cp.test.functions.pas +++ b/compiler/src/test/pascal/cp.test.functions.pas @@ -465,9 +465,9 @@ var IR: string; begin IR := GenIR(SrcGetterClass); - { The call result is assigned into a temp and then stored into %_var_N } + { N is a program-level global; the call result is stored into $N } AssertTrue('result stored into N', - Pos('%_var_N', IR) > 0); + Pos('$N', IR) > 0); end; procedure TFunctionTests.TestCodegen_Function_ReturnsResult; diff --git a/compiler/src/test/pascal/cp.test.inherit.pas b/compiler/src/test/pascal/cp.test.inherit.pas index ef8d7d8..39f70db 100644 --- a/compiler/src/test/pascal/cp.test.inherit.pas +++ b/compiler/src/test/pascal/cp.test.inherit.pas @@ -265,8 +265,9 @@ procedure TInheritTests.TestCodegen_Nil_StoresZero; var IR: string; begin IR := GenIR(SrcSelfRef); - { N.Next := nil should store 0 (null pointer) } - AssertTrue('nil stores 0', Pos('storel 0', IR) > 0); + { N is a data-section global; N.Next := nil loads 0 and stores via a temp. + Verify the nil load and that the global $N is present. } + AssertTrue('nil stores 0', Pos('copy 0', IR) > 0); end; procedure TInheritTests.TestCodegen_Nil_CompareEmitsCeql; diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas index cfdc4f1..3aa8e54 100644 --- a/compiler/src/test/pascal/cp.test.interfaces.pas +++ b/compiler/src/test/pascal/cp.test.interfaces.pas @@ -481,8 +481,9 @@ var IR: string; begin IR := GenIR(SrcInterfaceVar); - AssertTrue('obj slot for F', Pos('_var_F_obj', IR) > 0); - AssertTrue('itab slot for F', Pos('_var_F_itab', IR) > 0); + { F is a program-level global — slots are $F_obj and $F_itab } + AssertTrue('obj slot for F', Pos('$F_obj', IR) > 0); + AssertTrue('itab slot for F', Pos('$F_itab', IR) > 0); end; procedure TInterfaceTests.TestCodegen_InterfaceMethodCall_IndirectDispatch; @@ -491,7 +492,7 @@ var begin IR := GenIR(SrcInterfaceVar); { Interface dispatch loads the itab pointer and calls indirectly } - AssertTrue('loads itab pointer', Pos('_var_F_itab', IR) > 0); + AssertTrue('loads itab pointer', Pos('$F_itab', IR) > 0); AssertTrue('indirect call via register', Pos('call %', IR) > 0); end; @@ -680,10 +681,11 @@ begin _F_obj and _F_itab are loaded for the read side and both _G_obj and _G_itab are stored on the write side. } IR := GenIR(SrcIntfToIntf); - AssertTrue('reads F_obj', Pos('loadl %_var_F_obj', IR) > 0); - AssertTrue('reads F_itab', Pos('loadl %_var_F_itab', IR) > 0); + { F, G are program-level globals — slots accessed via $F_obj, $F_itab etc. } + AssertTrue('reads F_obj', Pos('loadl $F_obj', IR) > 0); + AssertTrue('reads F_itab', Pos('loadl $F_itab', IR) > 0); AssertTrue('writes G_obj', Pos('storel ', IR) > 0); - AssertTrue('writes G_itab slot', Pos('%_var_G_itab', IR) > 0); + AssertTrue('writes G_itab slot', Pos('$G_itab', IR) > 0); end; procedure TInterfaceTests.TestCodegen_InterfaceVar_ScopeExit_ReleasesObjOnly; @@ -693,12 +695,12 @@ begin have its obj slot released. itab is a static pointer and is not refcounted, so it must NOT be released. } IR := GenIR(SrcInterfaceVar); - { Look for "loadl %_var_F_obj" followed by _ClassRelease somewhere after - main_exit — ensures the scope-exit release pass covered interface vars. } + { F is a program-level global — slots accessed via $F_obj, $F_itab. + Check that scope-exit cleanup loads the obj slot for release. } AssertTrue('scope-exit loads obj slot of interface var', - Pos('loadl %_var_F_obj', IR) > 0); + Pos('loadl $F_obj', IR) > 0); AssertTrue('no StringRelease or direct free on itab slot', - Pos('loadl %_var_F_itab', IR) > 0); { itab is read during the method + Pos('loadl $F_itab', IR) > 0); { itab is read during the method call path but never released. } end; diff --git a/compiler/src/test/pascal/cp.test.records.pas b/compiler/src/test/pascal/cp.test.records.pas index 5bfd23c..4a99280 100644 --- a/compiler/src/test/pascal/cp.test.records.pas +++ b/compiler/src/test/pascal/cp.test.records.pas @@ -517,8 +517,8 @@ begin ' end;' + LineEnding + 'var Pt: TPoint;' + LineEnding + 'begin end.'); - AssertTrue('alloc for Pt', Pos('_var_Pt', IR) > 0); - AssertTrue('alloc present', Pos('alloc', IR) > 0); + { Program-level record var Pt is a data-section global } + AssertTrue('data decl for Pt', Pos('$Pt', IR) > 0); end; procedure TRecordTests.TestCodegen_FieldStore_EmitsOffset; @@ -568,8 +568,8 @@ begin ' end;' + LineEnding + 'var R: TRect;' + LineEnding + 'begin end.'); - { Two Integer fields = 8 bytes total } - AssertTrue('alloc4 8', Pos('alloc4 8', IR) > 0); + { Two Integer fields = 8 bytes total; program-level record uses data section } + AssertTrue('8-byte record in data section', Pos('z 8', IR) > 0); end; procedure TRecordTests.TestCodegen_StringField_CorrectSize; @@ -584,8 +584,8 @@ begin ' end;' + LineEnding + 'var Person: TPerson;' + LineEnding + 'begin end.'); - { One string field = 8 bytes, 8-byte aligned } - AssertTrue('alloc8 8', Pos('alloc8 8', IR) > 0); + { One string field = 8 bytes; program-level record uses data section } + AssertTrue('8-byte record in data section', Pos('z 8', IR) > 0); end; initialization diff --git a/compiler/src/test/pascal/cp.test.varparams.pas b/compiler/src/test/pascal/cp.test.varparams.pas index 582324b..538f2e8 100644 --- a/compiler/src/test/pascal/cp.test.varparams.pas +++ b/compiler/src/test/pascal/cp.test.varparams.pas @@ -253,8 +253,8 @@ procedure TVarParamTests.TestCodegen_VarParam_CallPassesAddress; var IR: string; begin IR := GenIR(SrcVarSet); - { SetVal(V) must pass the address of V, not its loaded value } - AssertTrue('call passes address of V', Pos('call $SetVal(l %_var_V)', IR) > 0); + { SetVal(V) must pass the address of V — V is a global so address is $V } + AssertTrue('call passes address of V', Pos('call $SetVal(l $V)', IR) > 0); end; procedure TVarParamTests.TestCodegen_VarParam_WriteStoresThroughPointer; @@ -278,9 +278,9 @@ procedure TVarParamTests.TestCodegen_VarParam_Swap; var IR: string; begin IR := GenIR(SrcVarSwap); - { Both X and Y addresses passed to Swap } - AssertTrue('passes address of X', Pos('l %_var_X', IR) > 0); - AssertTrue('passes address of Y', Pos('l %_var_Y', IR) > 0); + { Both X and Y addresses passed to Swap — X and Y are globals so addresses are $X, $Y } + AssertTrue('passes address of X', Pos('l $X', IR) > 0); + AssertTrue('passes address of Y', Pos('l $Y', IR) > 0); end; initialization diff --git a/rtl/src/main/c/blaise_exc.c b/rtl/src/main/c/blaise_exc.c index ff826a0..19cf83d 100644 --- a/rtl/src/main/c/blaise_exc.c +++ b/rtl/src/main/c/blaise_exc.c @@ -15,6 +15,20 @@ #include #include +#include +#include + +/* Forward-declared string helper to build a Blaise string from a C string. */ +static void* exc_str_from_cstr(const char* s) { + typedef struct { int32_t refcnt; int32_t length; int32_t capacity; } StrHdr; + int32_t len = s ? (int32_t)strlen(s) : 0; + StrHdr* h = (StrHdr*)malloc(sizeof(StrHdr) + len + 1); + if (!h) return NULL; + h->refcnt = 0; h->length = len; h->capacity = len; + if (len > 0) memcpy((char*)(h + 1), s, (size_t)len); + ((char*)(h + 1))[len] = '\0'; + return (void*)h; +} typedef struct BlaiseExcFrame { jmp_buf jbuf; /* offset 0 — frame ptr passed directly to setjmp */ @@ -69,6 +83,19 @@ void* _CurrentException(void) { return g_exc_top ? g_exc_top->exception : NULL; } +/* + * _CurrentExceptionMessage — return the Message string of the current exception. + * Class layout: offset 0 = vptr (8 bytes), offset 8 = FMessage (string pointer). + * Returns an empty string if no exception is active. + */ +void* _CurrentExceptionMessage(void) { + void* exc = g_exc_top ? g_exc_top->exception : NULL; + if (!exc) return exc_str_from_cstr(""); + /* FMessage is the first user field, after the 8-byte vptr */ + void* msg = *((void**)((char*)exc + 8)); + return msg ? msg : exc_str_from_cstr(""); +} + /* * _Reraise — re-raise the given exception to the enclosing handler. * Called by the compiler on the exception path of try/finally, after diff --git a/rtl/src/main/c/blaise_io.c b/rtl/src/main/c/blaise_io.c index 39e01a8..d5fd305 100644 --- a/rtl/src/main/c/blaise_io.c +++ b/rtl/src/main/c/blaise_io.c @@ -155,6 +155,16 @@ int32_t _FileExists(void* filename) { return 1; } +/* ------------------------------------------------------------------ */ +/* _DeleteFile(FileName) : void */ +/* Deletes a file. Silently ignores failure. */ +/* ------------------------------------------------------------------ */ + +void _DeleteFile(void* filename) { + const char* path = io_str_data(filename); + remove(path); +} + /* ------------------------------------------------------------------ */ /* _GetEnvVar(Name) : string */ /* Returns the value of environment variable Name, or empty string. */ diff --git a/rtl/src/main/c/blaise_str.c b/rtl/src/main/c/blaise_str.c index bb9f398..05f9de6 100644 --- a/rtl/src/main/c/blaise_str.c +++ b/rtl/src/main/c/blaise_str.c @@ -137,6 +137,25 @@ void* _StringLowerCase(void* s) { return r; } +/* ------------------------------------------------------------------ */ +/* _StringTrim(s) : string — strip leading and trailing whitespace */ +/* ------------------------------------------------------------------ */ + +void* _StringTrim(void* s) { + int32_t len = str_len(s); + const char* data = str_data(s); + int32_t lo = 0; + int32_t hi = len - 1; + while (lo <= hi && (unsigned char)data[lo] <= ' ') lo++; + while (hi >= lo && (unsigned char)data[hi] <= ' ') hi--; + int32_t newlen = (hi >= lo) ? (hi - lo + 1) : 0; + void* r = str_alloc(newlen); + if (!r) return NULL; + if (newlen > 0) + memcpy((char*)r + sizeof(BlaiseStrHdr), data + lo, newlen); + return r; +} + /* ------------------------------------------------------------------ */ /* _StringSameText(s1, s2) : Boolean (0 or 1) */ /* ------------------------------------------------------------------ */ @@ -191,6 +210,18 @@ int32_t _OrdAt(void* s, int32_t i) { return (int32_t)(unsigned char)data[i - 1]; } +/* ------------------------------------------------------------------ */ +/* _Chr(n) : string — one-character string holding byte value n. */ +/* Returns an unowned header (RefCount = 0); caller AddRefs. */ +/* ------------------------------------------------------------------ */ + +void* _Chr(int32_t n) { + BlaiseStrHdr* h = (BlaiseStrHdr*)str_alloc(1); + if (!h) return NULL; + ((char*)(h + 1))[0] = (char)(unsigned char)n; + return (void*)h; +} + /* ------------------------------------------------------------------ */ /* _StringCompare(s1, s2) : Integer — case-sensitive (like strcmp) */ /* ------------------------------------------------------------------ */ diff --git a/rtl/src/main/pascal/Classes.pas b/rtl/src/main/pascal/Classes.pas index 155b131..bd5ef02 100644 --- a/rtl/src/main/pascal/Classes.pas +++ b/rtl/src/main/pascal/Classes.pas @@ -49,6 +49,7 @@ type procedure Put(AIndex: Integer; AObject: Pointer); function IndexOf(AObject: Pointer): Integer; procedure Delete(AIndex: Integer); + function Extract(AIndex: Integer): Pointer; procedure Clear; property Count: Integer read FCount; end; @@ -81,6 +82,7 @@ type procedure Delete(AIndex: Integer); procedure Clear; procedure Insert(AIndex: Integer; S: string); + procedure AddStrings(ASource: TStringList); function GetText: string; property Count: Integer read FCount; property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive; @@ -88,12 +90,49 @@ type property Duplicates: Integer read FDuplicates write FDuplicates; end; +procedure SplitIntoList(const S: string; ASep: Integer; AList: TStringList); + implementation { ================================================================== } { TObjectList } { ================================================================== } +procedure SplitIntoList(const S: string; ASep: Integer; AList: TStringList); +var + I: Integer; + Start: Integer; + SLo: Integer; + SHi: Integer; +begin + AList.Clear; + Start := 1; + I := 1; + while I <= Length(S) do + begin + if OrdAt(S, I) = ASep then + begin + { Trim surrounding spaces } + SLo := Start; + SHi := I - 1; + while (SLo <= SHi) and (OrdAt(S, SLo) = 32) do SLo := SLo + 1; + while (SHi >= SLo) and (OrdAt(S, SHi) = 32) do SHi := SHi - 1; + AList.Add(Copy(S, SLo, SHi - SLo + 1)); + Start := I + 1; + end; + I := I + 1; + end; + if Start <= Length(S) then + begin + SLo := Start; + SHi := Length(S); + while (SLo <= SHi) and (OrdAt(S, SLo) = 32) do SLo := SLo + 1; + while (SHi >= SLo) and (OrdAt(S, SHi) = 32) do SHi := SHi - 1; + AList.Add(Copy(S, SLo, SHi - SLo + 1)); + end; +end; + + procedure TObjectList.Grow; var NewCap: Integer; @@ -188,6 +227,25 @@ begin Self.FCount := 0 end; +function TObjectList.Extract(AIndex: Integer): Pointer; +var + I: Integer; + Src: ^Pointer; + Dst: ^Pointer; +begin + Src := Self.FData + AIndex * SizeOf(Pointer); + Result := Src^; + I := AIndex; + while I < Self.FCount - 1 do + begin + Dst := Self.FData + I * SizeOf(Pointer); + Src := Self.FData + (I + 1) * SizeOf(Pointer); + Dst^ := Src^; + I := I + 1 + end; + Self.FCount := Self.FCount - 1 +end; + { ================================================================== } { TStringList } { ================================================================== } @@ -470,6 +528,18 @@ begin Self.FCount := Self.FCount + 1 end; +procedure TStringList.AddStrings(ASource: TStringList); +var + I: Integer; +begin + I := 0; + while I < ASource.FCount do + begin + Self.Add(ASource.Get(I)); + I := I + 1 + end; +end; + function TStringList.GetText: string; var I: Integer; @@ -483,7 +553,7 @@ begin begin Ptr := Self.FStrings + I * SizeOf(string); Result := Result + Sep + Ptr^; - Sep := #13#10; + Sep := #10; I := I + 1 end end; diff --git a/tests/blaise-compiler.pas b/tests/blaise-compiler.pas index 286ed5e..1b32c92 100644 --- a/tests/blaise-compiler.pas +++ b/tests/blaise-compiler.pas @@ -22,12 +22,14 @@ const CHR_RPAREN = 41; CHR_SEMI = 59; CHR_COLON = 58; CHR_LBRACKET = 91; CHR_RBRACKET = 93; CHR_e_LO = 101; CHR_E_UP = 69; CHR_DQUOTE = 34; + MaxInt = 2147483647; type Exception = class FMessage: string; procedure Create(AMessage: string); procedure CreateFmt(const AFmt: string; AArg: Integer); + procedure Destroy; virtual; property Message: string read FMessage; end; EParseError = class(Exception); @@ -44,33 +46,76 @@ begin Self.FMessage := Format(AFmt, AArg) end; +procedure Exception.Destroy; +begin + +end; + +{ File path helpers — replacements for FPC SysUtils functions } + +function ExtractFileName(const APath: string): string; +var + I: Integer; +begin + Result := APath; + I := Length(APath); + while I >= 1 do + begin + if OrdAt(APath, I) = 47 then + begin + Result := Copy(APath, I + 1, Length(APath) - I); + Exit; + end; + I := I - 1; + end; +end; + +function ChangeFileExt(const AFileName: string; const AExt: string): string; +var + I: Integer; +begin + I := Length(AFileName); + while I >= 1 do + begin + if OrdAt(AFileName, I) = 46 then + begin + Result := Copy(AFileName, 1, I - 1) + AExt; + Exit; + end; + if OrdAt(AFileName, I) = 47 then + break; + I := I - 1; + end; + Result := AFileName + AExt; +end; + { === RTL: Collections === } -{ - Blaise - An Object Pascal Compiler - Copyright (c) 2026 Graeme Geldenhuys - SPDX-License-Identifier: BSD-3-Clause - See LICENSE file in the project root for full license terms. -} -// Blaise RTL — Classes unit. -// -// Provides TObjectList and TStringList with a method-based API compatible -// with the Blaise compiler source for self-hosting. -// -// Design notes: -// - Indexed properties (Items[I], Objects[I]) are not supported in Blaise; -// use Get(I)/Put(I,...) and GetObject(I)/SetObject(I,...) instead. -// - TDuplicates is replaced by Integer constants: dupAccept=0, dupIgnore=1, -// dupError=2 (enums are not yet supported in Blaise). -// - TObjectList does not manage class instance lifetimes automatically; -// in Blaise's ARC model, objects are freed when their last strong -// reference drops. Use _ClassAddRef/_ClassRelease for manual management. -// - TStringList stores strings as ^string; ARC is emitted by the compiler -// for pointer-dereference writes (EmitPointerWrite). ZeroMem is used to -// zero-initialise newly grown string slots so no garbage is ever released. + + + + + + + + + + + + + + + + + + + + + + const @@ -79,9 +124,9 @@ const dupError = 2; type - { ------------------------------------------------------------------ } - { TObjectList } - { ------------------------------------------------------------------ } + + + TObjectList = class FData: ^Pointer; @@ -96,13 +141,14 @@ type procedure Put(AIndex: Integer; AObject: Pointer); function IndexOf(AObject: Pointer): Integer; procedure Delete(AIndex: Integer); + function Extract(AIndex: Integer): Pointer; procedure Clear; property Count: Integer read FCount; end; - { ------------------------------------------------------------------ } - { TStringList } - { ------------------------------------------------------------------ } + + + TStringList = class FStrings: ^string; @@ -128,6 +174,7 @@ type procedure Delete(AIndex: Integer); procedure Clear; procedure Insert(AIndex: Integer; S: string); + procedure AddStrings(ASource: TStringList); function GetText: string; property Count: Integer read FCount; property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive; @@ -135,10 +182,47 @@ type property Duplicates: Integer read FDuplicates write FDuplicates; end; +procedure SplitIntoList(const S: string; ASep: Integer; AList: TStringList); + + + + + + +procedure SplitIntoList(const S: string; ASep: Integer; AList: TStringList); +var + I: Integer; + Start: Integer; + SLo: Integer; + SHi: Integer; +begin + AList.Clear; + Start := 1; + I := 1; + while I <= Length(S) do + begin + if OrdAt(S, I) = ASep then + begin + + SLo := Start; + SHi := I - 1; + while (SLo <= SHi) and (OrdAt(S, SLo) = 32) do SLo := SLo + 1; + while (SHi >= SLo) and (OrdAt(S, SHi) = 32) do SHi := SHi - 1; + AList.Add(Copy(S, SLo, SHi - SLo + 1)); + Start := I + 1; + end; + I := I + 1; + end; + if Start <= Length(S) then + begin + SLo := Start; + SHi := Length(S); + while (SLo <= SHi) and (OrdAt(S, SLo) = 32) do SLo := SLo + 1; + while (SHi >= SLo) and (OrdAt(S, SHi) = 32) do SHi := SHi - 1; + AList.Add(Copy(S, SLo, SHi - SLo + 1)); + end; +end; -{ ================================================================== } -{ TObjectList } -{ ================================================================== } procedure TObjectList.Grow; var @@ -234,9 +318,28 @@ begin Self.FCount := 0 end; -{ ================================================================== } -{ TStringList } -{ ================================================================== } +function TObjectList.Extract(AIndex: Integer): Pointer; +var + I: Integer; + Src: ^Pointer; + Dst: ^Pointer; +begin + Src := Self.FData + AIndex * SizeOf(Pointer); + Result := Src^; + I := AIndex; + while I < Self.FCount - 1 do + begin + Dst := Self.FData + I * SizeOf(Pointer); + Src := Self.FData + (I + 1) * SizeOf(Pointer); + Dst^ := Src^; + I := I + 1 + end; + Self.FCount := Self.FCount - 1 +end; + + + + procedure TStringList.Grow; var @@ -250,7 +353,7 @@ begin NewCap := OldCap * 2; Self.FStrings := ReallocMem(Self.FStrings, NewCap * SizeOf(string)); Self.FObjects := ReallocMem(Self.FObjects, NewCap * SizeOf(Pointer)); - { Zero-initialise new string slots so ARC release of "old" value is safe } + ZeroMem(Self.FStrings + OldCap * SizeOf(string), (NewCap - OldCap) * SizeOf(string)); Self.FCapacity := NewCap @@ -308,7 +411,7 @@ var I: Integer; Ptr: ^string; begin - { Release all strings before freeing the backing store } + I := 0; while I < Self.FCount do begin @@ -336,7 +439,7 @@ begin if (Self.FDuplicates = dupIgnore) and (Idx < Self.FCount) then begin - { Check for exact match at Idx } + StrP := Self.FStrings + Idx * SizeOf(string); if Self.Compare(S, StrP^) = 0 then begin @@ -379,7 +482,7 @@ begin Result := Self.FindSorted(S, Index) else begin - { Linear search for unsorted list } + I := 0; while I < Self.FCount do begin @@ -458,7 +561,7 @@ begin ODst^ := OSrc^; I := I + 1 end; - { Release the last (duplicate) string slot and clear the object slot } + SDst := Self.FStrings + (Self.FCount - 1) * SizeOf(string); SDst^ := nil; ODst := Self.FObjects + (Self.FCount - 1) * SizeOf(Pointer); @@ -493,7 +596,7 @@ var begin if Self.FCount = Self.FCapacity then Self.Grow; - { Shift elements right from FCount-1 down to AIndex } + I := Self.FCount; while I > AIndex do begin @@ -505,10 +608,10 @@ begin ODst^ := OSrc^; I := I - 1 end; - { Zero the source slot that was shifted (now duplicated at AIndex+1) } + SSrc := Self.FStrings + AIndex * SizeOf(string); - SSrc^ := nil; { release the "old" value ARC wrote there during shift } - { Write the new string at AIndex } + SSrc^ := nil; + Ptr := Self.FStrings + AIndex * SizeOf(string); OPtr := Self.FObjects + AIndex * SizeOf(Pointer); Ptr^ := S; @@ -516,6 +619,18 @@ begin Self.FCount := Self.FCount + 1 end; +procedure TStringList.AddStrings(ASource: TStringList); +var + I: Integer; +begin + I := 0; + while I < ASource.FCount do + begin + Self.Add(ASource.Get(I)); + I := I + 1 + end; +end; + function TStringList.GetText: string; var I: Integer; @@ -529,7 +644,7 @@ begin begin Ptr := Self.FStrings + I * SizeOf(string); Result := Result + Sep + Ptr^; - Sep := #13#10; + Sep := #10; I := I + 1 end end; @@ -583,26 +698,26 @@ begin Result := KwList.Find(AText, Idx) end; -{ - Blaise - An Object Pascal Compiler - Copyright (c) 2026 Graeme Geldenhuys - SPDX-License-Identifier: BSD-3-Clause - See LICENSE file in the project root for full license terms. -} -{ - Clean Pascal Compiler — General Pascal Tokeniser - Lightweight Object Pascal tokeniser. Operates on a string buffer and - yields tokens one at a time via NextToken. No exceptions on malformed - source — unrecognised characters produce fptkSymbol tokens of length 1, - and unterminated strings or comments consume to end-of-source. - Does NOT evaluate compiler directives or IFDEF branches — everything - is tokenised literally. - Ported from the fpGUI IDE tokeniser (same author). -} + + + + + + + + + + + + + + + + @@ -623,20 +738,20 @@ type TFpgPasToken = record Kind: TFpgPasTokenKind; - Line: Integer; { 1-based line number } - Column: Integer; { 1-based column } - Len: Integer; { character length in source } - TextStart: Integer; { 1-based index into source string } + Line: Integer; + Column: Integer; + Len: Integer; + TextStart: Integer; end; - { TFpgPascalTokeniser } + TFpgPascalTokeniser = class(TObject) FSource: string; FPos: Integer; FLine: Integer; - FLineStart: Integer; { FPos value at start of current line } + FLineStart: Integer; FToken: TFpgPasToken; function Peek: Integer; function PeekAt(AOffset: Integer): Integer; @@ -661,7 +776,7 @@ type property Source: string read FSource; end; -{ Returns True if AText is a Pascal keyword (case-insensitive). } + function PasIsKeyword(const AText: string): Boolean; @@ -674,11 +789,11 @@ begin Result := BinarySearchKeyword(UpperCase(AText)); end; -{ TFpgPascalTokeniser } + procedure TFpgPascalTokeniser.Create; begin - inherited Create; + FSource := ''; FPos := 1; FLine := 1; @@ -739,9 +854,9 @@ end; procedure TFpgPascalTokeniser.ReadLineEnding; begin FToken.Kind := fptkLineEnding; - if (OrdAt(FSource, FPos) = 13) and (PeekAt(1) = #10) then - Advance; { consume CR of CRLF } - Advance; { consume LF (or lone CR) } + if (OrdAt(FSource, FPos) = 13) and (PeekAt(1) = 10) then + Advance; + Advance; FToken.Len := FPos - FToken.TextStart; AdvanceLine; end; @@ -767,7 +882,7 @@ begin if c = 36 then begin - { Hex: $[0-9A-Fa-f]+ } + Advance; while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)) or ((OrdAt(FSource, FPos) >= 65) and (OrdAt(FSource, FPos) <= 70)) or ((OrdAt(FSource, FPos) >= 97) and (OrdAt(FSource, FPos) <= 102)))) do @@ -778,7 +893,7 @@ begin if c = 37 then begin - { Binary: %[01]+ } + Advance; while (FPos <= Length(FSource)) and (((OrdAt(FSource, FPos) = 48) or (OrdAt(FSource, FPos) = 49))) do Advance; @@ -788,7 +903,7 @@ begin if c = 38 then begin - { Octal: &[0-7]+ } + Advance; while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 55)))) do Advance; @@ -796,20 +911,20 @@ begin Exit; end; - { Decimal integer or float } + while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)))) do Advance; - { Check for decimal point (but not '..') } + if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 46) and - (PeekAt(1) <> '.') then + (PeekAt(1) <> 46) then begin - Advance; { consume '.' } + Advance; while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)))) do Advance; end; - { Check for exponent } + if (FPos <= Length(FSource)) and (((OrdAt(FSource, FPos) = 101) or (OrdAt(FSource, FPos) = 69))) then begin Advance; @@ -826,12 +941,12 @@ procedure TFpgPascalTokeniser.ReadString; var c: Integer; begin - { Pascal string literals can be composed of: - - 'quoted text' (with '' for embedded quotes) - - #nn (decimal char code) - - #$nn (hex char code) - - ^A (control char) - These can be concatenated without operators: 'abc'#13#10'def' } + + + + + + FToken.Kind := fptkString; while True do @@ -839,30 +954,30 @@ begin c := Peek; if c = 39 then begin - Advance; { opening quote } + Advance; while FPos <= Length(FSource) do begin if OrdAt(FSource, FPos) = 39 then begin Advance; - { Embedded quote? '' } + if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 39) then Advance else - Break; { closing quote } + Break; end else if ((OrdAt(FSource, FPos) = 10) or (OrdAt(FSource, FPos) = 13)) then - Break { unterminated string at line end } + Break else Advance; end; end else if c = 35 then begin - Advance; { consume # } + Advance; if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 36) then begin - Advance; { hex char code } + Advance; while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)) or ((OrdAt(FSource, FPos) >= 65) and (OrdAt(FSource, FPos) <= 70)) or ((OrdAt(FSource, FPos) >= 97) and (OrdAt(FSource, FPos) <= 102)))) do Advance; @@ -875,26 +990,25 @@ begin end else if c = 94 then begin - Advance; { consume ^ } + Advance; if (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 65) and (OrdAt(FSource, FPos) <= 90)) or ((OrdAt(FSource, FPos) >= 97) and (OrdAt(FSource, FPos) <= 122)))) then Advance; end else - Break; { not a string continuation } - end; - - FToken.Len := FPos - FToken.TextStart; + Break; + if False then break; +end; FToken.Len := FPos - FToken.TextStart; end; procedure TFpgPascalTokeniser.ReadBraceCommentOrDirective; begin - // Already at open-brace. Check next char for '$'. - if PeekAt(1) = '$' then + + if PeekAt(1) = 36 then FToken.Kind := fptkDirective else FToken.Kind := fptkComment; - Advance; // consume open-brace + Advance; while FPos <= Length(FSource) do begin if OrdAt(FSource, FPos) = 125 then @@ -922,20 +1036,20 @@ end; procedure TFpgPascalTokeniser.ReadParenStarCommentOrDirective; begin - { Already at '('. Next is '*'. Check char after '*' for '$'. } - if PeekAt(2) = '$' then + + if PeekAt(2) = 36 then FToken.Kind := fptkDirective else FToken.Kind := fptkComment; - Advance; { consume '(' } - Advance; { consume '*' } + Advance; + Advance; while FPos <= Length(FSource) do begin - if (OrdAt(FSource, FPos) = 42) and (PeekAt(1) = ')') then + if (OrdAt(FSource, FPos) = 42) and (PeekAt(1) = 41) then begin - Advance; { consume '*' } - Advance; { consume ')' } + Advance; + Advance; Break; end else if OrdAt(FSource, FPos) = 13 then @@ -959,7 +1073,7 @@ end; procedure TFpgPascalTokeniser.ReadLineComment; begin FToken.Kind := fptkComment; - { Consume everything until end of line or end of source } + while (FPos <= Length(FSource)) and not (((OrdAt(FSource, FPos) = 10) or (OrdAt(FSource, FPos) = 13))) do Advance; @@ -976,18 +1090,18 @@ begin Advance; case c of - ':': if c2 = 61 then Advance; // := - '<': if ((c2 = 62) or (c2 = 61)) then Advance; // <> or <= - '>': if ((c2 = 60) or (c2 = 61)) then Advance; // >< or >= - '.': if c2 = 46 then Advance; // .. - '*': if c2 = 42 then Advance; // ** - '@': if c2 = 64 then Advance; // @@ - '+': if c2 = 61 then Advance; // += - '-': if c2 = 61 then Advance; // -= - '/': if c2 = 61 then Advance; // /= (// handled separately) + 58: if c2 = 61 then Advance; + 60: if ((c2 = 62) or (c2 = 61)) then Advance; + 62: if ((c2 = 60) or (c2 = 61)) then Advance; + 46: if c2 = 46 then Advance; + 42: if c2 = 42 then Advance; + 64: if c2 = 64 then Advance; + 43: if c2 = 61 then Advance; + 45: if c2 = 61 then Advance; + 47: if c2 = 61 then Advance; end; - // Special: *= (if * was not followed by *) + if (c = 42) and (c2 <> 42) and (c2 = 61) then Advance; @@ -1009,14 +1123,14 @@ begin Exit; end; - { Record token start position } + FToken.TextStart := FPos; FToken.Line := FLine; FToken.Column := FPos - FLineStart + 1; c := OrdAt(FSource, FPos); - { Whitespace (not line endings) } + if ((c = 32) or (c = 9)) then begin ReadWhitespace; @@ -1024,7 +1138,7 @@ begin Exit; end; - { Line endings } + if ((c = 13) or (c = 10)) then begin ReadLineEnding; @@ -1032,7 +1146,7 @@ begin Exit; end; - { Identifiers and keywords } + if (((c >= 65) and (c <= 90)) or ((c >= 97) and (c <= 122)) or (c = 95)) then begin ReadIdentifierOrKeyword; @@ -1040,7 +1154,7 @@ begin Exit; end; - { Numbers: digits or $ (hex) or % (binary) or & (octal) } + if (((c >= 48) and (c <= 57))) then begin ReadNumber; @@ -1066,7 +1180,7 @@ begin Exit; end; - { Strings: ' or # — Clean Pascal does not support ^X control-char string escapes } + if ((c = 39) or (c = 35)) then begin ReadString; @@ -1074,7 +1188,7 @@ begin Exit; end; - { Comments and directives } + if c = 123 then begin ReadBraceCommentOrDirective; @@ -1098,7 +1212,7 @@ begin Exit; end; - { Symbols and operators } + ReadSymbol; Result := FToken; end; @@ -1119,3 +1233,11312 @@ end; + +{ === uLexer === } + + + + + + + + + + + + + + + + +type + TTokenKind = ( + tkEOF, + + tkIntLit, + tkStringLit, + + tkProgram, + tkUses, + tkType, + tkRecord, + tkClass, + tkProcedure, + tkFunction, + tkVar, + tkBegin, + tkEnd, + tkIf, + tkThen, + tkElse, + tkWhile, + tkDo, + tkFor, + tkTo, + tkDownto, + tkTry, + tkFinally, + tkExcept, + tkRaise, + tkNil, + tkUnit, + tkIntf, + tkImplementation, + tkVirtual, + tkOverride, + tkIs, + tkAs, + tkAnd, + tkOr, + tkNot, + tkExit, + tkBreak, + tkContinue, + tkInherited, + tkCase, + tkOf, + tkConst, + + tkIdent, + + tkPlus, + tkMinus, + tkStar, + tkSlash, + tkDiv, + + tkAssign, + tkEquals, + tkNotEquals, + tkLessThan, + tkGreaterThan, + tkLessEqual, + tkGreaterEqual, + tkColon, + + tkLParen, + tkRParen, + tkLBracket, + tkRBracket, + tkComma, + tkSemicolon, + tkDot, + tkCaret + ); + + TToken = record + Kind: TTokenKind; + Value: string; + Line: Integer; + Col: Integer; + end; + + TLexer = class + + FTok: TFpgPascalTokeniser; + function MapKeyword(const AUpper: string): TTokenKind; + function UnescapeString(const ARaw: string): string; + + procedure Create(const ASource: string); + procedure Destroy; + function Next: TToken; + end; + + +procedure TLexer.Create(const ASource: string); +begin + + FTok := TFpgPascalTokeniser.Create; + FTok.SetSource(ASource); +end; + +procedure TLexer.Destroy; +begin + FTok.Free; + +end; + +function TLexer.MapKeyword(const AUpper: string): TTokenKind; +begin + if AUpper = 'PROGRAM' then Result := tkProgram + else if AUpper = 'USES' then Result := tkUses + else if AUpper = 'VAR' then Result := tkVar + else if AUpper = 'BEGIN' then Result := tkBegin + 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 = 'PROCEDURE' then Result := tkProcedure + else if AUpper = 'FUNCTION' then Result := tkFunction + else if AUpper = 'DIV' then Result := tkDiv + else if AUpper = 'IF' then Result := tkIf + else if AUpper = 'THEN' then Result := tkThen + else if AUpper = 'ELSE' then Result := tkElse + else if AUpper = 'WHILE' then Result := tkWhile + else if AUpper = 'DO' then Result := tkDo + else if AUpper = 'FOR' then Result := tkFor + else if AUpper = 'TO' then Result := tkTo + else if AUpper = 'DOWNTO' then Result := tkDownto + else if AUpper = 'TRY' then Result := tkTry + else if AUpper = 'FINALLY' then Result := tkFinally + else if AUpper = 'EXCEPT' then Result := tkExcept + else if AUpper = 'RAISE' then Result := tkRaise + else if AUpper = 'NIL' then Result := tkNil + else if AUpper = 'UNIT' then Result := tkUnit + else if AUpper = 'INTERFACE' then Result := tkIntf + else if AUpper = 'IMPLEMENTATION' then Result := tkImplementation + else if AUpper = 'VIRTUAL' then Result := tkVirtual + else if AUpper = 'OVERRIDE' then Result := tkOverride + else if AUpper = 'IS' then Result := tkIs + else if AUpper = 'AS' then Result := tkAs + else if AUpper = 'AND' then Result := tkAnd + else if AUpper = 'OR' then Result := tkOr + else if AUpper = 'NOT' then Result := tkNot + else if AUpper = 'EXIT' then Result := tkExit + else if AUpper = 'BREAK' then Result := tkBreak + else if AUpper = 'CONTINUE' then Result := tkContinue + else if AUpper = 'CASE' then Result := tkCase + else if AUpper = 'OF' then Result := tkOf + else if AUpper = 'CONST' then Result := tkConst + else if AUpper = 'INHERITED' then Result := tkInherited + else + Result := tkIdent; +end; + +function TLexer.UnescapeString(const ARaw: string): string; + + + + +var + I, Len: Integer; +begin + Result := ''; + Len := Length(ARaw); + if (Len >= 2) and (OrdAt(ARaw, 1) = 39) then + begin + I := 2; + while I <= Len do + begin + if OrdAt(ARaw, I) = 39 then + begin + if (I < Len) and (OrdAt(ARaw, I + 1) = 39) then + begin + Result := Result + ''''; + I := I + 2; + end + else + I := I + 1; + end + else + begin + Result := Result + Copy(ARaw, I, 1); + I := I + 1; + end; + end; + end; +end; + +function TLexer.Next: TToken; +var + raw: TFpgPasToken; + text: string; +begin + while True do +begin + raw := FTok.NextToken; + if not (((raw.Kind = fptkWhitespace) or (raw.Kind = fptkLineEnding) or (raw.Kind = fptkComment) or (raw.Kind = fptkDirective))) then break; +end; Result.Line := raw.Line; + Result.Col := raw.Column; + + case raw.Kind of + fptkEOF: + begin + Result.Kind := tkEOF; + Result.Value := ''; + end; + + fptkKeyword: + begin + text := FTok.TokenTextUpper; + Result.Kind := MapKeyword(text); + Result.Value := FTok.TokenText; + end; + + fptkIdentifier: + begin + text := FTok.TokenTextUpper; + if text = 'VIRTUAL' then Result.Kind := tkVirtual + else if text = 'OVERRIDE' then Result.Kind := tkOverride + else if text = 'EXIT' then Result.Kind := tkExit + else if text = 'BREAK' then Result.Kind := tkBreak + else if text = 'CONTINUE' then Result.Kind := tkContinue + else if text = 'CASE' then Result.Kind := tkCase + else if text = 'OF' then Result.Kind := tkOf + else if text = 'CONST' then Result.Kind := tkConst + else Result.Kind := tkIdent; + Result.Value := FTok.TokenText; + end; + + fptkNumber: + begin + Result.Kind := tkIntLit; + Result.Value := FTok.TokenText; + end; + + fptkString: + begin + Result.Kind := tkStringLit; + Result.Value := UnescapeString(FTok.TokenText); + end; + + fptkSymbol: + begin + text := FTok.TokenText; + if text = ':=' then Result.Kind := tkAssign + else if text = '=' then Result.Kind := tkEquals + else if text = '<>' then Result.Kind := tkNotEquals + else if text = '<=' then Result.Kind := tkLessEqual + else if text = '>=' then Result.Kind := tkGreaterEqual + else if text = '<' then Result.Kind := tkLessThan + else if text = '>' then Result.Kind := tkGreaterThan + else if text = ':' then Result.Kind := tkColon + else if text = '(' then Result.Kind := tkLParen + else if text = ')' then Result.Kind := tkRParen + else if text = '[' then Result.Kind := tkLBracket + else if text = ']' then Result.Kind := tkRBracket + else if text = ',' then Result.Kind := tkComma + else if text = ';' then Result.Kind := tkSemicolon + else if text = '.' then Result.Kind := tkDot + else if text = '+' then Result.Kind := tkPlus + else if text = '-' then Result.Kind := tkMinus + else if text = '*' then Result.Kind := tkStar + else if text = '/' then Result.Kind := tkSlash + else if text = '^' then Result.Kind := tkCaret + else + raise Exception.Create(Format('Unexpected symbol ''%s'' at line %d col %d', text, raw.Line, raw.Column)); + Result.Value := text; + end; + + else + raise Exception.Create(Format('Unexpected token kind %d at line %d col %d', raw.Kind, raw.Line, raw.Column)); + end; +end; + + + + +{ === uSymbolTable === } + + + + + + + + + + + + +type + + + + + TTypeKind = ( + tyInteger, + tyInt64, + tyUInt32, + tyByte, + tyBoolean, + tyString, + tyRecord, + tyClass, + tyInterface, + tyVoid, + tyNil, + tyPointer, + tyEnum + ); + + TTypeDesc = class + + Kind: TTypeKind; + Name: string; + function IsNumeric: Boolean; + function IsString: Boolean; + function IsOrdinal: Boolean; + function IsRecord: Boolean; + + function ByteSize: Integer; + + function AllocAlign: Integer; + end; + + + + TPointerTypeDesc = class(TTypeDesc) + + BaseType: TTypeDesc; + end; + + + + + TEnumTypeDesc = class(TTypeDesc) + + Members: TStringList; + procedure Create(const AName: string); + procedure Destroy; + function OrdinalOf(const AMember: string): Integer; + end; + + + TFieldInfo = class + + Name: string; + TypeDesc: TTypeDesc; + Offset: Integer; + IsWeak: Boolean; + + + end; + + + TVTableEntry = class + + Slot: Integer; + MethName: string; + ImplName: string; + end; + + TPropertyInfo = class + + Name: string; + TypeDesc: TTypeDesc; + ReadField: string; + ReadMethod: string; + WriteField: string; + WriteMethod: string; + end; + + + TRecordTypeDesc = class(TTypeDesc) + + FFields: TObjectList; + FKeys: TStringList; + FParent: TRecordTypeDesc; + FVTable: TObjectList; + FImplements: TObjectList; + FProperties: TObjectList; + FHasDestroyMethod: Boolean; + + procedure Create(const AName: string; AKind: TTypeKind); + procedure Destroy; + procedure AddField(const AName: string; AType: TTypeDesc); + function FindField(const AName: string): TFieldInfo; + function TotalSize: Integer; + function MaxAlign: Integer; + + + function HasVTable: Boolean; + function VTableCount: Integer; + function VTableEntryAt(ASlot: Integer): TVTableEntry; + function FindVTableSlot(const AMethodName: string): Integer; + function AddVTableSlot(const AMethodName, AImplName: string): Integer; + procedure OverrideVTableSlot(ASlot: Integer; const AImplName: string); + procedure CopyVTableFrom(AParent: TRecordTypeDesc); + + + procedure AddImplements(AIntf: TInterfaceTypeDesc); + function ImplementsCount: Integer; + function ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc; + + + procedure AddProperty(AProp: TPropertyInfo); + function FindProperty(const AName: string): TPropertyInfo; + + property Fields: TObjectList read FFields; + property Parent: TRecordTypeDesc read FParent write FParent; + property HasDestroyMethod: Boolean + read FHasDestroyMethod write FHasDestroyMethod; + end; + + + TInterfaceTypeDesc = class(TTypeDesc) + + FMethods: TStringList; + FReturnTypes: TStringList; + FParent: TInterfaceTypeDesc; + + procedure Create(const AName: string); + procedure Destroy; + procedure AddMethod(const AName: string; + const AReturnTypeName: string); + function HasMethod(const AName: string): Boolean; + function MethodCount: Integer; + function MethodName(AIndex: Integer): string; + function MethodReturnTypeName(AIndex: Integer): string; + function MethodIndex(const AName: string): Integer; + property Parent: TInterfaceTypeDesc read FParent write FParent; + end; + + + + + + TSymbolKind = ( + skVariable, + skType, + skProcedure, + skFunction, + skParameter, + skVarParameter, + skConstant + ); + + TParamDesc = class + + Name: string; + TypeDesc: TTypeDesc; + IsConst: Boolean; + IsVar: Boolean; + end; + + TSymbol = class + + Name: string; + Kind: TSymbolKind; + TypeDesc: TTypeDesc; + Params: TObjectList; + ConstValue: Int64; + IsWeak: Boolean; + + + IsGlobal: Boolean; + + procedure Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc); + procedure Destroy; + end; + + + + + + TScope = class + + FParent: TScope; + FSymbols: TObjectList; + FKeys: TStringList; + + procedure Create(AParent: TScope); + procedure Destroy; + property Parent: TScope read FParent; + + function Define(ASymbol: TSymbol): Boolean; + function LookupLocal(const AName: string): TSymbol; + function Lookup(const AName: string): TSymbol; + end; + + + + + + TSymbolTable = class + + FScopeStack: TObjectList; + FAllTypes: TObjectList; + FGenerics: TStringList; + + FTypeInteger: TTypeDesc; + FTypeInt64: TTypeDesc; + FTypeUInt32: TTypeDesc; + FTypeByte: TTypeDesc; + FTypeBoolean: TTypeDesc; + FTypeString: TTypeDesc; + FTypeVoid: TTypeDesc; + FTypeNil: TTypeDesc; + FTypePointer: TPointerTypeDesc; + + function GetCurrentScope: TScope; + function GetScopeDepth: Integer; + function NewType(AKind: TTypeKind; const AName: string): TTypeDesc; + procedure RegisterBuiltins; + + procedure Create; + procedure Destroy; + + + function PushScope: TScope; + procedure PopScope; + property CurrentScope: TScope read GetCurrentScope; + property ScopeDepth: Integer read GetScopeDepth; + + + function Define(ASymbol: TSymbol): Boolean; + + function DefineGlobal(ASymbol: TSymbol): Boolean; + function Lookup(const AName: string): TSymbol; + + + function FindType(const AName: string): TTypeDesc; + + + + function NewRecordType(const AName: string): TRecordTypeDesc; + + + function NewClassType(const AName: string): TRecordTypeDesc; + + + function NewInterfaceType(const AName: string): TInterfaceTypeDesc; + + + function NewPointerType(const AName: string; ABase: TTypeDesc): TPointerTypeDesc; + function NewEnumType(const AName: string): TEnumTypeDesc; + + + + procedure RegisterGeneric(const AName: string; ATempl: TObject); + function FindGeneric(const AName: string): TObject; + + + property TypeInteger: TTypeDesc read FTypeInteger; + property TypeInt64: TTypeDesc read FTypeInt64; + property TypeUInt32: TTypeDesc read FTypeUInt32; + property TypeByte: TTypeDesc read FTypeByte; + property TypeBoolean: TTypeDesc read FTypeBoolean; + property TypeString: TTypeDesc read FTypeString; + property TypeVoid: TTypeDesc read FTypeVoid; + property TypeNil: TTypeDesc read FTypeNil; + property TypePointer: TPointerTypeDesc read FTypePointer; + end; + + + + + + +function TTypeDesc.IsNumeric: Boolean; +begin + Result := ((Kind = tyInteger) or (Kind = tyInt64) or (Kind = tyUInt32) or (Kind = tyByte) or (Kind = tyEnum)); +end; + +function TTypeDesc.IsString: Boolean; +begin + Result := Kind = tyString; +end; + +function TTypeDesc.IsOrdinal: Boolean; +begin + Result := ((Kind = tyInteger) or (Kind = tyInt64) or (Kind = tyUInt32) or (Kind = tyByte) or (Kind = tyBoolean) or (Kind = tyEnum)); +end; + +function TTypeDesc.IsRecord: Boolean; +begin + Result := Kind = tyRecord; +end; + +function TTypeDesc.ByteSize: Integer; +begin + case Kind of + tyInteger, tyUInt32, tyEnum: Result := 4; + tyInt64: Result := 8; + tyByte, tyBoolean: Result := 1; + tyString: Result := 8; + tyRecord: Result := TRecordTypeDesc(Self).TotalSize; + tyNil: Result := 8; + else + Result := 8; + end; +end; + +function TTypeDesc.AllocAlign: Integer; +begin + case Kind of + tyInteger, tyUInt32, tyEnum: Result := 4; + tyByte, tyBoolean: Result := 4; + tyInt64, tyString: Result := 8; + tyRecord: Result := TRecordTypeDesc(Self).MaxAlign; + else + Result := 8; + end; +end; + + + + + +procedure TRecordTypeDesc.Create(const AName: string; AKind: TTypeKind); +begin + + Kind := AKind; + Name := AName; + FFields := TObjectList.Create(True); + FKeys := TStringList.Create; + FKeys.Sorted := True; + FKeys.CaseSensitive := False; + FKeys.Duplicates := 1; + FVTable := nil; + FImplements := TObjectList.Create(False); + FProperties := TObjectList.Create(True); +end; + +procedure TRecordTypeDesc.Destroy; +begin + FProperties.Free; + FImplements.Free; + FKeys.Free; + FFields.Free; + FVTable.Free; + +end; + +procedure TRecordTypeDesc.AddField(const AName: string; AType: TTypeDesc); +var + Info: TFieldInfo; + Offset: Integer; +begin + Offset := TotalSize; + Info := TFieldInfo.Create; + Info.Name := AName; + Info.TypeDesc := AType; + Info.Offset := Offset; + FFields.Add(Info); + FKeys.AddObject(AName, Info); +end; + +function TRecordTypeDesc.FindField(const AName: string): TFieldInfo; +var + Idx: Integer; +begin + if FKeys.Find(AName, Idx) then + Result := TFieldInfo(FKeys.GetObject(Idx)) + else + Result := nil; +end; + +function TRecordTypeDesc.TotalSize: Integer; +var + I: Integer; +begin + + if HasVTable then + Result := 8 + else + Result := 0; + for I := 0 to FFields.Count - 1 do + Result := Result + TFieldInfo(FFields.Get(I)).TypeDesc.ByteSize; +end; + +function TRecordTypeDesc.MaxAlign: Integer; +var + I, A: Integer; +begin + Result := 4; + if HasVTable then + Result := 8; + for I := 0 to FFields.Count - 1 do + begin + A := TFieldInfo(FFields.Get(I)).TypeDesc.AllocAlign; + if A > Result then + Result := A; + end; +end; + +function TRecordTypeDesc.HasVTable: Boolean; +begin + Result := (FVTable <> nil) and (FVTable.Count > 0); +end; + +function TRecordTypeDesc.VTableCount: Integer; +begin + if FVTable = nil then + Result := 0 + else + Result := FVTable.Count; +end; + +function TRecordTypeDesc.VTableEntryAt(ASlot: Integer): TVTableEntry; +begin + if (FVTable = nil) or (ASlot < 0) or (ASlot >= FVTable.Count) then + Result := nil + else + Result := TVTableEntry(FVTable.Get(ASlot)); +end; + +function TRecordTypeDesc.FindVTableSlot(const AMethodName: string): Integer; +var + I: Integer; + E: TVTableEntry; +begin + Result := -1; + if FVTable = nil then Exit; + for I := 0 to FVTable.Count - 1 do + begin + E := TVTableEntry(FVTable.Get(I)); + if SameText(E.MethName, AMethodName) then + begin + Result := I; + Exit; + end; + end; +end; + +function TRecordTypeDesc.AddVTableSlot(const AMethodName, AImplName: string): Integer; +var + E: TVTableEntry; +begin + if FVTable = nil then + FVTable := TObjectList.Create(True); + E := TVTableEntry.Create; + E.Slot := FVTable.Count; + E.MethName := AMethodName; + E.ImplName := AImplName; + FVTable.Add(E); + Result := E.Slot; +end; + +procedure TRecordTypeDesc.OverrideVTableSlot(ASlot: Integer; const AImplName: string); +var + E: TVTableEntry; +begin + if (FVTable <> nil) and (ASlot >= 0) and (ASlot < FVTable.Count) then + begin + E := TVTableEntry(FVTable.Get(ASlot)); + E.ImplName := AImplName; + end; +end; + +procedure TRecordTypeDesc.AddImplements(AIntf: TInterfaceTypeDesc); +begin + FImplements.Add(AIntf); +end; + +function TRecordTypeDesc.ImplementsCount: Integer; +begin + Result := FImplements.Count; +end; + +function TRecordTypeDesc.ImplementsIntfAt(AIndex: Integer): TInterfaceTypeDesc; +begin + Result := TInterfaceTypeDesc(FImplements.Get(AIndex)); +end; + +procedure TRecordTypeDesc.CopyVTableFrom(AParent: TRecordTypeDesc); +var + I: Integer; + Src, Dst: TVTableEntry; +begin + if (AParent = nil) or (AParent.VTableCount = 0) then Exit; + if FVTable = nil then + FVTable := TObjectList.Create(True); + for I := 0 to AParent.VTableCount - 1 do + begin + Src := AParent.VTableEntryAt(I); + Dst := TVTableEntry.Create; + Dst.Slot := Src.Slot; + Dst.MethName := Src.MethName; + Dst.ImplName := Src.ImplName; + FVTable.Add(Dst); + end; +end; + + + + + +procedure TRecordTypeDesc.AddProperty(AProp: TPropertyInfo); +begin + FProperties.Add(AProp); +end; + +function TRecordTypeDesc.FindProperty(const AName: string): TPropertyInfo; +var + I: Integer; +begin + for I := 0 to FProperties.Count - 1 do + if SameText(TPropertyInfo(FProperties.Get(I)).Name, AName) then + begin + Result := TPropertyInfo(FProperties.Get(I)); + Exit; + end; + Result := nil; +end; + +procedure TInterfaceTypeDesc.Create(const AName: string); +begin + + Kind := tyInterface; + Name := AName; + FMethods := TStringList.Create; + FMethods.CaseSensitive := False; + FReturnTypes := TStringList.Create; + FParent := nil; +end; + +procedure TInterfaceTypeDesc.Destroy; +begin + FReturnTypes.Free; + FMethods.Free; + +end; + +procedure TInterfaceTypeDesc.AddMethod(const AName: string; + const AReturnTypeName: string); +begin + FMethods.Add(AName); + FReturnTypes.Add(AReturnTypeName); +end; + +function TInterfaceTypeDesc.HasMethod(const AName: string): Boolean; +begin + Result := FMethods.IndexOf(AName) >= 0; +end; + +function TInterfaceTypeDesc.MethodCount: Integer; +begin + Result := FMethods.Count; +end; + +function TInterfaceTypeDesc.MethodName(AIndex: Integer): string; +begin + Result := FMethods.Get(AIndex); +end; + +function TInterfaceTypeDesc.MethodReturnTypeName(AIndex: Integer): string; +begin + Result := FReturnTypes.Get(AIndex); +end; + +function TInterfaceTypeDesc.MethodIndex(const AName: string): Integer; +begin + Result := FMethods.IndexOf(AName); +end; + + + + + +procedure TSymbol.Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc); +begin + + Name := AName; + Kind := AKind; + TypeDesc := AType; + Params := TObjectList.Create(True); + IsWeak := False; +end; + +procedure TSymbol.Destroy; +begin + Params.Free; + +end; + + + + + +procedure TScope.Create(AParent: TScope); +begin + + FParent := AParent; + FSymbols := TObjectList.Create(True); + FKeys := TStringList.Create; + FKeys.Sorted := True; + FKeys.CaseSensitive := False; + FKeys.Duplicates := 1; +end; + +procedure TScope.Destroy; +begin + FKeys.Free; + FSymbols.Free; + +end; + +function TScope.Define(ASymbol: TSymbol): Boolean; +var + Idx: Integer; +begin + if FKeys.Find(ASymbol.Name, Idx) then + begin + Result := False; + Exit; + end; + FSymbols.Add(ASymbol); + + FKeys.AddObject(ASymbol.Name, ASymbol); + Result := True; +end; + +function TScope.LookupLocal(const AName: string): TSymbol; +var + Idx: Integer; +begin + if FKeys.Find(AName, Idx) then + Result := TSymbol(FKeys.GetObject(Idx)) + else + Result := nil; +end; + +function TScope.Lookup(const AName: string): TSymbol; +var + S: TScope; +begin + S := Self; + while S <> nil do + begin + Result := S.LookupLocal(AName); + if Result <> nil then + Exit; + S := S.FParent; + end; + Result := nil; +end; + + + + + +procedure TEnumTypeDesc.Create(const AName: string); +begin + + Kind := tyEnum; + Name := AName; + Members := TStringList.Create; +end; + +procedure TEnumTypeDesc.Destroy; +begin + Members.Free; + +end; + +function TEnumTypeDesc.OrdinalOf(const AMember: string): Integer; +var + I: Integer; +begin + for I := 0 to Members.Count - 1 do + if SameText(Members.Get(I), AMember) then + begin + Result := I; + Exit; + end; + Result := -1; +end; + + + + + +procedure TSymbolTable.Create; +begin + + FScopeStack := TObjectList.Create(True); + FAllTypes := TObjectList.Create(True); + FGenerics := TStringList.Create; + FGenerics.CaseSensitive := True; + + FScopeStack.Add(TScope.Create(nil)); + RegisterBuiltins; +end; + +procedure TSymbolTable.Destroy; +begin + FGenerics.Free; + FScopeStack.Free; + FAllTypes.Free; + +end; + +function TSymbolTable.NewType(AKind: TTypeKind; const AName: string): TTypeDesc; +begin + Result := TTypeDesc.Create; + Result.Kind := AKind; + Result.Name := AName; + FAllTypes.Add(Result); +end; + +function TSymbolTable.NewRecordType(const AName: string): TRecordTypeDesc; +begin + Result := TRecordTypeDesc.Create(AName, tyRecord); + FAllTypes.Add(Result); +end; + +function TSymbolTable.NewClassType(const AName: string): TRecordTypeDesc; +begin + Result := TRecordTypeDesc.Create(AName, tyClass); + FAllTypes.Add(Result); +end; + +function TSymbolTable.NewInterfaceType(const AName: string): TInterfaceTypeDesc; +begin + Result := TInterfaceTypeDesc.Create(AName); + FAllTypes.Add(Result); +end; + +function TSymbolTable.NewPointerType(const AName: string; ABase: TTypeDesc): TPointerTypeDesc; +begin + Result := TPointerTypeDesc.Create; + Result.Kind := tyPointer; + Result.Name := AName; + Result.BaseType := ABase; + FAllTypes.Add(Result); +end; + +function TSymbolTable.NewEnumType(const AName: string): TEnumTypeDesc; +begin + Result := TEnumTypeDesc.Create(AName); + FAllTypes.Add(Result); +end; + +procedure TSymbolTable.RegisterGeneric(const AName: string; ATempl: TObject); +begin + FGenerics.AddObject(AName, ATempl); +end; + +function TSymbolTable.FindGeneric(const AName: string): TObject; +var + Idx: Integer; +begin + Idx := FGenerics.IndexOf(AName); + if Idx >= 0 then + Result := FGenerics.GetObject(Idx) + else + Result := nil; +end; + +procedure TSymbolTable.RegisterBuiltins; +var + Sym: TSymbol; +begin + + FTypeInteger := NewType(tyInteger, 'Integer'); + FTypeInt64 := NewType(tyInt64, 'Int64'); + FTypeUInt32 := NewType(tyUInt32, 'UInt32'); + FTypeByte := NewType(tyByte, 'Byte'); + FTypeBoolean := NewType(tyBoolean, 'Boolean'); + FTypeString := NewType(tyString, 'string'); + FTypeVoid := NewType(tyVoid, 'void'); + FTypeNil := NewType(tyNil, 'nil'); + FTypePointer := NewPointerType('Pointer', nil); + + + Define(TSymbol.Create('Integer', skType, FTypeInteger)); + Define(TSymbol.Create('Int64', skType, FTypeInt64)); + Define(TSymbol.Create('UInt32', skType, FTypeUInt32)); + Define(TSymbol.Create('Byte', skType, FTypeByte)); + Define(TSymbol.Create('Boolean', skType, FTypeBoolean)); + Define(TSymbol.Create('string', skType, FTypeString)); + Define(TSymbol.Create('Pointer', skType, FTypePointer)); + + + Define(TSymbol.Create('TObject', skType, NewClassType('TObject'))); + + + Define(TSymbol.Create('IInterface', skType, NewInterfaceType('IInterface'))); + + + Sym := TSymbol.Create('True', skConstant, FTypeBoolean); + Sym.ConstValue := 1; + Define(Sym); + Sym := TSymbol.Create('False', skConstant, FTypeBoolean); + Sym.ConstValue := 0; + Define(Sym); + + + Sym := TSymbol.Create('Write', skProcedure, nil); + Define(Sym); + Sym := TSymbol.Create('WriteLn', skProcedure, nil); + Define(Sym); + + + Sym := TSymbol.Create('GetMem', skFunction, FTypePointer); + Define(Sym); + Sym := TSymbol.Create('ReallocMem', skFunction, FTypePointer); + Define(Sym); + Sym := TSymbol.Create('FreeMem', skProcedure, nil); + Define(Sym); + + + Sym := TSymbol.Create('Format', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('Length', skFunction, FTypeInteger); + Define(Sym); + Sym := TSymbol.Create('Pos', skFunction, FTypeInteger); + Define(Sym); + Sym := TSymbol.Create('Copy', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('UpperCase', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('LowerCase', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('Trim', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('SameText', skFunction, FTypeBoolean); + Define(Sym); + Sym := TSymbol.Create('IntToStr', skFunction, FTypeString); + Define(Sym); + Sym := TSymbol.Create('StrToInt', skFunction, FTypeInteger); + Define(Sym); + Sym := TSymbol.Create('CompareStr', skFunction, FTypeInteger); + Define(Sym); + Sym := TSymbol.Create('CompareText', skFunction, FTypeInteger); + Define(Sym); + Sym := TSymbol.Create('OrdAt', skFunction, FTypeInteger); + Define(Sym); + + Sym := TSymbol.Create('ZeroMem', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('_ClassAddRef', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('_ClassRelease',skProcedure, nil); Define(Sym); + + Sym := TSymbol.Create('ParamCount', skFunction, FTypeInteger); Define(Sym); + Sym := TSymbol.Create('ParamStr', skFunction, FTypeString); Define(Sym); + + Sym := TSymbol.Create('ReadFile', skFunction, FTypeString); Define(Sym); + Sym := TSymbol.Create('WriteFile', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('AppendFile', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('FileExists', skFunction, FTypeBoolean); Define(Sym); + Sym := TSymbol.Create('DeleteFile', skProcedure, nil); Define(Sym); + Sym := TSymbol.Create('CurrentExceptionMessage', skFunction, FTypeString); Define(Sym); + + Sym := TSymbol.Create('GetEnvVar', skFunction, FTypeString); Define(Sym); + Sym := TSymbol.Create('Exec', skFunction, FTypeInteger); Define(Sym); + Sym := TSymbol.Create('Halt', skProcedure, nil); Define(Sym); +end; + +function TSymbolTable.DefineGlobal(ASymbol: TSymbol): Boolean; +begin + Result := TScope(FScopeStack.Get(0)).Define(ASymbol); +end; + +function TSymbolTable.GetCurrentScope: TScope; +begin + Result := TScope(FScopeStack.Get(FScopeStack.Count - 1)); +end; + +function TSymbolTable.GetScopeDepth: Integer; +begin + Result := FScopeStack.Count; +end; + +function TSymbolTable.PushScope: TScope; +begin + Result := TScope.Create(CurrentScope); + FScopeStack.Add(Result); +end; + +procedure TSymbolTable.PopScope; +begin + if FScopeStack.Count > 1 then + FScopeStack.Delete(FScopeStack.Count - 1); +end; + +function TSymbolTable.Define(ASymbol: TSymbol): Boolean; +begin + Result := CurrentScope.Define(ASymbol); +end; + +function TSymbolTable.Lookup(const AName: string): TSymbol; +begin + Result := CurrentScope.Lookup(AName); +end; + +function TSymbolTable.FindType(const AName: string): TTypeDesc; +var + Sym: TSymbol; +begin + Sym := CurrentScope.Lookup(AName); + if (Sym <> nil) and (Sym.Kind = skType) then + Result := Sym.TypeDesc + else + Result := nil; +end; + + + + +{ === uAST === } + + + + + + + + + + + + +type + + TASTNode = class + + Line: Integer; + Col: Integer; + procedure Destroy; virtual; + end; + + + + + + + TASTExpr = class(TASTNode) + + ResolvedType: TTypeDesc; + end; + + TIntLiteral = class(TASTExpr) + + Value: Int64; + end; + + TStringLiteral = class(TASTExpr) + + Value: string; + end; + + TNilLiteral = class(TASTExpr); + + TIdentExpr = class(TASTExpr) + + Name: string; + IsVarParam: Boolean; + IsConstant: Boolean; + ConstValue: Int64; + IsNoArgFuncCall: Boolean; + IsGlobal: Boolean; + IsImplicitSelf: Boolean; + ImplicitFieldInfo: TObject; + IsImplicitSelfMethod: Boolean; + ImplicitMethodDecl: TObject; + end; + + TFieldAccessExpr = class(TASTExpr) + + RecordName: string; + FieldName: string; + Base: TASTExpr; + FieldInfo: TFieldInfo; + IsConstructorCall: Boolean; + IsClassAccess: Boolean; + PropRead: TPropertyInfo; + PropOwnerType: string; + IsImplicitSelf: Boolean; + ImplicitBaseInfo: TFieldInfo; + IsMethodCall: Boolean; + ResolvedMethod: TObject; + IsGlobal: Boolean; + procedure Destroy; override; + end; + + TIsExpr = class(TASTExpr) + + Obj: TASTExpr; + TypeName: string; + ResolvedTargetType: TTypeDesc; + procedure Destroy; override; + end; + + TAsExpr = class(TASTExpr) + + Obj: TASTExpr; + TypeName: string; + procedure Destroy; override; + end; + + TBinaryOp = (boAdd, boSub, boMul, boDiv, boEQ, boNE, boLT, boGT, boLE, boGE, + boAnd, boOr); + + TBinaryExpr = class(TASTExpr) + + Op: TBinaryOp; + Left: TASTExpr; + Right: TASTExpr; + procedure Destroy; override; + end; + + TNotExpr = class(TASTExpr) + + Expr: TASTExpr; + procedure Destroy; override; + end; + + + + + + TASTStmt = class(TASTNode); + + TAssignment = class(TASTStmt) + + Name: string; + Expr: TASTExpr; + IsVarParam: Boolean; + IsGlobal: Boolean; + ResolvedLhsType: TTypeDesc; + IsWeakLhs: Boolean; + + + + ImplicitSelfField: TObject; + procedure Destroy; override; + end; + + TIfStmt = class(TASTStmt) + + Condition: TASTExpr; + ThenStmt: TASTStmt; + ElseStmt: TASTStmt; + procedure Destroy; override; + end; + + TCompoundStmt = class(TASTStmt) + + Stmts: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + TWhileStmt = class(TASTStmt) + + Condition: TASTExpr; + Body: TASTStmt; + procedure Destroy; override; + end; + + TForStmt = class(TASTStmt) + + VarName: string; + StartExpr: TASTExpr; + EndExpr: TASTExpr; + IsDownTo: Boolean; + Body: TASTStmt; + procedure Destroy; override; + end; + + TTryFinallyStmt = class(TASTStmt) + + TryBody: TCompoundStmt; + FinallyBody: TCompoundStmt; + procedure Destroy; override; + end; + + TTryExceptStmt = class(TASTStmt) + + TryBody: TCompoundStmt; + ExceptBody: TCompoundStmt; + procedure Destroy; override; + end; + + TRaiseStmt = class(TASTStmt) + + Expr: TASTExpr; + procedure Destroy; override; + end; + + + TExitStmt = class(TASTStmt); + + + TBreakStmt = class(TASTStmt); + + + TContinueStmt = class(TASTStmt); + + + TCaseBranch = class + + Values: TObjectList; + Stmt: TASTStmt; + procedure Create; + procedure Destroy; + end; + + TCaseStmt = class(TASTStmt) + + Selector: TASTExpr; + Branches: TObjectList; + ElseStmt: TASTStmt; + procedure Create; + procedure Destroy; override; + end; + + TFieldAssignment = class(TASTStmt) + + RecordName: string; + FieldName: string; + Expr: TASTExpr; + ObjExpr: TASTExpr; + FieldInfo: TFieldInfo; + IsClassAccess: Boolean; + IsImplicitSelf: Boolean; + ImplicitBaseInfo: TFieldInfo; + IsGlobal: Boolean; + procedure Destroy; override; + end; + + + TPointerWriteStmt = class(TASTStmt) + + PtrExpr: TASTExpr; + ValExpr: TASTExpr; + BaseTy: TTypeDesc; + procedure Destroy; override; + end; + + TProcCall = class(TASTStmt) + + Name: string; + Args: TObjectList; + ResolvedDecl: TObject; + IsImplicitSelfMethod: Boolean; + procedure Create; + procedure Destroy; override; + end; + + TFuncCallExpr = class(TASTExpr) + + Name: string; + Args: TObjectList; + ResolvedDecl: TObject; + IsImplicitSelfMethod: Boolean; + procedure Create; + procedure Destroy; override; + end; + + + TDerefExpr = class(TASTExpr) + + Expr: TASTExpr; + procedure Destroy; override; + end; + + TMethodCallStmt = class(TASTStmt) + + ObjectName: string; + Name: string; + Args: TObjectList; + ObjExpr: TASTExpr; + + ResolvedClassType: TTypeDesc; + ResolvedMethod: TObject; + IsImplicitSelf: Boolean; + ImplicitBaseInfo: TFieldInfo; + IsGlobal: Boolean; + procedure Create; + procedure Destroy; override; + end; + + + + + TInheritedCallStmt = class(TASTStmt) + + Name: string; + Args: TObjectList; + + ResolvedParentType: TObject; + ResolvedMethod: TObject; + procedure Create; + procedure Destroy; override; + end; + + + + + + TVarDecl = class(TASTNode) + + Names: TStringList; + TypeName: string; + ResolvedType: TTypeDesc; + Attributes: TStringList; + + + + + IsWeak: Boolean; + + + IsGlobal: Boolean; + procedure Create; + procedure Destroy; override; + end; + + + + + + + TASTTypeDef = class(TASTNode); + + + TEnumTypeDef = class(TASTTypeDef) + + Members: TStringList; + procedure Create; + procedure Destroy; override; + end; + + TFieldDecl = class(TASTNode) + + Names: TStringList; + TypeName: string; + ResolvedType: TTypeDesc; + Attributes: TStringList; + IsWeak: Boolean; + procedure Create; + procedure Destroy; override; + end; + + TRecordTypeDef = class(TASTTypeDef) + + Fields: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + TMethodParam = class(TASTNode) + + ParamName: string; + TypeName: string; + IsVarParam: Boolean; + ResolvedType: TTypeDesc; + end; + + TMethodDecl = class(TASTNode) + + Name: string; + OwnerTypeName: string; + Params: TObjectList; + ReturnTypeName: string; + ResolvedReturnType: TTypeDesc; + Body: TBlock; + OwnBody: Boolean; + IsVirtual: Boolean; + IsOverride: Boolean; + VTableSlot: Integer; + TypeParams: TStringList; + TypeParamConstraints: TStringList; + + OwnerTypeParams: TStringList; + procedure Create; + procedure Destroy; override; + end; + + TMethodCallExpr = class(TASTExpr) + + ObjectName: string; + Name: string; + Args: TObjectList; + ObjExpr: TASTExpr; + ResolvedClassType: TTypeDesc; + ResolvedMethod: TObject; + IsConstructorCall: Boolean; + IsGlobal: Boolean; + procedure Create; + procedure Destroy; override; + end; + + + TPropertyDecl = class(TASTNode) + + Name: string; + TypeName: string; + ReadName: string; + WriteName: string; + end; + + TClassTypeDef = class(TASTTypeDef) + + ParentName: string; + ImplementsNames: TStringList; + Fields: TObjectList; + Methods: TObjectList; + Properties: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + + TGenericTypeDef = class(TASTTypeDef) + + ParamNames: TStringList; + ParamConstraints: TStringList; + ClassDef: TClassTypeDef; + procedure Create; + procedure Destroy; override; + end; + + + + TGenericFuncInstance = class + + InstName: string; + MethodDecl: TMethodDecl; + procedure Create; + procedure Destroy; + end; + + + + TGenericInstance = class + + TypeName: string; + ClassDef: TClassTypeDef; + TypeDesc: TTypeDesc; + procedure Create; + procedure Destroy; + end; + + TInterfaceTypeDef = class(TASTTypeDef) + + ParentName: string; + Methods: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + + TGenericInterfaceDef = class(TASTTypeDef) + + ParamNames: TStringList; + ParamConstraints: TStringList; + IntfDef: TInterfaceTypeDef; + procedure Create; + procedure Destroy; override; + end; + + + + TGenericInterfaceInstance = class + + InstName: string; + IntfDef: TInterfaceTypeDef; + TypeDesc: TTypeDesc; + procedure Create; + procedure Destroy; + end; + + TTypeDecl = class(TASTNode) + + Name: string; + Def: TASTTypeDef; + procedure Destroy; override; + end; + + + TConstDecl = class(TASTNode) + + Name: string; + IntVal: Int64; + StrVal: string; + IsString: Boolean; + end; + + + + + + TBlock = class(TASTNode) + + TypeDecls: TObjectList; + ConstDecls: TObjectList; + Decls: TObjectList; + ProcDecls: TObjectList; + Stmts: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + TProgram = class(TASTNode) + + Name: string; + UsedUnits: TStringList; + Block: TBlock; + SymbolTable: TSymbolTable; + GenericInstances: TObjectList; + GenericFuncInstances: TObjectList; + GenericIntfInstances: TObjectList; + procedure Create; + procedure Destroy; override; + end; + + TUnit = class(TASTNode) + + Name: string; + IntfBlock: TBlock; + ImplBlock: TBlock; + procedure Create; + procedure Destroy; override; + end; + +function BinaryOpName(AOp: TBinaryOp): string; +function IsComparisonOp(AOp: TBinaryOp): Boolean; + + +function BinaryOpName(AOp: TBinaryOp): string; +begin + case AOp of + boAdd: Result := '+'; + boSub: Result := '-'; + boMul: Result := '*'; + boDiv: Result := 'div'; + boEQ: Result := '='; + boNE: Result := '<>'; + boLT: Result := '<'; + boGT: Result := '>'; + boLE: Result := '<='; + boGE: Result := '>='; + boAnd: Result := 'and'; + boOr: Result := 'or'; + else + Result := '?'; + end; +end; + +function IsComparisonOp(AOp: TBinaryOp): Boolean; +begin + Result := ((AOp = boEQ) or (AOp = boNE) or (AOp = boLT) or (AOp = boGT) or (AOp = boLE) or (AOp = boGE)); +end; + + + +procedure TASTNode.Destroy; +begin + +end; + +procedure TIfStmt.Destroy; +begin + Condition.Free; + ThenStmt.Free; + ElseStmt.Free; + +end; + + + +procedure TCompoundStmt.Create; +begin + + Stmts := TObjectList.Create(True); +end; + +procedure TCompoundStmt.Destroy; +begin + Stmts.Free; + +end; + + + +procedure TWhileStmt.Destroy; +begin + Condition.Free; + Body.Free; + +end; + + + +procedure TForStmt.Destroy; +begin + StartExpr.Free; + EndExpr.Free; + Body.Free; + +end; + + + +procedure TTryFinallyStmt.Destroy; +begin + TryBody.Free; + FinallyBody.Free; + +end; + + + +procedure TTryExceptStmt.Destroy; +begin + TryBody.Free; + ExceptBody.Free; + +end; + + + +procedure TRaiseStmt.Destroy; +begin + Expr.Free; + +end; + + + +procedure TFieldAccessExpr.Destroy; +begin + Base.Free; + +end; + + + +procedure TIsExpr.Destroy; +begin + Obj.Free; + +end; + + + +procedure TAsExpr.Destroy; +begin + Obj.Free; + +end; + + + +procedure TBinaryExpr.Destroy; +begin + Left.Free; + Right.Free; + +end; + + + +procedure TNotExpr.Destroy; +begin + Expr.Free; + +end; + + + +procedure TAssignment.Destroy; +begin + Expr.Free; + +end; + + + +procedure TFieldAssignment.Destroy; +begin + Expr.Free; + ObjExpr.Free; + +end; + + + +procedure TPointerWriteStmt.Destroy; +begin + PtrExpr.Free; + ValExpr.Free; + +end; + + + +procedure TDerefExpr.Destroy; +begin + Expr.Free; + +end; + + + +procedure TProcCall.Create; +begin + + Args := TObjectList.Create(True); +end; + +procedure TProcCall.Destroy; +begin + Args.Free; + +end; + + + +procedure TFuncCallExpr.Create; +begin + + Args := TObjectList.Create(True); +end; + +procedure TFuncCallExpr.Destroy; +begin + Args.Free; + +end; + + + +procedure TMethodCallStmt.Create; +begin + + Args := TObjectList.Create(True); +end; + +procedure TMethodCallStmt.Destroy; +begin + Args.Free; + ObjExpr.Free; + +end; + + + +procedure TInheritedCallStmt.Create; +begin + + Args := TObjectList.Create(True); +end; + +procedure TInheritedCallStmt.Destroy; +begin + Args.Free; + +end; + + + +procedure TVarDecl.Create; +begin + + Names := TStringList.Create; + Attributes := TStringList.Create; + IsWeak := False; +end; + +procedure TVarDecl.Destroy; +begin + Attributes.Free; + Names.Free; + +end; + + + +procedure TFieldDecl.Create; +begin + + Names := TStringList.Create; + Attributes := TStringList.Create; + IsWeak := False; +end; + +procedure TFieldDecl.Destroy; +begin + Attributes.Free; + Names.Free; + +end; + + + +procedure TRecordTypeDef.Create; +begin + + Fields := TObjectList.Create(True); +end; + +procedure TRecordTypeDef.Destroy; +begin + Fields.Free; + +end; + + + +procedure TMethodDecl.Create; +begin + + Params := TObjectList.Create(True); + VTableSlot := -1; + OwnBody := True; +end; + +procedure TMethodDecl.Destroy; +begin + Params.Free; + TypeParams.Free; + TypeParamConstraints.Free; + OwnerTypeParams.Free; + if OwnBody then Body.Free; + +end; + + + +procedure TMethodCallExpr.Create; +begin + + Args := TObjectList.Create(True); +end; + +procedure TMethodCallExpr.Destroy; +begin + Args.Free; + ObjExpr.Free; + +end; + + + +procedure TClassTypeDef.Create; +begin + + ImplementsNames := TStringList.Create; + Fields := TObjectList.Create(True); + Methods := TObjectList.Create(True); + Properties := TObjectList.Create(True); +end; + +procedure TClassTypeDef.Destroy; +begin + Properties.Free; + Methods.Free; + Fields.Free; + ImplementsNames.Free; + +end; + + + +procedure TInterfaceTypeDef.Create; +begin + + Methods := TObjectList.Create(True); +end; + +procedure TInterfaceTypeDef.Destroy; +begin + Methods.Free; + +end; + + + +procedure TGenericTypeDef.Create; +begin + + ParamNames := TStringList.Create; + ParamConstraints := TStringList.Create; + ClassDef := TClassTypeDef.Create; +end; + +procedure TGenericTypeDef.Destroy; +begin + ClassDef.Free; + ParamConstraints.Free; + ParamNames.Free; + +end; + + + + + +procedure TGenericFuncInstance.Create; +begin + +end; + +procedure TGenericFuncInstance.Destroy; +begin + MethodDecl.Free; + +end; + + + +procedure TGenericInterfaceDef.Create; +begin + + ParamNames := TStringList.Create; + ParamConstraints := TStringList.Create; + IntfDef := TInterfaceTypeDef.Create; +end; + +procedure TGenericInterfaceDef.Destroy; +begin + IntfDef.Free; + ParamConstraints.Free; + ParamNames.Free; + +end; + + + +procedure TGenericInterfaceInstance.Create; +begin + + IntfDef := TInterfaceTypeDef.Create; +end; + +procedure TGenericInterfaceInstance.Destroy; +begin + IntfDef.Free; + +end; + + + +procedure TGenericInstance.Create; +begin + + ClassDef := TClassTypeDef.Create; +end; + +procedure TGenericInstance.Destroy; +begin + ClassDef.Free; + +end; + + + +procedure TTypeDecl.Destroy; +begin + Def.Free; + +end; + + + +procedure TBlock.Create; +begin + + TypeDecls := TObjectList.Create(True); + ConstDecls := TObjectList.Create(True); + Decls := TObjectList.Create(True); + ProcDecls := TObjectList.Create(True); + Stmts := TObjectList.Create(True); +end; + +procedure TBlock.Destroy; +begin + TypeDecls.Free; + ConstDecls.Free; + Decls.Free; + ProcDecls.Free; + Stmts.Free; + +end; + + + +procedure TEnumTypeDef.Create; +begin + + Members := TStringList.Create; +end; + +procedure TEnumTypeDef.Destroy; +begin + Members.Free; + +end; + + + +procedure TCaseBranch.Create; +begin + + Values := TObjectList.Create(True); +end; + +procedure TCaseBranch.Destroy; +begin + Stmt.Free; + Values.Free; + +end; + + + +procedure TCaseStmt.Create; +begin + + Branches := TObjectList.Create(True); +end; + +procedure TCaseStmt.Destroy; +begin + ElseStmt.Free; + Branches.Free; + Selector.Free; + +end; + + + +procedure TProgram.Create; +begin + + UsedUnits := TStringList.Create; + GenericInstances := TObjectList.Create(True); + GenericFuncInstances := TObjectList.Create(True); + GenericIntfInstances := TObjectList.Create(True); +end; + +procedure TProgram.Destroy; +begin + GenericIntfInstances.Free; + GenericFuncInstances.Free; + GenericInstances.Free; + SymbolTable.Free; + UsedUnits.Free; + Block.Free; + +end; + + + +procedure TUnit.Create; +begin + + IntfBlock := TBlock.Create; + ImplBlock := TBlock.Create; +end; + +procedure TUnit.Destroy; +begin + IntfBlock.Free; + ImplBlock.Free; + +end; + + + + +{ === uParser === } + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +type + + TParser = class + + FLexer: TLexer; + FCurrent: TToken; + FLookahead: TToken; + FLookahead2: TToken; + + procedure Advance; + function PeekKind: TTokenKind; + function PeekKind2: TTokenKind; + procedure Expect(AKind: TTokenKind); + function Check(AKind: TTokenKind): Boolean; + function ParseTypeName: string; + + function ParseProgram: TProgram; + procedure ParseUses(AProg: TProgram); + function ParseBlock: TBlock; + procedure ParseTypeSection(ABlock: TBlock); + procedure ParseTypeDecl(ABlock: TBlock); + procedure ParseConstBlock(ABlock: TBlock); + function ParseEnumDef: TEnumTypeDef; + function ParseRecordDef: TRecordTypeDef; + function ParseGenericName: string; + function ParseClassDef: TClassTypeDef; + function ParseInterfaceDef: TInterfaceTypeDef; + procedure ParseFieldDecl(AFields: TObjectList); + procedure ParseAttributeList(AAttrs: TStringList); + function ParsePropertyDecl: TPropertyDecl; + function ParseMethodDecl(IsFunction: Boolean): TMethodDecl; + procedure ParseParamList(AParams: TObjectList); + procedure ParseStandaloneDecl(ABlock: TBlock); + procedure ParseVarBlock(ABlock: TBlock); + procedure ParseVarDecl(ABlock: TBlock); + procedure ParseStmtList(ABlock: TBlock); + function ParseStmt: TASTStmt; + function ParseIfStmt: TIfStmt; + function ParseWhileStmt: TWhileStmt; + function ParseForStmt: TForStmt; + function ParseTryStmt: TASTStmt; + procedure ParseBodyInto(ATarget: TCompoundStmt; AStop1, AStop2: TTokenKind); + function ParseRaiseStmt: TRaiseStmt; + function ParseInheritedStmt: TInheritedCallStmt; + function ParseCaseStmt: TCaseStmt; + function ParseForwardDecl(IsFunction: Boolean): TMethodDecl; + function ParseCompoundStmt: TCompoundStmt; + function ParseExpr: TASTExpr; + function ParseAddSub: TASTExpr; + function ParseTerm: TASTExpr; + function ParseFactor: TASTExpr; + procedure ParseArgList(ACall: TProcCall); + procedure ParseMethodCallArgList(ACall: TMethodCallStmt); + + procedure Create(ALexer: TLexer); + function Parse: TProgram; + function ParseUnit: TUnit; + end; + + +procedure TParser.Create(ALexer: TLexer); +begin + + FLexer := ALexer; + FCurrent := FLexer.Next; + FLookahead := FLexer.Next; + FLookahead2 := FLexer.Next; +end; + +procedure TParser.Advance; +begin + FCurrent := FLookahead; + FLookahead := FLookahead2; + FLookahead2 := FLexer.Next; +end; + +function TParser.PeekKind: TTokenKind; +begin + Result := FLookahead.Kind; +end; + +function TParser.PeekKind2: TTokenKind; +begin + Result := FLookahead2.Kind; +end; + + + + +function TParser.ParseTypeName: string; +begin + + if Check(tkCaret) then + begin + Advance; + Result := '^' + Self.ParseTypeName; + Exit; + end; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result := FCurrent.Value; + Advance; + if Check(tkLessThan) then + begin + Advance; + Result := Result + '<'; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type argument after ''<'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result := Result + FCurrent.Value; + Advance; + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type argument after '','' at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result := Result + ',' + FCurrent.Value; + Advance; + end; + Expect(tkGreaterThan); + Result := Result + '>'; + end; +end; + +procedure TParser.Expect(AKind: TTokenKind); +begin + if FCurrent.Kind <> AKind then + raise EParseError.Create(Format('Expected token %d but got %d (''%s'') at line %d col %d', AKind, FCurrent.Kind, FCurrent.Value, + FCurrent.Line, FCurrent.Col)); + Advance; +end; + +function TParser.Check(AKind: TTokenKind): Boolean; +begin + Result := FCurrent.Kind = AKind; +end; + + + +function TParser.Parse: TProgram; +begin + Result := ParseProgram; +end; + +function TParser.ParseProgram: TProgram; +begin + Result := TProgram.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + + Expect(tkProgram); + + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected program name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Name := FCurrent.Value; + Advance; + + Expect(tkSemicolon); + + if Check(tkUses) then + ParseUses(Result); + + Result.Block := ParseBlock; + + Expect(tkDot); + + if not Check(tkEOF) then + raise EParseError.Create(Format('Unexpected tokens after program end at line %d col %d', FCurrent.Line, FCurrent.Col)); + except + Result.Free; + raise; + end; +end; + +procedure TParser.ParseUses(AProg: TProgram); +var + UName: string; +begin + Expect(tkUses); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected unit name after ''uses'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + UName := FCurrent.Value; + Advance; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected identifier after ''.'' in unit name at line %d col %d', FCurrent.Line, FCurrent.Col)); + UName := UName + '.' + FCurrent.Value; + Advance; + end; + AProg.UsedUnits.Add(UName); + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected unit name after '','' at line %d col %d', FCurrent.Line, FCurrent.Col)); + UName := FCurrent.Value; + Advance; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected identifier after ''.'' in unit name at line %d col %d', FCurrent.Line, FCurrent.Col)); + UName := UName + '.' + FCurrent.Value; + Advance; + end; + AProg.UsedUnits.Add(UName); + end; + Expect(tkSemicolon); +end; + +function TParser.ParseBlock: TBlock; +begin + Result := TBlock.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + + + + while Check(tkType) or Check(tkVar) or Check(tkProcedure) or + Check(tkFunction) or Check(tkConst) do + begin + if Check(tkType) then + ParseTypeSection(Result) + else if Check(tkVar) then + ParseVarBlock(Result) + else if Check(tkConst) then + ParseConstBlock(Result) + else + ParseStandaloneDecl(Result); + end; + + Expect(tkBegin); + ParseStmtList(Result); + Expect(tkEnd); + except + Result.Free; + raise; + end; +end; + + + + + +procedure TParser.ParseTypeSection(ABlock: TBlock); +begin + Expect(tkType); + + while Check(tkIdent) do + ParseTypeDecl(ABlock); +end; + +procedure TParser.ParseTypeDecl(ABlock: TBlock); +var + TD: TTypeDecl; + GD: TGenericTypeDef; + GID: TGenericInterfaceDef; + ParamNames: TStringList; + ParamConstraints: TStringList; + IsGeneric: Boolean; + Constraint: string; +begin + TD := TTypeDecl.Create; + TD.Line := FCurrent.Line; + TD.Col := FCurrent.Col; + try + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type name at line %d col %d', FCurrent.Line, FCurrent.Col)); + TD.Name := FCurrent.Value; + Advance; + + IsGeneric := Check(tkLessThan); + if IsGeneric then + begin + Advance; + ParamNames := TStringList.Create; + ParamConstraints := TStringList.Create; + try + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type parameter name at line %d col %d', FCurrent.Line, FCurrent.Col)); + ParamNames.Add(FCurrent.Value); + Advance; + + Constraint := ''; + if Check(tkColon) then + begin + Advance; + if Check(tkClass) then begin Constraint := 'class'; Advance; end + else if Check(tkRecord) then begin Constraint := 'record'; Advance; end + else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end + else + raise EParseError.Create(Format('Expected ''class'', ''record'', or a type name after '':'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + ParamConstraints.Add(Constraint); + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type parameter name at line %d col %d', FCurrent.Line, FCurrent.Col)); + ParamNames.Add(FCurrent.Value); + Advance; + Constraint := ''; + if Check(tkColon) then + begin + Advance; + if Check(tkClass) then begin Constraint := 'class'; Advance; end + else if Check(tkRecord) then begin Constraint := 'record'; Advance; end + else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end + else + raise EParseError.Create(Format('Expected ''class'', ''record'', or a type name after '':'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + ParamConstraints.Add(Constraint); + end; + Expect(tkGreaterThan); + Expect(tkEquals); + if Check(tkIntf) then + begin + GID := TGenericInterfaceDef.Create; + GID.Line := TD.Line; + GID.Col := TD.Col; + GID.ParamNames.AddStrings(ParamNames); + GID.ParamConstraints.AddStrings(ParamConstraints); + GID.IntfDef.Free; + GID.IntfDef := ParseInterfaceDef; + TD.Def := GID; + end + else + begin + if not Check(tkClass) then + raise EParseError.Create(Format('Generic type must be a class or interface at line %d col %d', FCurrent.Line, FCurrent.Col)); + GD := TGenericTypeDef.Create; + GD.Line := TD.Line; + GD.Col := TD.Col; + GD.ParamNames.AddStrings(ParamNames); + GD.ParamConstraints.AddStrings(ParamConstraints); + GD.ClassDef.Free; + GD.ClassDef := ParseClassDef; + TD.Def := GD; + end; + finally + ParamConstraints.Free; + ParamNames.Free; + end; + end + else + begin + Expect(tkEquals); + if Check(tkRecord) then + TD.Def := ParseRecordDef + else if Check(tkClass) then + TD.Def := ParseClassDef + else if Check(tkIntf) then + TD.Def := ParseInterfaceDef + else if Check(tkLParen) then + TD.Def := ParseEnumDef + else + raise EParseError.Create(Format('Expected ''record'', ''class'', ''interface'', or ''('' at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + Expect(tkSemicolon); + ABlock.TypeDecls.Add(TD); + except + TD.Free; + raise; + end; +end; + +procedure TParser.ParseConstBlock(ABlock: TBlock); +var + CD: TConstDecl; +begin + Expect(tkConst); + while Check(tkIdent) do + begin + CD := TConstDecl.Create; + CD.Line := FCurrent.Line; + CD.Col := FCurrent.Col; + CD.Name := FCurrent.Value; + Advance; + Expect(tkEquals); + if Check(tkMinus) then + begin + Advance; + if not Check(tkIntLit) then + raise EParseError.Create(Format('Expected integer after minus in const at line %d col %d', FCurrent.Line, FCurrent.Col)); + CD.IntVal := -StrToInt(FCurrent.Value); + CD.IsString := False; + Advance; + end + else if Check(tkIntLit) then + begin + CD.IntVal := StrToInt(FCurrent.Value); + CD.IsString := False; + Advance; + end + else if Check(tkStringLit) then + begin + CD.StrVal := FCurrent.Value; + CD.IsString := True; + Advance; + end + else + raise EParseError.Create(Format('Expected integer or string constant at line %d col %d', FCurrent.Line, FCurrent.Col)); + Expect(tkSemicolon); + ABlock.ConstDecls.Add(CD); + end; +end; + +function TParser.ParseEnumDef: TEnumTypeDef; +begin + Result := TEnumTypeDef.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkLParen); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected enum member at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Members.Add(FCurrent.Value); + Advance; + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected enum member at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Members.Add(FCurrent.Value); + Advance; + end; + Expect(tkRParen); + except + Result.Free; + raise; + end; +end; + +function TParser.ParseRecordDef: TRecordTypeDef; +begin + Result := TRecordTypeDef.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkRecord); + while Check(tkIdent) or Check(tkLBracket) do + ParseFieldDecl(Result.Fields); + Expect(tkEnd); + except + Result.Free; + raise; + end; +end; + +function TParser.ParseGenericName: string; +var + TypeArgs: string; +begin + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected identifier at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result := FCurrent.Value; + Advance; + if Check(tkLessThan) then + begin + Advance; + TypeArgs := FCurrent.Value; + Advance; + while Check(tkComma) do + begin + Advance; + TypeArgs := TypeArgs + ',' + FCurrent.Value; + Advance; + end; + Expect(tkGreaterThan); + Result := Result + '<' + TypeArgs + '>'; + end; +end; + +function TParser.ParseClassDef: TClassTypeDef; +begin + Result := TClassTypeDef.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkClass); + if Check(tkLParen) then + begin + Advance; + + Result.ParentName := ParseGenericName; + + while Check(tkComma) do + begin + Advance; + Result.ImplementsNames.Add(ParseGenericName); + end; + Expect(tkRParen); + end; + + + + while True do +begin + if Check(tkIdent) and SameText(FCurrent.Value, 'property') then + Result.Properties.Add(ParsePropertyDecl) + else if Check(tkIdent) or Check(tkLBracket) then + ParseFieldDecl(Result.Fields) + else if Check(tkFunction) then + Result.Methods.Add(ParseMethodDecl(True)) + else if Check(tkProcedure) then + Result.Methods.Add(ParseMethodDecl(False)) + else + Break; + if False then break; +end; if Check(tkEnd) then + Advance + else if not (Check(tkSemicolon) or Check(tkEOF)) then + raise EParseError.Create(Format('Expected ''end'' in class definition at line %d col %d', FCurrent.Line, FCurrent.Col)); + except + Result.Free; + raise; + end; +end; + +function TParser.ParseInterfaceDef: TInterfaceTypeDef; +begin + Result := TInterfaceTypeDef.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkIntf); + if Check(tkLParen) then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected parent interface name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.ParentName := FCurrent.Value; + Advance; + Expect(tkRParen); + end; + 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; + raise; + end; +end; + +function TParser.ParseMethodDecl(IsFunction: Boolean): TMethodDecl; +var + TempParams: TStringList; + TempConstraints: TStringList; + Constraint: string; +begin + TempParams := nil; + TempConstraints := nil; + Result := TMethodDecl.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + if IsFunction then + Expect(tkFunction) + else + Expect(tkProcedure); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected method name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Name := FCurrent.Value; + Advance; + + + + if Check(tkLessThan) and (PeekKind = tkIdent) and + (((PeekKind2 = tkGreaterThan) or (PeekKind2 = tkComma) or (PeekKind2 = tkColon))) then + begin + TempParams := TStringList.Create; + TempConstraints := TStringList.Create; + try + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type parameter name at line %d col %d', FCurrent.Line, FCurrent.Col)); + TempParams.Add(FCurrent.Value); + Advance; + Constraint := ''; + if Check(tkColon) then + begin + Advance; + if Check(tkClass) then begin Constraint := 'class'; Advance; end + else if Check(tkRecord) then begin Constraint := 'record'; Advance; end + else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end + else + raise EParseError.Create(Format('Expected ''class'', ''record'', or a type name after '':'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + TempConstraints.Add(Constraint); + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected type parameter name at line %d col %d', FCurrent.Line, FCurrent.Col)); + TempParams.Add(FCurrent.Value); + Advance; + Constraint := ''; + if Check(tkColon) then + begin + Advance; + if Check(tkClass) then begin Constraint := 'class'; Advance; end + else if Check(tkRecord) then begin Constraint := 'record'; Advance; end + else if Check(tkIdent) then begin Constraint := FCurrent.Value; Advance; end + else + raise EParseError.Create(Format('Expected ''class'', ''record'', or a type name after '':'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + TempConstraints.Add(Constraint); + end; + Expect(tkGreaterThan); + if Check(tkDot) then + begin + + + Result.OwnerTypeParams := TempParams; + TempParams := nil; + TempConstraints := nil; + end + else + begin + + Result.TypeParams := TempParams; + Result.TypeParamConstraints := TempConstraints; + TempParams := nil; + TempConstraints := nil; + end; + finally + TempParams.Free; + TempConstraints.Free; + end; + end; + + if Check(tkDot) then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected method name after ''.'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.OwnerTypeName := Result.Name; + Result.Name := FCurrent.Value; + Advance; + end; + if Check(tkLParen) then + begin + Advance; + if not Check(tkRParen) then + ParseParamList(Result.Params); + Expect(tkRParen); + end; + if IsFunction then + begin + Expect(tkColon); + Result.ReturnTypeName := ParseTypeName; + end; + Expect(tkSemicolon); + if Check(tkVirtual) then + begin + Result.IsVirtual := True; + Advance; + Expect(tkSemicolon); + end + else if Check(tkOverride) then + begin + Result.IsOverride := True; + Advance; + Expect(tkSemicolon); + end; + + + if Check(tkBegin) or Check(tkVar) or Check(tkType) then + begin + Result.Body := ParseBlock; + Expect(tkSemicolon); + end; + except + Result.Free; + raise; + end; +end; + +procedure TParser.ParseParamList(AParams: TObjectList); +var + Par: TMethodParam; + I: Integer; + Names: TStringList; + TypeN: string; + IsVarGrp: Boolean; +begin + while True do +begin + IsVarGrp := Check(tkVar); + if IsVarGrp then Advance + else if Check(tkConst) then Advance; + Names := TStringList.Create; + try + if not Check(tkIdent) then + raise EParseError.Create(Format('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.Create(Format('Expected parameter name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Names.Add(FCurrent.Value); + Advance; + end; + Expect(tkColon); + TypeN := ParseTypeName; + for I := 0 to Names.Count - 1 do + begin + Par := TMethodParam.Create; + Par.ParamName := Names.Get(I); + Par.TypeName := TypeN; + Par.IsVarParam := IsVarGrp; + AParams.Add(Par); + end; + finally + Names.Free; + end; + if Check(tkSemicolon) then + Advance + else + Break; + if False then break; +end;end; + +procedure TParser.ParseStandaloneDecl(ABlock: TBlock); +var + IsFunc: Boolean; + MD: TMethodDecl; +begin + IsFunc := Check(tkFunction); + MD := ParseMethodDecl(IsFunc); + ABlock.ProcDecls.Add(MD); +end; + +function TParser.ParsePropertyDecl: TPropertyDecl; +begin + Result := TPropertyDecl.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected property name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Name := FCurrent.Value; + Advance; + Expect(tkColon); + Result.TypeName := ParseTypeName; + + if Check(tkIdent) and SameText(FCurrent.Value, 'read') then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected read accessor name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.ReadName := FCurrent.Value; + Advance; + end; + + if Check(tkIdent) and SameText(FCurrent.Value, 'write') then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected write accessor name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.WriteName := FCurrent.Value; + Advance; + end; + Expect(tkSemicolon); + except + Result.Free; + raise; + end; +end; + +procedure TParser.ParseAttributeList(AAttrs: TStringList); + + + + + + +var + Depth: Integer; +begin + while Check(tkLBracket) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected attribute name after ''['' at line %d col %d', FCurrent.Line, FCurrent.Col)); + AAttrs.Add(FCurrent.Value); + Advance; + + + + + if Check(tkLParen) then + begin + Depth := 1; + Advance; + while (Depth > 0) and (FCurrent.Kind <> tkEOF) do + begin + if Check(tkLParen) then Depth := Depth + 1 + else if Check(tkRParen) then Depth := Depth - 1; + Advance; + end; + end; + Expect(tkRBracket); + end; +end; + +procedure TParser.ParseFieldDecl(AFields: TObjectList); +var + Fld: TFieldDecl; +begin + Fld := TFieldDecl.Create; + Fld.Line := FCurrent.Line; + Fld.Col := FCurrent.Col; + try + ParseAttributeList(Fld.Attributes); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Fld.Names.Add(FCurrent.Value); + Advance; + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Fld.Names.Add(FCurrent.Value); + Advance; + end; + Expect(tkColon); + Fld.TypeName := ParseTypeName; + Expect(tkSemicolon); + AFields.Add(Fld); + except + Fld.Free; + raise; + end; +end; + + + + + +procedure TParser.ParseVarBlock(ABlock: TBlock); +begin + Expect(tkVar); + while Check(tkIdent) or Check(tkLBracket) do + ParseVarDecl(ABlock); +end; + +procedure TParser.ParseVarDecl(ABlock: TBlock); +var + Decl: TVarDecl; +begin + Decl := TVarDecl.Create; + Decl.Line := FCurrent.Line; + Decl.Col := FCurrent.Col; + try + ParseAttributeList(Decl.Attributes); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected variable name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Decl.Names.Add(FCurrent.Value); + Advance; + while Check(tkComma) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected variable name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Decl.Names.Add(FCurrent.Value); + Advance; + end; + Expect(tkColon); + Decl.TypeName := ParseTypeName; + Expect(tkSemicolon); + ABlock.Decls.Add(Decl); + except + Decl.Free; + raise; + end; +end; + + + + + +procedure TParser.ParseStmtList(ABlock: TBlock); +var + Stmt: TASTStmt; +begin + while not (Check(tkEnd) or Check(tkEOF) or Check(tkElse)) do + begin + Stmt := ParseStmt; + if Stmt <> nil then + ABlock.Stmts.Add(Stmt); + if Check(tkSemicolon) then + Advance + else + Break; + end; +end; + +function TParser.ParseStmt: TASTStmt; +var + Name: string; + Line, Col: Integer; + Call: TProcCall; + Assign: TAssignment; + FldAssign: TFieldAssignment; + MCall: TMethodCallStmt; + MCallExpr: TMethodCallExpr; + PtrWrite: TPointerWriteStmt; + PtrIdNode: TIdentExpr; + SecondIdent: string; + FldNode: TFieldAccessExpr; + CastRcv: TASTExpr; + FCallNode: TFuncCallExpr; +begin + Result := nil; + + if Check(tkEnd) or Check(tkEOF) or Check(tkSemicolon) or Check(tkElse) then + Exit; + + if Check(tkIf) then + begin + Result := ParseIfStmt; + Exit; + end; + + if Check(tkWhile) then + begin + Result := ParseWhileStmt; + Exit; + end; + + if Check(tkFor) then + begin + Result := ParseForStmt; + Exit; + end; + + if Check(tkTry) then + begin + Result := ParseTryStmt; + Exit; + end; + + if Check(tkRaise) then + begin + Result := ParseRaiseStmt; + Exit; + end; + + if Check(tkExit) then + begin + Result := TExitStmt.Create; + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Advance; + Exit; + end; + + if Check(tkBreak) then + begin + Result := TBreakStmt.Create; + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Advance; + Exit; + end; + + if Check(tkContinue) then + begin + Result := TContinueStmt.Create; + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Advance; + Exit; + end; + + if Check(tkInherited) then + begin + Result := ParseInheritedStmt; + Exit; + end; + + if Check(tkCase) then + begin + Result := ParseCaseStmt; + Exit; + end; + + if Check(tkBegin) then + begin + Result := ParseCompoundStmt; + Exit; + end; + + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected statement at line %d col %d', FCurrent.Line, FCurrent.Col)); + + Name := FCurrent.Value; + Line := FCurrent.Line; + Col := FCurrent.Col; + Advance; + + if Check(tkCaret) then + begin + + Advance; + Expect(tkAssign); + PtrWrite := TPointerWriteStmt.Create; + PtrWrite.Line := Line; + PtrWrite.Col := Col; + PtrIdNode := TIdentExpr.Create; + PtrIdNode.Line := Line; + PtrIdNode.Col := Col; + PtrIdNode.Name := Name; + PtrWrite.PtrExpr := PtrIdNode; + PtrWrite.ValExpr := ParseExpr; + Result := PtrWrite; + end + else if Check(tkDot) then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field or method name at line %d col %d', FCurrent.Line, FCurrent.Col)); + SecondIdent := FCurrent.Value; + Advance; + + if Check(tkAssign) then + begin + + 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 + + + if Check(tkDot) then + begin + + + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + + PtrIdNode := TIdentExpr.Create; + PtrIdNode.Line := Line; + PtrIdNode.Col := Col; + PtrIdNode.Name := Name; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := PtrIdNode; + FldNode.FieldName:= SecondIdent; + MCall.ObjExpr := FldNode; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field or method name at line %d col %d', FCurrent.Line, FCurrent.Col)); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkDot) then + begin + + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := MCall.ObjExpr; + FldNode.FieldName:= SecondIdent; + MCall.ObjExpr := FldNode; + end + else + begin + MCall.Name := SecondIdent; + if Check(tkLParen) then + begin + Advance; + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + end; + Break; + end; + end; + Result := MCall; + end + else + begin + 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; + + if Check(tkDot) then + begin + MCallExpr := TMethodCallExpr.Create; + MCallExpr.Line := Line; + MCallExpr.Col := Col; + MCallExpr.ObjectName := MCall.ObjectName; + MCallExpr.Name := MCall.Name; + while MCall.Args.Count > 0 do + MCallExpr.Args.Add(MCall.Args.Extract(0)); + MCall.Free; + MCall := nil; + CastRcv := MCallExpr; + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected identifier after ''.'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + MCall.Name := SecondIdent; + MCall.ObjExpr := CastRcv; + Advance; + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + Result := MCall; + Exit; + end; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := CastRcv; + FldNode.FieldName := SecondIdent; + CastRcv := FldNode; + end; + if Check(tkAssign) and (CastRcv is TFieldAccessExpr) then + begin + Advance; + FldAssign := TFieldAssignment.Create; + FldAssign.Line := Line; + FldAssign.Col := Col; + FldAssign.FieldName := TFieldAccessExpr(CastRcv).FieldName; + FldAssign.ObjExpr := TFieldAccessExpr(CastRcv).Base; + TFieldAccessExpr(CastRcv).Base := nil; + CastRcv.Free; + FldAssign.Expr := ParseExpr; + Result := FldAssign; + Exit; + end; + raise EParseError.Create(Format('Expected method call or assignment after chain at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + Result := MCall; + end; + end; + end + else if Check(tkAssign) then + begin + Advance; + Assign := TAssignment.Create; + Assign.Line := Line; + Assign.Col := Col; + Assign.Name := Name; + Assign.Expr := ParseExpr; + Result := Assign; + end + else + begin + + + + + if Check(tkLParen) then + begin + FCallNode := TFuncCallExpr.Create; + FCallNode.Line := Line; + FCallNode.Col := Col; + FCallNode.Name := Name; + Advance; + if not Check(tkRParen) then + begin + FCallNode.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + FCallNode.Args.Add(ParseExpr); + end; + end; + Expect(tkRParen); + if Check(tkDot) then + begin + CastRcv := FCallNode; + + + while Check(tkDot) do + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field or method name at line %d col %d', FCurrent.Line, FCurrent.Col)); + SecondIdent := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + MCall := TMethodCallStmt.Create; + MCall.Line := Line; + MCall.Col := Col; + MCall.ObjectName := ''; + MCall.Name := SecondIdent; + MCall.ObjExpr := CastRcv; + Advance; + if not Check(tkRParen) then + ParseMethodCallArgList(MCall); + Expect(tkRParen); + Result := MCall; + Exit; + end; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.Base := CastRcv; + FldNode.FieldName := SecondIdent; + CastRcv := FldNode; + end; + + if Check(tkAssign) and (CastRcv is TFieldAccessExpr) then + begin + Advance; + FldAssign := TFieldAssignment.Create; + FldAssign.Line := Line; + FldAssign.Col := Col; + FldAssign.FieldName := TFieldAccessExpr(CastRcv).FieldName; + FldAssign.ObjExpr := TFieldAccessExpr(CastRcv).Base; + TFieldAccessExpr(CastRcv).Base := nil; + CastRcv.Free; + FldAssign.Expr := ParseExpr; + Result := FldAssign; + Exit; + end; + raise EParseError.Create(Format('Expected method call after typecast at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + + + Call := TProcCall.Create; + Call.Line := Line; + Call.Col := Col; + Call.Name := Name; + while FCallNode.Args.Count > 0 do + Call.Args.Add(FCallNode.Args.Extract(0)); + FCallNode.Free; + Result := Call; + Exit; + end; + Call := TProcCall.Create; + Call.Line := Line; + Call.Col := Col; + Call.Name := Name; + Result := Call; + end; +end; + +function TParser.ParseWhileStmt: TWhileStmt; +begin + Result := TWhileStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkWhile); + Result.Condition := ParseExpr; + Expect(tkDo); + Result.Body := ParseStmt; + except + Result.Free; + raise; + end; +end; + +function TParser.ParseIfStmt: TIfStmt; +begin + Result := TIfStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkIf); + Result.Condition := ParseExpr; + Expect(tkThen); + Result.ThenStmt := ParseStmt; + if Check(tkElse) then + begin + Advance; + Result.ElseStmt := ParseStmt; + end; + except + Result.Free; + raise; + end; +end; + +function TParser.ParseForStmt: TForStmt; +begin + Result := TForStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkFor); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected loop variable at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.VarName := FCurrent.Value; + Advance; + Expect(tkAssign); + Result.StartExpr := ParseExpr; + if Check(tkTo) then + begin + Result.IsDownTo := False; + Advance; + end + else if Check(tkDownto) then + begin + Result.IsDownTo := True; + Advance; + end + else + raise EParseError.Create(Format('Expected ''to'' or ''downto'' at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.EndExpr := ParseExpr; + Expect(tkDo); + Result.Body := ParseStmt; + except + Result.Free; + raise; + end; +end; + +procedure TParser.ParseBodyInto(ATarget: TCompoundStmt; + AStop1, AStop2: TTokenKind); +var + S: TASTStmt; +begin + while not (Check(AStop1) or Check(AStop2) or + Check(tkEnd) or Check(tkEOF)) do + begin + S := ParseStmt; + if S <> nil then + ATarget.Stmts.Add(S); + if Check(tkSemicolon) then + Advance + else + Break; + end; +end; + +function TParser.ParseTryStmt: TASTStmt; +var + TryBody: TCompoundStmt; + FinallyBody: TCompoundStmt; + ExceptBody: TCompoundStmt; + Stmt: TASTStmt; + TFS: TTryFinallyStmt; + TES: TTryExceptStmt; + Line, Col: Integer; +begin + Line := FCurrent.Line; + Col := FCurrent.Col; + Expect(tkTry); + + TryBody := TCompoundStmt.Create; + TryBody.Line := Line; + TryBody.Col := Col; + try + ParseBodyInto(TryBody, tkFinally, tkExcept); + + if Check(tkFinally) then + begin + Advance; + FinallyBody := TCompoundStmt.Create; + try + ParseBodyInto(FinallyBody, tkEnd, tkEnd); + Expect(tkEnd); + TFS := TTryFinallyStmt.Create; + TFS.Line := Line; + TFS.Col := Col; + TFS.TryBody := TryBody; + TFS.FinallyBody := FinallyBody; + TryBody := nil; + FinallyBody := nil; + Result := TFS; + except + FinallyBody.Free; + raise; + end; + end + else if Check(tkExcept) then + begin + Advance; + ExceptBody := TCompoundStmt.Create; + try + ParseBodyInto(ExceptBody, tkEnd, tkEnd); + Expect(tkEnd); + TES := TTryExceptStmt.Create; + TES.Line := Line; + TES.Col := Col; + TES.TryBody := TryBody; + TES.ExceptBody := ExceptBody; + TryBody := nil; + ExceptBody := nil; + Result := TES; + except + ExceptBody.Free; + raise; + end; + end + else + begin + raise EParseError.Create(Format('Expected ''finally'' or ''except'' after try body at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + except + TryBody.Free; + raise; + end; +end; + +function TParser.ParseRaiseStmt: TRaiseStmt; +begin + Result := TRaiseStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkRaise); + + if not (Check(tkSemicolon) or Check(tkEnd) or Check(tkEOF) or + Check(tkFinally) or Check(tkExcept) or Check(tkElse)) then + Result.Expr := ParseExpr; + except + Result.Free; + raise; + end; +end; + +function TParser.ParseInheritedStmt: TInheritedCallStmt; +begin + Result := TInheritedCallStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkInherited); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected method name after ''inherited'' 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 + begin + Result.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + Result.Args.Add(ParseExpr); + end; + end; + Expect(tkRParen); + end; + except + Result.Free; + raise; + end; +end; + +function TParser.ParseCompoundStmt: TCompoundStmt; +var + Stmt: TASTStmt; +begin + Result := TCompoundStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkBegin); + while not (Check(tkEnd) or Check(tkEOF)) do + begin + Stmt := ParseStmt; + if Stmt <> nil then + Result.Stmts.Add(Stmt); + if Check(tkSemicolon) then + Advance + else + Break; + end; + Expect(tkEnd); + except + Result.Free; + raise; + end; +end; + +function TParser.ParseCaseStmt: TCaseStmt; +var + Branch: TCaseBranch; + Stmt: TASTStmt; + CmpElse: TCompoundStmt; +begin + Result := TCaseStmt.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + Expect(tkCase); + Result.Selector := ParseExpr; + Expect(tkOf); + + while not (Check(tkEnd) or Check(tkElse) or Check(tkEOF)) do + begin + Branch := TCaseBranch.Create; + Branch.Values.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + Branch.Values.Add(ParseExpr); + end; + Expect(tkColon); + Stmt := ParseStmt; + + if Check(tkSemicolon) then Advance; + if Stmt <> nil then + Branch.Stmt := Stmt + else + Branch.Stmt := TCompoundStmt.Create; + Result.Branches.Add(Branch); + end; + if Check(tkElse) then + begin + Advance; + if Check(tkBegin) then + Result.ElseStmt := ParseCompoundStmt + else + begin + + CmpElse := TCompoundStmt.Create; + CmpElse.Stmts.Add(ParseStmt); + if Check(tkSemicolon) then Advance; + while not (Check(tkEnd) or Check(tkEOF)) do + begin + CmpElse.Stmts.Add(ParseStmt); + if Check(tkSemicolon) then Advance; + end; + if CmpElse.Stmts.Count = 1 then + begin + + Result.ElseStmt := TASTStmt(CmpElse.Stmts.Extract(0)); + CmpElse.Free; + end + else + Result.ElseStmt := CmpElse; + end; + if Check(tkSemicolon) then Advance; + end; + Expect(tkEnd); + except + Result.Free; + raise; + end; +end; + +procedure TParser.ParseArgList(ACall: TProcCall); +begin + ACall.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + ACall.Args.Add(ParseExpr); + end; +end; + +procedure TParser.ParseMethodCallArgList(ACall: TMethodCallStmt); +begin + ACall.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + ACall.Args.Add(ParseExpr); + end; +end; + + + + + +function TParser.ParseForwardDecl(IsFunction: Boolean): TMethodDecl; +begin + Result := TMethodDecl.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + if IsFunction then + Expect(tkFunction) + else + Expect(tkProcedure); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected 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; + if IsFunction then + begin + Expect(tkColon); + Result.ReturnTypeName := ParseTypeName; + end; + Expect(tkSemicolon); + + except + Result.Free; + raise; + end; +end; + +function TParser.ParseUnit: TUnit; +begin + Result := TUnit.Create; + try + Result.Line := FCurrent.Line; + Result.Col := FCurrent.Col; + + Expect(tkUnit); + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected unit name at line %d col %d', FCurrent.Line, FCurrent.Col)); + Result.Name := FCurrent.Value; + Advance; + Expect(tkSemicolon); + + + Expect(tkIntf); + if Check(tkType) then + ParseTypeSection(Result.IntfBlock); + while Check(tkProcedure) or Check(tkFunction) do + begin + if Check(tkFunction) then + Result.IntfBlock.ProcDecls.Add(ParseForwardDecl(True)) + else + Result.IntfBlock.ProcDecls.Add(ParseForwardDecl(False)); + end; + + + Expect(tkImplementation); + while Check(tkProcedure) or Check(tkFunction) do + begin + if Check(tkFunction) then + Result.ImplBlock.ProcDecls.Add(ParseMethodDecl(True)) + else + Result.ImplBlock.ProcDecls.Add(ParseMethodDecl(False)); + end; + + Expect(tkEnd); + Expect(tkDot); + + if not Check(tkEOF) then + raise EParseError.Create(Format('Unexpected tokens after unit end at line %d col %d', FCurrent.Line, FCurrent.Col)); + except + Result.Free; + raise; + end; +end; + + + + + +function TParser.ParseExpr: TASTExpr; +var + Right: TASTExpr; + CmpOp: TBinaryOp; + Node: TBinaryExpr; + IsNode: TIsExpr; + AsNode: TAsExpr; +begin + Result := ParseAddSub; + + + if Check(tkEquals) or Check(tkNotEquals) or + Check(tkLessThan) or Check(tkGreaterThan) or + Check(tkLessEqual) or Check(tkGreaterEqual) then + begin + if Check(tkEquals) then CmpOp := boEQ + else if Check(tkNotEquals) then CmpOp := boNE + else if Check(tkLessThan) then CmpOp := boLT + else if Check(tkGreaterThan) then CmpOp := boGT + else if Check(tkLessEqual) then CmpOp := boLE + else CmpOp := boGE; + Advance; + Right := ParseAddSub; + Node := TBinaryExpr.Create; + Node.Op := CmpOp; + Node.Left := Result; + Node.Right := Right; + Result := Node; + end + else if Check(tkIs) then + begin + IsNode := TIsExpr.Create; + IsNode.Line := FCurrent.Line; + IsNode.Col := FCurrent.Col; + Advance; + IsNode.Obj := Result; + IsNode.TypeName := FCurrent.Value; + Expect(tkIdent); + Result := IsNode; + end + else if Check(tkAs) then + begin + Advance; + AsNode := TAsExpr.Create; + AsNode.Obj := Result; + AsNode.TypeName := FCurrent.Value; + Expect(tkIdent); + Result := AsNode; + end; +end; + +function TParser.ParseAddSub: TASTExpr; +var + Right: TASTExpr; + Op: TBinaryOp; + Node: TBinaryExpr; +begin + Result := ParseTerm; + while Check(tkPlus) or Check(tkMinus) or Check(tkOr) do + begin + if Check(tkPlus) then Op := boAdd + else if Check(tkMinus) then Op := boSub + else Op := boOr; + Advance; + Right := ParseTerm; + Node := TBinaryExpr.Create; + Node.Op := Op; + Node.Left := Result; + Node.Right := Right; + Result := Node; + end; +end; + +function TParser.ParseTerm: TASTExpr; +var + Right: TASTExpr; + Op: TBinaryOp; + Node: TBinaryExpr; +begin + Result := ParseFactor; + while Check(tkStar) or Check(tkSlash) or Check(tkDiv) or Check(tkAnd) do + begin + if Check(tkStar) then Op := boMul + else if Check(tkAnd) then Op := boAnd + else Op := boDiv; + Advance; + Right := ParseFactor; + Node := TBinaryExpr.Create; + Node.Op := Op; + Node.Left := Result; + Node.Right := Right; + Result := Node; + end; +end; + +function TParser.ParseFactor: TASTExpr; +var + IntNode: TIntLiteral; + StrNode: TStringLiteral; + NilNode: TNilLiteral; + IdNode: TIdentExpr; + FldNode: TFieldAccessExpr; + MCallNode: TMethodCallExpr; + FCallNode: TFuncCallExpr; + DerefNode: TDerefExpr; + NotNode: TNotExpr; + Inner: TASTExpr; + Name: string; + SecondName: string; + Line, Col: Integer; + ZeroNode: TIntLiteral; + NegNode: TBinaryExpr; +begin + case FCurrent.Kind of + tkNot: + begin + NotNode := TNotExpr.Create; + NotNode.Line := FCurrent.Line; + NotNode.Col := FCurrent.Col; + Advance; + NotNode.Expr := Self.ParseFactor; + Result := NotNode; + end; + tkMinus: + begin + + ZeroNode := TIntLiteral.Create; + ZeroNode.Line := FCurrent.Line; + ZeroNode.Col := FCurrent.Col; + ZeroNode.Value := 0; + NegNode := TBinaryExpr.Create; + NegNode.Line := FCurrent.Line; + NegNode.Col := FCurrent.Col; + NegNode.Op := boSub; + NegNode.Left := ZeroNode; + Advance; + NegNode.Right := Self.ParseFactor; + Result := NegNode; + end; + tkNil: + begin + NilNode := TNilLiteral.Create; + NilNode.Line := FCurrent.Line; + NilNode.Col := FCurrent.Col; + Advance; + Result := NilNode; + end; + tkIntLit: + begin + IntNode := TIntLiteral.Create; + IntNode.Line := FCurrent.Line; + IntNode.Col := FCurrent.Col; + IntNode.Value := StrToInt(FCurrent.Value); + Advance; + Result := IntNode; + end; + tkStringLit: + begin + StrNode := TStringLiteral.Create; + StrNode.Line := FCurrent.Line; + StrNode.Col := FCurrent.Col; + StrNode.Value := FCurrent.Value; + Advance; + Result := StrNode; + end; + tkIdent: + begin + Name := FCurrent.Value; + Line := FCurrent.Line; + Col := FCurrent.Col; + Advance; + + + + + if Check(tkLessThan) and (PeekKind = tkIdent) and + (((PeekKind2 = tkGreaterThan) or (PeekKind2 = tkComma))) then + begin + Advance; + Name := Name + '<' + FCurrent.Value; + Advance; + while Check(tkComma) do + begin + Advance; + Name := Name + ',' + FCurrent.Value; + Advance; + end; + Expect(tkGreaterThan); + Name := Name + '>'; + + if not (Check(tkDot) or Check(tkLParen)) then + raise EParseError.Create(Format('Expected ''.'' or ''('' after generic type arguments at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; + if Check(tkDot) then + begin + Advance; + if not Check(tkIdent) then + raise EParseError.Create(Format('Expected field or method name at line %d col %d', FCurrent.Line, FCurrent.Col)); + SecondName := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + + 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 + + FldNode := TFieldAccessExpr.Create; + FldNode.Line := Line; + FldNode.Col := Col; + FldNode.RecordName := Name; + FldNode.FieldName := SecondName; + Result := FldNode; + + while Check(tkDot) and (PeekKind = tkIdent) do + begin + Advance; + SecondName := FCurrent.Value; + Advance; + if Check(tkLParen) then + begin + + MCallNode := TMethodCallExpr.Create; + MCallNode.Line := FCurrent.Line; + MCallNode.Col := FCurrent.Col; + MCallNode.ObjectName := ''; + MCallNode.Name := SecondName; + MCallNode.ObjExpr := Result; + 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 + FldNode := TFieldAccessExpr.Create; + FldNode.Line := FCurrent.Line; + FldNode.Col := FCurrent.Col; + FldNode.Base := Result; + FldNode.FieldName := SecondName; + Result := FldNode; + end; + end; + end; + end + else if Check(tkLParen) then + begin + + FCallNode := TFuncCallExpr.Create; + FCallNode.Line := Line; + FCallNode.Col := Col; + FCallNode.Name := Name; + Advance; + if not Check(tkRParen) then + begin + FCallNode.Args.Add(ParseExpr); + while Check(tkComma) do + begin + Advance; + FCallNode.Args.Add(ParseExpr); + end; + end; + Expect(tkRParen); + Result := FCallNode; + + while Check(tkDot) and (PeekKind = tkIdent) do + begin + Advance; + SecondName := FCurrent.Value; + Advance; + FldNode := TFieldAccessExpr.Create; + FldNode.Line := FCurrent.Line; + FldNode.Col := FCurrent.Col; + FldNode.Base := Result; + FldNode.FieldName := SecondName; + Result := FldNode; + if Check(tkLParen) then + begin + + + + + Advance; + if not Check(tkRParen) then + begin + FldNode.ResolvedType := nil; + end; + + + MCallNode := TMethodCallExpr.Create; + MCallNode.Line := FldNode.Line; + MCallNode.Col := FldNode.Col; + MCallNode.ObjectName := ''; + MCallNode.Name := SecondName; + MCallNode.ObjExpr := FldNode.Base; + FldNode.Base := nil; + FldNode.Free; + 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; + end; + end + else + begin + IdNode := TIdentExpr.Create; + IdNode.Line := Line; + IdNode.Col := Col; + IdNode.Name := Name; + Result := IdNode; + end; + + if Check(tkCaret) then + begin + Advance; + DerefNode := TDerefExpr.Create; + DerefNode.Line := Line; + DerefNode.Col := Col; + DerefNode.Expr := Result; + Result := DerefNode; + end; + end; + tkLParen: + begin + Advance; + Inner := ParseExpr; + Expect(tkRParen); + + if Check(tkCaret) then + begin + Advance; + DerefNode := TDerefExpr.Create; + DerefNode.Line := FCurrent.Line; + DerefNode.Col := FCurrent.Col; + DerefNode.Expr := Inner; + Result := DerefNode; + end + else + Result := Inner; + end; + else + raise EParseError.Create(Format('Expected expression at line %d col %d', FCurrent.Line, FCurrent.Col)); + end; +end; + + + + +{ === uSemantic === } + + + + + + + + + + + + + + + + + + + + + + +type + + TSemanticAnalyser = class + + FTable: TSymbolTable; + FProg: TProgram; + FMethodIndex: TStringList; + FProcIndex: TStringList; + FGenericFuncTemplates: TStringList; + FLoopDepth: Integer; + FScopeDepth: Integer; + FCurrentClass: TRecordTypeDesc; + + + function FindTypeOrInstantiate(const AName: string): TTypeDesc; + function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc; + function InstantiateGenericInterface(const ATypeName: string): TInterfaceTypeDesc; + function SubstTypeParam(const ATypeName: string; + AParamNames, AArgs: TStringList): string; + + + function InstantiateGenericFunc(const AInstName: string): TMethodDecl; + + procedure AnalyseBlock(ABlock: TBlock); + procedure AnalyseConstDecls(ABlock: TBlock); + procedure AnalyseTypeDecls(ABlock: TBlock); + procedure LinkClassMethodImpls(ABlock: TBlock); + procedure LinkGenericClassMethodImpls(ABlock: TBlock); + procedure AnalyseMethodBodies(ABlock: TBlock); + procedure AnalyseMethodDecl(AMethod: TMethodDecl; AClassType: TRecordTypeDesc); + procedure AnalyseStandaloneDecls(ABlock: TBlock); + procedure AnalyseStandaloneBodies(ABlock: TBlock); + procedure AnalyseStandaloneDecl(ADecl: TMethodDecl); + 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); + procedure AnalyseInheritedCall(ACall: TInheritedCallStmt); + procedure AnalyseCaseStmt(AStmt: TCaseStmt); + function AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc; + function AnalyseFuncCallExpr(AExpr: TFuncCallExpr): TTypeDesc; + function AnalyseExpr(AExpr: TASTExpr): TTypeDesc; + function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc; + function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc; + function AnalyseIsExpr(AExpr: TIsExpr): TTypeDesc; + function AnalyseAsExpr(AExpr: TAsExpr): TTypeDesc; + function AnalyseDerefExpr(AExpr: TDerefExpr): TTypeDesc; + procedure AnalysePointerWriteStmt(AStmt: TPointerWriteStmt); + + procedure AnalyseCompoundBody(ABody: TCompoundStmt); + function FindMethodDecl(const ATypeName, AMethodName: string): TMethodDecl; + + + + + function AttrMatches(const AAttrName, ACanonical: string): Boolean; + function HasWeakAttribute(AAttrs: TStringList): Boolean; + + procedure SemanticError(const AMsg: string; ALine, ACol: Integer); + procedure CheckTypesMatch(AExpected, AActual: TTypeDesc; + const AContext: string; ALine, ACol: Integer); + + function IsSubtypeOf(AActual, AExpected: TTypeDesc): Boolean; + + + + procedure CheckTypeParamConstraint(const AParamName, AArgName, AConstraint, + AContext: string); + + procedure Create; + procedure Destroy; + procedure Analyse(AProg: TProgram); + procedure AnalyseUnit(AUnit: TUnit); + end; + + +procedure TSemanticAnalyser.Create; +begin + + FTable := TSymbolTable.Create; + FMethodIndex := TStringList.Create; + FMethodIndex.CaseSensitive := False; + FProcIndex := TStringList.Create; + FProcIndex.CaseSensitive := False; + FGenericFuncTemplates := TStringList.Create; + FGenericFuncTemplates.CaseSensitive := False; + FLoopDepth := 0; +end; + +procedure TSemanticAnalyser.Destroy; +begin + FGenericFuncTemplates.Free; + FProcIndex.Free; + FMethodIndex.Free; + FTable.Free; + +end; + +procedure TSemanticAnalyser.SemanticError(const AMsg: string; ALine, ACol: Integer); +begin + raise ESemanticError.Create(Format('%s at line %d col %d', AMsg, ALine, ACol)); +end; + +function TSemanticAnalyser.AttrMatches(const AAttrName, ACanonical: string): Boolean; + + + + +var + Suffix: string; +begin + if SameText(AAttrName, ACanonical) then + begin Result := True; Exit end; + Suffix := ACanonical + 'Attribute'; + Result := SameText(AAttrName, Suffix); +end; + +function TSemanticAnalyser.HasWeakAttribute(AAttrs: TStringList): Boolean; +var + I: Integer; +begin + if AAttrs = nil then begin Result := False; Exit end; + for I := 0 to AAttrs.Count - 1 do + if AttrMatches(AAttrs.Get(I), 'Weak') then + begin Result := True; Exit end; + Result := False; +end; + +procedure TSemanticAnalyser.CheckTypeParamConstraint( + const AParamName, AArgName, AConstraint, AContext: string); +var + ArgType: TTypeDesc; + ConstrType: TTypeDesc; + RT: TRecordTypeDesc; + I: Integer; + Implements: Boolean; +begin + if AConstraint = '' then Exit; + + ArgType := FTable.FindType(AArgName); + if ArgType = nil then + raise ESemanticError.Create(Format('Unknown type ''%s'' for type parameter ''%s'' in %s', AArgName, AParamName, AContext)); + + if SameText(AConstraint, 'class') then + begin + if ArgType.Kind <> tyClass then + raise ESemanticError.Create(Format('Type ''%s'' does not satisfy constraint ''%s: class'' in %s', AArgName, AParamName, AContext)); + Exit; + end; + + if SameText(AConstraint, 'record') then + begin + if not (((ArgType.Kind = tyRecord) or (ArgType.Kind = tyInteger) or (ArgType.Kind = tyInt64) or (ArgType.Kind = tyUInt32) or (ArgType.Kind = tyByte) or (ArgType.Kind = tyBoolean) or (ArgType.Kind = tyString) or (ArgType.Kind = tyPointer))) then + raise ESemanticError.Create(Format('Type ''%s'' does not satisfy constraint ''%s: record'' in %s', AArgName, AParamName, AContext)); + Exit; + end; + + + + ConstrType := FTable.FindType(AConstraint); + if ConstrType = nil then + raise ESemanticError.Create(Format('Unknown constraint type ''%s'' for type parameter ''%s'' in %s', AConstraint, AParamName, AContext)); + + if ArgType = ConstrType then Exit; + + if (ConstrType.Kind = tyClass) and (ArgType.Kind = tyClass) then + begin + if IsSubtypeOf(ArgType, ConstrType) then Exit; + raise ESemanticError.Create(Format('Type ''%s'' does not inherit from ''%s'' (constraint ''%s: %s'') in %s', AArgName, AConstraint, AParamName, AConstraint, AContext)); + end; + + if (ConstrType.Kind = tyInterface) and (ArgType.Kind = tyClass) then + begin + RT := TRecordTypeDesc(ArgType); + Implements := False; + for I := 0 to RT.ImplementsCount - 1 do + if RT.ImplementsIntfAt(I) = ConstrType then + begin + Implements := True; + Break; + end; + if not Implements then + raise ESemanticError.Create(Format('Type ''%s'' does not implement ''%s'' (constraint ''%s: %s'') in %s', AArgName, AConstraint, AParamName, AConstraint, AContext)); + Exit; + end; + + raise ESemanticError.Create(Format('Type ''%s'' does not satisfy constraint ''%s: %s'' in %s', AArgName, AParamName, AConstraint, AContext)); +end; + +function TSemanticAnalyser.IsSubtypeOf(AActual, AExpected: TTypeDesc): Boolean; +var + Walk: TRecordTypeDesc; +begin + Result := AActual = AExpected; + if Result then Exit; + if (AActual = nil) or (AExpected = nil) then Exit; + if (AActual.Kind <> tyClass) or (AExpected.Kind <> tyClass) then Exit; + Walk := TRecordTypeDesc(AActual).Parent; + while Walk <> nil do + begin + if Walk = AExpected then + begin + Result := True; + Exit; + end; + Walk := Walk.Parent; + end; +end; + +procedure TSemanticAnalyser.CheckTypesMatch(AExpected, AActual: TTypeDesc; + const AContext: string; ALine, ACol: Integer); +var + RT: TRecordTypeDesc; + I: Integer; +begin + if AExpected = AActual then + Exit; + + if (AActual.Kind = tyNil) and (((AExpected.Kind = tyClass) or (AExpected.Kind = tyInterface) or (AExpected.Kind = tyPointer) or (AExpected.Kind = tyString))) then + Exit; + + + + if (AExpected.Kind = tyPointer) and (AActual.Kind = tyPointer) then + begin + if (TPointerTypeDesc(AExpected).BaseType = nil) or + (TPointerTypeDesc(AActual).BaseType = nil) or + (TPointerTypeDesc(AExpected).BaseType = TPointerTypeDesc(AActual).BaseType) then + Exit; + end; + + + if (AExpected.Kind = tyEnum) and AActual.IsNumeric then Exit; + if (AActual.Kind = tyEnum) and AExpected.IsNumeric then Exit; + + if AExpected.IsNumeric and AActual.IsNumeric then Exit; + + if IsSubtypeOf(AActual, AExpected) then + Exit; + + if (AExpected.Kind = tyClass) and (AExpected.Name = 'TObject') and + (AActual.Kind = tyClass) then + Exit; + + if (AExpected.Kind = tyInterface) and (AActual.Kind = tyClass) then + begin + RT := TRecordTypeDesc(AActual); + for I := 0 to RT.ImplementsCount - 1 do + if RT.ImplementsIntfAt(I) = AExpected then + Exit; + end; + + if (AExpected.Kind = tyPointer) and + (TPointerTypeDesc(AExpected).BaseType = nil) and + (((AActual.Kind = tyClass) or (AActual.Kind = tyInterface) or (AActual.Kind = tyString) or (AActual.Kind = tyPointer))) then + Exit; + if (AActual.Kind = tyPointer) and + (TPointerTypeDesc(AActual).BaseType = nil) and + (((AExpected.Kind = tyClass) or (AExpected.Kind = tyInterface) or (AExpected.Kind = tyString) or (AExpected.Kind = tyPointer))) then + Exit; + SemanticError( + Format('Type mismatch in %s: expected ''%s'' but got ''%s''', AContext, AExpected.Name, AActual.Name), + ALine, ACol); +end; + +procedure TSemanticAnalyser.Analyse(AProg: TProgram); +begin + FProg := AProg; + AnalyseBlock(AProg.Block); + + + + AProg.SymbolTable := FTable; + FTable := nil; +end; + +procedure TSemanticAnalyser.AnalyseUnit(AUnit: TUnit); +var + I, J: Integer; + MDecl: TMethodDecl; + ImplDecl: TMethodDecl; + ImplIdx: Integer; + Par: TMethodParam; + ParType: TTypeDesc; + Sym: TSymbol; +begin + FTable.PushScope; + try + + AnalyseTypeDecls(AUnit.IntfBlock); + + + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + begin + MDecl := TMethodDecl(AUnit.IntfBlock.ProcDecls.Get(I)); + + for J := 0 to MDecl.Params.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(J)); + 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; + + if MDecl.ReturnTypeName <> '' then + begin + ParType := FTable.FindType(MDecl.ReturnTypeName); + if ParType = nil then + SemanticError( + Format('Unknown return type ''%s'' for ''%s''', MDecl.ReturnTypeName, MDecl.Name), + MDecl.Line, MDecl.Col); + MDecl.ResolvedReturnType := ParType; + end; + + FProcIndex.AddObject(MDecl.Name, MDecl); + + if MDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(MDecl.Name, skFunction, MDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(MDecl.Name, skProcedure, nil); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate identifier ''%s''', MDecl.Name), + MDecl.Line, MDecl.Col); + end; + end; + + + + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + begin + ImplDecl := TMethodDecl(AUnit.ImplBlock.ProcDecls.Get(I)); + if (ImplDecl.OwnerTypeName <> '') and (ImplDecl.OwnerTypeParams <> nil) then + Continue; + + for J := 0 to ImplDecl.Params.Count - 1 do + begin + Par := TMethodParam(ImplDecl.Params.Get(J)); + ParType := FTable.FindType(Par.TypeName); + if ParType = nil then + SemanticError( + Format('Unknown type ''%s'' for parameter ''%s''', Par.TypeName, Par.ParamName), + ImplDecl.Line, ImplDecl.Col); + Par.ResolvedType := ParType; + end; + + if ImplDecl.ReturnTypeName <> '' then + begin + ParType := FTable.FindType(ImplDecl.ReturnTypeName); + if ParType = nil then + SemanticError( + Format('Unknown return type ''%s'' for ''%s''', ImplDecl.ReturnTypeName, ImplDecl.Name), + ImplDecl.Line, ImplDecl.Col); + ImplDecl.ResolvedReturnType := ParType; + end; + + ImplIdx := FProcIndex.IndexOf(ImplDecl.Name); + if ImplIdx >= 0 then + begin + + MDecl := TMethodDecl(FProcIndex.GetObject(ImplIdx)); + if MDecl.Params.Count <> ImplDecl.Params.Count then + SemanticError( + Format('Signature mismatch for ''%s'': interface has %d params, implementation has %d', ImplDecl.Name, MDecl.Params.Count, ImplDecl.Params.Count), + ImplDecl.Line, ImplDecl.Col); + + FProcIndex.SetObject(ImplIdx, ImplDecl); + end + else + begin + + FProcIndex.AddObject(ImplDecl.Name, ImplDecl); + if ImplDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(ImplDecl.Name, skFunction, ImplDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(ImplDecl.Name, skProcedure, nil); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate identifier ''%s''', ImplDecl.Name), + ImplDecl.Line, ImplDecl.Col); + end; + end; + end; + + + LinkGenericClassMethodImpls(AUnit.ImplBlock); + + + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + begin + MDecl := TMethodDecl(AUnit.IntfBlock.ProcDecls.Get(I)); + ImplIdx := FProcIndex.IndexOf(MDecl.Name); + if (ImplIdx < 0) or + (TMethodDecl(FProcIndex.GetObject(ImplIdx)).Body = nil) then + SemanticError( + Format('Interface function ''%s'' has no implementation', MDecl.Name), + MDecl.Line, MDecl.Col); + end; + + + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + begin + ImplDecl := TMethodDecl(AUnit.ImplBlock.ProcDecls.Get(I)); + if (ImplDecl.OwnerTypeName <> '') and (ImplDecl.OwnerTypeParams <> nil) then + Continue; + AnalyseStandaloneDecl(ImplDecl); + end; + finally + FTable.PopScope; + end; +end; + +procedure TSemanticAnalyser.LinkClassMethodImpls(ABlock: TBlock); +var + I: Integer; + Decl: TMethodDecl; + Key: string; + Idx: Integer; + CD: TMethodDecl; +begin + for I := 0 to ABlock.ProcDecls.Count - 1 do + begin + Decl := TMethodDecl(ABlock.ProcDecls.Get(I)); + if Decl.OwnerTypeName = '' then Continue; + if Decl.OwnerTypeParams <> nil then Continue; + Key := Decl.OwnerTypeName + '.' + Decl.Name; + Idx := FMethodIndex.IndexOf(Key); + if Idx < 0 then + SemanticError( + Format('Method ''%s'' is not declared in class ''%s''', Decl.Name, Decl.OwnerTypeName), + Decl.Line, Decl.Col); + CD := TMethodDecl(FMethodIndex.GetObject(Idx)); + if CD.Body <> nil then + SemanticError( + Format('Method ''%s.%s'' already has an inline body', Decl.OwnerTypeName, Decl.Name), + Decl.Line, Decl.Col); + + CD.Body := Decl.Body; + Decl.Body := nil; + end; +end; + +procedure TSemanticAnalyser.LinkGenericClassMethodImpls(ABlock: TBlock); +var + I, J: Integer; + Decl: TMethodDecl; + Templ: TGenericTypeDef; + MDecl: TMethodDecl; +begin + for I := 0 to ABlock.ProcDecls.Count - 1 do + begin + Decl := TMethodDecl(ABlock.ProcDecls.Get(I)); + if (Decl.OwnerTypeName = '') or (Decl.OwnerTypeParams = nil) then + Continue; + + if not (FTable.FindGeneric(Decl.OwnerTypeName) is TGenericTypeDef) then + SemanticError( + Format('Generic type ''%s'' not found for method ''%s''', Decl.OwnerTypeName, Decl.Name), + Decl.Line, Decl.Col); + Templ := TGenericTypeDef(FTable.FindGeneric(Decl.OwnerTypeName)); + + MDecl := nil; + for J := 0 to Templ.ClassDef.Methods.Count - 1 do + if SameText(TMethodDecl(Templ.ClassDef.Methods.Get(J)).Name, Decl.Name) then + begin + MDecl := TMethodDecl(Templ.ClassDef.Methods.Get(J)); + Break; + end; + if MDecl = nil then + SemanticError( + Format('Method ''%s'' is not declared in generic class ''%s''', Decl.Name, Decl.OwnerTypeName), + Decl.Line, Decl.Col); + if MDecl.Body <> nil then + SemanticError( + Format('Method ''%s.%s'' already has a body', Decl.OwnerTypeName, Decl.Name), + Decl.Line, Decl.Col); + MDecl.Body := Decl.Body; + Decl.Body := nil; + end; +end; + +function TSemanticAnalyser.FindTypeOrInstantiate(const AName: string): TTypeDesc; +var + BaseName: string; + BaseType: TTypeDesc; + PT: TPointerTypeDesc; + Sym: TSymbol; +begin + Result := FTable.FindType(AName); + if Result <> nil then Exit; + + if (Length(AName) > 1) and (OrdAt(AName, 1) = 94) then + begin + BaseName := Copy(AName, 2, MaxInt); + BaseType := FindTypeOrInstantiate(BaseName); + if BaseType <> nil then + begin + PT := FTable.NewPointerType(AName, BaseType); + Sym := TSymbol.Create(AName, skType, PT); + FTable.DefineGlobal(Sym); + Result := PT; + end; + Exit; + end; + if Pos('<', AName) > 0 then + begin + Result := InstantiateGeneric(AName); + if Result = nil then + Result := InstantiateGenericInterface(AName); + end; +end; + +function TSemanticAnalyser.SubstTypeParam(const ATypeName: string; + AParamNames, AArgs: TStringList): string; +var + I: Integer; +begin + Result := ATypeName; + + for I := 0 to AParamNames.Count - 1 do + if SameText(Result, AParamNames.Get(I)) then + begin + Result := AArgs.Get(I); + Exit; + end; + + if (Length(Result) > 0) and (OrdAt(Result, 1) = 94) then + Result := '^' + Self.SubstTypeParam(Copy(Result, 2, MaxInt), AParamNames, AArgs); +end; + +function TSemanticAnalyser.InstantiateGeneric(const ATypeName: string): TRecordTypeDesc; +var + BracPos: Integer; + BaseName: string; + ArgsStr: string; + Args: TStringList; + Templ: TGenericTypeDef; + ClonedCD: TClassTypeDef; + I, J, K: Integer; + FDecl: TFieldDecl; + NewFDecl: TFieldDecl; + MDecl: TMethodDecl; + NewMDecl: TMethodDecl; + Par: TMethodParam; + NewPar: TMethodParam; + Sym: TSymbol; + Key: string; + FldType: TTypeDesc; + FldName: string; + ParType: TTypeDesc; + RT: TRecordTypeDesc; + GI: TGenericInstance; + Subst: string; + ConcrType: TTypeDesc; +begin + Result := nil; + + + BracPos := Pos('<', ATypeName); + if BracPos = 0 then Exit; + BaseName := Copy(ATypeName, 1, BracPos - 1); + ArgsStr := Copy(ATypeName, BracPos + 1, Length(ATypeName) - BracPos - 1); + + Args := TStringList.Create; + try + while ArgsStr <> '' do + begin + BracPos := Pos(',', ArgsStr); + if BracPos > 0 then + begin + Args.Add(Trim(Copy(ArgsStr, 1, BracPos - 1))); + ArgsStr := Trim(Copy(ArgsStr, BracPos + 1, MaxInt)); + end + else + begin + Args.Add(Trim(ArgsStr)); + ArgsStr := ''; + end; + end; + + + if not (FTable.FindGeneric(BaseName) is TGenericTypeDef) then Exit; + Templ := TGenericTypeDef(FTable.FindGeneric(BaseName)); + if Templ = nil then Exit; + if Args.Count <> Templ.ParamNames.Count then Exit; + + + for I := 0 to Args.Count - 1 do + if (Templ.ParamConstraints <> nil) and (I < Templ.ParamConstraints.Count) then + CheckTypeParamConstraint(Templ.ParamNames.Get(I), Args.Get(I), + Templ.ParamConstraints.Get(I), + Format('instantiation ''%s''', ATypeName)); + + + + RT := FTable.NewClassType(ATypeName); + Sym := TSymbol.Create(ATypeName, skType, RT); + FTable.DefineGlobal(Sym); + + + ClonedCD := TClassTypeDef.Create; + ClonedCD.ParentName := Templ.ClassDef.ParentName; + for I := 0 to Templ.ClassDef.ImplementsNames.Count - 1 do + ClonedCD.ImplementsNames.Add(Templ.ClassDef.ImplementsNames.Get(I)); + + + for I := 0 to Templ.ClassDef.Fields.Count - 1 do + begin + FDecl := TFieldDecl(Templ.ClassDef.Fields.Get(I)); + NewFDecl := TFieldDecl.Create; + for J := 0 to FDecl.Names.Count - 1 do + NewFDecl.Names.Add(FDecl.Names.Get(J)); + NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args); + ClonedCD.Fields.Add(NewFDecl); + end; + + + for I := 0 to Templ.ClassDef.Methods.Count - 1 do + begin + MDecl := TMethodDecl(Templ.ClassDef.Methods.Get(I)); + NewMDecl := TMethodDecl.Create; + NewMDecl.Name := MDecl.Name; + NewMDecl.OwnerTypeName := ATypeName; + NewMDecl.IsVirtual := MDecl.IsVirtual; + NewMDecl.IsOverride := MDecl.IsOverride; + NewMDecl.Body := MDecl.Body; + NewMDecl.OwnBody := False; + + for J := 0 to MDecl.Params.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(J)); + NewPar := TMethodParam.Create; + NewPar.ParamName := Par.ParamName; + NewPar.IsVarParam := Par.IsVarParam; + NewPar.TypeName := SubstTypeParam(Par.TypeName, Templ.ParamNames, Args); + NewMDecl.Params.Add(NewPar); + end; + + NewMDecl.ReturnTypeName := + SubstTypeParam(MDecl.ReturnTypeName, Templ.ParamNames, Args); + + ClonedCD.Methods.Add(NewMDecl); + end; + + + for J := 0 to ClonedCD.Methods.Count - 1 do + begin + NewMDecl := TMethodDecl(ClonedCD.Methods.Get(J)); + if NewMDecl.IsVirtual then + RT.AddVTableSlot(NewMDecl.Name, '$' + ATypeName + '_' + NewMDecl.Name) + else if NewMDecl.IsOverride then + RT.OverrideVTableSlot( + RT.FindVTableSlot(NewMDecl.Name), + '$' + ATypeName + '_' + NewMDecl.Name); + end; + + + for J := 0 to ClonedCD.Fields.Count - 1 do + begin + NewFDecl := TFieldDecl(ClonedCD.Fields.Get(J)); + FldType := FindTypeOrInstantiate(NewFDecl.TypeName); + if FldType = nil then + SemanticError( + Format('Unknown type ''%s'' for field in ''%s''', NewFDecl.TypeName, ATypeName), + 0, 0); + NewFDecl.ResolvedType := FldType; + for K := 0 to NewFDecl.Names.Count - 1 do + begin + FldName := NewFDecl.Names.Get(K); + RT.AddField(FldName, FldType); + end; + end; + + + for J := 0 to ClonedCD.Methods.Count - 1 do + begin + NewMDecl := TMethodDecl(ClonedCD.Methods.Get(J)); + Key := ATypeName + '.' + NewMDecl.Name; + FMethodIndex.AddObject(Key, NewMDecl); + if SameText(NewMDecl.Name, 'Destroy') then + RT.HasDestroyMethod := True; + + if NewMDecl.IsVirtual or NewMDecl.IsOverride then + NewMDecl.VTableSlot := RT.FindVTableSlot(NewMDecl.Name); + + for K := 0 to NewMDecl.Params.Count - 1 do + begin + Par := TMethodParam(NewMDecl.Params.Get(K)); + ParType := FindTypeOrInstantiate(Par.TypeName); + if ParType = nil then + SemanticError( + Format('Unknown type ''%s'' for param ''%s'' in ''%s''', Par.TypeName, Par.ParamName, ATypeName), + 0, 0); + Par.ResolvedType := ParType; + end; + + if NewMDecl.ReturnTypeName <> '' then + begin + ParType := FindTypeOrInstantiate(NewMDecl.ReturnTypeName); + if ParType = nil then + SemanticError( + Format('Unknown return type ''%s'' for method ''%s'' in ''%s''', NewMDecl.ReturnTypeName, NewMDecl.Name, ATypeName), + 0, 0); + NewMDecl.ResolvedReturnType := ParType; + end; + end; + + + + + FTable.PushScope; + try + for K := 0 to Templ.ParamNames.Count - 1 do + begin + ConcrType := FindTypeOrInstantiate(Args.Get(K)); + if ConcrType <> nil then + begin + Sym := TSymbol.Create(Templ.ParamNames.Get(K), skType, ConcrType); + FTable.Define(Sym); + end; + end; + for J := 0 to ClonedCD.Methods.Count - 1 do + begin + NewMDecl := TMethodDecl(ClonedCD.Methods.Get(J)); + if NewMDecl.Body <> nil then + AnalyseMethodDecl(NewMDecl, RT); + end; + finally + FTable.PopScope; + end; + + + GI := TGenericInstance.Create; + GI.TypeName := ATypeName; + GI.ClassDef := ClonedCD; + GI.TypeDesc := RT; + FProg.GenericInstances.Add(GI); + + Result := RT; + finally + Args.Free; + end; +end; + +function TSemanticAnalyser.InstantiateGenericInterface(const ATypeName: string): TInterfaceTypeDesc; +var + BracPos: Integer; + BaseName: string; + ArgsStr: string; + Args: TStringList; + Templ: TGenericInterfaceDef; + TemplObj: TObject; + I: Integer; + MDecl: TMethodDecl; + Sym: TSymbol; + GII: TGenericInterfaceInstance; + MangledName: string; +begin + Result := nil; + + BracPos := Pos('<', ATypeName); + if BracPos = 0 then Exit; + BaseName := Copy(ATypeName, 1, BracPos - 1); + ArgsStr := Copy(ATypeName, BracPos + 1, Length(ATypeName) - BracPos - 1); + + Args := TStringList.Create; + try + while ArgsStr <> '' do + begin + BracPos := Pos(',', ArgsStr); + if BracPos > 0 then + begin + Args.Add(Trim(Copy(ArgsStr, 1, BracPos - 1))); + ArgsStr := Trim(Copy(ArgsStr, BracPos + 1, MaxInt)); + end + else + begin + Args.Add(Trim(ArgsStr)); + ArgsStr := ''; + end; + end; + + TemplObj := FTable.FindGeneric(BaseName); + if (TemplObj = nil) or not (TemplObj is TGenericInterfaceDef) then Exit; + Templ := TGenericInterfaceDef(TemplObj); + if Args.Count <> Templ.ParamNames.Count then Exit; + + for I := 0 to Args.Count - 1 do + if (Templ.ParamConstraints <> nil) and (I < Templ.ParamConstraints.Count) then + CheckTypeParamConstraint(Templ.ParamNames.Get(I), Args.Get(I), + Templ.ParamConstraints.Get(I), + Format('interface instantiation ''%s''', ATypeName)); + + + Sym := FTable.Lookup(ATypeName); + if (Sym <> nil) and (Sym.TypeDesc is TInterfaceTypeDesc) then + begin + Result := TInterfaceTypeDesc(Sym.TypeDesc); + Exit; + end; + + + MangledName := BaseName; + for I := 0 to Args.Count - 1 do + MangledName := MangledName + '_' + Args.Get(I); + + + Result := FTable.NewInterfaceType(ATypeName); + Sym := TSymbol.Create(ATypeName, skType, Result); + FTable.DefineGlobal(Sym); + + + for I := 0 to Templ.IntfDef.Methods.Count - 1 do + begin + MDecl := TMethodDecl(Templ.IntfDef.Methods.Get(I)); + Result.AddMethod(MDecl.Name, + SubstTypeParam(MDecl.ReturnTypeName, Templ.ParamNames, Args)); + end; + + + GII := TGenericInterfaceInstance.Create; + GII.InstName := MangledName; + GII.IntfDef.Free; + GII.IntfDef := nil; + GII.TypeDesc := Result; + FProg.GenericIntfInstances.Add(GII); + finally + Args.Free; + end; +end; + +function TSemanticAnalyser.InstantiateGenericFunc(const AInstName: string): TMethodDecl; +var + BracPos: Integer; + BaseName: string; + ArgsStr: string; + Args: TStringList; + Templ: TMethodDecl; + TemplIdx: Integer; + NewMDecl: TMethodDecl; + NewPar: TMethodParam; + OldPar: TMethodParam; + ParTypeName: string; + RetTypeName: string; + SubstType: TTypeDesc; + I, J: Integer; + Sym: TSymbol; + GFI: TGenericFuncInstance; +begin + Result := nil; + + + BracPos := Pos('<', AInstName); + if BracPos = 0 then Exit; + + BaseName := Copy(AInstName, 1, BracPos - 1); + ArgsStr := Copy(AInstName, BracPos + 1, Length(AInstName) - BracPos - 1); + + TemplIdx := FGenericFuncTemplates.IndexOf(BaseName); + if TemplIdx < 0 then Exit; + + Templ := TMethodDecl(FGenericFuncTemplates.GetObject(TemplIdx)); + + Args := TStringList.Create; + try + SplitIntoList(ArgsStr, 44, Args); + + + if Args.Count <> Templ.TypeParams.Count then + SemanticError( + Format('Generic function ''%s'' expects %d type parameter(s) but got %d', BaseName, Templ.TypeParams.Count, Args.Count), + 0, 0); + + + for I := 0 to Args.Count - 1 do + if (Templ.TypeParamConstraints <> nil) and + (I < Templ.TypeParamConstraints.Count) then + CheckTypeParamConstraint(Templ.TypeParams.Get(I), Args.Get(I), + Templ.TypeParamConstraints.Get(I), + Format('generic function ''%s''', AInstName)); + + NewMDecl := TMethodDecl.Create; + NewMDecl.Name := AInstName; + NewMDecl.OwnBody := False; + NewMDecl.Body := Templ.Body; + + + RetTypeName := Templ.ReturnTypeName; + for I := 0 to Templ.TypeParams.Count - 1 do + if SameText(RetTypeName, Templ.TypeParams.Get(I)) then + RetTypeName := Args.Get(I); + NewMDecl.ReturnTypeName := RetTypeName; + if RetTypeName <> '' then + begin + SubstType := FindTypeOrInstantiate(RetTypeName); + if SubstType = nil then + SemanticError(Format('Unknown type ''%s'' in generic function instance ''%s''', RetTypeName, AInstName), 0, 0); + NewMDecl.ResolvedReturnType := SubstType; + end; + + + for I := 0 to Templ.Params.Count - 1 do + begin + OldPar := TMethodParam(Templ.Params.Get(I)); + NewPar := TMethodParam.Create; + NewPar.ParamName := OldPar.ParamName; + NewPar.IsVarParam := OldPar.IsVarParam; + ParTypeName := OldPar.TypeName; + for J := 0 to Templ.TypeParams.Count - 1 do + if SameText(ParTypeName, Templ.TypeParams.Get(J)) then + ParTypeName := Args.Get(J); + NewPar.TypeName := ParTypeName; + SubstType := FindTypeOrInstantiate(ParTypeName); + if SubstType = nil then + SemanticError(Format('Unknown type ''%s'' for parameter ''%s'' in ''%s''', ParTypeName, NewPar.ParamName, AInstName), 0, 0); + NewPar.ResolvedType := SubstType; + NewMDecl.Params.Add(NewPar); + end; + + + AnalyseStandaloneDecl(NewMDecl); + + + FProcIndex.AddObject(AInstName, NewMDecl); + if NewMDecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(AInstName, skFunction, NewMDecl.ResolvedReturnType) + else + Sym := TSymbol.Create(AInstName, skProcedure, nil); + FTable.DefineGlobal(Sym); + + + GFI := TGenericFuncInstance.Create; + GFI.InstName := AInstName; + GFI.MethodDecl := NewMDecl; + FProg.GenericFuncInstances.Add(GFI); + + Result := NewMDecl; + finally + Args.Free; + end; +end; + +procedure TSemanticAnalyser.AnalyseBlock(ABlock: TBlock); +begin + + + + AnalyseConstDecls(ABlock); + AnalyseTypeDecls(ABlock); + + + LinkClassMethodImpls(ABlock); + LinkGenericClassMethodImpls(ABlock); + + + AnalyseStandaloneDecls(ABlock); + AnalyseMethodBodies(ABlock); + FTable.PushScope; + FScopeDepth := FScopeDepth + 1; + try + AnalyseVarDecls(ABlock); + AnalyseStandaloneBodies(ABlock); + AnalyseStmts(ABlock); + finally + FScopeDepth := FScopeDepth - 1; + FTable.PopScope; + end; +end; + +procedure TSemanticAnalyser.AnalyseConstDecls(ABlock: TBlock); +var + I: Integer; + CD: TConstDecl; + Sym: TSymbol; + TD: TTypeDesc; +begin + for I := 0 to ABlock.ConstDecls.Count - 1 do + begin + CD := TConstDecl(ABlock.ConstDecls.Get(I)); + if CD.IsString then + TD := FTable.TypeString + else + TD := FTable.TypeInteger; + Sym := TSymbol.Create(CD.Name, skConstant, TD); + Sym.ConstValue := CD.IntVal; + if not FTable.Define(Sym) then + Sym.Free; + end; +end; + +procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock); +var + I, J, K: Integer; + L: Integer; + TD: TTypeDecl; + FieldList: TObjectList; + MethodList: TObjectList; + FDecl: TFieldDecl; + MDecl: TMethodDecl; + Par: TMethodParam; + ParType: TTypeDesc; + RT: TRecordTypeDesc; + ParentRT: TRecordTypeDesc; + ParentSym: TSymbol; + FldType: TTypeDesc; + FldName: string; + Sym: TSymbol; + Key: string; + FldInfo: TFieldInfo; + IntfDesc: TInterfaceTypeDesc; + IntfName: string; + IntfSym: TSymbol; + ITD: TInterfaceTypeDef; + PropDecl: TPropertyDecl; + PropInfo: TPropertyInfo; + PropType: TTypeDesc; + EnumDesc: TEnumTypeDesc; + EnumDef: TEnumTypeDef; + MName: string; + MSym: TSymbol; +begin + + + for I := 0 to ABlock.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(ABlock.TypeDecls.Get(I)); + if TD.Def is TRecordTypeDef then + RT := FTable.NewRecordType(TD.Name) + else if TD.Def is TClassTypeDef then + RT := FTable.NewClassType(TD.Name) + else if TD.Def is TGenericTypeDef then + begin + + FTable.RegisterGeneric(TD.Name, TD.Def); + Continue; + end + else if TD.Def is TGenericInterfaceDef then + begin + + FTable.RegisterGeneric(TD.Name, TD.Def); + Continue; + end + else if TD.Def is TInterfaceTypeDef then + begin + IntfDesc := FTable.NewInterfaceType(TD.Name); + Sym := TSymbol.Create(TD.Name, skType, IntfDesc); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate type name ''%s''', TD.Name), TD.Line, TD.Col); + end; + Continue; + end + else if TD.Def is TEnumTypeDef then + begin + + EnumDef := TEnumTypeDef(TD.Def); + EnumDesc := FTable.NewEnumType(TD.Name); + for K := 0 to EnumDef.Members.Count - 1 do + begin + MName := EnumDef.Members.Get(K); + EnumDesc.Members.Add(MName); + MSym := TSymbol.Create(MName, skConstant, EnumDesc); + MSym.ConstValue := K; + if not FTable.Define(MSym) then + MSym.Free; + end; + Sym := TSymbol.Create(TD.Name, skType, EnumDesc); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate type name ''%s''', TD.Name), TD.Line, TD.Col); + end; + Continue; + end + else + begin + SemanticError('Only record, class, interface, or enum type definitions are supported', + TD.Line, TD.Col); + Continue; + end; + Sym := TSymbol.Create(TD.Name, skType, RT); + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError(Format('Duplicate type name ''%s''', TD.Name), TD.Line, TD.Col); + end; + end; + + + for I := 0 to ABlock.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(ABlock.TypeDecls.Get(I)); + + + if TD.Def is TGenericTypeDef then Continue; + if TD.Def is TGenericInterfaceDef then Continue; + if TD.Def is TEnumTypeDef then Continue; + + + if TD.Def is TInterfaceTypeDef then + begin + ITD := TInterfaceTypeDef(TD.Def); + IntfSym := FTable.Lookup(TD.Name); + IntfDesc := TInterfaceTypeDesc(IntfSym.TypeDesc); + if ITD.ParentName <> '' then + begin + Sym := FTable.Lookup(ITD.ParentName); + if (Sym = nil) or not (Sym.TypeDesc is TInterfaceTypeDesc) then + SemanticError( + Format('Unknown parent interface ''%s'' for ''%s''', ITD.ParentName, TD.Name), + TD.Line, TD.Col); + IntfDesc.Parent := TInterfaceTypeDesc(Sym.TypeDesc); + + for J := 0 to IntfDesc.Parent.MethodCount - 1 do + IntfDesc.AddMethod(IntfDesc.Parent.MethodName(J), + IntfDesc.Parent.MethodReturnTypeName(J)); + end; + for J := 0 to ITD.Methods.Count - 1 do + IntfDesc.AddMethod(TMethodDecl(ITD.Methods.Get(J)).Name, + TMethodDecl(ITD.Methods.Get(J)).ReturnTypeName); + Continue; + end; + + Sym := FTable.Lookup(TD.Name); + RT := TRecordTypeDesc(Sym.TypeDesc); + + if TD.Def is TRecordTypeDef then + begin + FieldList := TRecordTypeDef(TD.Def).Fields; + MethodList := nil; + end + else + begin + FieldList := TClassTypeDef(TD.Def).Fields; + MethodList := TClassTypeDef(TD.Def).Methods; + + + + + + if TClassTypeDef(TD.Def).ParentName <> '' then + begin + ParentSym := nil; + + if Pos('<', TClassTypeDef(TD.Def).ParentName) > 0 then + begin + IntfDesc := TInterfaceTypeDesc( + FindTypeOrInstantiate(TClassTypeDef(TD.Def).ParentName)); + if IntfDesc <> nil then + begin + + TClassTypeDef(TD.Def).ImplementsNames.Insert( + 0, TClassTypeDef(TD.Def).ParentName); + TClassTypeDef(TD.Def).ParentName := ''; + end; + end; + if TClassTypeDef(TD.Def).ParentName <> '' then + begin + ParentSym := FTable.Lookup(TClassTypeDef(TD.Def).ParentName); + if (ParentSym = nil) or not (ParentSym.TypeDesc is TRecordTypeDesc) then + SemanticError( + Format('Unknown parent class ''%s'' for ''%s''', TClassTypeDef(TD.Def).ParentName, TD.Name), + TD.Line, TD.Col); + ParentRT := TRecordTypeDesc(ParentSym.TypeDesc); + RT.Parent := ParentRT; + RT.CopyVTableFrom(ParentRT); + for K := 0 to ParentRT.Fields.Count - 1 do + begin + FldInfo := TFieldInfo(ParentRT.Fields.Get(K)); + RT.AddField(FldInfo.Name, FldInfo.TypeDesc); + end; + end; + end; + + + + if MethodList <> nil then + for J := 0 to MethodList.Count - 1 do + begin + MDecl := TMethodDecl(MethodList.Get(J)); + if MDecl.IsVirtual then + RT.AddVTableSlot(MDecl.Name, '$' + TD.Name + '_' + MDecl.Name) + else if MDecl.IsOverride then + RT.OverrideVTableSlot( + RT.FindVTableSlot(MDecl.Name), + '$' + TD.Name + '_' + MDecl.Name); + end; + end; + + + for J := 0 to FieldList.Count - 1 do + begin + FDecl := TFieldDecl(FieldList.Get(J)); + FldType := FindTypeOrInstantiate(FDecl.TypeName); + if FldType = nil then + SemanticError( + Format('Unknown type ''%s'' for field', FDecl.TypeName), + FDecl.Line, FDecl.Col); + FDecl.ResolvedType := FldType; + + if HasWeakAttribute(FDecl.Attributes) then + begin + if not ((FldType.Kind = tyClass) or (FldType.Kind = tyInterface)) then + SemanticError( + Format('[Weak] can only be applied to class or interface ' + + 'fields, not ''%s''', FDecl.TypeName), + FDecl.Line, FDecl.Col); + FDecl.IsWeak := True; + end; + for K := 0 to FDecl.Names.Count - 1 do + begin + FldName := FDecl.Names.Get(K); + RT.AddField(FldName, FldType); + + + + if FDecl.IsWeak then + RT.FindField(FldName).IsWeak := True; + end; + end; + + + if MethodList <> nil then + for J := 0 to MethodList.Count - 1 do + begin + MDecl := TMethodDecl(MethodList.Get(J)); + MDecl.OwnerTypeName := TD.Name; + Key := TD.Name + '.' + MDecl.Name; + FMethodIndex.AddObject(Key, MDecl); + if SameText(MDecl.Name, 'Destroy') then + RT.HasDestroyMethod := True; + + + if MDecl.IsVirtual or MDecl.IsOverride then + begin + MDecl.VTableSlot := RT.FindVTableSlot(MDecl.Name); + if MDecl.IsOverride and (MDecl.VTableSlot < 0) then + SemanticError( + Format('Method ''%s'' marked override but no virtual base method found', MDecl.Name), + MDecl.Line, MDecl.Col); + end; + + for K := 0 to MDecl.Params.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(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; + + 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; + + + if TD.Def is TClassTypeDef then + for J := 0 to TClassTypeDef(TD.Def).Properties.Count - 1 do + begin + PropDecl := TPropertyDecl(TClassTypeDef(TD.Def).Properties.Get(J)); + PropType := FTable.FindType(PropDecl.TypeName); + if PropType = nil then + SemanticError( + Format('Unknown type ''%s'' for property ''%s''', PropDecl.TypeName, PropDecl.Name), + PropDecl.Line, PropDecl.Col); + PropInfo := TPropertyInfo.Create; + PropInfo.Name := PropDecl.Name; + PropInfo.TypeDesc := PropType; + if PropDecl.ReadName <> '' then + begin + if RT.FindField(PropDecl.ReadName) <> nil then + PropInfo.ReadField := PropDecl.ReadName + else + PropInfo.ReadMethod := PropDecl.ReadName; + end; + if PropDecl.WriteName <> '' then + begin + if RT.FindField(PropDecl.WriteName) <> nil then + PropInfo.WriteField := PropDecl.WriteName + else + PropInfo.WriteMethod := PropDecl.WriteName; + end; + RT.AddProperty(PropInfo); + end; + + + if TD.Def is TClassTypeDef then + for L := 0 to TClassTypeDef(TD.Def).ImplementsNames.Count - 1 do + begin + IntfName := TClassTypeDef(TD.Def).ImplementsNames.Get(L); + IntfSym := FTable.Lookup(IntfName); + if IntfSym = nil then + begin + + IntfDesc := TInterfaceTypeDesc(FindTypeOrInstantiate(IntfName)); + if IntfDesc = nil then + SemanticError( + Format('Unknown interface ''%s'' in implements list of ''%s''', IntfName, TD.Name), + TD.Line, TD.Col); + IntfSym := FTable.Lookup(IntfName); + end; + if (IntfSym = nil) or not (IntfSym.TypeDesc is TInterfaceTypeDesc) then + SemanticError( + Format('Unknown interface ''%s'' in implements list of ''%s''', IntfName, TD.Name), + TD.Line, TD.Col); + IntfDesc := TInterfaceTypeDesc(IntfSym.TypeDesc); + RT.AddImplements(IntfDesc); + for J := 0 to IntfDesc.MethodCount - 1 do + begin + Key := IntfDesc.MethodName(J); + if RT.FindField(Key) = nil then + begin + + MDecl := nil; + if TD.Def is TClassTypeDef then + for K := 0 to TClassTypeDef(TD.Def).Methods.Count - 1 do + if SameText(TMethodDecl(TClassTypeDef(TD.Def).Methods.Get(K)).Name, Key) then + begin + MDecl := TMethodDecl(TClassTypeDef(TD.Def).Methods.Get(K)); + Break; + end; + if MDecl = nil then + SemanticError( + Format('Class ''%s'' does not implement method ''%s'' from interface ''%s''', TD.Name, Key, IntfName), + TD.Line, TD.Col); + end; + 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.Get(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.Get(J)), RT); + end; +end; + +procedure TSemanticAnalyser.AnalyseMethodDecl( + AMethod: TMethodDecl; AClassType: TRecordTypeDesc); +var + I: Integer; + Par: TMethodParam; + Sym: TSymbol; + SavedClass: TRecordTypeDesc; +begin + SavedClass := FCurrentClass; + FCurrentClass := AClassType; + FTable.PushScope; + FScopeDepth := FScopeDepth + 1; + try + + Sym := TSymbol.Create('Self', skVariable, AClassType); + FTable.Define(Sym); + + + if AMethod.ResolvedReturnType <> nil then + begin + Sym := TSymbol.Create('Result', skVariable, AMethod.ResolvedReturnType); + FTable.Define(Sym); + end; + + + for I := 0 to AMethod.Params.Count - 1 do + begin + Par := TMethodParam(AMethod.Params.Get(I)); + if Par.ResolvedType = nil then + SemanticError( + Format('Parameter ''%s'' has unresolved type', Par.ParamName), + AMethod.Line, AMethod.Col); + if Par.IsVarParam then + Sym := TSymbol.Create(Par.ParamName, skVarParameter, Par.ResolvedType) + else + 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; + + + if AMethod.Body <> nil then + AnalyseBlock(AMethod.Body); + finally + FScopeDepth := FScopeDepth - 1; + FTable.PopScope; + FCurrentClass := SavedClass; + end; +end; + +function TSemanticAnalyser.FindMethodDecl( + const ATypeName, AMethodName: string): TMethodDecl; +var + CurrName: string; + Idx: Integer; + Key: string; + Sym: TSymbol; + RT: TRecordTypeDesc; +begin + CurrName := ATypeName; + while CurrName <> '' do + begin + Key := CurrName + '.' + AMethodName; + Idx := FMethodIndex.IndexOf(Key); + if Idx >= 0 then + begin + Result := TMethodDecl(FMethodIndex.GetObject(Idx)); + Exit; + end; + + Sym := FTable.Lookup(CurrName); + if (Sym <> nil) and (Sym.TypeDesc is TRecordTypeDesc) then + begin + RT := TRecordTypeDesc(Sym.TypeDesc); + if RT.Parent <> nil then + CurrName := RT.Parent.Name + else + Break; + end + else + Break; + end; + Result := nil; +end; + +procedure TSemanticAnalyser.AnalyseStandaloneDecls(ABlock: TBlock); +var + I, J: Integer; + ADecl: TMethodDecl; + Par: TMethodParam; + ParType: TTypeDesc; + RetType: TTypeDesc; + Sym: TSymbol; +begin + for I := 0 to ABlock.ProcDecls.Count - 1 do + begin + ADecl := TMethodDecl(ABlock.ProcDecls.Get(I)); + + if ADecl.OwnerTypeName <> '' then Continue; + + if ADecl.TypeParams <> nil then + begin + FGenericFuncTemplates.AddObject(ADecl.Name, ADecl); + Continue; + end; + + + for J := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(J)); + ParType := FTable.FindType(Par.TypeName); + if ParType = nil then + SemanticError( + Format('Unknown type ''%s'' for parameter ''%s'' of ''%s''', Par.TypeName, Par.ParamName, ADecl.Name), + ADecl.Line, ADecl.Col); + Par.ResolvedType := ParType; + end; + + + if ADecl.ReturnTypeName <> '' then + begin + RetType := FTable.FindType(ADecl.ReturnTypeName); + if RetType = nil then + SemanticError( + Format('Unknown return type ''%s'' for function ''%s''', ADecl.ReturnTypeName, ADecl.Name), + ADecl.Line, ADecl.Col); + ADecl.ResolvedReturnType := RetType; + end; + + + + J := FProcIndex.IndexOf(ADecl.Name); + if (J >= 0) and (TMethodDecl(FProcIndex.GetObject(J)).Body = nil) then + begin + FProcIndex.SetObject(J, ADecl); + Continue; + end; + + + FProcIndex.AddObject(ADecl.Name, ADecl); + + + if ADecl.ReturnTypeName <> '' then + Sym := TSymbol.Create(ADecl.Name, skFunction, ADecl.ResolvedReturnType) + else + Sym := TSymbol.Create(ADecl.Name, skProcedure, nil); + + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError( + Format('Duplicate identifier ''%s''', ADecl.Name), + ADecl.Line, ADecl.Col); + end; + end; +end; + +procedure TSemanticAnalyser.AnalyseStandaloneDecl(ADecl: TMethodDecl); +var + I: Integer; + Par: TMethodParam; + Sym: TSymbol; +begin + FTable.PushScope; + FScopeDepth := FScopeDepth + 1; + try + + if ADecl.ResolvedReturnType <> nil then + begin + Sym := TSymbol.Create('Result', skVariable, ADecl.ResolvedReturnType); + FTable.Define(Sym); + end; + + + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(I)); + if Par.IsVarParam then + Sym := TSymbol.Create(Par.ParamName, skVarParameter, Par.ResolvedType) + else + 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), + ADecl.Line, ADecl.Col); + end; + end; + + AnalyseBlock(ADecl.Body); + finally + FScopeDepth := FScopeDepth - 1; + FTable.PopScope; + end; +end; + +procedure TSemanticAnalyser.AnalyseStandaloneBodies(ABlock: TBlock); +var + I: Integer; + ADecl: TMethodDecl; +begin + for I := 0 to ABlock.ProcDecls.Count - 1 do + begin + ADecl := TMethodDecl(ABlock.ProcDecls.Get(I)); + + if ADecl.OwnerTypeName <> '' then Continue; + + if ADecl.TypeParams <> nil then Continue; + + if ADecl.Body = nil then Continue; + AnalyseStandaloneDecl(ADecl); + end; +end; + +procedure TSemanticAnalyser.AnalyseVarDecls(ABlock: TBlock); +var + I, J: Integer; + Decl: TVarDecl; + Typ: TTypeDesc; + VarName: string; + Sym: TSymbol; +begin + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls.Get(I)); + + Typ := FindTypeOrInstantiate(Decl.TypeName); + if Typ = nil then + SemanticError( + Format('Unknown type ''%s''', Decl.TypeName), + Decl.Line, Decl.Col); + + Decl.ResolvedType := Typ; + + + + + + if HasWeakAttribute(Decl.Attributes) then + begin + if not ((Typ.Kind = tyClass) or (Typ.Kind = tyInterface)) then + SemanticError( + Format('[Weak] can only be applied to class or interface types, ' + + 'not ''%s''', Decl.TypeName), + Decl.Line, Decl.Col); + Decl.IsWeak := True; + end; + + + Decl.IsGlobal := (FScopeDepth = 1); + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + Sym := TSymbol.Create(VarName, skVariable, Typ); + Sym.IsWeak := Decl.IsWeak; + Sym.IsGlobal := Decl.IsGlobal; + if not FTable.Define(Sym) then + begin + Sym.Free; + SemanticError( + Format('Duplicate identifier ''%s''', VarName), + Decl.Line, Decl.Col); + end; + end; + end; +end; + +procedure TSemanticAnalyser.AnalyseCompoundBody(ABody: TCompoundStmt); +var + I: Integer; +begin + for I := 0 to ABody.Stmts.Count - 1 do + AnalyseStmt(TASTStmt(ABody.Stmts.Get(I))); +end; + +procedure TSemanticAnalyser.AnalyseStmts(ABlock: TBlock); +var + I: Integer; +begin + for I := 0 to ABlock.Stmts.Count - 1 do + AnalyseStmt(TASTStmt(ABlock.Stmts.Get(I))); +end; + +procedure TSemanticAnalyser.AnalyseStmt(AStmt: TASTStmt); +var + IfS: TIfStmt; + CmpS: TCompoundStmt; + ForS: TForStmt; + I: Integer; + CondType: TTypeDesc; + VarSym: TSymbol; + StartType: TTypeDesc; + EndType: TTypeDesc; +begin + if AStmt is TForStmt then + begin + ForS := TForStmt(AStmt); + VarSym := FTable.Lookup(ForS.VarName); + if VarSym = nil then + SemanticError( + Format('Undeclared loop variable ''%s''', ForS.VarName), + ForS.Line, ForS.Col); + if VarSym.Kind <> skVariable then + SemanticError( + Format('''%s'' is not a variable', ForS.VarName), + ForS.Line, ForS.Col); + if not VarSym.TypeDesc.IsOrdinal then + SemanticError( + Format('Loop variable ''%s'' must be an ordinal type, got ''%s''', ForS.VarName, VarSym.TypeDesc.Name), + ForS.Line, ForS.Col); + StartType := AnalyseExpr(ForS.StartExpr); + CheckTypesMatch(VarSym.TypeDesc, StartType, + 'for-loop start expression', ForS.Line, ForS.Col); + EndType := AnalyseExpr(ForS.EndExpr); + CheckTypesMatch(VarSym.TypeDesc, EndType, + 'for-loop end expression', ForS.Line, ForS.Col); + FLoopDepth := FLoopDepth + 1; + try + AnalyseStmt(ForS.Body); + finally + FLoopDepth := FLoopDepth - 1; + end; + end + else if AStmt is TWhileStmt then + begin + begin + CondType := AnalyseExpr(TWhileStmt(AStmt).Condition); + if CondType.Kind <> tyBoolean then + SemanticError( + Format('while condition must be Boolean, got ''%s''', CondType.Name), + AStmt.Line, AStmt.Col); + FLoopDepth := FLoopDepth + 1; + try + AnalyseStmt(TWhileStmt(AStmt).Body); + finally + FLoopDepth := FLoopDepth - 1; + end; + end; + end + else if AStmt is TExitStmt then + begin + + + end + else if AStmt is TBreakStmt then + begin + if FLoopDepth = 0 then + SemanticError('''break'' is not inside a loop', AStmt.Line, AStmt.Col); + end + else if AStmt is TContinueStmt then + begin + if FLoopDepth = 0 then + SemanticError('''continue'' is not inside a loop', AStmt.Line, AStmt.Col); + end + else if AStmt is TIfStmt then + begin + IfS := TIfStmt(AStmt); + CondType := AnalyseExpr(IfS.Condition); + if CondType.Kind <> tyBoolean then + SemanticError( + Format('if condition must be Boolean, got ''%s''', CondType.Name), + IfS.Line, IfS.Col); + AnalyseStmt(IfS.ThenStmt); + if IfS.ElseStmt <> nil then + AnalyseStmt(IfS.ElseStmt); + end + else if AStmt is TCompoundStmt then + begin + CmpS := TCompoundStmt(AStmt); + for I := 0 to CmpS.Stmts.Count - 1 do + AnalyseStmt(TASTStmt(CmpS.Stmts.Get(I))); + end + else if AStmt is TTryFinallyStmt then + begin + begin + AnalyseCompoundBody(TTryFinallyStmt(AStmt).TryBody); + AnalyseCompoundBody(TTryFinallyStmt(AStmt).FinallyBody); + end; + end + else if AStmt is TTryExceptStmt then + begin + begin + AnalyseCompoundBody(TTryExceptStmt(AStmt).TryBody); + AnalyseCompoundBody(TTryExceptStmt(AStmt).ExceptBody); + end; + end + else if AStmt is TRaiseStmt then + begin + begin + if TRaiseStmt(AStmt).Expr <> nil then + begin + CondType := AnalyseExpr(TRaiseStmt(AStmt).Expr); + if CondType.Kind <> tyClass then + SemanticError( + Format('raise expression must be a class instance, got ''%s''', CondType.Name), + AStmt.Line, AStmt.Col); + end; + end; + end + else if AStmt is TFieldAssignment then + 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 TInheritedCallStmt then + AnalyseInheritedCall(TInheritedCallStmt(AStmt)) + else if AStmt is TPointerWriteStmt then + AnalysePointerWriteStmt(TPointerWriteStmt(AStmt)) + else if AStmt is TProcCall then + AnalyseProcCall(TProcCall(AStmt)) + else if AStmt is TCaseStmt then + AnalyseCaseStmt(TCaseStmt(AStmt)); +end; + +procedure TSemanticAnalyser.AnalyseMethodCall(ACall: TMethodCallStmt); +var + ObjSym: TSymbol; + RT: TRecordTypeDesc; + MDecl: TMethodDecl; + Par: TMethodParam; + ArgType: TTypeDesc; + I: Integer; + ObjType: TTypeDesc; +begin + + if ACall.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(ACall.ObjExpr); + if not (((ObjType.Kind = tyClass) or (ObjType.Kind = tyInterface))) then + SemanticError( + Format('Receiver of ''.%s'' must be a class or interface', ACall.Name), + ACall.Line, ACall.Col); + RT := TRecordTypeDesc(ObjType); + MDecl := FindMethodDecl(RT.Name, ACall.Name); + if (MDecl = nil) and SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; + Exit; + end; + 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + Exit; + end; + + ObjSym := FTable.Lookup(ACall.ObjectName); + if ObjSym = nil then + begin + + if FCurrentClass <> nil then + begin + ACall.ImplicitBaseInfo := + FCurrentClass.FindField(ACall.ObjectName); + if (ACall.ImplicitBaseInfo <> nil) and + (((ACall.ImplicitBaseInfo.TypeDesc.Kind = tyClass) or (ACall.ImplicitBaseInfo.TypeDesc.Kind = tyInterface))) then + begin + ACall.IsImplicitSelf := True; + RT := TRecordTypeDesc(ACall.ImplicitBaseInfo.TypeDesc); + MDecl := FindMethodDecl(RT.Name, ACall.Name); + if (MDecl = nil) and SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; + Exit; + end; + 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + Exit; + end; + end; + SemanticError( + Format('Undeclared variable ''%s''', ACall.ObjectName), + ACall.Line, ACall.Col); + end; + if not (((ObjSym.Kind = skVariable) or (ObjSym.Kind = skParameter) or (ObjSym.Kind = skVarParameter))) then + SemanticError( + Format('''%s'' is not a variable', ACall.ObjectName), + ACall.Line, ACall.Col); + if not (((ObjSym.TypeDesc.Kind = tyClass) or (ObjSym.TypeDesc.Kind = tyInterface))) then + SemanticError( + Format('''%s'' is not a class or interface variable', ACall.ObjectName), + ACall.Line, ACall.Col); + + + if ObjSym.TypeDesc.Kind = tyInterface then + begin + if not TInterfaceTypeDesc(ObjSym.TypeDesc).HasMethod(ACall.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', ObjSym.TypeDesc.Name, ACall.Name), + ACall.Line, ACall.Col); + + ACall.ResolvedClassType := ObjSym.TypeDesc; + ACall.ResolvedMethod := nil; + ACall.IsGlobal := ObjSym.IsGlobal; + Exit; + end; + + RT := TRecordTypeDesc(ObjSym.TypeDesc); + MDecl := FindMethodDecl(RT.Name, ACall.Name); + if MDecl = nil then + begin + + if SameText(ACall.Name, 'Free') and (ACall.Args.Count = 0) then + begin + ACall.ResolvedClassType := RT; + ACall.ResolvedMethod := nil; + Exit; + end; + SemanticError( + Format('Class ''%s'' has no method ''%s''', RT.Name, ACall.Name), + ACall.Line, ACall.Col); + end; + + 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + ACall.IsGlobal := ObjSym.IsGlobal; +end; + +procedure TSemanticAnalyser.AnalyseAssignment(AAssign: TAssignment); +var + VarSym: TSymbol; + FldInfo: TFieldInfo; + ExprType: TTypeDesc; +begin + VarSym := FTable.Lookup(AAssign.Name); + if VarSym = nil then + begin + + if FCurrentClass <> nil then + begin + FldInfo := FCurrentClass.FindField(AAssign.Name); + if FldInfo <> nil then + begin + AAssign.ImplicitSelfField := FldInfo; + AAssign.ResolvedLhsType := FldInfo.TypeDesc; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col); + Exit; + end; + end; + SemanticError( + Format('Undeclared variable ''%s''', AAssign.Name), + AAssign.Line, AAssign.Col); + end; + if not (((VarSym.Kind = skVariable) or (VarSym.Kind = skVarParameter))) then + SemanticError( + Format('''%s'' is not a variable', AAssign.Name), + AAssign.Line, AAssign.Col); + + AAssign.IsVarParam := (VarSym.Kind = skVarParameter); + AAssign.ResolvedLhsType := VarSym.TypeDesc; + AAssign.IsWeakLhs := VarSym.IsWeak; + AAssign.IsGlobal := VarSym.IsGlobal; + + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(VarSym.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col); +end; + +procedure TSemanticAnalyser.AnalyseInheritedCall(ACall: TInheritedCallStmt); +var + ParentType: TRecordTypeDesc; + MDecl: TMethodDecl; + ArgType: TTypeDesc; + Par: TMethodParam; + I: Integer; +begin + if FCurrentClass = nil then + SemanticError('''inherited'' used outside a method body', + ACall.Line, ACall.Col); + + if FCurrentClass.Parent = nil then + SemanticError( + Format('Class ''%s'' has no parent; ''inherited'' is not valid', FCurrentClass.Name), + ACall.Line, ACall.Col); + + ParentType := FCurrentClass.Parent; + MDecl := FindMethodDecl(ParentType.Name, ACall.Name); + if MDecl = nil then + SemanticError( + Format('Parent class ''%s'' has no method ''%s''', ParentType.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', ParentType.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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(I)); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of inherited ''%s''', I + 1, ACall.Name), + ACall.Line, ACall.Col); + end; + + ACall.ResolvedParentType := ParentType; + ACall.ResolvedMethod := MDecl; +end; + +procedure TSemanticAnalyser.AnalyseFieldAssignment(AAssign: TFieldAssignment); +var + RecSym: TSymbol; + RT: TRecordTypeDesc; + FldInfo: TFieldInfo; + BaseInfo: TFieldInfo; + BaseType: TTypeDesc; + PropInfo: TPropertyInfo; + ExprType: TTypeDesc; + ObjType: TTypeDesc; +begin + + if AAssign.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(AAssign.ObjExpr); + if not (((ObjType.Kind = tyRecord) or (ObjType.Kind = tyClass))) then + SemanticError( + Format('Field assignment: expression is not a record or class (got %s)', ObjType.Name), + AAssign.Line, AAssign.Col); + RT := TRecordTypeDesc(ObjType); + FldInfo := RT.FindField(AAssign.FieldName); + if FldInfo = nil then + begin + PropInfo := RT.FindProperty(AAssign.FieldName); + if (PropInfo <> nil) and (PropInfo.WriteField <> '') then + begin + AAssign.FieldName := PropInfo.WriteField; + FldInfo := RT.FindField(PropInfo.WriteField); + end + else + SemanticError( + Format('Type ''%s'' has no field ''%s''', ObjType.Name, AAssign.FieldName), + AAssign.Line, AAssign.Col); + end; + AAssign.IsClassAccess := ObjType.Kind = tyClass; + AAssign.FieldInfo := FldInfo; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment', + AAssign.Line, AAssign.Col); + Exit; + end; + RecSym := FTable.Lookup(AAssign.RecordName); + if RecSym = nil then + begin + + if FCurrentClass <> nil then + begin + BaseInfo := FCurrentClass.FindField(AAssign.RecordName); + if (BaseInfo <> nil) and + (((BaseInfo.TypeDesc.Kind = tyRecord) or (BaseInfo.TypeDesc.Kind = tyClass))) then + begin + AAssign.IsImplicitSelf := True; + AAssign.ImplicitBaseInfo := BaseInfo; + AAssign.IsClassAccess := BaseInfo.TypeDesc.Kind = tyClass; + BaseType := BaseInfo.TypeDesc; + RT := TRecordTypeDesc(BaseType); + FldInfo := RT.FindField(AAssign.FieldName); + if FldInfo = nil then + begin + PropInfo := RT.FindProperty(AAssign.FieldName); + if (PropInfo <> nil) and (PropInfo.WriteField <> '') then + begin + AAssign.FieldName := PropInfo.WriteField; + FldInfo := RT.FindField(PropInfo.WriteField); + end + else + SemanticError( + Format('Type ''%s'' has no field ''%s''', AAssign.RecordName, AAssign.FieldName), + AAssign.Line, AAssign.Col); + end; + AAssign.FieldInfo := FldInfo; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment', + AAssign.Line, AAssign.Col); + Exit; + end; + end; + SemanticError( + Format('Undeclared variable ''%s''', AAssign.RecordName), + AAssign.Line, AAssign.Col); + end; + if not ((RecSym.Kind = skVariable) or (RecSym.Kind = skParameter)) then + SemanticError( + Format('''%s'' is not a variable', AAssign.RecordName), + AAssign.Line, AAssign.Col); + if not (((RecSym.TypeDesc.Kind = tyRecord) or (RecSym.TypeDesc.Kind = tyClass))) then + SemanticError( + Format('''%s'' is not a record or class variable', AAssign.RecordName), + AAssign.Line, AAssign.Col); + + AAssign.IsClassAccess := RecSym.TypeDesc.Kind = tyClass; + AAssign.IsGlobal := RecSym.IsGlobal; + + RT := TRecordTypeDesc(RecSym.TypeDesc); + FldInfo := RT.FindField(AAssign.FieldName); + if FldInfo = nil then + begin + + PropInfo := RT.FindProperty(AAssign.FieldName); + if PropInfo <> nil then + begin + if PropInfo.WriteField <> '' then + begin + + AAssign.FieldName := PropInfo.WriteField; + FldInfo := RT.FindField(PropInfo.WriteField); + end + else if PropInfo.WriteMethod <> '' then + SemanticError( + Format('Method-backed property write not yet supported for ''%s''', AAssign.FieldName), + AAssign.Line, AAssign.Col) + else + SemanticError( + Format('Property ''%s'' is read-only', AAssign.FieldName), + AAssign.Line, AAssign.Col); + end + else + SemanticError( + Format('Type ''%s'' has no field ''%s''', AAssign.RecordName, AAssign.FieldName), + AAssign.Line, AAssign.Col); + end; + + AAssign.FieldInfo := FldInfo; + ExprType := AnalyseExpr(AAssign.Expr); + CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment', + AAssign.Line, AAssign.Col); +end; + +procedure TSemanticAnalyser.AnalyseProcCall(ACall: TProcCall); +var + Sym: TSymbol; + MDecl: TMethodDecl; + Par: TMethodParam; + ArgType: TTypeDesc; + Idx: Integer; + I: Integer; +begin + Sym := FTable.Lookup(ACall.Name); + if Sym = nil then + begin + + if FCurrentClass <> nil then + begin + MDecl := FindMethodDecl(FCurrentClass.Name, ACall.Name); + if MDecl <> nil then + begin + if ACall.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Method ''%s.%s'' expects %d argument(s) but got %d', FCurrentClass.Name, ACall.Name, MDecl.Params.Count, ACall.Args.Count), + ACall.Line, ACall.Col); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgType := AnalyseExpr(TASTExpr(ACall.Args.Get(I))); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', I + 1, ACall.Name), + ACall.Line, ACall.Col); + end; + ACall.ResolvedDecl := MDecl; + ACall.IsImplicitSelfMethod := True; + Exit; + end; + end; + + if Pos('<', ACall.Name) > 0 then + InstantiateGenericFunc(ACall.Name); + Sym := FTable.Lookup(ACall.Name); + if Sym = nil then + SemanticError( + Format('Undeclared procedure ''%s''', ACall.Name), + ACall.Line, ACall.Col); + end; + if not (((Sym.Kind = skProcedure) or (Sym.Kind = skFunction))) then + SemanticError( + Format('''%s'' is not a procedure or function', ACall.Name), + ACall.Line, ACall.Col); + + + Idx := FProcIndex.IndexOf(ACall.Name); + if Idx >= 0 then + begin + MDecl := TMethodDecl(FProcIndex.GetObject(Idx)); + if ACall.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Procedure ''%s'' expects %d argument(s) but got %d', ACall.Name, MDecl.Params.Count, ACall.Args.Count), + ACall.Line, ACall.Col); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + if Par.IsVarParam then + begin + + if not (TASTExpr(ACall.Args.Get(I)) is TIdentExpr) then + SemanticError( + Format('var argument %d of ''%s'' must be a variable', I + 1, ACall.Name), + ACall.Line, ACall.Col); + ArgType := AnalyseExpr(TASTExpr(ACall.Args.Get(I))); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('var argument %d of ''%s''', I + 1, ACall.Name), + ACall.Line, ACall.Col); + end + else + begin + ArgType := AnalyseExpr(TASTExpr(ACall.Args.Get(I))); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', I + 1, ACall.Name), + ACall.Line, ACall.Col); + end; + end; + ACall.ResolvedDecl := MDecl; + end + else + begin + + for I := 0 to ACall.Args.Count - 1 do + AnalyseExpr(TASTExpr(ACall.Args.Get(I))); + end; +end; + +function TSemanticAnalyser.AnalyseFuncCallExpr(AExpr: TFuncCallExpr): TTypeDesc; +var + Sym: TSymbol; + MDecl: TMethodDecl; + Par: TMethodParam; + ArgType: TTypeDesc; + Idx: Integer; + I: Integer; +begin + + if SameText(AExpr.Name, 'SizeOf') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('SizeOf requires exactly one argument', AExpr.Line, AExpr.Col); + if AExpr.Args.Get(0) is TIdentExpr then + begin + Sym := FTable.Lookup(TIdentExpr(AExpr.Args.Get(0)).Name); + if (Sym <> nil) and (Sym.Kind = skType) then + TIdentExpr(AExpr.Args.Get(0)).ResolvedType := Sym.TypeDesc; + end; + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + Sym := FTable.Lookup(AExpr.Name); + if Sym = nil then + begin + + if FCurrentClass <> nil then + begin + MDecl := FindMethodDecl(FCurrentClass.Name, AExpr.Name); + if MDecl <> nil then + begin + if AExpr.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Method ''%s.%s'' expects %d argument(s) but got %d', FCurrentClass.Name, AExpr.Name, MDecl.Params.Count, AExpr.Args.Count), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgType := AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', I + 1, AExpr.Name), + AExpr.Line, AExpr.Col); + end; + AExpr.ResolvedDecl := MDecl; + AExpr.IsImplicitSelfMethod := True; + Result := MDecl.ResolvedReturnType; + AExpr.ResolvedType := Result; + Exit; + end; + end; + + if Pos('<', AExpr.Name) > 0 then + InstantiateGenericFunc(AExpr.Name); + Sym := FTable.Lookup(AExpr.Name); + if Sym = nil then + SemanticError( + Format('Undeclared function ''%s''', AExpr.Name), + AExpr.Line, AExpr.Col); + end; + + if Sym.Kind = skType then + begin + if AExpr.Args.Count <> 1 then + SemanticError( + Format('Type cast ''%s'' expects exactly one argument', AExpr.Name), + AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := Sym.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + + if Sym.Kind <> skFunction then + SemanticError( + Format('''%s'' is not a function', AExpr.Name), + AExpr.Line, AExpr.Col); + + + if SameText(AExpr.Name, 'GetMem') or SameText(AExpr.Name, 'ReallocMem') then + begin + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + Result := FTable.TypePointer; + AExpr.ResolvedType := Result; + Exit; + end; + + + + if SameText(AExpr.Name, 'Length') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('Length requires exactly one argument', AExpr.Line, AExpr.Col); + ArgType := AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + if ArgType.Kind <> tyString then + SemanticError('Length argument must be a string', AExpr.Line, AExpr.Col); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'Pos') then + begin + if AExpr.Args.Count <> 2 then + SemanticError('Pos requires exactly two arguments', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(1))); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'Copy') then + begin + if AExpr.Args.Count <> 3 then + SemanticError('Copy requires exactly three arguments', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(1))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(2))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'UpperCase') or SameText(AExpr.Name, 'LowerCase') + or SameText(AExpr.Name, 'Trim') then + begin + if AExpr.Args.Count <> 1 then + SemanticError(AExpr.Name + ' requires exactly one argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'SameText') then + begin + if AExpr.Args.Count <> 2 then + SemanticError('SameText requires exactly two arguments', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(1))); + Result := FTable.TypeBoolean; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'IntToStr') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('IntToStr requires exactly one argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'StrToInt') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('StrToInt requires exactly one argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'Format') then + begin + if AExpr.Args.Count < 1 then + SemanticError('Format requires at least one argument', AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'OrdAt') then + begin + if AExpr.Args.Count <> 2 then + SemanticError('OrdAt requires exactly 2 arguments', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(1))); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'CompareStr') or SameText(AExpr.Name, 'CompareText') then + begin + if AExpr.Args.Count <> 2 then + SemanticError(AExpr.Name + ' requires exactly 2 arguments', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + AnalyseExpr(TASTExpr(AExpr.Args.Get(1))); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + + if SameText(AExpr.Name, 'ParamCount') then + begin + if AExpr.Args.Count <> 0 then + SemanticError('ParamCount takes no arguments', AExpr.Line, AExpr.Col); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'ParamStr') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('ParamStr requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + + if SameText(AExpr.Name, 'ReadFile') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('ReadFile requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'FileExists') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('FileExists requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeBoolean; + AExpr.ResolvedType := Result; + Exit; + end; + + + if SameText(AExpr.Name, 'GetEnvVar') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('GetEnvVar requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeString; + AExpr.ResolvedType := Result; + Exit; + end; + + if SameText(AExpr.Name, 'Exec') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('Exec requires exactly 1 argument', AExpr.Line, AExpr.Col); + AnalyseExpr(TASTExpr(AExpr.Args.Get(0))); + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + + Idx := FProcIndex.IndexOf(AExpr.Name); + if Idx < 0 then + SemanticError( + Format('Cannot find declaration for function ''%s''', AExpr.Name), + AExpr.Line, AExpr.Col); + + MDecl := TMethodDecl(FProcIndex.GetObject(Idx)); + + if AExpr.Args.Count <> MDecl.Params.Count then + SemanticError( + Format('Function ''%s'' expects %d argument(s) but got %d', 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(I)); + CheckTypesMatch(Par.ResolvedType, ArgType, + Format('argument %d of ''%s''', I + 1, AExpr.Name), + AExpr.Line, AExpr.Col); + end; + + AExpr.ResolvedDecl := MDecl; + Result := MDecl.ResolvedReturnType; +end; + +function TSemanticAnalyser.AnalyseMethodCallExpr(AExpr: TMethodCallExpr): TTypeDesc; +var + ObjSym: TSymbol; + RT: TRecordTypeDesc; + MDecl: TMethodDecl; + Par: TMethodParam; + ArgType: TTypeDesc; + I: Integer; + IntfDesc: TInterfaceTypeDesc; + ObjType: TTypeDesc; +begin + + if AExpr.ObjExpr <> nil then + begin + ObjType := AnalyseExpr(AExpr.ObjExpr); + if not (((ObjType.Kind = tyClass) or (ObjType.Kind = tyInterface))) then + SemanticError( + Format('Receiver of ''.%s'' must be a class or interface', AExpr.Name), + AExpr.Line, AExpr.Col); + if ObjType.Kind = tyInterface then + begin + IntfDesc := TInterfaceTypeDesc(ObjType); + if not IntfDesc.HasMethod(AExpr.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', ObjType.Name, AExpr.Name), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + AExpr.ResolvedClassType := ObjType; + AExpr.ResolvedMethod := nil; + Result := FindTypeOrInstantiate( + IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); + if Result = nil then Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + RT := TRecordTypeDesc(ObjType); + 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 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + AExpr.ResolvedType := Result; + Exit; + end; + + ObjSym := FTable.Lookup(AExpr.ObjectName); + if ObjSym = nil then + begin + + + if FCurrentClass <> nil then + begin + ObjType := nil; + ObjSym := nil; + begin + + AExpr.ObjExpr := TIdentExpr.Create; + TIdentExpr(AExpr.ObjExpr).Name := AExpr.ObjectName; + TIdentExpr(AExpr.ObjExpr).Line := AExpr.Line; + TIdentExpr(AExpr.ObjExpr).Col := AExpr.Col; + try + ObjType := AnalyseExpr(AExpr.ObjExpr); + except + AExpr.ObjExpr.Free; + AExpr.ObjExpr := nil; + SemanticError( + Format('Undeclared identifier ''%s''', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + end; + end; + if (ObjType = nil) or not (((ObjType.Kind = tyClass) or (ObjType.Kind = tyInterface))) then + begin + AExpr.ObjExpr.Free; + AExpr.ObjExpr := nil; + SemanticError( + Format('Undeclared identifier ''%s''', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + end; + AExpr.ObjectName := ''; + if ObjType.Kind = tyInterface then + begin + IntfDesc := TInterfaceTypeDesc(ObjType); + if not IntfDesc.HasMethod(AExpr.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', ObjType.Name, AExpr.Name), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + AExpr.ResolvedClassType := ObjType; + AExpr.ResolvedMethod := nil; + Result := FindTypeOrInstantiate( + IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); + if Result = nil then Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + RT := TRecordTypeDesc(ObjType); + 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 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + AExpr.ResolvedType := Result; + Exit; + end; + SemanticError( + Format('Undeclared identifier ''%s''', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + end; + + + + if (ObjSym.Kind = skType) and + (SameText(AExpr.Name, 'Create') or + (Pos('Create', AExpr.Name) = 1)) then + begin + if ObjSym.TypeDesc.Kind <> tyClass then + SemanticError( + Format('Cannot construct non-class type ''%s''', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + + MDecl := FindMethodDecl(AExpr.ObjectName, AExpr.Name); + AExpr.ResolvedMethod := MDecl; + AExpr.ResolvedClassType := ObjSym.TypeDesc; + AExpr.IsConstructorCall := True; + Result := ObjSym.TypeDesc; + Exit; + end; + + if not (((ObjSym.Kind = skVariable) or (ObjSym.Kind = skParameter) or (ObjSym.Kind = skVarParameter))) then + SemanticError( + Format('''%s'' is not a variable', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + if not (((ObjSym.TypeDesc.Kind = tyClass) or (ObjSym.TypeDesc.Kind = tyInterface))) then + SemanticError( + Format('''%s'' is not a class or interface variable', AExpr.ObjectName), + AExpr.Line, AExpr.Col); + + + if ObjSym.TypeDesc.Kind = tyInterface then + begin + IntfDesc := TInterfaceTypeDesc(ObjSym.TypeDesc); + if not IntfDesc.HasMethod(AExpr.Name) then + SemanticError( + Format('Interface ''%s'' has no method ''%s''', ObjSym.TypeDesc.Name, AExpr.Name), + AExpr.Line, AExpr.Col); + for I := 0 to AExpr.Args.Count - 1 do + AnalyseExpr(TASTExpr(AExpr.Args.Get(I))); + AExpr.ResolvedClassType := ObjSym.TypeDesc; + AExpr.ResolvedMethod := nil; + AExpr.IsGlobal := ObjSym.IsGlobal; + + Result := FindTypeOrInstantiate( + IntfDesc.MethodReturnTypeName(IntfDesc.MethodIndex(AExpr.Name))); + if Result = nil then + Result := FTable.TypeInteger; + Exit; + end; + + 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.Get(I))); + Par := TMethodParam(MDecl.Params.Get(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; + AExpr.IsGlobal := ObjSym.IsGlobal; + Result := MDecl.ResolvedReturnType; +end; + +function TSemanticAnalyser.AnalyseExpr(AExpr: TASTExpr): TTypeDesc; +var + Sym: TSymbol; + FldInfo: TFieldInfo; + PropInfo: TPropertyInfo; +begin + if AExpr is TNilLiteral then + Result := FTable.TypeNil + else if AExpr is TIntLiteral then + Result := FTable.TypeInteger + else if AExpr is TStringLiteral then + Result := FTable.TypeString + else if AExpr is TIdentExpr then + begin + Sym := FTable.Lookup(TIdentExpr(AExpr).Name); + if Sym = nil then + begin + + if FCurrentClass <> nil then + begin + FldInfo := FCurrentClass.FindField(TIdentExpr(AExpr).Name); + if FldInfo <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelf := True; + TIdentExpr(AExpr).ImplicitFieldInfo := FldInfo; + Result := FldInfo.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + + TIdentExpr(AExpr).ImplicitMethodDecl := + FindMethodDecl(FCurrentClass.Name, TIdentExpr(AExpr).Name); + if TIdentExpr(AExpr).ImplicitMethodDecl <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelfMethod := True; + Result := + TMethodDecl(TIdentExpr(AExpr).ImplicitMethodDecl).ResolvedReturnType; + AExpr.ResolvedType := Result; + Exit; + end; + + FldInfo := nil; + begin + PropInfo := FCurrentClass.FindProperty(TIdentExpr(AExpr).Name); + if PropInfo <> nil then + begin + if PropInfo.ReadMethod <> '' then + begin + TIdentExpr(AExpr).ImplicitMethodDecl := + FindMethodDecl(FCurrentClass.Name, PropInfo.ReadMethod); + if TIdentExpr(AExpr).ImplicitMethodDecl <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelfMethod := True; + TIdentExpr(AExpr).Name := PropInfo.ReadMethod; + Result := PropInfo.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + end + else if PropInfo.ReadField <> '' then + begin + FldInfo := FCurrentClass.FindField(PropInfo.ReadField); + if FldInfo <> nil then + begin + TIdentExpr(AExpr).IsImplicitSelf := True; + TIdentExpr(AExpr).ImplicitFieldInfo := FldInfo; + Result := FldInfo.TypeDesc; + AExpr.ResolvedType := Result; + Exit; + end; + end; + end; + end; + end; + SemanticError( + Format('Undeclared identifier ''%s''', TIdentExpr(AExpr).Name), + AExpr.Line, AExpr.Col); + end; + TIdentExpr(AExpr).IsVarParam := (Sym.Kind = skVarParameter); + TIdentExpr(AExpr).IsGlobal := Sym.IsGlobal; + if Sym.Kind = skConstant then + begin + TIdentExpr(AExpr).IsConstant := True; + TIdentExpr(AExpr).ConstValue := Sym.ConstValue; + end; + + if (Sym.Kind = skFunction) and (Sym.TypeDesc <> nil) and + (FProcIndex.IndexOf(TIdentExpr(AExpr).Name) < 0) then + TIdentExpr(AExpr).IsNoArgFuncCall := True; + Result := Sym.TypeDesc; + end + else if AExpr is TFuncCallExpr then + Result := AnalyseFuncCallExpr(TFuncCallExpr(AExpr)) + 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 + Result := AnalyseBinaryExpr(TBinaryExpr(AExpr)) + else if AExpr is TIsExpr then + Result := AnalyseIsExpr(TIsExpr(AExpr)) + else if AExpr is TAsExpr then + Result := AnalyseAsExpr(TAsExpr(AExpr)) + else if AExpr is TDerefExpr then + Result := AnalyseDerefExpr(TDerefExpr(AExpr)) + else if AExpr is TNotExpr then + begin + Result := AnalyseExpr(TNotExpr(AExpr).Expr); + if Result.Kind <> tyBoolean then + SemanticError( + Format('''not'' requires a Boolean operand, got ''%s''', Result.Name), + AExpr.Line, AExpr.Col); + Result := FTable.TypeBoolean; + end + else + SemanticError('Unknown expression node', AExpr.Line, AExpr.Col); + + AExpr.ResolvedType := Result; +end; + +function TSemanticAnalyser.AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc; +var + RecSym: TSymbol; + RT: TRecordTypeDesc; + FldInfo: TFieldInfo; + PropInfo: TPropertyInfo; + BaseType: TTypeDesc; +begin + + + + if AAccess.Base <> nil then + begin + BaseType := AnalyseExpr(AAccess.Base); + if not (((BaseType.Kind = tyRecord) or (BaseType.Kind = tyClass))) then + SemanticError( + Format('Field access ''.%s'' requires a record or class base, got ''%s''', AAccess.FieldName, BaseType.Name), + AAccess.Line, AAccess.Col); + AAccess.IsClassAccess := BaseType.Kind = tyClass; + RT := TRecordTypeDesc(BaseType); + FldInfo := RT.FindField(AAccess.FieldName); + if FldInfo = nil then + begin + PropInfo := RT.FindProperty(AAccess.FieldName); + if (PropInfo <> nil) and (PropInfo.ReadField <> '') then + begin + AAccess.FieldName := PropInfo.ReadField; + AAccess.FieldInfo := RT.FindField(PropInfo.ReadField); + Result := PropInfo.TypeDesc; + Exit; + end; + + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + Exit; + end; + SemanticError( + Format('Type ''%s'' has no field ''%s''', BaseType.Name, AAccess.FieldName), + AAccess.Line, AAccess.Col); + end; + AAccess.FieldInfo := FldInfo; + Result := FldInfo.TypeDesc; + Exit; + end; + + RecSym := FTable.Lookup(AAccess.RecordName); + if RecSym = nil then + begin + + if FCurrentClass <> nil then + begin + FldInfo := FCurrentClass.FindField(AAccess.RecordName); + if (FldInfo <> nil) and + (((FldInfo.TypeDesc.Kind = tyRecord) or (FldInfo.TypeDesc.Kind = tyClass))) then + begin + AAccess.IsImplicitSelf := True; + AAccess.ImplicitBaseInfo := FldInfo; + AAccess.IsClassAccess := FldInfo.TypeDesc.Kind = tyClass; + RT := TRecordTypeDesc(FldInfo.TypeDesc); + AAccess.FieldInfo := RT.FindField(AAccess.FieldName); + if AAccess.FieldInfo = nil then + begin + + PropInfo := RT.FindProperty(AAccess.FieldName); + if (PropInfo <> nil) and (PropInfo.ReadField <> '') then + begin + AAccess.FieldName := PropInfo.ReadField; + AAccess.FieldInfo := RT.FindField(PropInfo.ReadField); + Result := PropInfo.TypeDesc; + AAccess.ResolvedType := Result; + Exit; + end; + + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + AAccess.ResolvedType := Result; + Exit; + end; + SemanticError( + Format('Type ''%s'' has no field ''%s''', AAccess.RecordName, AAccess.FieldName), + AAccess.Line, AAccess.Col); + end; + Result := AAccess.FieldInfo.TypeDesc; + Exit; + end; + end; + SemanticError( + Format('Undeclared identifier ''%s''', AAccess.RecordName), + AAccess.Line, AAccess.Col); + end; + + + if RecSym.Kind = skType then + begin + if RecSym.TypeDesc.Kind <> tyClass then + SemanticError( + Format('Cannot call procedure on non-class type ''%s''', AAccess.RecordName), + AAccess.Line, AAccess.Col); + if not SameText(AAccess.FieldName, 'Create') then + SemanticError( + Format('Unknown class method ''%s'' on type ''%s''', AAccess.FieldName, AAccess.RecordName), + AAccess.Line, AAccess.Col); + AAccess.IsConstructorCall := True; + Result := RecSym.TypeDesc; + Exit; + end; + + + if not (((RecSym.Kind = skVariable) or (RecSym.Kind = skParameter) or (RecSym.Kind = skVarParameter))) then + SemanticError( + Format('''%s'' is not a variable or type', AAccess.RecordName), + AAccess.Line, AAccess.Col); + + if not (((RecSym.TypeDesc.Kind = tyRecord) or (RecSym.TypeDesc.Kind = tyClass))) then + SemanticError( + Format('''%s'' is not a record or class', AAccess.RecordName), + AAccess.Line, AAccess.Col); + + AAccess.IsClassAccess := RecSym.TypeDesc.Kind = tyClass; + AAccess.IsGlobal := RecSym.IsGlobal; + + RT := TRecordTypeDesc(RecSym.TypeDesc); + FldInfo := RT.FindField(AAccess.FieldName); + if FldInfo = nil then + begin + + AAccess.ResolvedMethod := FindMethodDecl(RT.Name, AAccess.FieldName); + if AAccess.ResolvedMethod <> nil then + begin + AAccess.IsMethodCall := True; + Result := TMethodDecl(AAccess.ResolvedMethod).ResolvedReturnType; + AAccess.ResolvedType := Result; + Exit; + end; + + PropInfo := RT.FindProperty(AAccess.FieldName); + if PropInfo <> nil then + begin + if PropInfo.ReadField <> '' then + begin + + AAccess.FieldName := PropInfo.ReadField; + AAccess.FieldInfo := RT.FindField(PropInfo.ReadField); + Result := PropInfo.TypeDesc; + AAccess.ResolvedType := Result; + Exit; + end + else if PropInfo.ReadMethod <> '' then + begin + + AAccess.PropRead := PropInfo; + AAccess.PropOwnerType := RT.Name; + Result := PropInfo.TypeDesc; + AAccess.ResolvedType := Result; + Exit; + end; + end; + SemanticError( + Format('Type ''%s'' has no field ''%s''', AAccess.RecordName, AAccess.FieldName), + AAccess.Line, AAccess.Col); + end; + + AAccess.FieldInfo := FldInfo; + Result := FldInfo.TypeDesc; +end; + +function TSemanticAnalyser.AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc; +var + LType, RType: TTypeDesc; +begin + LType := AnalyseExpr(ABin.Left); + RType := AnalyseExpr(ABin.Right); + + + if ((ABin.Op = boAnd) or (ABin.Op = boOr)) then + begin + if LType.Kind <> tyBoolean then + SemanticError( + Format('Left operand of ''%s'' must be Boolean, got ''%s''', BinaryOpName(ABin.Op), LType.Name), + ABin.Line, ABin.Col); + if RType.Kind <> tyBoolean then + SemanticError( + Format('Right operand of ''%s'' must be Boolean, got ''%s''', BinaryOpName(ABin.Op), RType.Name), + ABin.Line, ABin.Col); + Result := FTable.TypeBoolean; + Exit; + end; + + if IsComparisonOp(ABin.Op) then + begin + + if not ( + (LType = RType) or + ((LType.Kind = tyNil) and (((RType.Kind = tyClass) or (RType.Kind = tyInterface) or (RType.Kind = tyPointer)))) or + ((RType.Kind = tyNil) and (((LType.Kind = tyClass) or (LType.Kind = tyInterface) or (LType.Kind = tyPointer)))) or + ((LType.Kind = tyPointer) and (RType.Kind = tyPointer)) or + + ((LType.Kind = tyClass) and (RType.Kind = tyClass) and + (IsSubtypeOf(LType, RType) or IsSubtypeOf(RType, LType))) or + + ((LType.Kind = tyClass) and (RType.Kind = tyClass) and + ((LType.Name = 'TObject') or (RType.Name = 'TObject'))) + ) then + CheckTypesMatch(LType, RType, + Format('comparison ''%s''', BinaryOpName(ABin.Op)), + ABin.Line, ABin.Col); + Result := FTable.TypeBoolean; + end + else + begin + + if (ABin.Op = boAdd) and LType.IsString and RType.IsString then + begin + Result := FTable.TypeString; + Exit; + end; + + + if (((ABin.Op = boAdd) or (ABin.Op = boSub))) and (LType.Kind = tyPointer) and RType.IsNumeric then + begin + Result := LType; + Exit; + end; + if (ABin.Op = boAdd) and LType.IsNumeric and (RType.Kind = tyPointer) then + begin + Result := RType; + Exit; + end; + + if not LType.IsNumeric then + SemanticError( + Format('Left operand of ''%s'' must be numeric, got ''%s''', BinaryOpName(ABin.Op), LType.Name), + ABin.Line, ABin.Col); + if not RType.IsNumeric then + SemanticError( + Format('Right operand of ''%s'' must be numeric, got ''%s''', BinaryOpName(ABin.Op), RType.Name), + ABin.Line, ABin.Col); + CheckTypesMatch(LType, RType, 'binary expression', ABin.Line, ABin.Col); + Result := LType; + end; +end; + +function TSemanticAnalyser.AnalyseIsExpr(AExpr: TIsExpr): TTypeDesc; +var + ObjType: TTypeDesc; + TargetType: TTypeDesc; +begin + ObjType := AnalyseExpr(AExpr.Obj); + + if not ((ObjType.Kind = tyClass) or (ObjType.Kind = tyPointer) or + (ObjType.Kind = tyInterface)) then + SemanticError( + Format('''is'' requires a class instance on the left, got ''%s''', ObjType.Name), + AExpr.Line, AExpr.Col); + + TargetType := FTable.FindType(AExpr.TypeName); + if (TargetType = nil) or + ((TargetType.Kind <> tyClass) and (TargetType.Kind <> tyInterface)) then + SemanticError( + Format('''is'' requires a class or interface type name on the right, got ''%s''', AExpr.TypeName), + AExpr.Line, AExpr.Col); + + AExpr.ResolvedTargetType := TargetType; + Result := FTable.TypeBoolean; +end; + +function TSemanticAnalyser.AnalyseAsExpr(AExpr: TAsExpr): TTypeDesc; +var + ObjType: TTypeDesc; + TargetType: TTypeDesc; +begin + ObjType := AnalyseExpr(AExpr.Obj); + if ObjType.Kind <> tyClass then + SemanticError( + Format('''as'' requires a class instance on the left, got ''%s''', ObjType.Name), + AExpr.Line, AExpr.Col); + + TargetType := FTable.FindType(AExpr.TypeName); + if (TargetType = nil) or + ((TargetType.Kind <> tyClass) and (TargetType.Kind <> tyInterface)) then + SemanticError( + Format('''as'' requires a class or interface type name on the right, got ''%s''', AExpr.TypeName), + AExpr.Line, AExpr.Col); + + Result := TargetType; +end; + +function TSemanticAnalyser.AnalyseDerefExpr(AExpr: TDerefExpr): TTypeDesc; +var + PtrType: TTypeDesc; +begin + PtrType := AnalyseExpr(AExpr.Expr); + if PtrType.Kind <> tyPointer then + SemanticError( + Format('Dereference operator ''%s^'' requires a pointer type', PtrType.Name), + AExpr.Line, AExpr.Col); + if TPointerTypeDesc(PtrType).BaseType = nil then + SemanticError( + 'Cannot dereference untyped ''Pointer'' — use a typed pointer (e.g. ^Integer)', + AExpr.Line, AExpr.Col); + Result := TPointerTypeDesc(PtrType).BaseType; +end; + +procedure TSemanticAnalyser.AnalyseCaseStmt(AStmt: TCaseStmt); +var + SelType: TTypeDesc; + Branch: TCaseBranch; + ValType: TTypeDesc; + I, J: Integer; +begin + SelType := AnalyseExpr(AStmt.Selector); + if not SelType.IsOrdinal then + SemanticError( + Format('case selector must be ordinal type, got ''%s''', SelType.Name), + AStmt.Line, AStmt.Col); + for I := 0 to AStmt.Branches.Count - 1 do + begin + Branch := TCaseBranch(AStmt.Branches.Get(I)); + for J := 0 to Branch.Values.Count - 1 do + begin + ValType := AnalyseExpr(TASTExpr(Branch.Values.Get(J))); + CheckTypesMatch(SelType, ValType, 'case value', AStmt.Line, AStmt.Col); + end; + AnalyseStmt(Branch.Stmt); + end; + if AStmt.ElseStmt <> nil then + AnalyseStmt(AStmt.ElseStmt); +end; + +procedure TSemanticAnalyser.AnalysePointerWriteStmt(AStmt: TPointerWriteStmt); +var + PtrType: TTypeDesc; + ValType: TTypeDesc; +begin + PtrType := AnalyseExpr(AStmt.PtrExpr); + if PtrType.Kind <> tyPointer then + SemanticError( + Format('Pointer write requires a pointer type, got ''%s''', PtrType.Name), + AStmt.Line, AStmt.Col); + if TPointerTypeDesc(PtrType).BaseType = nil then + SemanticError( + 'Cannot write through untyped ''Pointer'' — use a typed pointer (e.g. ^Integer)', + AStmt.Line, AStmt.Col); + AStmt.BaseTy := TPointerTypeDesc(PtrType).BaseType; + ValType := AnalyseExpr(AStmt.ValExpr); + CheckTypesMatch(AStmt.BaseTy, ValType, 'pointer write', AStmt.Line, AStmt.Col); +end; + + + + +{ === uCodeGenQBE === } + + + + + + + + + + + + + + + + + +type + + TCodeGenQBE = class + + FOutput: TStringList; + FStrLits: TStringList; + FTempCount: Integer; + FLabelCount: Integer; + FCurrentBlock: TBlock; + FBreakLabels: TStringList; + FContinueLabels: TStringList; + FExitLabel: string; + + function AllocTemp: string; + function AllocLabel(const APrefix: string): string; + function EmitStrLit(const AValue: string): string; + procedure EmitLine(const ALine: string); + procedure EmitDataSection; + procedure EmitMainHeader; + procedure EmitMainFooter; + procedure EmitTypeInfoDefs(AProg: TProgram); + procedure EmitVTableDefs(AProg: TProgram); + procedure EmitMethodDefs(AProg: TProgram); + procedure EmitInterfaceDefs(AProg: TProgram); + procedure EmitFieldCleanupDefs(AProg: TProgram); + procedure EmitFieldCleanupFn(const AMangledName: string; + ARec: TRecordTypeDesc); + procedure EmitMethodDef(const ATypeName: string; AMethod: TMethodDecl); + procedure EmitStandaloneDefs(AProg: TProgram); + procedure EmitStandaloneDef(ADecl: TMethodDecl); + procedure EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean); + procedure EmitBlock(ABlock: TBlock); + procedure EmitVarAllocs(ABlock: TBlock); + procedure EmitGlobalVarData(ABlock: TBlock); + procedure EmitParamAllocs(AMethod: TMethodDecl; AClassType: TRecordTypeDesc); + procedure EmitArcCleanup(ABlock: TBlock); + procedure EmitExcPathArcCleanup(ABlock: TBlock); + procedure EmitStmt(AStmt: TASTStmt); + procedure EmitIfStmt(AStmt: TIfStmt); + procedure EmitWhileStmt(AStmt: TWhileStmt); + procedure EmitForStmt(AStmt: TForStmt); + procedure EmitTryFinallyStmt(AStmt: TTryFinallyStmt); + procedure EmitTryExceptStmt(AStmt: TTryExceptStmt); + procedure EmitRaiseStmt(AStmt: TRaiseStmt); + procedure EmitCompoundStmt(AStmt: TCompoundStmt); + procedure EmitAssignment(AAssign: TAssignment); + procedure EmitFieldAssignment(AAssign: TFieldAssignment); + procedure EmitMethodCall(ACall: TMethodCallStmt); + procedure EmitInheritedCall(ACall: TInheritedCallStmt); + procedure EmitCaseStmt(AStmt: TCaseStmt); + procedure EmitProcCall(ACall: TProcCall); + procedure EmitPointerWrite(AStmt: TPointerWriteStmt); + procedure EmitWrite(ACall: TProcCall; ANewline: Boolean); + function EmitExpr(AExpr: TASTExpr): string; + function EmitIsExpr(AExpr: TIsExpr): string; + function EmitAsExpr(AExpr: TAsExpr): string; + + + + function EmitInstancePtr(AExpr: TASTExpr): string; + function FieldPtr(const ARecordVar: string; AOffset: Integer): string; + + + function VarRef(const AName: string; AIsGlobal: Boolean): string; + function QbeTypeOf(AType: TTypeDesc): string; + function QbeEscapeString(const AStr: string): string; + + function QBEMangle(const AName: string): string; + + procedure Create; + procedure Destroy; + procedure Generate(AProg: TProgram); + procedure GenerateUnit(AUnit: TUnit); + function GetOutput: string; + end; + + +procedure TCodeGenQBE.Create; +begin + + FOutput := TStringList.Create; + FStrLits := TStringList.Create; + FBreakLabels := TStringList.Create; + FContinueLabels := TStringList.Create; + FTempCount := 0; +end; + +procedure TCodeGenQBE.Destroy; +begin + FBreakLabels.Free; + FContinueLabels.Free; + FOutput.Free; + FStrLits.Free; + +end; + +function TCodeGenQBE.AllocTemp: string; +begin + Result := Format('%%_t%d', FTempCount); + FTempCount := FTempCount + 1; +end; + +function TCodeGenQBE.AllocLabel(const APrefix: string): string; +begin + Result := Format('%s_%d', APrefix, FLabelCount); + FLabelCount := FLabelCount + 1; +end; + +function TCodeGenQBE.EmitStrLit(const AValue: string): string; +var + Idx: Integer; +begin + Idx := FStrLits.IndexOf(AValue); + if Idx < 0 then + Idx := FStrLits.Add(AValue); + Result := Format('$__s%d', Idx); +end; + +procedure TCodeGenQBE.EmitLine(const ALine: string); +begin + FOutput.Add(ALine); +end; + +procedure TCodeGenQBE.EmitDataSection; +var + I: Integer; + StrLen: Integer; +begin + + + if FStrLits.Count > 0 then + begin + EmitLine('# String literals'); + for I := 0 to FStrLits.Count - 1 do + begin + StrLen := Length(FStrLits.Get(I)); + EmitLine(Format('data $__s%d = { w -1, w %d, w %d, b "%s", b 0 }', I, StrLen, StrLen, QbeEscapeString(FStrLits.Get(I)))); + end; + end; + + + + + + EmitLine('data $__fmt_s_nl = { b "%s\n", b 0 }'); + EmitLine('data $__fmt_s = { b "%s", b 0 }'); + EmitLine('data $__fmt_d_nl = { b "%d\n", b 0 }'); + EmitLine('data $__fmt_d = { b "%d", b 0 }'); + EmitLine('data $__fmt_nl = { b "\n", b 0 }'); + EmitLine(''); +end; + +procedure TCodeGenQBE.EmitMainHeader; +begin + EmitLine('export function w $main(w %argc, l %argv) {'); + EmitLine('@start'); + EmitLine(' call $_SetArgs(w %argc, l %argv)'); +end; + +procedure TCodeGenQBE.EmitMainFooter; +begin + EmitLine(' ret 0'); + EmitLine('}'); +end; + +function TCodeGenQBE.QbeTypeOf(AType: TTypeDesc): string; +begin + case AType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: Result := 'w'; + tyInt64, tyString: Result := 'l'; + tyRecord: Result := 'l'; + tyClass: Result := 'l'; + tyPointer: Result := 'l'; + else + Result := 'w'; + end; +end; + +procedure TCodeGenQBE.EmitVarAllocs(ABlock: TBlock); +var + I, J: Integer; + Decl: TVarDecl; + VarName: string; + RT: TRecordTypeDesc; + RecSize: Integer; + RecAlign: Integer; +begin + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls.Get(I)); + if Decl.ResolvedType = nil then + raise ECodeGenError.Create(Format('Variable ''%s'' has no resolved type — semantic pass required', Decl.Names.Get(0))); + if Decl.IsGlobal then + Continue; + + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + case Decl.ResolvedType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: + begin + EmitLine(Format(' %%_var_%s =l alloc4 1', VarName)); + EmitLine(Format(' storew 0, %%_var_%s', VarName)); + end; + + tyInt64: + begin + EmitLine(Format(' %%_var_%s =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s', VarName)); + end; + + tyString: + begin + EmitLine(Format(' %%_var_%s =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s', VarName)); + end; + + tyRecord: + begin + RT := TRecordTypeDesc(Decl.ResolvedType); + RecSize := RT.TotalSize; + RecAlign := RT.MaxAlign; + if RecAlign >= 8 then + EmitLine(Format(' %%_var_%s =l alloc8 %d', VarName, RecSize)) + else + EmitLine(Format(' %%_var_%s =l alloc4 %d', VarName, RecSize)); + + + + if RecSize > 0 then + EmitLine(Format(' call $memset(l %%_var_%s, w 0, l %d)', VarName, RecSize)); + end; + + tyClass: + begin + + EmitLine(Format(' %%_var_%s =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s', VarName)); + end; + + tyPointer: + begin + + EmitLine(Format(' %%_var_%s =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s', VarName)); + end; + + tyInterface: + begin + + EmitLine(Format(' %%_var_%s_obj =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s_obj', VarName)); + EmitLine(Format(' %%_var_%s_itab =l alloc8 1', VarName)); + EmitLine(Format(' storel 0, %%_var_%s_itab', VarName)); + end; + + else + raise ECodeGenError.Create(Format('Unsupported type kind %d for variable ''%s''', Decl.ResolvedType.Kind, VarName)); + end; + end; + end; +end; + +procedure TCodeGenQBE.EmitGlobalVarData(ABlock: TBlock); + + + + +var + I, J: Integer; + Decl: TVarDecl; + VarName: string; + RT: TRecordTypeDesc; +begin + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls.Get(I)); + if not Decl.IsGlobal then Continue; + if Decl.ResolvedType = nil then Continue; + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + case Decl.ResolvedType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: + EmitLine(Format('data $%s = { w 0 }', VarName)); + tyInt64: + EmitLine(Format('data $%s = { l 0 }', VarName)); + tyString, tyClass, tyPointer: + EmitLine(Format('data $%s = { l 0 }', VarName)); + tyInterface: + begin + EmitLine(Format('data $%s_obj = { l 0 }', VarName)); + EmitLine(Format('data $%s_itab = { l 0 }', VarName)); + end; + tyRecord: + begin + RT := TRecordTypeDesc(Decl.ResolvedType); + if RT.TotalSize > 0 then + EmitLine(Format('data $%s = { z %d }', VarName, RT.TotalSize)) + else + EmitLine(Format('data $%s = { l 0 }', VarName)); + end; + else + EmitLine(Format('data $%s = { l 0 }', VarName)); + end; + end; + end; +end; + +procedure TCodeGenQBE.EmitArcCleanup(ABlock: TBlock); + + + + + + +var + I, J: Integer; + Decl: TVarDecl; + VarName: string; + ValTemp: string; + RelFn: string; + IsIntf: Boolean; +begin + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls.Get(I)); + if Decl.ResolvedType = nil then Continue; + IsIntf := Decl.ResolvedType.Kind = tyInterface; + if Decl.IsWeak then + begin + + + + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + if IsIntf then + EmitLine(Format(' call $_WeakClear(l %s_obj)', VarRef(VarName, Decl.IsGlobal))) + else + EmitLine(Format(' call $_WeakClear(l %s)', VarRef(VarName, Decl.IsGlobal))); + end; + Continue; + end; + if Decl.ResolvedType.IsString then + RelFn := '$_StringRelease' + else if Decl.ResolvedType.Kind = tyClass then + RelFn := '$_ClassRelease' + else if IsIntf then + RelFn := '$_ClassRelease' + else + Continue; + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + ValTemp := AllocTemp; + if IsIntf then + EmitLine(Format(' %s =l loadl %s_obj', ValTemp, VarRef(VarName, Decl.IsGlobal))) + else + EmitLine(Format(' %s =l loadl %s', ValTemp, VarRef(VarName, Decl.IsGlobal))); + EmitLine(Format(' call %s(l %s)', RelFn, ValTemp)); + end; + end; +end; + +procedure TCodeGenQBE.EmitBlock(ABlock: TBlock); +var + I: Integer; +begin + FCurrentBlock := ABlock; + EmitVarAllocs(ABlock); + for I := 0 to ABlock.Stmts.Count - 1 do + EmitStmt(TASTStmt(ABlock.Stmts.Get(I))); + + if FExitLabel <> '' then + begin + EmitLine(Format(' jmp @%s', FExitLabel)); + EmitLine('@' + FExitLabel); + end; + EmitArcCleanup(ABlock); +end; + +procedure TCodeGenQBE.EmitExcPathArcCleanup(ABlock: TBlock); +var + I, J: Integer; + Decl: TVarDecl; + VarName: string; + ValTemp: string; + RelFn: string; + IsIntf: Boolean; +begin + if ABlock = nil then Exit; + for I := 0 to ABlock.Decls.Count - 1 do + begin + Decl := TVarDecl(ABlock.Decls.Get(I)); + if Decl.ResolvedType = nil then Continue; + IsIntf := Decl.ResolvedType.Kind = tyInterface; + if Decl.IsWeak then + begin + + + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + if IsIntf then + EmitLine(Format(' call $_WeakClear(l %s_obj)', VarRef(VarName, Decl.IsGlobal))) + else + EmitLine(Format(' call $_WeakClear(l %s)', VarRef(VarName, Decl.IsGlobal))); + end; + Continue; + end; + if Decl.ResolvedType.IsString then + RelFn := '$_StringRelease' + else if Decl.ResolvedType.Kind = tyClass then + RelFn := '$_ClassRelease' + else if IsIntf then + RelFn := '$_ClassRelease' + else + Continue; + for J := 0 to Decl.Names.Count - 1 do + begin + VarName := Decl.Names.Get(J); + ValTemp := AllocTemp; + if IsIntf then + begin + EmitLine(Format(' %s =l loadl %s_obj', ValTemp, VarRef(VarName, Decl.IsGlobal))); + EmitLine(Format(' call %s(l %s)', RelFn, ValTemp)); + EmitLine(Format(' storel 0, %s_obj', VarRef(VarName, Decl.IsGlobal))); + end + else + begin + EmitLine(Format(' %s =l loadl %s', ValTemp, VarRef(VarName, Decl.IsGlobal))); + EmitLine(Format(' call %s(l %s)', RelFn, ValTemp)); + EmitLine(Format(' storel 0, %s', VarRef(VarName, Decl.IsGlobal))); + end; + end; + end; +end; + +procedure TCodeGenQBE.EmitStmt(AStmt: TASTStmt); +var + DeadLbl: string; +begin + if AStmt = nil then + raise ECodeGenError.Create('EmitStmt called with nil statement'); + if AStmt is TTryFinallyStmt then + EmitTryFinallyStmt(TTryFinallyStmt(AStmt)) + else if AStmt is TTryExceptStmt then + EmitTryExceptStmt(TTryExceptStmt(AStmt)) + else if AStmt is TRaiseStmt then + EmitRaiseStmt(TRaiseStmt(AStmt)) + else if AStmt is TForStmt then + EmitForStmt(TForStmt(AStmt)) + else if AStmt is TWhileStmt then + EmitWhileStmt(TWhileStmt(AStmt)) + else if AStmt is TIfStmt then + EmitIfStmt(TIfStmt(AStmt)) + else if AStmt is TCompoundStmt then + EmitCompoundStmt(TCompoundStmt(AStmt)) + else if AStmt is TFieldAssignment then + EmitFieldAssignment(TFieldAssignment(AStmt)) + else if AStmt is TPointerWriteStmt then + EmitPointerWrite(TPointerWriteStmt(AStmt)) + else if AStmt is TAssignment then + EmitAssignment(TAssignment(AStmt)) + else if AStmt is TMethodCallStmt then + EmitMethodCall(TMethodCallStmt(AStmt)) + else if AStmt is TInheritedCallStmt then + EmitInheritedCall(TInheritedCallStmt(AStmt)) + else if AStmt is TCaseStmt then + EmitCaseStmt(TCaseStmt(AStmt)) + else if AStmt is TProcCall then + EmitProcCall(TProcCall(AStmt)) + else if AStmt is TExitStmt then + begin + if FExitLabel <> '' then + EmitLine(Format(' jmp @%s', FExitLabel)) + else + EmitLine(' ret 0'); + + DeadLbl := AllocLabel('after_exit'); + EmitLine('@' + DeadLbl); + end + else if AStmt is TBreakStmt then + begin + if FBreakLabels.Count = 0 then + raise ECodeGenError.Create('break outside loop'); + EmitLine(Format(' jmp @%s', FBreakLabels.Get(FBreakLabels.Count - 1))); + DeadLbl := AllocLabel('after_break'); + EmitLine('@' + DeadLbl); + end + else if AStmt is TContinueStmt then + begin + if FContinueLabels.Count = 0 then + raise ECodeGenError.Create('continue outside loop'); + EmitLine(Format(' jmp @%s', FContinueLabels.Get(FContinueLabels.Count - 1))); + DeadLbl := AllocLabel('after_continue'); + EmitLine('@' + DeadLbl); + end + else + raise ECodeGenError.Create(Format('Unknown statement node type at line %d', AStmt.Line)); +end; + +procedure TCodeGenQBE.EmitIfStmt(AStmt: TIfStmt); +var + CondTemp: string; + LblThen: string; + LblElse: string; + LblEnd: string; +begin + LblThen := AllocLabel('if_then'); + LblEnd := AllocLabel('if_end'); + + CondTemp := EmitExpr(AStmt.Condition); + + if AStmt.ElseStmt <> nil then + begin + LblElse := AllocLabel('if_else'); + EmitLine(Format(' jnz %s, @%s, @%s', CondTemp, LblThen, LblElse)); + EmitLine('@' + LblThen); + EmitStmt(AStmt.ThenStmt); + EmitLine(Format(' jmp @%s', LblEnd)); + EmitLine('@' + LblElse); + EmitStmt(AStmt.ElseStmt); + EmitLine(Format(' jmp @%s', LblEnd)); + end + else + begin + EmitLine(Format(' jnz %s, @%s, @%s', CondTemp, LblThen, LblEnd)); + EmitLine('@' + LblThen); + EmitStmt(AStmt.ThenStmt); + EmitLine(Format(' jmp @%s', LblEnd)); + end; + + EmitLine('@' + LblEnd); +end; + +procedure TCodeGenQBE.EmitTryFinallyStmt(AStmt: TTryFinallyStmt); +var + LblTry: string; + LblFinExc: string; + LblEnd: string; + FrameTemp: string; + SjrTemp: string; + ExcTemp: string; + I: Integer; +begin + LblTry := AllocLabel('try_body'); + LblFinExc := AllocLabel('fin_exc'); + LblEnd := AllocLabel('fin_end'); + + + + + FrameTemp := AllocTemp; + EmitLine(Format(' %s =l alloc16 512', FrameTemp)); + EmitLine(Format(' call $_PushExcFrame(l %s)', FrameTemp)); + + SjrTemp := AllocTemp; + EmitLine(Format(' %s =w call $setjmp(l %s)', SjrTemp, FrameTemp)); + EmitLine(Format(' jnz %s, @%s, @%s', SjrTemp, LblFinExc, LblTry)); + + + EmitLine('@' + LblTry); + for I := 0 to AStmt.TryBody.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.TryBody.Stmts.Get(I))); + EmitLine(' call $_PopExcFrame()'); + for I := 0 to AStmt.FinallyBody.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.FinallyBody.Stmts.Get(I))); + EmitLine(Format(' jmp @%s', LblEnd)); + + + + EmitLine('@' + LblFinExc); + ExcTemp := AllocTemp; + EmitLine(Format(' %s =l call $_CurrentException()', ExcTemp)); + EmitLine(' call $_PopExcFrame()'); + for I := 0 to AStmt.FinallyBody.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.FinallyBody.Stmts.Get(I))); + EmitExcPathArcCleanup(FCurrentBlock); + EmitLine(Format(' call $_Reraise(l %s)', ExcTemp)); + EmitLine(Format(' jmp @%s', LblEnd)); + + EmitLine('@' + LblEnd); +end; + +procedure TCodeGenQBE.EmitTryExceptStmt(AStmt: TTryExceptStmt); +var + LblTry: string; + LblExcept: string; + LblEnd: string; + FrameTemp: string; + SjrTemp: string; + I: Integer; +begin + LblTry := AllocLabel('try_body'); + LblExcept := AllocLabel('except_handler'); + LblEnd := AllocLabel('except_end'); + + + + + FrameTemp := AllocTemp; + EmitLine(Format(' %s =l alloc16 512', FrameTemp)); + EmitLine(Format(' call $_PushExcFrame(l %s)', FrameTemp)); + + SjrTemp := AllocTemp; + EmitLine(Format(' %s =w call $setjmp(l %s)', SjrTemp, FrameTemp)); + EmitLine(Format(' jnz %s, @%s, @%s', SjrTemp, LblExcept, LblTry)); + + + EmitLine('@' + LblTry); + for I := 0 to AStmt.TryBody.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.TryBody.Stmts.Get(I))); + EmitLine(' call $_PopExcFrame()'); + EmitLine(Format(' jmp @%s', LblEnd)); + + + EmitLine('@' + LblExcept); + EmitLine(' call $_PopExcFrame()'); + for I := 0 to AStmt.ExceptBody.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.ExceptBody.Stmts.Get(I))); + EmitLine(Format(' jmp @%s', LblEnd)); + + EmitLine('@' + LblEnd); +end; + +procedure TCodeGenQBE.EmitRaiseStmt(AStmt: TRaiseStmt); +var + ObjTemp: string; +begin + if AStmt.Expr <> nil then + begin + ObjTemp := EmitExpr(AStmt.Expr); + EmitLine(Format(' call $_Raise(l %s)', ObjTemp)); + end + else + + EmitLine(' call $_Raise(l 0)'); +end; + +procedure TCodeGenQBE.EmitForStmt(AStmt: TForStmt); +var + LblCond: string; + LblBody: string; + LblNext: string; + LblEnd: string; + StartT: string; + EndT: string; + CurT: string; + CmpT: string; + StepT: string; + CmpOp: string; + StepOp: string; +begin + LblCond := AllocLabel('for_cond'); + LblBody := AllocLabel('for_body'); + LblNext := AllocLabel('for_next'); + LblEnd := AllocLabel('for_end'); + + + StartT := EmitExpr(AStmt.StartExpr); + EmitLine(Format(' storew %s, %%_var_%s', StartT, AStmt.VarName)); + + + EndT := EmitExpr(AStmt.EndExpr); + + + EmitLine(Format(' jmp @%s', LblCond)); + + + EmitLine('@' + LblCond); + CurT := AllocTemp; + EmitLine(Format(' %s =w loadw %%_var_%s', CurT, AStmt.VarName)); + CmpT := AllocTemp; + if AStmt.IsDownTo then + CmpOp := 'csgew' + else + CmpOp := 'cslew'; + EmitLine(Format(' %s =w %s %s, %s', CmpT, CmpOp, CurT, EndT)); + EmitLine(Format(' jnz %s, @%s, @%s', CmpT, LblBody, LblEnd)); + + + EmitLine('@' + LblBody); + FBreakLabels.Add(LblEnd); + FContinueLabels.Add(LblNext); + try + EmitStmt(AStmt.Body); + finally + FBreakLabels.Delete(FBreakLabels.Count - 1); + FContinueLabels.Delete(FContinueLabels.Count - 1); + end; + EmitLine(Format(' jmp @%s', LblNext)); + + + EmitLine('@' + LblNext); + CurT := AllocTemp; + StepT := AllocTemp; + EmitLine(Format(' %s =w loadw %%_var_%s', CurT, AStmt.VarName)); + if AStmt.IsDownTo then + StepOp := 'sub' + else + StepOp := 'add'; + EmitLine(Format(' %s =w %s %s, 1', StepT, StepOp, CurT)); + EmitLine(Format(' storew %s, %%_var_%s', StepT, AStmt.VarName)); + EmitLine(Format(' jmp @%s', LblCond)); + + + EmitLine('@' + LblEnd); +end; + +procedure TCodeGenQBE.EmitWhileStmt(AStmt: TWhileStmt); +var + LblCond: string; + LblBody: string; + LblEnd: string; + CondTemp: string; +begin + LblCond := AllocLabel('while_cond'); + LblBody := AllocLabel('while_body'); + LblEnd := AllocLabel('while_end'); + + + EmitLine(Format(' jmp @%s', LblCond)); + + + EmitLine('@' + LblCond); + CondTemp := EmitExpr(AStmt.Condition); + EmitLine(Format(' jnz %s, @%s, @%s', CondTemp, LblBody, LblEnd)); + + + EmitLine('@' + LblBody); + FBreakLabels.Add(LblEnd); + FContinueLabels.Add(LblCond); + try + EmitStmt(AStmt.Body); + finally + FBreakLabels.Delete(FBreakLabels.Count - 1); + FContinueLabels.Delete(FContinueLabels.Count - 1); + end; + EmitLine(Format(' jmp @%s', LblCond)); + + + EmitLine('@' + LblEnd); +end; + +procedure TCodeGenQBE.EmitCompoundStmt(AStmt: TCompoundStmt); +var + I: Integer; +begin + for I := 0 to AStmt.Stmts.Count - 1 do + EmitStmt(TASTStmt(AStmt.Stmts.Get(I))); +end; + +procedure TCodeGenQBE.EmitAssignment(AAssign: TAssignment); +var + ValTemp, OldTemp, QType, StoreInstr, PtrTemp: string; + IntfDesc: TInterfaceTypeDesc; + ClassRT: TRecordTypeDesc; + ItabName: string; + AE: TAsExpr; + ObjTemp: string; + ItabTemp: string; + CheckTemp: string; + LblOk: string; + LblFail: string; + LblEnd: string; + ISFld: TFieldInfo; + ISAddrT: string; + ExtTemp: string; +begin + if AAssign.Expr.ResolvedType = nil then + raise ECodeGenError.Create(Format('Expression in assignment to ''%s'' has no resolved type', AAssign.Name)); + + + if AAssign.ImplicitSelfField <> nil then + begin + ISFld := TFieldInfo(AAssign.ImplicitSelfField); + ValTemp := EmitExpr(AAssign.Expr); + ObjTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', ObjTemp)); + if ISFld.Offset > 0 then + begin + ISAddrT := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', ISAddrT, ObjTemp, ISFld.Offset)); + ObjTemp := ISAddrT; + end; + QType := QbeTypeOf(ISFld.TypeDesc); + if QType = 'w' then + EmitLine(Format(' storew %s, %s', ValTemp, ObjTemp)) + else + begin + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', ExtTemp, ValTemp)); + ValTemp := ExtTemp; + end; + EmitLine(Format(' storel %s, %s', ValTemp, ObjTemp)); + end; + Exit; + end; + + + + + + + if (AAssign.ResolvedLhsType <> nil) and + (AAssign.ResolvedLhsType.Kind = tyInterface) and + (AAssign.Expr is TAsExpr) and + (AAssign.Expr.ResolvedType.Kind = tyInterface) then + begin + AE := TAsExpr(AAssign.Expr); + IntfDesc := TInterfaceTypeDesc(AAssign.ResolvedLhsType); + ObjTemp := EmitExpr(AE.Obj); + ItabTemp := AllocTemp; + EmitLine(Format(' %s =l call $_GetItab(l %s, l $typeinfo_%s)', ItabTemp, ObjTemp, AE.TypeName)); + CheckTemp := AllocTemp; + LblOk := AllocLabel('as_ok'); + LblFail := AllocLabel('as_fail'); + LblEnd := AllocLabel('as_end'); + EmitLine(Format(' %s =w cnel %s, 0', CheckTemp, ItabTemp)); + EmitLine(Format(' jnz %s, @%s, @%s', CheckTemp, LblOk, LblFail)); + EmitLine('@' + LblFail); + EmitLine(' call $_Raise_InvalidCast()'); + EmitLine(Format(' jmp @%s', LblEnd)); + EmitLine('@' + LblOk); + if AAssign.IsWeakLhs then + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', VarRef(AAssign.Name, AAssign.IsGlobal), ObjTemp)) + else + begin + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + EmitLine(Format(' call $_ClassAddRef(l %s)', ObjTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s_obj', ObjTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end; + EmitLine(Format(' storel %s, %s_itab', ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + EmitLine('@' + LblEnd); + Exit; + end; + + + + + + if (AAssign.ResolvedLhsType <> nil) and + (AAssign.ResolvedLhsType.Kind = tyInterface) and + (AAssign.Expr.ResolvedType.Kind = tyClass) then + begin + IntfDesc := TInterfaceTypeDesc(AAssign.ResolvedLhsType); + ClassRT := TRecordTypeDesc(AAssign.Expr.ResolvedType); + ItabName := '$itab_' + ClassRT.Name + '_' + IntfDesc.Name; + ValTemp := EmitExpr(AAssign.Expr); + if AAssign.IsWeakLhs then + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', VarRef(AAssign.Name, AAssign.IsGlobal), ValTemp)) + else + begin + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + EmitLine(Format(' call $_ClassAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s_obj', ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end; + EmitLine(Format(' storel %s, %s_itab', ItabName, VarRef(AAssign.Name, AAssign.IsGlobal))); + Exit; + end; + + + + + + if (AAssign.ResolvedLhsType <> nil) and + (AAssign.ResolvedLhsType.Kind = tyInterface) and + (AAssign.Expr.ResolvedType.Kind = tyInterface) and + (AAssign.Expr is TIdentExpr) then + begin + ObjTemp := AllocTemp; + ItabTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', ObjTemp, VarRef(TIdentExpr(AAssign.Expr).Name, TIdentExpr(AAssign.Expr).IsGlobal))); + EmitLine(Format(' %s =l loadl %s_itab', ItabTemp, VarRef(TIdentExpr(AAssign.Expr).Name, TIdentExpr(AAssign.Expr).IsGlobal))); + if AAssign.IsWeakLhs then + begin + EmitLine(Format(' call $_WeakAssign(l %s_obj, l %s)', VarRef(AAssign.Name, AAssign.IsGlobal), ObjTemp)); + EmitLine(Format(' storel %s, %s_itab', ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + Exit; + end; + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + EmitLine(Format(' call $_ClassAddRef(l %s)', ObjTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s_obj', ObjTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + EmitLine(Format(' storel %s, %s_itab', ItabTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + Exit; + end; + + if AAssign.IsVarParam then + begin + + QType := QbeTypeOf(AAssign.Expr.ResolvedType); + ValTemp := EmitExpr(AAssign.Expr); + PtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', PtrTemp, AAssign.Name)); + if QType = 'w' then StoreInstr := 'storew' + else StoreInstr := 'storel'; + EmitLine(Format(' %s %s, %s', StoreInstr, ValTemp, PtrTemp)); + end + else if AAssign.Expr.ResolvedType.IsString then + begin + + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + ValTemp := EmitExpr(AAssign.Expr); + EmitLine(Format(' call $_StringAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_StringRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s', ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end + else if AAssign.IsWeakLhs and (AAssign.Expr.ResolvedType.Kind = tyClass) then + begin + + + + + ValTemp := EmitExpr(AAssign.Expr); + EmitLine(Format(' call $_WeakAssign(l %s, l %s)', VarRef(AAssign.Name, AAssign.IsGlobal), ValTemp)); + end + else if AAssign.Expr.ResolvedType.Kind = tyClass then + begin + + + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', OldTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + ValTemp := EmitExpr(AAssign.Expr); + EmitLine(Format(' call $_ClassAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s', ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end + else + begin + + + if (AAssign.ResolvedLhsType <> nil) and + (QbeTypeOf(AAssign.ResolvedLhsType) = 'l') then + begin + ValTemp := EmitExpr(AAssign.Expr); + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', ExtTemp, ValTemp)); + ValTemp := ExtTemp; + end; + EmitLine(Format(' storel %s, %s', ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end + else + begin + QType := QbeTypeOf(AAssign.Expr.ResolvedType); + ValTemp := EmitExpr(AAssign.Expr); + if QType = 'w' then StoreInstr := 'storew' + else StoreInstr := 'storel'; + EmitLine(Format(' %s %s, %s', StoreInstr, ValTemp, VarRef(AAssign.Name, AAssign.IsGlobal))); + end; + end; +end; + +function TCodeGenQBE.EmitInstancePtr(AExpr: TASTExpr): string; +var + Id: TIdentExpr; + Fld: TFieldAccessExpr; + Base: string; + Ptr: string; + Loaded: string; + SelfT: string; + ImplFld: TFieldInfo; +begin + if AExpr is TIdentExpr then + begin + Id := TIdentExpr(AExpr); + + if Id.IsImplicitSelf then + begin + ImplFld := TFieldInfo(Id.ImplicitFieldInfo); + SelfT := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', SelfT)); + if ImplFld.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, SelfT, ImplFld.Offset)); + SelfT := Ptr; + end; + Loaded := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Loaded, SelfT)); + Result := Loaded; + Exit; + end; + if (AExpr.ResolvedType <> nil) and (AExpr.ResolvedType.Kind = tyClass) then + begin + Loaded := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Loaded, VarRef(Id.Name, Id.IsGlobal))); + Result := Loaded; + end + else + Result := VarRef(Id.Name, Id.IsGlobal); + Exit; + end; + + if AExpr is TFieldAccessExpr then + begin + Fld := TFieldAccessExpr(AExpr); + if Fld.Base <> nil then + Base := EmitInstancePtr(Fld.Base) + else + begin + + if (Fld.ResolvedType = nil) then + raise ECodeGenError.Create('Chained base has no resolved type'); + if Fld.IsClassAccess then + begin + Loaded := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Loaded, VarRef(Fld.RecordName, Fld.IsGlobal))); + Base := Loaded; + end + else + Base := VarRef(Fld.RecordName, Fld.IsGlobal); + end; + if Fld.FieldInfo = nil then + raise ECodeGenError.Create( + 'Chained field access ''' + Fld.FieldName + ''' has no resolved field info'); + if Fld.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, Base, Fld.FieldInfo.Offset)); + end + else + Ptr := Base; + + + if Fld.FieldInfo.TypeDesc.Kind = tyClass then + begin + Loaded := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Loaded, Ptr)); + Result := Loaded; + end + else + Result := Ptr; + Exit; + end; + + + + if (AExpr.ResolvedType <> nil) and + (((AExpr.ResolvedType.Kind = tyClass) or (AExpr.ResolvedType.Kind = tyInterface) or (AExpr.ResolvedType.Kind = tyPointer) or (AExpr.ResolvedType.Kind = tyRecord))) then + begin + Result := EmitExpr(AExpr); + Exit; + end; + raise ECodeGenError.Create('EmitInstancePtr: unsupported base expression'); +end; + +function TCodeGenQBE.FieldPtr(const ARecordVar: string; AOffset: Integer): string; +var + PtrTemp: string; +begin + if AOffset = 0 then + begin + Result := Format('%%_var_%s', ARecordVar); + end + else + begin + PtrTemp := AllocTemp; + EmitLine(Format(' %s =l add %%_var_%s, %d', PtrTemp, ARecordVar, AOffset)); + Result := PtrTemp; + end; +end; + +function TCodeGenQBE.VarRef(const AName: string; AIsGlobal: Boolean): string; +begin + if AIsGlobal then + Result := '$' + AName + else + Result := '%_var_' + AName; +end; + +procedure TCodeGenQBE.EmitFieldAssignment(AAssign: TFieldAssignment); +var + Ptr, PtrTemp, ValTemp, OldTemp, QType, StoreInstr, ExtTemp: string; + IsArc: Boolean; + IsStr: Boolean; +begin + if AAssign.FieldInfo = nil then + raise ECodeGenError.Create(Format('Field assignment ''%s.%s'' has no resolved field info', AAssign.RecordName, AAssign.FieldName)); + + ValTemp := EmitExpr(AAssign.Expr); + + if AAssign.ObjExpr <> nil then + begin + + PtrTemp := EmitExpr(AAssign.ObjExpr); + if AAssign.IsClassAccess then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Ptr, PtrTemp)); + PtrTemp := Ptr; + end; + if AAssign.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, PtrTemp, AAssign.FieldInfo.Offset)); + end + else + Ptr := PtrTemp; + end + else if AAssign.IsImplicitSelf then + begin + + PtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', PtrTemp)); + if AAssign.ImplicitBaseInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, PtrTemp, AAssign.ImplicitBaseInfo.Offset)); + PtrTemp := Ptr; + end; + if AAssign.IsClassAccess then + begin + + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Ptr, PtrTemp)); + PtrTemp := Ptr; + end; + if AAssign.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, PtrTemp, AAssign.FieldInfo.Offset)); + end + else + Ptr := PtrTemp; + end + else if AAssign.IsClassAccess then + begin + + PtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', PtrTemp, VarRef(AAssign.RecordName, AAssign.IsGlobal))); + if AAssign.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, PtrTemp, AAssign.FieldInfo.Offset)); + end + else + Ptr := PtrTemp; + end + else + Ptr := FieldPtr(AAssign.RecordName, AAssign.FieldInfo.Offset); + + IsStr := AAssign.FieldInfo.TypeDesc.IsString; + IsArc := IsStr or (AAssign.FieldInfo.TypeDesc.Kind = tyClass); + if AAssign.FieldInfo.IsWeak then + begin + + + EmitLine(Format(' call $_WeakAssign(l %s, l %s)', Ptr, ValTemp)); + end + else if IsArc then + begin + + + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', OldTemp, Ptr)); + if IsStr then + begin + EmitLine(Format(' call $_StringAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_StringRelease(l %s)', OldTemp)); + end + else + begin + EmitLine(Format(' call $_ClassAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', OldTemp)); + end; + EmitLine(Format(' storel %s, %s', ValTemp, Ptr)); + end + else + begin + QType := QbeTypeOf(AAssign.FieldInfo.TypeDesc); + if QType = 'w' then StoreInstr := 'storew' + else + begin + StoreInstr := 'storel'; + + if QbeTypeOf(AAssign.Expr.ResolvedType) = 'w' then + begin + ExtTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', ExtTemp, ValTemp)); + ValTemp := ExtTemp; + end; + end; + EmitLine(Format(' %s %s, %s', StoreInstr, ValTemp, Ptr)); + end; +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; + VTblTemp: string; + FPtrTemp: string; + SlotOff: Integer; + IntfDesc: TInterfaceTypeDesc; +begin + + if (ACall.ResolvedClassType <> nil) and + (ACall.ResolvedClassType.Kind = tyInterface) then + begin + IntfDesc := TInterfaceTypeDesc(ACall.ResolvedClassType); + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal))); + VTblTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_itab', VTblTemp, VarRef(ACall.ObjectName, ACall.IsGlobal))); + SlotOff := IntfDesc.MethodIndex(ACall.Name) * 8; + FPtrTemp := AllocTemp; + if SlotOff = 0 then + EmitLine(Format(' %s =l loadl %s', FPtrTemp, VTblTemp)) + else + begin + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', ArgTemp, VTblTemp, SlotOff)); + EmitLine(Format(' %s =l loadl %s', FPtrTemp, ArgTemp)); + end; + EmitLine(Format(' call %s(l %s)', FPtrTemp, SelfTemp)); + Exit; + end; + + + if ACall.ObjExpr <> nil then + begin + SelfTemp := EmitExpr(ACall.ObjExpr); + RT := TRecordTypeDesc(ACall.ResolvedClassType); + MDecl := TMethodDecl(ACall.ResolvedMethod); + if (MDecl = nil) and SameText(ACall.Name, 'Free') then + begin + EmitLine(Format(' call $_ClassRelease(l %s)', SelfTemp)); + Exit; + end; + ArgLine := Format('l %s', SelfTemp); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(I))); + QType := QbeTypeOf(Par.ResolvedType); + ArgLine := ArgLine + Format(', %s %s', QType, ArgTemp); + end; + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + ACall.Name + else + FuncName := '$' + RT.Name + '_' + ACall.Name; + EmitLine(Format(' call %s(%s)', FuncName, ArgLine)); + Exit; + end; + + + + + + + if (ACall.ResolvedMethod = nil) and SameText(ACall.Name, 'Free') then + begin + SelfTemp := AllocTemp; + if ACall.IsImplicitSelf then + begin + + + EmitLine(Format(' %s =l loadl %%_var_Self', SelfTemp)); + if ACall.ImplicitBaseInfo.Offset > 0 then + begin + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', FPtrTemp, SelfTemp, ACall.ImplicitBaseInfo.Offset)); + end + else + FPtrTemp := SelfTemp; + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', ArgTemp, FPtrTemp)); + EmitLine(Format(' call $_ClassRelease(l %s)', ArgTemp)); + EmitLine(Format(' storel 0, %s', FPtrTemp)); + Exit; + end; + EmitLine(Format(' %s =l loadl %s', SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal))); + EmitLine(Format(' call $_ClassRelease(l %s)', SelfTemp)); + EmitLine(Format(' storel 0, %s', VarRef(ACall.ObjectName, ACall.IsGlobal))); + Exit; + end; + + RT := TRecordTypeDesc(ACall.ResolvedClassType); + MDecl := TMethodDecl(ACall.ResolvedMethod); + + + SelfTemp := AllocTemp; + if ACall.IsImplicitSelf then + begin + + EmitLine(Format(' %s =l loadl %%_var_Self', SelfTemp)); + if ACall.ImplicitBaseInfo.Offset > 0 then + begin + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', FPtrTemp, SelfTemp, ACall.ImplicitBaseInfo.Offset)); + SelfTemp := FPtrTemp; + end; + FPtrTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', FPtrTemp, SelfTemp)); + SelfTemp := FPtrTemp; + end + else + EmitLine(Format(' %s =l loadl %s', SelfTemp, VarRef(ACall.ObjectName, ACall.IsGlobal))); + + + ArgLine := Format('l %s', SelfTemp); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(I))); + QType := QbeTypeOf(Par.ResolvedType); + ArgLine := ArgLine + Format(', %s %s', QType, ArgTemp); + end; + + if MDecl.VTableSlot >= 0 then + begin + + + VTblTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', VTblTemp, SelfTemp)); + FPtrTemp := AllocTemp; + SlotOff := (MDecl.VTableSlot + 1) * 8; + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', ArgTemp, VTblTemp, SlotOff)); + EmitLine(Format(' %s =l loadl %s', FPtrTemp, ArgTemp)); + EmitLine(Format(' call %s(%s)', FPtrTemp, ArgLine)); + end + else + begin + + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + ACall.Name + else + FuncName := '$' + RT.Name + '_' + ACall.Name; + EmitLine(Format(' call %s(%s)', FuncName, ArgLine)); + end; +end; + +procedure TCodeGenQBE.EmitCaseStmt(AStmt: TCaseStmt); +var + SelTemp: string; + ValTemp: string; + CmpTemp: string; + NextLbl: string; + BranchLbl: string; + ElseLbl: string; + EndLbl: string; + Branch: TCaseBranch; + I, J: Integer; + BranchLabels: TStringList; +begin + SelTemp := EmitExpr(AStmt.Selector); + EndLbl := AllocLabel('case_end'); + ElseLbl := AllocLabel('case_else'); + + BranchLabels := TStringList.Create; + try + for I := 0 to AStmt.Branches.Count - 1 do + BranchLabels.Add(AllocLabel('case_br')); + + + + for I := 0 to AStmt.Branches.Count - 1 do + begin + Branch := TCaseBranch(AStmt.Branches.Get(I)); + BranchLbl := BranchLabels.Get(I); + for J := 0 to Branch.Values.Count - 1 do + begin + ValTemp := EmitExpr(TASTExpr(Branch.Values.Get(J))); + CmpTemp := AllocTemp; + NextLbl := AllocLabel('case_next'); + EmitLine(Format(' %s =w ceqw %s, %s', CmpTemp, SelTemp, ValTemp)); + EmitLine(Format(' jnz %s, @%s, @%s', CmpTemp, BranchLbl, NextLbl)); + EmitLine('@' + NextLbl); + end; + end; + EmitLine(Format(' jmp @%s', ElseLbl)); + + + for I := 0 to AStmt.Branches.Count - 1 do + begin + Branch := TCaseBranch(AStmt.Branches.Get(I)); + BranchLbl := BranchLabels.Get(I); + EmitLine('@' + BranchLbl); + EmitStmt(Branch.Stmt); + EmitLine(Format(' jmp @%s', EndLbl)); + end; + + EmitLine('@' + ElseLbl); + if AStmt.ElseStmt <> nil then + EmitStmt(AStmt.ElseStmt); + EmitLine(Format(' jmp @%s', EndLbl)); + + EmitLine('@' + EndLbl); + finally + BranchLabels.Free; + end; +end; + +procedure TCodeGenQBE.EmitInheritedCall(ACall: TInheritedCallStmt); +var + MDecl: TMethodDecl; + SelfTemp: string; + ArgLine: string; + ArgTemp: string; + Par: TMethodParam; + QType: string; + I: Integer; +begin + MDecl := TMethodDecl(ACall.ResolvedMethod); + + + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', SelfTemp)); + + + ArgLine := Format('l %s', SelfTemp); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(I))); + QType := QbeTypeOf(Par.ResolvedType); + ArgLine := ArgLine + Format(', %s %s', QType, ArgTemp); + end; + + + EmitLine(Format(' call $%s_%s(%s)', MDecl.OwnerTypeName, ACall.Name, ArgLine)); +end; + +procedure TCodeGenQBE.EmitParamAllocs(AMethod: TMethodDecl; + AClassType: TRecordTypeDesc); +var + I: Integer; + Par: TMethodParam; +begin + + EmitLine(' %_var_Self =l alloc8 1'); + EmitLine(' storel %_par_Self, %_var_Self'); + + + for I := 0 to AMethod.Params.Count - 1 do + begin + Par := TMethodParam(AMethod.Params.Get(I)); + if Par.IsVarParam then + begin + + EmitLine(Format(' %%_var_%s =l alloc8 1', Par.ParamName)); + EmitLine(Format(' storel %%_par_%s, %%_var_%s', Par.ParamName, Par.ParamName)); + end + else + case Par.ResolvedType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: + 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; + IsFunc: Boolean; + RetQType: string; + RetTemp: string; + SavedExitLbl: string; + ValTemp: string; +begin + FuncName := '$' + ATypeName + '_' + AMethod.Name; + IsFunc := AMethod.ResolvedReturnType <> nil; + + + Sig := 'l %_par_Self'; + for I := 0 to AMethod.Params.Count - 1 do + begin + Par := TMethodParam(AMethod.Params.Get(I)); + if Par.IsVarParam then + Sig := Sig + Format(', l %%_par_%s', Par.ParamName) + else + Sig := Sig + Format(', %s %%_par_%s', QbeTypeOf(Par.ResolvedType), Par.ParamName); + end; + + 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)); + + EmitLine('@start'); + EmitParamAllocs(AMethod, nil); + + + + + + for I := 0 to AMethod.Params.Count - 1 do + begin + Par := TMethodParam(AMethod.Params.Get(I)); + if Par.IsVarParam then Continue; + if Par.ResolvedType.Kind = tyClass then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_ClassAddRef(l %s)', ValTemp)); + end; + end; + + + 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; + + SavedExitLbl := FExitLabel; + FExitLabel := AllocLabel('method_exit'); + try + EmitBlock(AMethod.Body); + finally + FExitLabel := SavedExitLbl; + end; + + + for I := 0 to AMethod.Params.Count - 1 do + begin + Par := TMethodParam(AMethod.Params.Get(I)); + if Par.IsVarParam then Continue; + if Par.ResolvedType.Kind = tyClass then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_ClassRelease(l %s)', ValTemp)); + end; + end; + + 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; + +procedure TCodeGenQBE.EmitTypeInfoDefs(AProg: TProgram); + + + + + + + + + + +var + I: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + RT: TRecordTypeDesc; + GI: TGenericInstance; + ParentStr: string; + ImplStr: string; + MName: string; +begin + EmitLine('data $typeinfo_TObject = { l 0, l 0 }'); + + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TClassTypeDef) then Continue; + TDesc := AProg.SymbolTable.FindType(TD.Name); + if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; + RT := TRecordTypeDesc(TDesc); + if RT.Parent <> nil then + ParentStr := '$typeinfo_' + RT.Parent.Name + else + ParentStr := '0'; + if RT.ImplementsCount > 0 then + ImplStr := '$impllist_' + TD.Name + else + ImplStr := '0'; + EmitLine('data $typeinfo_' + TD.Name + + ' = { l ' + ParentStr + ', l ' + ImplStr + ' }'); + end; + + + for I := 0 to AProg.GenericInstances.Count - 1 do + begin + GI := TGenericInstance(AProg.GenericInstances.Get(I)); + RT := TRecordTypeDesc(GI.TypeDesc); + MName := QBEMangle(GI.TypeName); + if RT.Parent <> nil then + ParentStr := '$typeinfo_' + QBEMangle(RT.Parent.Name) + else + ParentStr := '0'; + ImplStr := '0'; + EmitLine('data $typeinfo_' + MName + ' = { l ' + ParentStr + ', l ' + ImplStr + ' }'); + end; + + EmitLine(''); +end; + +procedure TCodeGenQBE.EmitVTableDefs(AProg: TProgram); + + +var + I, S: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + RT: TRecordTypeDesc; + GI: TGenericInstance; + E: TVTableEntry; + Line: string; + MName: string; +begin + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TClassTypeDef) then Continue; + TDesc := AProg.SymbolTable.FindType(TD.Name); + if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; + RT := TRecordTypeDesc(TDesc); + if not RT.HasVTable then Continue; + + Line := 'data $vtable_' + TD.Name + ' = { l $typeinfo_' + TD.Name; + for S := 0 to RT.VTableCount - 1 do + begin + E := RT.VTableEntryAt(S); + Line := Line + ', l ' + E.ImplName; + end; + Line := Line + ' }'; + EmitLine(Line); + end; + + + for I := 0 to AProg.GenericInstances.Count - 1 do + begin + GI := TGenericInstance(AProg.GenericInstances.Get(I)); + RT := TRecordTypeDesc(GI.TypeDesc); + if not RT.HasVTable then Continue; + MName := QBEMangle(GI.TypeName); + Line := 'data $vtable_' + MName + ' = { l $typeinfo_' + MName; + for S := 0 to RT.VTableCount - 1 do + begin + E := RT.VTableEntryAt(S); + Line := Line + ', l ' + QBEMangle(E.ImplName); + end; + Line := Line + ' }'; + EmitLine(Line); + end; + + EmitLine(''); +end; + +procedure TCodeGenQBE.EmitInterfaceDefs(AProg: TProgram); + + + + + +var + I, J, K: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + IntfDesc: TInterfaceTypeDesc; + ClassRT: TRecordTypeDesc; + ItabLine: string; + ImplLine: string; + MethName: string; + IntfMangle: string; + GII: TGenericInterfaceInstance; +begin + + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TInterfaceTypeDef) then Continue; + EmitLine('data $typeinfo_' + TD.Name + ' = { l 0 }'); + end; + + + for I := 0 to AProg.GenericIntfInstances.Count - 1 do + begin + GII := TGenericInterfaceInstance(AProg.GenericIntfInstances.Get(I)); + EmitLine('data $typeinfo_' + GII.InstName + ' = { l 0 }'); + end; + + + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TClassTypeDef) then Continue; + TDesc := AProg.SymbolTable.FindType(TD.Name); + if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; + ClassRT := TRecordTypeDesc(TDesc); + if ClassRT.ImplementsCount = 0 then Continue; + + + for J := 0 to ClassRT.ImplementsCount - 1 do + begin + IntfDesc := ClassRT.ImplementsIntfAt(J); + IntfMangle := QBEMangle(IntfDesc.Name); + ItabLine := 'data $itab_' + TD.Name + '_' + IntfMangle + ' = {'; + for K := 0 to IntfDesc.MethodCount - 1 do + begin + MethName := IntfDesc.MethodName(K); + if K = 0 then + ItabLine := ItabLine + ' l $' + TD.Name + '_' + MethName + else + ItabLine := ItabLine + ', l $' + TD.Name + '_' + MethName; + end; + ItabLine := ItabLine + ' }'; + EmitLine(ItabLine); + end; + + + ImplLine := 'data $impllist_' + TD.Name + ' = {'; + for J := 0 to ClassRT.ImplementsCount - 1 do + begin + IntfDesc := ClassRT.ImplementsIntfAt(J); + IntfMangle := QBEMangle(IntfDesc.Name); + if J = 0 then + ImplLine := ImplLine + ' l $typeinfo_' + IntfMangle + + ', l $itab_' + TD.Name + '_' + IntfMangle + else + ImplLine := ImplLine + ', l $typeinfo_' + IntfMangle + + ', l $itab_' + TD.Name + '_' + IntfMangle; + end; + ImplLine := ImplLine + ', l 0 }'; + EmitLine(ImplLine); + end; + EmitLine(''); +end; + +procedure TCodeGenQBE.EmitFieldCleanupFn(const AMangledName: string; + ARec: TRecordTypeDesc); + + + + + + + + + + + + + + +var + I: Integer; + F: TFieldInfo; + Temp: string; + PtrT: string; +begin + EmitLine(Format('function $_FieldCleanup_%s(l %%self) {', AMangledName)); + EmitLine('@start'); + + + if ARec.HasDestroyMethod then + EmitLine(Format(' call $%s_Destroy(l %%self)', AMangledName)); + for I := 0 to ARec.Fields.Count - 1 do + begin + F := TFieldInfo(ARec.Fields.Get(I)); + if F.TypeDesc = nil then Continue; + if not (F.TypeDesc.IsString or (F.TypeDesc.Kind = tyClass)) then + Continue; + if F.Offset > 0 then + begin + PtrT := AllocTemp; + EmitLine(Format(' %s =l add %%self, %d', PtrT, F.Offset)); + end + else + PtrT := '%self'; + if F.IsWeak then + begin + + + EmitLine(Format(' call $_WeakClear(l %s)', PtrT)); + Continue; + end; + Temp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Temp, PtrT)); + if F.TypeDesc.IsString then + EmitLine(Format(' call $_StringRelease(l %s)', Temp)) + else + EmitLine(Format(' call $_ClassRelease(l %s)', Temp)); + end; + EmitLine(' ret'); + EmitLine('}'); + EmitLine(''); +end; + +procedure TCodeGenQBE.EmitFieldCleanupDefs(AProg: TProgram); + + + +var + I: Integer; + TD: TTypeDecl; + TDesc: TTypeDesc; + RT: TRecordTypeDesc; + GI: TGenericInstance; +begin + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TClassTypeDef) then Continue; + TDesc := AProg.SymbolTable.FindType(TD.Name); + if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue; + RT := TRecordTypeDesc(TDesc); + EmitFieldCleanupFn(TD.Name, RT); + end; + for I := 0 to AProg.GenericInstances.Count - 1 do + begin + GI := TGenericInstance(AProg.GenericInstances.Get(I)); + RT := TRecordTypeDesc(GI.TypeDesc); + EmitFieldCleanupFn(QBEMangle(GI.TypeName), RT); + end; +end; + +procedure TCodeGenQBE.EmitMethodDefs(AProg: TProgram); +var + I, J: Integer; + TD: TTypeDecl; + CD: TClassTypeDef; + GI: TGenericInstance; + MDecl: TMethodDecl; +begin + for I := 0 to AProg.Block.TypeDecls.Count - 1 do + begin + TD := TTypeDecl(AProg.Block.TypeDecls.Get(I)); + if not (TD.Def is TClassTypeDef) then + Continue; + CD := TClassTypeDef(TD.Def); + for J := 0 to CD.Methods.Count - 1 do + if TMethodDecl(CD.Methods.Get(J)).Body <> nil then + EmitMethodDef(TD.Name, TMethodDecl(CD.Methods.Get(J))); + end; + + + for I := 0 to AProg.GenericInstances.Count - 1 do + begin + GI := TGenericInstance(AProg.GenericInstances.Get(I)); + for J := 0 to GI.ClassDef.Methods.Count - 1 do + begin + MDecl := TMethodDecl(GI.ClassDef.Methods.Get(J)); + if MDecl.Body <> nil then + EmitMethodDef(QBEMangle(GI.TypeName), MDecl); + end; + end; +end; + +procedure TCodeGenQBE.EmitFuncDef(ADecl: TMethodDecl; AExported: Boolean); +var + Sig: string; + I: Integer; + Par: TMethodParam; + FuncName: string; + IsFunc: Boolean; + RetQType: string; + RetTemp: string; + ValTemp: string; + Prefix: string; + SavedExitLbl: string; +begin + FuncName := '$' + QBEMangle(ADecl.Name); + IsFunc := ADecl.ResolvedReturnType <> nil; + if AExported then Prefix := 'export ' else Prefix := ''; + + Sig := ''; + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(I)); + if Sig <> '' then Sig := Sig + ', '; + if Par.IsVarParam then + Sig := Sig + Format('l %%_par_%s', Par.ParamName) + else + Sig := Sig + Format('%s %%_par_%s', QbeTypeOf(Par.ResolvedType), Par.ParamName); + end; + + if IsFunc then + begin + RetQType := QbeTypeOf(ADecl.ResolvedReturnType); + EmitLine(Format('%sfunction %s %s(%s) {', Prefix, RetQType, FuncName, Sig)); + end + else + EmitLine(Format('%sfunction %s(%s) {', Prefix, FuncName, Sig)); + + EmitLine('@start'); + + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(I)); + if Par.IsVarParam then + begin + + EmitLine(Format(' %%_var_%s =l alloc8 1', Par.ParamName)); + EmitLine(Format(' storel %%_par_%s, %%_var_%s', Par.ParamName, Par.ParamName)); + end + else + begin + case Par.ResolvedType.Kind of + tyInteger, tyUInt32, tyBoolean, tyByte, tyEnum: + begin + EmitLine(Format(' %%_var_%s =l alloc4 1', Par.ParamName)); + EmitLine(Format(' storew %%_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; + + + + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(I)); + if Par.IsVarParam then Continue; + if Par.ResolvedType.Kind = tyString then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_StringAddRef(l %s)', ValTemp)); + end + else if Par.ResolvedType.Kind = tyClass then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_ClassAddRef(l %s)', ValTemp)); + end; + end; + + 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; + + SavedExitLbl := FExitLabel; + FExitLabel := AllocLabel('func_exit'); + try + EmitBlock(ADecl.Body); + finally + FExitLabel := SavedExitLbl; + end; + + + + for I := 0 to ADecl.Params.Count - 1 do + begin + Par := TMethodParam(ADecl.Params.Get(I)); + if Par.IsVarParam then Continue; + if Par.ResolvedType.Kind = tyString then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_StringRelease(l %s)', ValTemp)); + end + else if Par.ResolvedType.Kind = tyClass then + begin + ValTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', ValTemp, Par.ParamName)); + EmitLine(Format(' call $_ClassRelease(l %s)', ValTemp)); + end; + end; + + 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; + +procedure TCodeGenQBE.EmitStandaloneDef(ADecl: TMethodDecl); +begin + EmitFuncDef(ADecl, False); +end; + +procedure TCodeGenQBE.EmitStandaloneDefs(AProg: TProgram); +var + I: Integer; + Decl: TMethodDecl; +begin + for I := 0 to AProg.Block.ProcDecls.Count - 1 do + begin + Decl := TMethodDecl(AProg.Block.ProcDecls.Get(I)); + + if Decl.OwnerTypeName <> '' then Continue; + + if Decl.TypeParams <> nil then Continue; + + if Decl.Body = nil then Continue; + EmitStandaloneDef(Decl); + end; + + for I := 0 to AProg.GenericFuncInstances.Count - 1 do + EmitStandaloneDef( + TGenericFuncInstance(AProg.GenericFuncInstances.Get(I)).MethodDecl); +end; + +procedure TCodeGenQBE.EmitProcCall(ACall: TProcCall); +var + UCaseName: string; + MDecl: TMethodDecl; + Par: TMethodParam; + ArgTemp: string; + ArgTemp2: string; + SizeTemp: string; + ArgLine: string; + I: Integer; +begin + + if ACall.ResolvedDecl <> nil then + begin + MDecl := TMethodDecl(ACall.ResolvedDecl); + if ACall.IsImplicitSelfMethod then + begin + + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', ArgTemp)); + ArgLine := Format('l %s', ArgTemp); + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(I))); + ArgLine := ArgLine + Format(', %s %s', QbeTypeOf(Par.ResolvedType), ArgTemp); + end; + EmitLine(Format(' call $%s_%s(%s)', MDecl.OwnerTypeName, ACall.Name, ArgLine)); + Exit; + end; + ArgLine := ''; + for I := 0 to ACall.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + if ArgLine <> '' then ArgLine := ArgLine + ', '; + if Par.IsVarParam then + + ArgLine := ArgLine + Format('l %%_var_%s', TIdentExpr(TASTExpr(ACall.Args.Get(I))).Name) + else + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(I))); + ArgLine := ArgLine + Format('%s %s', QbeTypeOf(Par.ResolvedType), ArgTemp); + end; + end; + EmitLine(Format(' call $%s(%s)', QBEMangle(ACall.Name), ArgLine)); + Exit; + end; + + + UCaseName := UpperCase(ACall.Name); + if UCaseName = 'WRITELN' then + EmitWrite(ACall, True) + else if UCaseName = 'WRITE' then + EmitWrite(ACall, False) + else if UCaseName = 'FREEMEM' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + EmitLine(Format(' call $free(l %s)', ArgTemp)); + end + else if UCaseName = 'ZEROMEM' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + ArgTemp2 := EmitExpr(TASTExpr(ACall.Args.Get(1))); + SizeTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', SizeTemp, ArgTemp2)); + EmitLine(Format(' call $memset(l %s, w 0, l %s)', ArgTemp, SizeTemp)); + end + else if UCaseName = '_CLASSADDREF' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + EmitLine(Format(' call $_ClassAddRef(l %s)', ArgTemp)); + end + else if UCaseName = '_CLASSRELEASE' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + EmitLine(Format(' call $_ClassRelease(l %s)', ArgTemp)); + end + else if UCaseName = 'WRITEFILE' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + ArgTemp2 := EmitExpr(TASTExpr(ACall.Args.Get(1))); + EmitLine(Format(' call $_WriteFile(l %s, l %s)', ArgTemp, ArgTemp2)); + end + else if UCaseName = 'APPENDFILE' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + ArgTemp2 := EmitExpr(TASTExpr(ACall.Args.Get(1))); + EmitLine(Format(' call $_AppendFile(l %s, l %s)', ArgTemp, ArgTemp2)); + end + else if UCaseName = 'HALT' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + EmitLine(Format(' call $exit(w %s)', ArgTemp)); + end + else if UCaseName = 'DELETEFILE' then + begin + ArgTemp := EmitExpr(TASTExpr(ACall.Args.Get(0))); + EmitLine(Format(' call $_DeleteFile(l %s)', ArgTemp)); + end + else + raise ECodeGenError.Create(Format('Unknown procedure ''%s'' at line %d', ACall.Name, ACall.Line)); +end; + +procedure TCodeGenQBE.EmitPointerWrite(AStmt: TPointerWriteStmt); +var + PtrTemp: string; + ValTemp: string; + OldTemp: string; + QType: string; + StoreInstr: string; +begin + PtrTemp := EmitExpr(AStmt.PtrExpr); + + if (AStmt.BaseTy <> nil) and AStmt.BaseTy.IsString then + begin + OldTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', OldTemp, PtrTemp)); + ValTemp := EmitExpr(AStmt.ValExpr); + EmitLine(Format(' call $_StringAddRef(l %s)', ValTemp)); + EmitLine(Format(' call $_StringRelease(l %s)', OldTemp)); + EmitLine(Format(' storel %s, %s', ValTemp, PtrTemp)); + Exit; + end; + ValTemp := EmitExpr(AStmt.ValExpr); + QType := QbeTypeOf(AStmt.BaseTy); + if QType = 'w' then StoreInstr := 'storew' + else StoreInstr := 'storel'; + EmitLine(Format(' %s %s, %s', StoreInstr, ValTemp, PtrTemp)); +end; + +procedure TCodeGenQBE.EmitWrite(ACall: TProcCall; ANewline: Boolean); +var + ArgExpr: TASTExpr; + ArgTemp: string; + CharPtr: string; + IsString: Boolean; + I: Integer; +begin + if ACall.Args.Count = 0 then + begin + if ANewline then + EmitLine(' call $printf(l $__fmt_nl)'); + Exit; + end; + + + + + for I := 0 to ACall.Args.Count - 1 do + begin + ArgExpr := TASTExpr(ACall.Args.Get(I)); + IsString := (ArgExpr.ResolvedType <> nil) and ArgExpr.ResolvedType.IsString; + ArgTemp := EmitExpr(ArgExpr); + if IsString then + begin + + CharPtr := AllocTemp; + EmitLine(Format(' %s =l add %s, 12', CharPtr, ArgTemp)); + EmitLine(Format(' call $printf(l $__fmt_s, ..., l %s)', CharPtr)); + end + else + EmitLine(Format(' call $printf(l $__fmt_d, ..., w %s)', ArgTemp)); + end; + + if ANewline then + EmitLine(' call $printf(l $__fmt_nl)'); +end; + +function TCodeGenQBE.EmitExpr(AExpr: TASTExpr): string; +var + T, L, R: string; + 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; + IntfDesc: TInterfaceTypeDesc; + VTblTemp: string; + FPtrTemp: string; + SlotOff: Integer; + NoArgCall: TFuncCallExpr; + ImplFld: TFieldInfo; + SelfT: string; + PtrT: string; +begin + if AExpr is TFuncCallExpr then + begin + + begin + + if SameText(TFuncCallExpr(AExpr).Name, 'SizeOf') then + begin + T := AllocTemp; + EmitLine(Format(' %s =w copy %d', T, TASTExpr(TFuncCallExpr(AExpr).Args.Get(0)).ResolvedType.ByteSize)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'GetMem') then + begin + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + + L := AllocTemp; + EmitLine(Format(' %s =l extsw %s', L, ArgTemp)); + EmitLine(Format(' %s =l call $malloc(l %s)', T, L)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'ReallocMem') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', ArgTemp, R)); + T := AllocTemp; + EmitLine(Format(' %s =l call $realloc(l %s, l %s)', T, L, ArgTemp)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'Length') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StringLength(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'Pos') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StringPos(l %s, l %s)', T, L, R)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'Copy') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(2))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringCopy(l %s, w %s, w %s)', T, L, R, ArgTemp)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'UpperCase') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringUpperCase(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'LowerCase') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringLowerCase(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'Trim') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringTrim(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'SameText') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StringSameText(l %s, l %s)', T, L, R)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'IntToStr') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_IntToStr(w %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'StrToInt') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StrToInt(l %s)', T, L)); + Result := T; + Exit; + end; + + + + + if SameText(TFuncCallExpr(AExpr).Name, 'Format') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + + ArgLine := Format('l %s, ...', L); + for I := 1 to TFuncCallExpr(AExpr).Args.Count - 1 do + begin + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(I))); + if ((TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyInteger) or (TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyBoolean) or (TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyByte) or (TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyUInt32) or (TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyInt64) or (TASTExpr(TFuncCallExpr(AExpr).Args.Get(I)).ResolvedType.Kind = tyEnum)) then + ArgLine := ArgLine + Format(', w 0, w %s', ArgTemp) + else + ArgLine := ArgLine + Format(', w 1, l %s', ArgTemp); + end; + T := AllocTemp; + EmitLine(Format(' %s =l call $_StringFormat(%s)', T, ArgLine)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'OrdAt') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_OrdAt(l %s, w %s)', T, L, R)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'CompareStr') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StringCompare(l %s, l %s)', T, L, R)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'CompareText') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + R := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(1))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_StringCompareText(l %s, l %s)', T, L, R)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'ParamCount') then + begin + T := AllocTemp; + EmitLine(Format(' %s =w call $_ParamCount()', T)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'ParamStr') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_ParamStr(w %s)', T, L)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'ReadFile') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_ReadFile(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'FileExists') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_FileExists(l %s)', T, L)); + Result := T; + Exit; + end; + + + if SameText(TFuncCallExpr(AExpr).Name, 'GetEnvVar') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =l call $_GetEnvVar(l %s)', T, L)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'CurrentExceptionMessage') then + begin + T := AllocTemp; + EmitLine(Format(' %s =l call $_CurrentExceptionMessage()', T)); + Result := T; + Exit; + end; + + if SameText(TFuncCallExpr(AExpr).Name, 'Exec') then + begin + L := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + EmitLine(Format(' %s =w call $_Exec(l %s)', T, L)); + Result := T; + Exit; + end; + + + if TFuncCallExpr(AExpr).ResolvedDecl = nil then + begin + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(0))); + T := AllocTemp; + QType := QbeTypeOf(TFuncCallExpr(AExpr).ResolvedType); + if QType = 'w' then + EmitLine(Format(' %s =w copy %s', T, ArgTemp)) + else + EmitLine(Format(' %s =l copy %s', T, ArgTemp)); + Result := T; + Exit; + end; + + MDecl := TMethodDecl(TFuncCallExpr(AExpr).ResolvedDecl); + QType := QbeTypeOf(MDecl.ResolvedReturnType); + if TFuncCallExpr(AExpr).IsImplicitSelfMethod then + begin + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', ArgTemp)); + ArgLine := Format('l %s', ArgTemp); + FuncName := '$' + MDecl.OwnerTypeName + '_' + TFuncCallExpr(AExpr).Name; + for I := 0 to TFuncCallExpr(AExpr).Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(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; + FuncName := '$' + QBEMangle(TFuncCallExpr(AExpr).Name); + ArgLine := ''; + for I := 0 to TFuncCallExpr(AExpr).Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(TFuncCallExpr(AExpr).Args.Get(I))); + if ArgLine <> '' then ArgLine := ArgLine + ', '; + 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; + end; + Exit; + end; + + if AExpr is TMethodCallExpr then + begin + MCallExpr := TMethodCallExpr(AExpr); + + + if (MCallExpr.ResolvedClassType <> nil) and + (MCallExpr.ResolvedClassType.Kind = tyInterface) then + begin + IntfDesc := TInterfaceTypeDesc(MCallExpr.ResolvedClassType); + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_obj', SelfTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal))); + VTblTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s_itab', VTblTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal))); + SlotOff := IntfDesc.MethodIndex(MCallExpr.Name) * 8; + FPtrTemp := AllocTemp; + if SlotOff = 0 then + EmitLine(Format(' %s =l loadl %s', FPtrTemp, VTblTemp)) + else + begin + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', ArgTemp, VTblTemp, SlotOff)); + EmitLine(Format(' %s =l loadl %s', FPtrTemp, ArgTemp)); + end; + + ArgLine := Format('l %s', SelfTemp); + for I := 0 to MCallExpr.Args.Count - 1 do + begin + ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Get(I))); + ArgLine := ArgLine + Format(', w %s', ArgTemp); + end; + T := AllocTemp; + EmitLine(Format(' %s =w call %s(%s)', T, FPtrTemp, ArgLine)); + Result := T; + Exit; + end; + + RT := TRecordTypeDesc(MCallExpr.ResolvedClassType); + + + if MCallExpr.IsConstructorCall then + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)', SelfTemp, RT.TotalSize, RT.Name)); + EmitLine(Format(' call $_ClassAddRef(l %s)', SelfTemp)); + + if MCallExpr.ResolvedMethod <> nil then + begin + MDecl := TMethodDecl(MCallExpr.ResolvedMethod); + ArgLine := Format('l %s', SelfTemp); + for I := 0 to MCallExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Get(I))); + ArgLine := ArgLine + Format(', %s %s', QbeTypeOf(Par.ResolvedType), ArgTemp); + end; + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + MCallExpr.Name + else + FuncName := '$' + RT.Name + '_' + MCallExpr.Name; + EmitLine(Format(' call %s(%s)', FuncName, ArgLine)); + end; + Result := SelfTemp; + Exit; + end; + + MDecl := TMethodDecl(MCallExpr.ResolvedMethod); + if MDecl.OwnerTypeName <> '' then + FuncName := '$' + MDecl.OwnerTypeName + '_' + MCallExpr.Name + else + FuncName := '$' + RT.Name + '_' + MCallExpr.Name; + QType := QbeTypeOf(MDecl.ResolvedReturnType); + + + + if MCallExpr.ObjExpr <> nil then + SelfTemp := EmitExpr(MCallExpr.ObjExpr) + else + begin + SelfTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', SelfTemp, VarRef(MCallExpr.ObjectName, MCallExpr.IsGlobal))); + end; + + + ArgLine := Format('l %s', SelfTemp); + for I := 0 to MCallExpr.Args.Count - 1 do + begin + Par := TMethodParam(MDecl.Params.Get(I)); + if Par.IsVarParam then + + ArgLine := ArgLine + Format(', l %%_var_%s', TIdentExpr(TASTExpr(MCallExpr.Args.Get(I))).Name) + else + begin + ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Get(I))); + ArgLine := ArgLine + Format(', %s %s', QbeTypeOf(Par.ResolvedType), ArgTemp); + end; + end; + + T := AllocTemp; + if MDecl.VTableSlot >= 0 then + begin + + VTblTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', VTblTemp, SelfTemp)); + FPtrTemp := AllocTemp; + SlotOff := (MDecl.VTableSlot + 1) * 8; + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', ArgTemp, VTblTemp, SlotOff)); + EmitLine(Format(' %s =l loadl %s', FPtrTemp, ArgTemp)); + EmitLine(Format(' %s =%s call %s(%s)', T, QType, FPtrTemp, ArgLine)); + end + else + EmitLine(Format(' %s =%s call %s(%s)', T, QType, FuncName, ArgLine)); + Result := T; + Exit; + end; + + if AExpr is TNilLiteral then + begin + T := AllocTemp; + EmitLine(Format(' %s =l copy 0', T)); + Result := T; + Exit; + end; + + if AExpr is TIntLiteral then + begin + T := AllocTemp; + EmitLine(Format(' %s =w copy %d', T, TIntLiteral(AExpr).Value)); + Result := T; + end + else if AExpr is TStringLiteral then + begin + Result := EmitStrLit(TStringLiteral(AExpr).Value); + end + else if AExpr is TFieldAccessExpr then + begin + FldAccess := TFieldAccessExpr(AExpr); + + + if FldAccess.Base <> nil then + begin + if FldAccess.IsMethodCall then + begin + + L := EmitInstancePtr(FldAccess.Base); + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L)); + Result := T; + Exit; + end; + L := EmitInstancePtr(FldAccess.Base); + if FldAccess.FieldInfo = nil then + raise ECodeGenError.Create(Format('Chained field ''%s'' has no resolved field info', FldAccess.FieldName)); + if FldAccess.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, L, FldAccess.FieldInfo.Offset)); + end + else + Ptr := L; + QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc); + T := AllocTemp; + if QType = 'w' then LoadInstr := 'loadw' + else LoadInstr := 'loadl'; + EmitLine(Format(' %s =%s %s %s', T, QType, LoadInstr, Ptr)); + Result := T; + Exit; + end; + if FldAccess.IsImplicitSelf then + begin + + L := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', L)); + if FldAccess.ImplicitBaseInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, L, FldAccess.ImplicitBaseInfo.Offset)); + L := Ptr; + end; + if FldAccess.IsClassAccess then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %s', Ptr, L)); + L := Ptr; + end; + if FldAccess.IsMethodCall then + begin + + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L)); + Result := T; + Exit; + end; + if FldAccess.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, L, FldAccess.FieldInfo.Offset)); + end + else + Ptr := L; + QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc); + T := AllocTemp; + if QType = 'w' then LoadInstr := 'loadw' + else LoadInstr := 'loadl'; + EmitLine(Format(' %s =%s %s %s', T, QType, LoadInstr, Ptr)); + Result := T; + end + else if FldAccess.IsMethodCall then + begin + + MDecl := TMethodDecl(FldAccess.ResolvedMethod); + L := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', L, FldAccess.RecordName)); + QType := QbeTypeOf(MDecl.ResolvedReturnType); + T := AllocTemp; + EmitLine(Format(' %s =%s call $%s_%s(l %s)', T, QType, MDecl.OwnerTypeName, FldAccess.FieldName, L)); + Result := T; + end + else if FldAccess.IsConstructorCall then + begin + + + + + + + + T := AllocTemp; + EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)', T, TRecordTypeDesc(FldAccess.ResolvedType).TotalSize, + QBEMangle(FldAccess.ResolvedType.Name))); + + if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable then + EmitLine(Format(' storel $vtable_%s, %s', QBEMangle(FldAccess.ResolvedType.Name), T)); + Result := T; + end + else if FldAccess.PropRead <> nil then + begin + + L := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', L, FldAccess.RecordName)); + T := AllocTemp; + QType := QbeTypeOf(FldAccess.PropRead.TypeDesc); + EmitLine(Format(' %s =%s call $%s_%s(l %s)', T, QType, QBEMangle(FldAccess.PropOwnerType), + FldAccess.PropRead.ReadMethod, L)); + Result := T; + end + else if FldAccess.IsClassAccess then + begin + + L := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', L, FldAccess.RecordName)); + if FldAccess.FieldInfo.Offset > 0 then + begin + Ptr := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', Ptr, L, FldAccess.FieldInfo.Offset)); + end + else + Ptr := L; + QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc); + T := AllocTemp; + if QType = 'w' then LoadInstr := 'loadw' + else LoadInstr := 'loadl'; + EmitLine(Format(' %s =%s %s %s', T, QType, LoadInstr, Ptr)); + Result := T; + end + else + begin + + if FldAccess.FieldInfo = nil then + raise ECodeGenError.Create(Format('Field access ''%s.%s'' has no resolved field info', FldAccess.RecordName, FldAccess.FieldName)); + Ptr := FieldPtr(FldAccess.RecordName, FldAccess.FieldInfo.Offset); + QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc); + T := AllocTemp; + if QType = 'w' then LoadInstr := 'loadw' + else LoadInstr := 'loadl'; + EmitLine(Format(' %s =%s %s %s', T, QType, LoadInstr, Ptr)); + Result := T; + end; + end + else if AExpr is TIdentExpr then + begin + T := AllocTemp; + if TIdentExpr(AExpr).IsImplicitSelf then + begin + + ImplFld := TFieldInfo(TIdentExpr(AExpr).ImplicitFieldInfo); + SelfT := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_Self', SelfT)); + T := AllocTemp; + QType := QbeTypeOf(AExpr.ResolvedType); + if ImplFld.Offset > 0 then + begin + PtrT := AllocTemp; + EmitLine(Format(' %s =l add %s, %d', PtrT, SelfT, ImplFld.Offset)); + if QType = 'w' then + EmitLine(Format(' %s =w loadw %s', T, PtrT)) + else + EmitLine(Format(' %s =l loadl %s', T, PtrT)); + end + else + begin + if QType = 'w' then + EmitLine(Format(' %s =w loadw %s', T, SelfT)) + else + EmitLine(Format(' %s =l loadl %s', T, SelfT)); + end; + Result := T; + Exit; + end; + + if TIdentExpr(AExpr).IsImplicitSelfMethod then + begin + + NoArgCall := TFuncCallExpr.Create; + try + NoArgCall.Name := TIdentExpr(AExpr).Name; + NoArgCall.ResolvedType := AExpr.ResolvedType; + NoArgCall.ResolvedDecl := TIdentExpr(AExpr).ImplicitMethodDecl; + NoArgCall.IsImplicitSelfMethod := True; + Result := EmitExpr(NoArgCall); + finally + NoArgCall.Free; + end; + Exit; + end + else if TIdentExpr(AExpr).IsNoArgFuncCall then + begin + + + + NoArgCall := TFuncCallExpr.Create; + try + NoArgCall.Name := TIdentExpr(AExpr).Name; + NoArgCall.ResolvedType := AExpr.ResolvedType; + Result := EmitExpr(NoArgCall); + finally + NoArgCall.Free; + end; + Exit; + end + else if TIdentExpr(AExpr).IsConstant then + begin + EmitLine(Format(' %s =w copy %d', T, TIdentExpr(AExpr).ConstValue)); + end + else if TIdentExpr(AExpr).IsVarParam then + begin + + Ptr := AllocTemp; + EmitLine(Format(' %s =l loadl %%_var_%s', Ptr, TIdentExpr(AExpr).Name)); + QType := QbeTypeOf(AExpr.ResolvedType); + if QType = 'l' then + EmitLine(Format(' %s =l loadl %s', T, Ptr)) + else + EmitLine(Format(' %s =w loadw %s', T, Ptr)); + end + else if TIdentExpr(AExpr).IsGlobal then + begin + + if (AExpr.ResolvedType <> nil) and (QbeTypeOf(AExpr.ResolvedType) = 'w') then + EmitLine(Format(' %s =w loadw $%s', T, TIdentExpr(AExpr).Name)) + else + EmitLine(Format(' %s =l loadl $%s', T, TIdentExpr(AExpr).Name)); + end + else if (AExpr.ResolvedType <> nil) and (QbeTypeOf(AExpr.ResolvedType) = 'l') then + begin + EmitLine(Format(' %s =l loadl %%_var_%s', T, TIdentExpr(AExpr).Name)); + end + else + begin + EmitLine(Format(' %s =w loadw %%_var_%s', T, TIdentExpr(AExpr).Name)); + end; + Result := T; + end + else if AExpr is TBinaryExpr then + begin + BinExpr := TBinaryExpr(AExpr); + L := EmitExpr(BinExpr.Left); + R := EmitExpr(BinExpr.Right); + T := AllocTemp; + + if (BinExpr.Op = boAdd) and + (BinExpr.Left.ResolvedType <> nil) and + BinExpr.Left.ResolvedType.IsString then + begin + EmitLine(Format(' %s =l call $_StringConcat(l %s, l %s)', T, L, R)); + Result := T; + Exit; + end; + + if (((BinExpr.Op = boAdd) or (BinExpr.Op = boSub))) and + (BinExpr.Left.ResolvedType <> nil) and + (BinExpr.Left.ResolvedType.Kind = tyPointer) then + begin + + ArgTemp := AllocTemp; + EmitLine(Format(' %s =l extsw %s', ArgTemp, R)); + if BinExpr.Op = boAdd then + EmitLine(Format(' %s =l add %s, %s', T, L, ArgTemp)) + else + EmitLine(Format(' %s =l sub %s, %s', T, L, ArgTemp)); + Result := T; + Exit; + end; + + if (BinExpr.Left.ResolvedType <> nil) and + BinExpr.Left.ResolvedType.IsString and + (((BinExpr.Op = boEQ) or (BinExpr.Op = boNE))) then + begin + EmitLine(Format(' %s =w call $_StringEquals(l %s, l %s)', T, L, R)); + if BinExpr.Op = boNE then + begin + ArgTemp := AllocTemp; + EmitLine(Format(' %s =w ceqw %s, 0', ArgTemp, T)); + T := ArgTemp; + end; + Result := T; + Exit; + end; + + if (BinExpr.Left.ResolvedType <> nil) and + (((BinExpr.Left.ResolvedType.Kind = tyClass) or (BinExpr.Left.ResolvedType.Kind = tyNil))) then + begin + case BinExpr.Op of + boEQ: Op := 'ceql'; + boNE: Op := 'cnel'; + else + Op := 'ceql'; + end; + EmitLine(Format(' %s =w %s %s, %s', T, Op, L, R)); + end + else + begin + case BinExpr.Op of + boAdd: Op := 'add'; + boSub: Op := 'sub'; + boMul: Op := 'mul'; + boDiv: Op := 'div'; + boEQ: Op := 'ceqw'; + boNE: Op := 'cnew'; + boLT: Op := 'csltw'; + boGT: Op := 'csgtw'; + boLE: Op := 'cslew'; + boGE: Op := 'csgew'; + boAnd: Op := 'and'; + boOr: Op := 'or'; + else + Op := 'add'; + end; + EmitLine(Format(' %s =w %s %s, %s', T, Op, L, R)); + end; + Result := T; + end + else if AExpr is TNotExpr then + begin + + L := EmitExpr(TNotExpr(AExpr).Expr); + T := AllocTemp; + EmitLine(Format(' %s =w xor %s, 1', T, L)); + Result := T; + end + else if AExpr is TDerefExpr then + begin + + T := EmitExpr(TDerefExpr(AExpr).Expr); + QType := QbeTypeOf(AExpr.ResolvedType); + L := AllocTemp; + if QType = 'w' then + EmitLine(Format(' %s =w loadw %s', L, T)) + else + EmitLine(Format(' %s =l loadl %s', L, T)); + Result := L; + end + else if AExpr is TIsExpr then + Result := EmitIsExpr(TIsExpr(AExpr)) + else if AExpr is TAsExpr then + Result := EmitAsExpr(TAsExpr(AExpr)) + else + raise ECodeGenError.Create('Unknown expression node type'); +end; + +function TCodeGenQBE.EmitIsExpr(AExpr: TIsExpr): string; +var + ObjTemp: string; + ResTemp: string; +begin + ObjTemp := EmitExpr(AExpr.Obj); + ResTemp := AllocTemp; + if (AExpr.ResolvedTargetType <> nil) and + (AExpr.ResolvedTargetType.Kind = tyInterface) then + EmitLine(Format(' %s =w call $_ImplementsInterface(l %s, l $typeinfo_%s)', ResTemp, ObjTemp, AExpr.TypeName)) + else + EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)', ResTemp, ObjTemp, AExpr.TypeName)); + Result := ResTemp; +end; + +function TCodeGenQBE.EmitAsExpr(AExpr: TAsExpr): string; +var + ObjTemp: string; + OkTemp: string; + SlotTemp: string; + ResTemp: string; + LblOk: string; + LblFail: string; + LblEnd: string; +begin + ObjTemp := EmitExpr(AExpr.Obj); + SlotTemp := AllocTemp; + EmitLine(Format(' %s =l alloc8 1', SlotTemp)); + + OkTemp := AllocTemp; + LblOk := AllocLabel('as_ok'); + LblFail := AllocLabel('as_fail'); + LblEnd := AllocLabel('as_end'); + + EmitLine(Format(' %s =w call $_IsInstance(l %s, l $typeinfo_%s)', OkTemp, ObjTemp, AExpr.TypeName)); + EmitLine(Format(' jnz %s, @%s, @%s', OkTemp, LblOk, LblFail)); + + EmitLine('@' + LblFail); + EmitLine(' call $_Raise_InvalidCast()'); + EmitLine(Format(' storel 0, %s', SlotTemp)); + EmitLine(Format(' jmp @%s', LblEnd)); + + EmitLine('@' + LblOk); + EmitLine(Format(' storel %s, %s', ObjTemp, SlotTemp)); + EmitLine(Format(' jmp @%s', LblEnd)); + + EmitLine('@' + LblEnd); + ResTemp := AllocTemp; + EmitLine(Format(' %s =l loadl %s', ResTemp, SlotTemp)); + Result := ResTemp; +end; + +function TCodeGenQBE.QBEMangle(const AName: string): string; +var + I: Integer; + C: Integer; +begin + Result := ''; + for I := 1 to Length(AName) do + begin + C := OrdAt(AName, I); + if C = 60 then + Result := Result + '_' + else if C = 62 then + begin end + else if C = 44 then + Result := Result + '_' + else + Result := Result + Copy(AName, I, 1); + end; +end; + +function TCodeGenQBE.QbeEscapeString(const AStr: string): string; +var + I: Integer; + C: Integer; +begin + Result := ''; + for I := 1 to Length(AStr) do + begin + C := OrdAt(AStr, I); + if C = 34 then + Result := Result + '\"' + else if C = 92 then + Result := Result + '\\' + else if C = 10 then + Result := Result + '\n' + else if C = 13 then + Result := Result + '\r' + else if C = 9 then + Result := Result + '\t' + else if (C < 32) or (C > 126) then + Result := Result + Format('\%02x', C) + else + Result := Result + Copy(AStr, I, 1); + end; +end; + +procedure TCodeGenQBE.Generate(AProg: TProgram); +var + Body: TStringList; + SavedOutput: TStringList; +begin + FOutput.Clear; + FStrLits.Clear; + FTempCount := 0; + FLabelCount := 0; + + Body := TStringList.Create; + try + SavedOutput := FOutput; + FOutput := Body; + try + EmitFieldCleanupDefs(AProg); + EmitMethodDefs(AProg); + EmitStandaloneDefs(AProg); + FExitLabel := 'main_exit'; + EmitMainHeader; + EmitBlock(AProg.Block); + EmitMainFooter; + FExitLabel := ''; + finally + FOutput := SavedOutput; + end; + + EmitLine('# Generated by Blaise Compiler'); + EmitLine('# Source: ' + AProg.Name); + EmitLine(''); + EmitDataSection; + EmitGlobalVarData(AProg.Block); + EmitInterfaceDefs(AProg); + EmitTypeInfoDefs(AProg); + EmitVTableDefs(AProg); + FOutput.AddStrings(Body); + finally + Body.Free; + end; +end; + +procedure TCodeGenQBE.GenerateUnit(AUnit: TUnit); +var + I: Integer; + ImplDecl: TMethodDecl; + IntfNames: TStringList; + Body: TStringList; + SavedOut: TStringList; +begin + FOutput.Clear; + FStrLits.Clear; + FTempCount := 0; + FLabelCount := 0; + + IntfNames := TStringList.Create; + try + IntfNames.CaseSensitive := False; + for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do + IntfNames.Add(TMethodDecl(AUnit.IntfBlock.ProcDecls.Get(I)).Name); + + Body := TStringList.Create; + try + SavedOut := FOutput; + FOutput := Body; + try + for I := 0 to AUnit.ImplBlock.ProcDecls.Count - 1 do + begin + ImplDecl := TMethodDecl(AUnit.ImplBlock.ProcDecls.Get(I)); + EmitFuncDef(ImplDecl, IntfNames.IndexOf(ImplDecl.Name) >= 0); + end; + finally + FOutput := SavedOut; + end; + + EmitLine('# Generated by Blaise Compiler'); + EmitLine('# Unit: ' + AUnit.Name); + EmitLine(''); + EmitDataSection; + FOutput.AddStrings(Body); + finally + Body.Free; + end; + finally + IntfNames.Free; + end; +end; + +function TCodeGenQBE.GetOutput: string; +begin + Result := FOutput.GetText; +end; + + + + +{ === Main program === } + + + + + + + + + + + + + + + + + + + + + + + +const + Version = '0.1.0-alpha'; + CompilerName = 'Blaise'; + +procedure PrintUsage; +begin + WriteLn('Blaise Compiler v', Version); + WriteLn('Copyright (c) 2026 Graeme Geldenhuys'); + WriteLn(''); + WriteLn('Usage:'); + WriteLn(' blaise --source --output '); + WriteLn(' blaise --source --emit-ir'); + WriteLn(''); + WriteLn('Flags:'); + WriteLn(' --source Pascal source file'); + WriteLn(' --output Output binary path'); + WriteLn(' --target linux-x86_64 (default), macos-arm64'); + WriteLn(' --emit-ir Print QBE IR to stdout and exit'); +end; + + + +procedure HandleFPCInfoQuery(const AArg: string); +var + Query: string; +begin + Query := Copy(AArg, 3, MaxInt); + if Query = 'V' then + begin + WriteLn('3.2.2'); + Halt(0); + end + else if Query = 'TP' then + begin + WriteLn('x86_64'); + Halt(0); + end + else if Query = 'TO' then + begin + WriteLn('linux'); + Halt(0); + end; + +end; + + + + +function ParseFPCArgs( + var SourceFile: string; + var OutputFile: string): Boolean; +var + I: Integer; + Arg: string; + OutDir: string; + OutName: string; +begin + Result := False; + SourceFile := ''; + OutputFile := ''; + OutDir := ''; + OutName := ''; + + I := 1; + while I <= ParamCount do + begin + Arg := ParamStr(I); + + if Copy(Arg, 1, 2) = '-i' then + HandleFPCInfoQuery(Arg) + else if Copy(Arg, 1, 3) = '-FE' then + OutDir := Copy(Arg, 4, MaxInt) + else if Copy(Arg, 1, 3) = '-FU' then begin end + else if Copy(Arg, 1, 3) = '-Fu' then begin end + else if Copy(Arg, 1, 2) = '-o' then + OutName := Copy(Arg, 3, MaxInt) + else if Copy(Arg, 1, 2) = '-M' then begin end + else if Copy(Arg, 1, 2) = '-O' then begin end + else if Copy(Arg, 1, 2) = '-d' then begin end + else if (Arg = '-g') or (Arg = '-gl') or (Arg = '-CX') or + (Arg = '-XX') or (Arg = '-Xs') then begin end + else if (Arg = '--help') or (Arg = '-h') then + begin + PrintUsage; + Halt(0); + end + else if (Length(Arg) > 0) and (OrdAt(Arg, 1) <> 45) then + begin + + if SourceFile = '' then + SourceFile := Arg; + end; + + + I := I + 1; + end; + + if SourceFile = '' then + begin + WriteLn('Error: no source file specified'); + Exit; + end; + + + if OutName = '' then + OutName := ChangeFileExt(ExtractFileName(SourceFile), ''); + if OutDir <> '' then + OutputFile := (OutDir + '/') + OutName + else + OutputFile := OutName; + + Result := True; +end; + + + +function IsFPCStyleInvocation: Boolean; +var + I: Integer; + Arg: string; +begin + Result := False; + for I := 1 to ParamCount do + begin + Arg := ParamStr(I); + if (Length(Arg) >= 2) and (OrdAt(Arg, 1) = 45) and (OrdAt(Arg, 2) <> 45) then + begin + Result := True; + Exit; + end; + end; +end; + +function ParseArgs( + var SourceFile: string; + var OutputFile: string; + var EmitIR: Boolean): Boolean; +var + I: Integer; + Arg: string; +begin + Result := False; + SourceFile := ''; + OutputFile := ''; + EmitIR := False; + + I := 1; + while I <= ParamCount do + begin + Arg := ParamStr(I); + if (Arg = '--source') and (I < ParamCount) then + begin + I := I + 1; + SourceFile := ParamStr(I); + end + else if (Arg = '--output') and (I < ParamCount) then + begin + I := I + 1; + OutputFile := ParamStr(I); + end + else if Arg = '--emit-ir' then + EmitIR := True + else if Arg = '--target' then + I := I + 1 + else if (Arg = '--help') or (Arg = '-h') then + begin + PrintUsage; + Halt(0); + end + else + begin + WriteLn('Unknown flag: ', Arg); + Exit; + end; + I := I + 1; + end; + + if SourceFile = '' then + begin + WriteLn('Error: --source is required'); + Exit; + end; + if (not EmitIR) and (OutputFile = '') then + begin + WriteLn('Error: --output is required (or use --emit-ir)'); + Exit; + end; + + Result := True; +end; + +function RunProcess(const ACmd: string; var AOutput: string): Integer; +begin + Result := Exec(ACmd); + AOutput := '' +end; + + + + + +function FindRTL: string; +var + BinDir: string; +begin + Result := GetEnvVar('BLAISE_RTL'); + if (Result <> '') and FileExists(Result) then + Exit; + BinDir := Copy(ParamStr(0), 1, Length(ParamStr(0)) - Length('blaise')); + Result := (BinDir + '/') + 'blaise_rtl.a'; + if FileExists(Result) then + Exit; + Result := ''; +end; + +procedure CompileToNative(const AIRFile, AOutputFile: string); +var + AsmFile, RTLPath: string; + Msg: string; + ExitCode: Integer; +begin + AsmFile := AIRFile + '.s'; + RTLPath := FindRTL; + + ExitCode := RunProcess('qbe' + ' ' + '-o' + ' ' + AsmFile + ' ' + AIRFile, Msg); + if ExitCode <> 0 then + begin + WriteLn('qbe error (exit ', ExitCode, '):'); + Write(Msg); + Halt(1); + end; + + if RTLPath <> '' then + ExitCode := RunProcess('cc' + ' ' + '-o' + ' ' + AOutputFile + ' ' + AsmFile + ' ' + RTLPath, Msg) + else + ExitCode := RunProcess('cc' + ' ' + '-o' + ' ' + AOutputFile + ' ' + AsmFile, Msg); + + if ExitCode <> 0 then + begin + WriteLn('cc error (exit ', ExitCode, '):'); + Write(Msg); + Halt(1); + end; + + DeleteFile(AsmFile); +end; + +var + SourceFile, OutputFile: string; + EmitIR: Boolean; + Source: TStringList; + Lexer: TLexer; + Parser: TParser; + Prog: TProgram; + Semantic: TSemanticAnalyser; + CG: TCodeGenQBE; + IR: string; + IRFile: string; + +begin + InitKeywords; + if IsFPCStyleInvocation then + begin + if not ParseFPCArgs(SourceFile, OutputFile) then + begin + PrintUsage; + Halt(1); + end; + EmitIR := False; + end + else + begin + if not ParseArgs(SourceFile, OutputFile, EmitIR) then + begin + PrintUsage; + Halt(1); + end; + end; + + if not FileExists(SourceFile) then + begin + WriteLn('Error: source file not found: ', SourceFile); + Halt(1); + end; + + Source := TStringList.Create; + try + Source.Add(ReadFile(SourceFile)); + except + + begin + WriteLn('Error reading source: ', CurrentExceptionMessage); + Halt(1); + end; + end; + + Lexer := nil; + Parser := nil; + Prog := nil; + Semantic := nil; + CG := nil; + try + try + Lexer := TLexer.Create(Source.GetText); + Parser := TParser.Create(Lexer); + Prog := Parser.Parse; + except + + begin + WriteLn('Parse error: ', CurrentExceptionMessage); + Halt(1); + end; + end; + + try + Semantic := TSemanticAnalyser.Create; + Semantic.Analyse(Prog); + except + + begin + WriteLn('Semantic error: ', CurrentExceptionMessage); + Halt(1); + end; + end; + + try + CG := TCodeGenQBE.Create; + CG.Generate(Prog); + IR := CG.GetOutput; + except + + begin + WriteLn('Code generation error: ', CurrentExceptionMessage); + Halt(1); + end; + end; + finally + CG.Free; + Semantic.Free; + Prog.Free; + Parser.Free; + Lexer.Free; + Source.Free; + end; + + if EmitIR then + begin + Write(IR); + Halt(0); + end; + + IRFile := OutputFile + '.ssa'; + try + Source := TStringList.Create; + try + + WriteFile(IRFile, IR); + finally + Source.Free; + end; + except + + begin + WriteLn('Error writing IR: ', CurrentExceptionMessage); + Halt(1); + end; + end; + + CompileToNative(IRFile, OutputFile); + DeleteFile(IRFile); + +end. diff --git a/tools/migrate_full.py b/tools/migrate_full.py new file mode 100644 index 0000000..28d72c0 --- /dev/null +++ b/tools/migrate_full.py @@ -0,0 +1,1365 @@ +#!/usr/bin/env python3 +""" +Full self-hosting migration script. + +Processes all 8 compiler units into tests/blaise-compiler.pas — a single +self-contained Pascal source that the compiler can compile into a +second-stage compiler (blaise2b). Source layout on disk: + + compiler/src/main/pascal/ — compiler units (uLexer, uParser, ...) + rtl/src/main/pascal/ — blaise RTL units compiled by this script + tests/blaise-compiler.pas — generated output + +The script strips FPC-specific syntax, rewrites idioms blaise does not +yet understand, and postprocess() injects the vtable fixes required on +root classes after the TObject hierarchy is dropped. + +Caveat: blaise's parser does not yet support nested procedures; the +generated file may need a minor hand edit (e.g. promoting a nested proc +to a class method) before it links as a second-stage compiler. Run the +script, compile tests/blaise-compiler.pas with blaise, and patch any +`undefined reference` linker errors in place. +""" +import re, subprocess, sys + +SRC = '/data/devel/new-pascal-compiler/compiler/src/main/pascal' +RTL = '/data/devel/new-pascal-compiler/rtl/src/main/pascal' +OUT = '/data/devel/new-pascal-compiler/tests/blaise-compiler.pas' + +def read(p): + with open(p) as f: return f.read() + +def write(p, text): + with open(p, 'w') as f: f.write(text) + +def strip_block_comments(text): + """Remove { ... } block comments including FPC-style nested ones. + FPC supports nested { } comments (comment depth > 1 gives a warning but compiles).""" + out = [] + i = 0 + n = len(text) + depth = 0 # nesting depth for { } comments + in_string = False + while i < n: + ch = text[i] + if in_string: + out.append(ch) + if ch == "'": + if i + 1 < n and text[i + 1] == "'": + out.append(text[i + 1]) + i += 2 + continue + in_string = False + elif depth > 0: + # Inside a { } comment + if ch == '{': + if i + 1 < n and text[i + 1] != '$': + depth += 1 # nested comment + # else directive inside comment — ignore + elif ch == '}': + depth -= 1 + elif ch == '\n': + out.append(ch) # keep newlines for line numbering + elif text[i:i+2] == '//': + # Line comment — keep through end of line + j = text.find('\n', i) + if j < 0: + break # strip rest + i = j # keep the newline + out.append(text[i]) + elif text[i:i+2] == '(*': + # (* ... *) comment — remove + j = text.find('*)', i + 2) + if j < 0: + break + # preserve newlines inside + for c in text[i:j + 2]: + if c == '\n': + out.append(c) + i = j + 2 + continue + elif ch == '{': + if i + 1 < n and text[i + 1] == '$': + # Compiler directive — keep it + j = text.find('}', i + 1) + if j < 0: + out.append(text[i:]) + break + out.append(text[i:j + 1]) + i = j + 1 + continue + depth = 1 # start of { } comment + elif ch == "'": + in_string = True + out.append(ch) + else: + out.append(ch) + i += 1 + return ''.join(out) + + +def strip_fpc(text): + text = strip_block_comments(text) + lines, out, skip = text.split('\n'), [], False + for line in lines: + s = line.strip() + if re.match(r'\{\$[A-Za-z]', s): continue + if re.match(r'^unit\s+\w', s, re.I): continue + if re.match(r'^program\s+\w', s, re.I): continue + if s.lower() in ('interface', 'implementation'): continue + if s == 'end.': continue + if re.match(r'^uses\b', s, re.I): skip = True; continue + if skip: + if ';' in line: skip = False + continue + out.append(line) + return '\n'.join(out) + +def basic(text): + def replace_incdec(text, fn_name, op): + # Scan for 'Inc('/'Dec(' and find its matching ')'. + out = [] + i = 0 + pat = re.compile(rf'\b{fn_name}\(') + while i < len(text): + m = pat.search(text, i) + if not m: + out.append(text[i:]) + break + start = m.start() + out.append(text[i:start]) + depth = 1 + j = m.end() + while j < len(text) and depth > 0: + if text[j] == '(': + depth += 1 + elif text[j] == ')': + depth -= 1 + j += 1 + if depth != 0: + out.append(text[start:]) + break + args = text[m.end(): j - 1] + # Split at the top-level comma only + depth = 0 + comma = -1 + for k, ch in enumerate(args): + if ch == '(': + depth += 1 + elif ch == ')': + depth -= 1 + elif ch == ',' and depth == 0: + comma = k + break + if comma >= 0: + lhs = args[:comma].strip() + rhs = args[comma + 1:].strip() + out.append(f"{lhs} := {lhs} {op} {rhs}") + else: + a = args.strip() + out.append(f"{a} := {a} {op} 1") + i = j + return ''.join(out) + text = replace_incdec(text, 'Inc', '+') + text = replace_incdec(text, 'Dec', '-') + # FreeAndNil(X) → X := nil (ARC handles the release) + text = re.sub(r"\bFreeAndNil\(([^)]+)\)", + lambda m: f"{m.group(1).strip()} := nil", text) + # StrToInt64 → StrToInt (Blaise lacks Int64 parsing) + text = text.replace("StrToInt64", "StrToInt") + text = text.replace('UpCase(', 'UpperCase(') + text = re.sub(r'\bconstructor\b', 'procedure', text) + text = re.sub(r'\bdestructor\b', 'procedure', text) + # Keep `override` — descendants of TASTNode/Exception need it for the + # vtable to propagate. Root classes (no parent after migration) get + # their `override` stripped or turned into `virtual` in postprocess. + text = re.sub(r';\s*overload\b', '', text) + text = re.sub(r';\s*inline\b', '', text) # inline directive not supported + # 'out' parameter modifier → 'var' (Blaise has var but not out) + text = re.sub(r'\bout\s+(\w+\s*:)', r'var \1', text) + # Empty if/else branches (comment-only in FPC become empty after stripping): + # "then\n\nelse" → "then begin end\nelse" + text = re.sub(r'\bthen\s*\n(\s*\n)+(\s*)(else\b)', r'then begin end\n\2\3', text) + # "then\s*\n\nend" — trailing branch with no body + text = re.sub(r'\bthen\s*\n(\s*\n)+(\s*)(end\b)', r'then begin end\n\2\3', text) + # Exit(expr) -> { Result := expr; Exit } (Delphi-style exit with value) + text = re.sub(r'\bExit\((False)\)', 'begin Result := False; Exit end', text) + text = re.sub(r'\bExit\((True)\)', 'begin Result := True; Exit end', text) + text = re.sub(r'\bExit\((\w+)\)', r'begin Result := \1; Exit end', text) + text = re.sub(r'\bshr\s+(\d+)', lambda m: f'div {2**int(m.group(1))}', text) + text = re.sub(r'\bshl\s+(\d+)', lambda m: f'* {2**int(m.group(1))}', text) + # Strip access modifier lines in class bodies + text = re.sub(r'^\s*(private|public|protected|published)\s*$', '', text, flags=re.MULTILINE) + # repeat ... until ; → while True do begin ... if then break end; + # Match a repeat..until with a boolean expression in parens. + def repeat_until_cond(m): + body = m.group(1) + cond = m.group(2).strip() + return f"while True do\nbegin{body} if {cond} then break;\nend;" + # repeat\n until (...); + text = re.sub(r"\brepeat\b(.*?)\buntil\s+(.+?);\s*\n", + repeat_until_cond, text, flags=re.DOTALL) + # Format('fmt', [a, b, c]) → Format('fmt', a, b, c) + # Also CreateFmt('fmt', [args]) → CreateFmt('fmt', args) + # Walk text, find ", [" preceded by a balanced-paren call, rewrite. + def strip_array_of_const(text): + out = [] + i = 0 + while i < len(text): + m = re.search(r',\s*\[', text[i:]) + if not m: + out.append(text[i:]) + break + j = i + m.start() + # find the matching ']' that is followed by ')' + k = i + m.end() + depth = 0 + close = -1 + while k < len(text): + ch = text[k] + if ch == '[': + depth += 1 + elif ch == ']': + if depth == 0: + close = k + break + depth -= 1 + k += 1 + if close == -1 or close + 1 >= len(text) or text[close + 1] != ')': + out.append(text[i:j+1]) + i = j + 1 + continue + # Replace ', [content])' with ', content)' + inner = text[i + m.end():close] + out.append(text[i:j]) + out.append(', ') + out.append(inner.strip()) + out.append(')') + i = close + 2 + return ''.join(out) + text = strip_array_of_const(text) + # Exception.CreateFmt(fmt, args...) → Exception.Create(Format(fmt, args...)) + # Blaise's Exception only has Create(msg); use Format builtin to build msg. + # Balanced-paren + string-literal-aware scan. + def createfmt_to_create(text): + out = [] + i = 0 + pat = re.compile(r"\b([A-Z]\w*)\.CreateFmt\s*\(") + while i < len(text): + m = pat.search(text, i) + if not m: + out.append(text[i:]) + break + out.append(text[i:m.start()]) + class_name = m.group(1) + j = m.end() + depth = 1 + in_str = False + while j < len(text) and depth > 0: + ch = text[j] + if in_str: + if ch == "'": + if j + 1 < len(text) and text[j + 1] == "'": + j += 2 + continue + in_str = False + elif ch == "'": + in_str = True + elif ch == '(': + depth += 1 + elif ch == ')': + depth -= 1 + j += 1 + if depth != 0: + out.append(text[m.start():]) + break + args = text[m.end(): j - 1].strip() + out.append(f"{class_name}.Create(Format({args}))") + i = j + return ''.join(out) + text = createfmt_to_create(text) + # Strip bare inherited calls (TObject in Blaise has no Create/Destroy) + text = re.sub(r"^\s*inherited(\s+\w+)?\s*;\s*$", "", text, flags=re.MULTILINE) + # Ord(enum_val) → enum_val (Blaise stores enums as integers) + text = re.sub(r"\bOrd\(([^()]+(?:\([^()]*\)[^()]*)?)\)", + lambda m: m.group(1), text) + # Strip forward class declarations: TFoo = class; (Blaise doesn't need them) + text = re.sub(r"^\s*T\w+\s*=\s*class\s*;\s*(\{[^}]*\})?\s*$", "", + text, flags=re.MULTILINE) + # Strip default parameter values in method signatures: param: Type = default + # Match inside parens: "name: Type = default_expr" before ';' or ')' + text = re.sub(r"(:\s*\w+)\s*=\s*[^,;)]+([,;)])", r"\1\2", text) + # Generic `x in [a, b, c]` → (x = a) or (x = b) or (x = c). Elements are + # treated as identifier-valued; char literals are handled by specialised + # transforms earlier in the pipeline. + def expand_in(m): + var = m.group(1).strip() + elems = [e.strip() for e in m.group(2).split(',')] + # Skip if any element looks like a char literal or range + for e in elems: + if e.startswith("'") or '..' in e: + return m.group(0) + conditions = [f"({var} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + + def expand_typecast_in(m): + # TypeCast(simple_arg).FieldChain in [...] — capture the full LHS + full_expr = m.group(1) + m.group(2) + elems = [e.strip() for e in m.group(3).split(',')] + for e in elems: + if e.startswith("'") or '..' in e: + return m.group(0) + conditions = [f"({full_expr} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + + # Handle TypeCast(simple_arg).FieldChain in [...] first (no nested parens in arg) + text = re.sub(r'(T\w+\([^)]+\))((?:\.\w+)+)\s+in\s+\[([^\]]+)\]', + expand_typecast_in, text) + text = re.sub(r'(\w+(?:\.\w+)*)\s+in\s+\[([^\]]+)\]', expand_in, text) + return text + +# ---- uPasTokeniser transforms ---- + +def char_literal_to_int(c): + """Convert a Pascal char literal to its ASCII integer value.""" + c = c.strip() + if c == "''''": return 39 # single quote + if c.startswith("'") and c.endswith("'") and len(c) == 3: + return ord(c[1]) + if c.startswith('#'): + return int(c[1:]) + return None + +def ordify_char_range(match_text): + """Convert a 'in [...]' expression for chars/tokens to an integer comparison.""" + # match_text is the bracketed part like ['0'..'9', 'A'..'F'] + # Returns a Blaise expression + # First, extract the variable being tested + # This is called with the full 'x in [...]' string + m = re.match(r'(.+?)\s+in\s+\[([^\]]+)\]', match_text.strip()) + if not m: return match_text + + var = m.group(1).strip() + elems = m.group(2).strip() + + # Parse the elements: 'a'..'z', 'A'..'Z', '_', etc. + conditions = [] + for elem in re.split(r',', elems): + elem = elem.strip() + # Range: 'a'..'z' + rm = re.match(r"'(.)'\.\.'(.)'", elem) + if rm: + lo, hi = ord(rm.group(1)), ord(rm.group(2)) + conditions.append(f"(({var} >= {lo}) and ({var} <= {hi}))") + continue + # Single char: 'x' or #n + nm = re.match(r"'(.)'", elem) + if nm: + conditions.append(f"({var} = {ord(nm.group(1))})") + continue + nm = re.match(r'#(\d+)', elem) + if nm: + conditions.append(f"({var} = {nm.group(1)})") + continue + # Unknown - leave as-is with a comment + conditions.append(f"(False {'{'}TODO: {elem}{'}'})") + + return ' or '.join(conditions) if conditions else 'False' + +def transform_tokeniser_in_exprs(text): + """Replace 'x in [char ranges]' with integer comparison chains.""" + # Pattern: variable in [...] + # We need to handle the common patterns in uPasTokeniser + + def replace_in(m): + full = m.group(0) + result = ordify_char_range(full) + return result + + # Match: expr in ['..'] + text = re.sub(r'\w+\s+in\s+\[[^\]]+\]', replace_in, text) + return text + +def transform_string_indexing(text): + """Replace FSource[FPos] with OrdAt(FSource, FPos).""" + # Simple case: FSource[FPos] + text = re.sub(r'\bFSource\[FPos\]', 'OrdAt(FSource, FPos)', text) + # FSource[FPos] might be compared with char literals - need to convert + # e.g., FSource[FPos] = '#' -> OrdAt(FSource, FPos) = 35 + def conv_char(m): + char = m.group(1) + if len(char) == 1: + return str(ord(char)) + return m.group(0) + text = re.sub(r"OrdAt\(FSource, FPos\) ([<>=!]+) '(.)'", + lambda m: f"OrdAt(FSource, FPos) {m.group(1)} {ord(m.group(2))}", + text) + # Handle #nn char literals too + text = re.sub(r"OrdAt\(FSource, FPos\) ([<>=!]+) #(\d+)", + lambda m: f"OrdAt(FSource, FPos) {m.group(1)} {m.group(2)}", + text) + return text + +def transform_char_vars(text): + """Convert Char variable declarations and usage to Integer.""" + # var c: Char -> var c: Integer + text = re.sub(r'\bChar\b', 'Integer', text) + # c := 'X' -> c := ORD_X (need char literal → integer conversion) + def conv_assign(m): + char = m.group(2) + if len(char) == 1: + return f"{m.group(1)} := {ord(char)}" + return m.group(0) + text = re.sub(r'(\w+)\s*:=\s*\'(.)\'', conv_assign, text) + # = '#nn' -> = nn + text = re.sub(r'= #(\d+)', r'= \1', text) + return text + +def transform_repeat_until(text): + """Convert repeat...until False to while True do begin...end.""" + # Handle 'repeat...until False' (loops with break) + # Simple pattern: replace 'repeat' with 'while True do begin' + # and 'until False;' with 'end;' + text = re.sub(r'\brepeat\b', 'while True do\nbegin', text) + text = re.sub(r'\buntil False;', 'end;', text) + # Handle 'until not (condition)' - convert to while loop + def until_to_while(m): + cond = m.group(1).strip() + return f"end; {{ was: until not {cond} }}\n{{ TODO: check loop semantics }}''" + text = re.sub(r'\buntil not \(([^)]+)\);', until_to_while, text) + return text + +# ---- uSymbolTable transforms ---- +def transform_symtable_indexed(text): + """Convert direct indexed access on owned list fields to .Get(I) calls.""" + # FFields[I] -> FFields.Get(I) + for field in ['FFields', 'FVTable', 'FProperties', 'FImplements', 'FScopeStack', + 'FAllTypes', 'FSymbols', 'FMethods', 'FReturnTypes', + 'Members', 'FMembers']: + # field[expr] -> field.Get(expr) (but NOT field[I] where this is already a TObjectList call) + text = re.sub(rf'\b{field}\[([^\]]+)\]', rf'{field}.Get(\1)', text) + # .Objects[I] -> .GetObject(I) + text = re.sub(r'\.Objects\[([^\]]+)\]', r'.GetObject(\1)', text) + # FKeys.Duplicates := dupIgnore -> FKeys.Duplicates := 1 + text = text.replace('FKeys.Duplicates := dupIgnore', 'FKeys.Duplicates := 1') + text = text.replace('FKeys.Duplicates := dupIgnore', 'FKeys.Duplicates := 1') + # Assignment to field via typecast: TCast(expr).Field := value + # Not supported by Blaise's statement parser — rewrite using a temp via Self helper. + # OverrideVTableSlot: store through an intermediate variable. + text = text.replace( + '''procedure TRecordTypeDesc.OverrideVTableSlot(ASlot: Integer; const AImplName: string); +begin + if (FVTable <> nil) and (ASlot >= 0) and (ASlot < FVTable.Count) then + TVTableEntry(FVTable.Get(ASlot)).ImplName := AImplName; +end;''', + '''procedure TRecordTypeDesc.OverrideVTableSlot(ASlot: Integer; const AImplName: string); +var + E: TVTableEntry; +begin + if (FVTable <> nil) and (ASlot >= 0) and (ASlot < FVTable.Count) then + begin + E := TVTableEntry(FVTable.Get(ASlot)); + E.ImplName := AImplName; + end; +end;''') + return text + +# ---- uSemantic transforms ---- +def transform_semantic_assignments(text): + """Rewrite FProcIndex.Objects[I] := X as a method call.""" + # After transform_semantic_in, .Objects[I] has been rewritten to .GetObject(I). + # Convert 'X.GetObject(I) := Expr' to 'X.SetObject(I, Expr)'. + def setobj(m): + prefix = m.group(1) + idx = m.group(2) + expr = m.group(3).rstrip(';').rstrip() + return f"{prefix}.SetObject({idx}, {expr});" + text = re.sub( + r"(\w+(?:\.\w+)*)\.GetObject\(([^()]+)\)\s*:=\s*([^;]+);", + setobj, text) + # X.Get(I) := Expr → X.Put(I, Expr) + def setget(m): + prefix = m.group(1) + idx = m.group(2) + expr = m.group(3).rstrip(';').rstrip() + return f"{prefix}.Put({idx}, {expr});" + text = re.sub( + r"(\w+(?:\.\w+)*)\.Get\(([^()]+)\)\s*:=\s*([^;]+);", + setget, text) + # Replace TStringList.DelimitedText pattern with manual split + text = text.replace( + ''' Args.StrictDelimiter := True; + Args.Delimiter := ','; + Args.DelimitedText := ArgsStr;''', + ''' SplitIntoList(ArgsStr, 44, Args);''') + # Remove the now-redundant Args[I] := Trim(Args[I]) loop (already trimmed) + text = text.replace( + ''' for I := 0 to Args.Count - 1 do + Args.Put(I, Trim(Args.Get(I)));''', '') + text = text.replace( + ''' for I := 0 to Args.Count - 1 do + Args[I] := Trim(Args[I]);''', '') + return text + +def expand_with_stmts(text): + """Expand 'with TypeCast(Var) do begin...end' to direct field access. + Only replaces field names within the with-block body, not globally.""" + type_fields = { + 'TWhileStmt': ['Condition', 'Body'], + 'TTryFinallyStmt': ['TryBody', 'FinallyBody'], + 'TTryExceptStmt': ['TryBody', 'ExceptBody'], + 'TRaiseStmt': ['Expr'], + 'TFuncCallExpr': ['Name', 'Args', 'ResolvedDecl', 'ResolvedType', + 'IsImplicitSelfMethod'], + } + lines = text.split('\n') + result = [] + i = 0 + while i < len(lines): + line = lines[i] + m = re.match(r'^(\s*)with\s+(T\w+)\((\w+)\)\s+do\s*$', line) + if m and m.group(2) in type_fields: + type_name = m.group(2) + var_name = m.group(3) + cast_expr = f'{type_name}({var_name})' + fields = type_fields[type_name] + i += 1 # skip 'with ... do' line + # Collect body lines for the begin...end block + block_lines = [] + while i < len(lines): + l = lines[i] + if re.match(r'^\s*begin\s*$', l): + block_lines.append(l) + i += 1 + depth = 1 + while i < len(lines) and depth > 0: + l = lines[i] + # Count begin/try/case as openers; end as closer + opens = len(re.findall(r'\b(?:begin|try|case)\b', l)) + closes = len(re.findall(r'\bend\b', l)) + depth += opens - closes + block_lines.append(l) + i += 1 + break + else: + block_lines.append(l) + i += 1 + # Replace bare field names ONLY within these block lines. + # Use negative lookbehind for '.' so that already-qualified + # access patterns like OtherObj.Field are not touched. + body = '\n'.join(block_lines) + for field in fields: + body = re.sub(rf'(? .GetObject(I) + text = re.sub(r'\.Objects\[([^\]]+)\]', r'.GetObject(\1)', text) + # TStringList/TObjectList param/local subscripting: AAttrs[I] → AAttrs.Get(I) + for name in ['AAttrs', 'AArgs', 'ParamNames', 'ParamConstraints', + 'AParamNames', 'AParamConstraints', 'Args', 'IntfNames', + 'MethodList', 'FieldList']: + text = re.sub(rf'\b{name}\[([^\]]+)\]', rf'{name}.Get(\1)', text) + # AST ObjectList fields accessed as Obj.Field[expr] → Obj.Field.Get(expr) + for name in ['ProcDecls', 'TypeDecls', 'ConstDecls', 'Decls', + 'Methods', 'Fields', 'Args', 'Params', 'Stmts', + 'Branches', 'Values', 'TypeParams', 'TypeParamConstraints', + 'OwnerTypeParams', 'OwnerTypeParamConstraints', + 'UsedUnits', 'Names', 'Attributes', 'Properties', + 'Implements', 'GenericInstances', 'GenericFuncInstances', + 'ImplementsNames', 'VTable', 'Members']: + text = re.sub(rf'\.{name}\[([^\]]+)\]', rf'.{name}.Get(\1)', text) + # String indexing with char literal comparison: str[N] = 'X' → OrdAt(str, N) = NN + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*''''", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = 39", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*''''", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> 39", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = {ord(m.group(3))}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> {ord(m.group(3))}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*#(\d+)", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = {m.group(3)}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*#(\d+)", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> {m.group(3)}", text) + # Strip ESemanticError redeclaration (already in header) + text = re.sub(r"^\s*ESemanticError\s*=\s*class\(Exception\)\s*;?\s*$", + "", text, flags=re.MULTILINE) + return text + +# ---- uAST transforms ---- +def transform_ast(text): + # .Objects[I] -> .GetObject(I) + text = re.sub(r'\.Objects\[([^\]]+)\]', r'.GetObject(\1)', text) + return text + +# ---- uCodeGenQBE transforms ---- +def patch_codegen_raw(text): + """Pre-processing on the RAW Pascal source before any other transforms. + Replaces patterns that Blaise can't handle with compatible equivalents.""" + # Replace QbeEscapeString with a Blaise-compatible version. + # The original uses Char type and string subscripting; Blaise has OrdAt. + NEW_FUNC = ( + "function TCodeGenQBE.QbeEscapeString(const AStr: string): string;\n" + "var\n" + " I: Integer;\n" + " C: Integer;\n" + "begin\n" + " Result := '';\n" + " for I := 1 to Length(AStr) do\n" + " begin\n" + " C := OrdAt(AStr, I);\n" + " if C = 34 then\n" + " Result := Result + '\\\"'\n" + " else if C = 92 then\n" + " Result := Result + '\\\\'\n" + " else if C = 10 then\n" + " Result := Result + '\\n'\n" + " else if C = 13 then\n" + " Result := Result + '\\r'\n" + " else if C = 9 then\n" + " Result := Result + '\\t'\n" + " else if (C < 32) or (C > 126) then\n" + " Result := Result + Format('\\%02x', C)\n" + " else\n" + " Result := Result + Copy(AStr, I, 1);\n" + " end;\n" + "end;" + ) + # Replace QBEMangle: uses AName[I] string subscripting + case/char literals + NEW_MANGLE = ( + "function TCodeGenQBE.QBEMangle(const AName: string): string;\n" + "var\n" + " I: Integer;\n" + " C: Integer;\n" + "begin\n" + " Result := '';\n" + " for I := 1 to Length(AName) do\n" + " begin\n" + " C := OrdAt(AName, I);\n" + " if C = 60 then\n" + " Result := Result + '_'\n" + " else if C = 62 then\n" + " begin end\n" + " else if C = 44 then\n" + " Result := Result + '_'\n" + " else\n" + " Result := Result + Copy(AName, I, 1);\n" + " end;\n" + "end;" + ) + marker2 = 'function TCodeGenQBE.QBEMangle(' + lines = text.split('\n') + start2 = next((i for i, l in enumerate(lines) if marker2 in l), -1) + if start2 >= 0: + depth2 = 0 + end2 = start2 + for j in range(start2, len(lines)): + lw = lines[j].strip().lower() + if lw in ('begin', 'try') or re.match(r'case\b.*\bof\s*$', lw): + depth2 += 1 + elif lw == 'end;' and depth2 > 0: + depth2 -= 1 + if depth2 == 0: + end2 = j + break + text = '\n'.join(lines[:start2]) + '\n' + NEW_MANGLE + '\n' + '\n'.join(lines[end2+1:]) + + # Find and replace via line scan to avoid regex escaping nightmares + marker = 'function TCodeGenQBE.QbeEscapeString(' + lines = text.split('\n') + start = next((i for i, l in enumerate(lines) if marker in l), -1) + if start >= 0: + # Find the closing 'end;' of the function. + # Count begin/try/case-of as openers; bare 'end;' as closers. + depth = 0 + end = start + for j in range(start, len(lines)): + lw = lines[j].strip().lower() + if lw in ('begin', 'try') or re.match(r'case\b.*\bof\s*$', lw): + depth += 1 + elif lw == 'end;' and depth > 0: + depth -= 1 + if depth == 0: + end = j + break + text = '\n'.join(lines[:start]) + '\n' + NEW_FUNC + '\n' + '\n'.join(lines[end+1:]) + return text + + +def expand_codegen_in_sets(text): + """Expand 'expr in [...]' patterns. Must run BEFORE expand_with_stmts so + that the LHS is still a simple word.word chain without typecast parens.""" + def expand_in(m): + var = m.group(1).strip() + elems = [e.strip() for e in m.group(2).split(',')] + conditions = [f"({var} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + + def expand_typecast_in(m): + # group(1)=TypeCast(expr), group(2)=.Field.Kind, group(3)=set members + full_expr = m.group(1) + m.group(2) + elems = [e.strip() for e in m.group(3).split(',')] + conditions = [f"({full_expr} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + + # Handle TypeCast(simple_expr).FieldChain in [...] where the arg has no + # nested parens (e.g. TASTExpr(Args[I]).ResolvedType.Kind in [...]) + text = re.sub( + r'(T\w+\([^)]+\))((?:\.\w+)+)\s+in\s+\[([^\]]+)\]', + expand_typecast_in, + text + ) + # Generic simple word.word chain before 'in [...]' + return re.sub(r'(\w+(?:\.\w+)*)\s+in\s+\[([^\]]+)\]', expand_in, text) + + +def transform_codegen_in(text): + # Strip ECodeGenError redeclaration (already in header) + text = re.sub(r"^\s*ECodeGenError\s*=\s*class\(Exception\)\s*;?\s*$", + "", text, flags=re.MULTILINE) + # TStringList has GetText not Text property + text = text.replace('.Text', '.GetText') + # Bare variable subscripts: FStrLits[I] → FStrLits.Get(I), etc. + for name in ['FStrLits', 'BranchLabels', 'Args', + 'FBreakLabels', 'FContinueLabels']: + text = re.sub(rf'\b{name}\[([^\]]+)\]', rf'{name}.Get(\1)', text) + # .Objects[I] -> .GetObject(I) + text = re.sub(r'\.Objects\[([^\]]+)\]', r'.GetObject(\1)', text) + # AST ObjectList fields accessed as Obj.Field[expr] → Obj.Field.Get(expr) + for name in ['ProcDecls', 'TypeDecls', 'ConstDecls', 'Decls', + 'Methods', 'Fields', 'Args', 'Params', 'Stmts', + 'Branches', 'Values', 'TypeParams', 'UsedUnits', + 'VTable', 'Members', 'ImplementsNames', 'Names', + 'GenericInstances', 'GenericFuncInstances', 'GenericIntfInstances', + 'Implements', 'Properties', 'Attributes']: + text = re.sub(rf'\.{name}\[([^\]]+)\]', rf'.{name}.Get(\1)', text) + return text + +# ---- uLexer transforms ---- +def transform_lexer_in(text): + def expand_in(m): + var = m.group(1).strip() + elems = [e.strip() for e in m.group(2).split(',')] + conditions = [f"({var} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + text = re.sub(r'(\w+(?:\.\w+)*)\s+in\s+\[([^\]]+)\]', expand_in, text) + # ARaw[I] = '''' / ARaw[I] = 'X' / ARaw[I] = #NN → OrdAt(ARaw, I) = NN + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*''''", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = 39", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*''''", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> 39", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = {ord(m.group(3))}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> {ord(m.group(3))}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*#(\d+)", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = {m.group(3)}", text) + text = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*#(\d+)", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> {m.group(3)}", text) + # Result := Result + ARaw[I] → Result := Result + Copy(ARaw, I, 1) + text = re.sub(r"(\w+)\s*:=\s*(\w+)\s*\+\s*(\w+)\[([^\]]+)\]", + lambda m: f"{m.group(1)} := {m.group(2)} + Copy({m.group(3)}, {m.group(4)}, 1)", + text) + return text + +# ---- uParser transforms ---- +def transform_parser_in(text): + def expand_in(m): + var = m.group(1).strip() + elems = [e.strip() for e in m.group(2).split(',')] + conditions = [f"({var} = {e})" for e in elems if e] + return '(' + ' or '.join(conditions) + ')' + text = re.sub(r'(\w+(?:\.\w+)*)\s+in\s+\[([^\]]+)\]', expand_in, text) + text = re.sub(r'\.Objects\[([^\]]+)\]', r'.GetObject(\1)', text) + # Names[I] (TStringList indexed) -> Names.Get(I) + text = re.sub(r'\bNames\[([^\]]+)\]', r'Names.Get(\1)', text) + # AST ObjectList fields: Obj.Field[expr] → Obj.Field.Get(expr) + for name in ['Args', 'Params', 'TypeDecls', 'ProcDecls', 'ConstDecls', + 'Decls', 'Methods', 'Fields', 'Stmts', 'Branches', 'Values', + 'TypeParams', 'TypeParamConstraints', 'OwnerTypeParams', + 'OwnerTypeParamConstraints', 'UsedUnits', 'Names', + 'Attributes', 'Properties', 'Implements', 'ImplementsNames', + 'VTable', 'Members', 'GenericInstances', 'GenericFuncInstances']: + text = re.sub(rf'\.{name}\[([^\]]+)\]', rf'.{name}.Get(\1)', text) + # Strip EParseError redeclaration (already in header) + text = re.sub(r"^\s*EParseError\s*=\s*class\(Exception\)\s*;?\s*$", + "", text, flags=re.MULTILINE) + # FPC-style Extract(Items[0]) → Blaise-style Extract(0) + text = re.sub(r"\.Extract\(\w+(?:\.\w+)*\.Items\[(\d+)\]\)", + r".Extract(\1)", text) + # X.Items[I] → X.Get(I) (generic FPC Items property → Blaise method) + text = re.sub(r"\.Items\[([^\]]+)\]", r".Get(\1)", text) + return text + +# ---- Keyword list replacement ---- +INIT_KEYWORDS = """ +var KwList: TStringList; + +procedure InitKeywords; +begin + KwList := TStringList.Create; + KwList.Sorted := True; + KwList.CaseSensitive := True; + KwList.Add('ABSOLUTE'); KwList.Add('AND'); KwList.Add('ARRAY'); + KwList.Add('AS'); KwList.Add('ASM'); KwList.Add('BEGIN'); + KwList.Add('BITPACKED'); KwList.Add('CASE'); KwList.Add('CLASS'); + KwList.Add('CONST'); KwList.Add('CONSTREF'); KwList.Add('CONSTRUCTOR'); + KwList.Add('CONTAINS'); KwList.Add('DESTRUCTOR'); KwList.Add('DISPINTERFACE'); + KwList.Add('DIV'); KwList.Add('DO'); KwList.Add('DOWNTO'); + KwList.Add('ELSE'); KwList.Add('END'); KwList.Add('EXCEPT'); + KwList.Add('EXPORTS'); KwList.Add('FALSE'); KwList.Add('FILE'); + KwList.Add('FINALIZATION'); KwList.Add('FINALLY'); KwList.Add('FOR'); + KwList.Add('FUNCTION'); KwList.Add('GENERIC'); KwList.Add('GOTO'); + KwList.Add('IF'); KwList.Add('IMPLEMENTATION'); KwList.Add('IN'); + KwList.Add('INHERITED'); KwList.Add('INITIALIZATION'); KwList.Add('INLINE'); + KwList.Add('INTERFACE'); KwList.Add('IS'); KwList.Add('LABEL'); + KwList.Add('LIBRARY'); KwList.Add('MOD'); KwList.Add('NIL'); + KwList.Add('NOT'); KwList.Add('OBJCCATEGORY'); KwList.Add('OBJCCLASS'); + KwList.Add('OBJCPROTOCOL'); KwList.Add('OBJECT'); KwList.Add('OF'); + KwList.Add('OPERATOR'); KwList.Add('OR'); KwList.Add('OTHERWISE'); + KwList.Add('PACKAGE'); KwList.Add('PACKED'); KwList.Add('PROCEDURE'); + KwList.Add('PROGRAM'); KwList.Add('PROPERTY'); KwList.Add('RAISE'); + KwList.Add('RECORD'); KwList.Add('REPEAT'); KwList.Add('REQUIRES'); + KwList.Add('RESOURCESTRING'); KwList.Add('SELF'); KwList.Add('SET'); + KwList.Add('SHL'); KwList.Add('SHR'); KwList.Add('SPECIALIZE'); + KwList.Add('THEN'); KwList.Add('THREADVAR'); KwList.Add('TO'); + KwList.Add('TRUE'); KwList.Add('TRY'); KwList.Add('TYPE'); + KwList.Add('UNIT'); KwList.Add('UNTIL'); KwList.Add('USES'); + KwList.Add('VAR'); KwList.Add('WHILE'); KwList.Add('WITH'); + KwList.Add('XOR') +end; + +function BinarySearchKeyword(const AText: string): Boolean; +var + Idx: Integer; +begin + Result := KwList.Find(AText, Idx) +end; + +""" + +def transform_tokeniser(text): + """Full transformation of uPasTokeniser for Blaise.""" + text = basic(text) + + # Step 1: Find the const block containing KeywordCount/Keywords and remove it + # Find '\nconst\n' that is followed eventually by 'KeywordCount' + lines = text.split('\n') + out_lines = [] + skip = False + for i, line in enumerate(lines): + stripped = line.strip() + # Start of const block with keyword array + if stripped == 'const' and i + 1 < len(lines) and 'KeywordCount' in '\n'.join(lines[i:i+5]): + skip = True + continue + # End of Keywords array (the ); line) + if skip and stripped == ');': + skip = False + continue + if not skip: + out_lines.append(line) + text = '\n'.join(out_lines) + + # Step 2: Remove old BinarySearchKeyword function + m = re.search(r'\nfunction BinarySearchKeyword[^\n]*\n', text) + if m: + # Find the matching 'end;' after this + start = m.start() + end_match = re.search(r'\nend;\n', text[m.end():]) + if end_match: + end_pos = m.end() + end_match.end() + text = text[:start] + text[end_pos:] + + # Step 3: Prepend new keyword list + new BinarySearchKeyword + text = INIT_KEYWORDS + text + + # Convert FSource[expr] to OrdAt(FSource, expr) + text = re.sub(r'\bFSource\[([^\]]+)\]', r'OrdAt(FSource, \1)', text) + + # Handle escaped single-quote in OrdAt comparisons first + text = text.replace("OrdAt(FSource, FPos) = ''''", "OrdAt(FSource, FPos) = 39") + text = text.replace("OrdAt(FSource, FPos) <> ''''", "OrdAt(FSource, FPos) <> 39") + # Convert char literals in comparisons with OrdAt result + def oat_cmp(op): + return re.sub( + rf"OrdAt\(FSource, ([^)]+)\) {op} '(.)'", + lambda m: f"OrdAt(FSource, {m.group(1)}) {op} {ord(m.group(2))}", + text) + # Apply to all OrdAt(FSource, expr) = 'X' patterns + text = re.sub(r"OrdAt\(FSource, ([^)]+)\) = '(.)'", + lambda m: f"OrdAt(FSource, {m.group(1)}) = {ord(m.group(2))}", text) + text = re.sub(r"OrdAt\(FSource, ([^)]+)\) <> '(.)'", + lambda m: f"OrdAt(FSource, {m.group(1)}) <> {ord(m.group(2))}", text) + text = re.sub(r"OrdAt\(FSource, ([^)]+)\) = #(\d+)", + lambda m: f"OrdAt(FSource, {m.group(1)}) = {m.group(2)}", text) + # PeekAt(...) comparisons + text = re.sub(r"PeekAt\(([^)]+)\) = '(.)'", + lambda m: f"PeekAt({m.group(1)}) = {ord(m.group(2))}", text) + text = re.sub(r"PeekAt\(([^)]+)\) <> '(.)'", + lambda m: f"PeekAt({m.group(1)}) <> {ord(m.group(2))}", text) + text = re.sub(r"PeekAt\(([^)]+)\) = #(\d+)", + lambda m: f"PeekAt({m.group(1)}) = {m.group(2)}", text) + text = re.sub(r"PeekAt\(([^)]+)\) <> #(\d+)", + lambda m: f"PeekAt({m.group(1)}) <> {m.group(2)}", text) + # FSource[FPos] = #NN (line 210 etc) - convert to OrdAt + text = re.sub(r"FSource\[FPos\]\s*=\s*#(\d+)", + lambda m: f"OrdAt(FSource, FPos) = {m.group(1)}", text) + text = re.sub(r"FSource\[FPos\]\s*<>\s*#(\d+)", + lambda m: f"OrdAt(FSource, FPos) <> {m.group(1)}", text) + text = re.sub(r"FSource\[FPos\]\s*=\s*'(.)'", + lambda m: f"OrdAt(FSource, FPos) = {ord(m.group(1))}", text) + text = re.sub(r"FSource\[FPos\]\s*<>\s*'(.)'", + lambda m: f"OrdAt(FSource, FPos) <> {ord(m.group(1))}", text) + # Strip inherited Create; calls - TObject has no Create in Blaise + text = re.sub(r"^\s*inherited Create;\s*$", "", text, flags=re.MULTILINE) + # Case labels using char literals - convert '.': to 46: + text = re.sub(r"^(\s+)'(.)':", + lambda m: f"{m.group(1)}{ord(m.group(2))}:", + text, flags=re.MULTILINE) + + # Convert c2 := char (local char var assignments) + text = re.sub(r"(c|c2)\s*:=\s*FSource\[FPos\]", r"\1 := OrdAt(FSource, FPos)", text) + text = re.sub(r"(c|c2)\s*:=\s*FSource\[FPos\s*\+\s*1\]", r"\1 := OrdAt(FSource, FPos + 1)", text) + + # c2 is assigned from PeekAt or Peek - those return chars + # We need those to return integers too + # For now, convert char comparisons on c and c2 + # Handle escaped single-quote comparisons first + for var in ['c', 'c2']: + text = text.replace(f"{var} = ''''", f"{var} = 39") + text = text.replace(f"{var} <> ''''", f"{var} <> 39") + for var in ['c', 'c2']: + text = re.sub(rf"{var} = '(.)'", lambda m, v=var: f"{v} = {ord(m.group(1))}", text) + text = re.sub(rf"{var} = #(\d+)", lambda m, v=var: f"{v} = {m.group(1)}", text) + text = re.sub(rf"{var} <> '(.)'", lambda m, v=var: f"{v} <> {ord(m.group(1))}", text) + + # Convert 'in [...]' patterns involving chars + def expand_char_in(m): + var = m.group(1).strip() + body = m.group(2) + parts = [] + for elem in re.split(r',\s*', body): + elem = elem.strip() + rm = re.match(r"'(.)'\.\.\'(.)'", elem) + if rm: + lo, hi = ord(rm.group(1)), ord(rm.group(2)) + parts.append(f"(({var} >= {lo}) and ({var} <= {hi}))") + continue + rm = re.match(r"'(.)'", elem) + if rm: + parts.append(f"({var} = {ord(rm.group(1))})") + continue + rm = re.match(r'#(\d+)', elem) + if rm: + parts.append(f"({var} = {rm.group(1)})") + continue + # Identifier (fptkXxx) + parts.append(f"({var} = {elem})") + return '(' + ' or '.join(parts) + ')' if parts else 'False' + + # Match: expr in [...] where expr can be ident, field access, or function call + text = re.sub(r'([\w.]+(?:\([^)]*\))?)\s+in\s+\[([^\]]+)\]', expand_char_in, text) + + # Convert Char type declarations + text = re.sub(r'\bChar\b', 'Integer', text) + + # Handle escaped single-quote char literal '''' = 39 BEFORE general transforms + text = text.replace("= ''''", "= 39") + text = text.replace(":= ''''", ":= 39") + # Convert char literal assignments: c := 'x' + text = re.sub(r"(\w+)\s*:=\s*'(.)'", + lambda m: f"{m.group(1)} := {ord(m.group(2))}", text) + text = re.sub(r"(\w+)\s*:=\s*#(\d+)", + lambda m: f"{m.group(1)} := {m.group(2)}", text) + + # repeat...until False -> while True do begin...end + text = text.replace('repeat\n', 'while True do\nbegin\n') + text = re.sub(r'\buntil False;', 'end;', text) + # until not (condition) - the one in uLexer: convert to while + break + text = re.sub(r'\buntil not \((.+?)\);\n', + lambda m: f' if not ({m.group(1)}) then break\nend;\n', text) + + # Peek and PeekAt methods - they return chars, now need to return integers + # The return type is Integer (we changed Char -> Integer) + + # FToken.Len and FToken.TextStart are Integer - fine + + # Copy() for string extraction is fine + + # GetSource: returns string - fine + # TokenText: returns string via Copy - fine + + return text + +# ====================================================================== +# Main build +# ====================================================================== + +HEADER = """{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: BSD-3-Clause + + blaise-compiler.pas - Self-hosting source. + Concatenated from all compiler units. +} + +program BlaiseCompiler; + +const + CHR_QUOTE = 39; CHR_HASH = 35; CHR_DOLLAR = 36; + CHR_LF = 10; CHR_CR = 13; CHR_TAB = 9; + CHR_SPACE = 32; CHR_0 = 48; CHR_9 = 57; + CHR_A_UP = 65; CHR_F_UP = 70; CHR_Z_UP = 90; + CHR_a_LO = 97; CHR_f_LO = 102; CHR_z_LO = 122; + CHR_UNDER = 95; CHR_CARET = 94; CHR_DOT = 46; + CHR_AT = 64; CHR_LT = 60; CHR_GT = 62; + CHR_EQ = 61; CHR_PLUS = 43; CHR_MINUS = 45; + CHR_STAR = 42; CHR_SLASH = 47; CHR_LPAREN = 40; + CHR_RPAREN = 41; CHR_SEMI = 59; CHR_COLON = 58; + CHR_LBRACKET = 91; CHR_RBRACKET = 93; CHR_e_LO = 101; + CHR_E_UP = 69; CHR_DQUOTE = 34; + MaxInt = 2147483647; + +type + Exception = class + FMessage: string; + procedure Create(AMessage: string); + procedure CreateFmt(const AFmt: string; AArg: Integer); + procedure Destroy; virtual; + property Message: string read FMessage; + end; + EParseError = class(Exception); + ESemanticError = class(Exception); + ECodeGenError = class(Exception); + +procedure Exception.Create(AMessage: string); +begin + Self.FMessage := AMessage +end; + +procedure Exception.CreateFmt(const AFmt: string; AArg: Integer); +begin + Self.FMessage := Format(AFmt, AArg) +end; + +procedure Exception.Destroy; +begin + +end; + +{ File path helpers — replacements for FPC SysUtils functions } + +function ExtractFileName(const APath: string): string; +var + I: Integer; +begin + Result := APath; + I := Length(APath); + while I >= 1 do + begin + if OrdAt(APath, I) = 47 then + begin + Result := Copy(APath, I + 1, Length(APath) - I); + Exit; + end; + I := I - 1; + end; +end; + +function ChangeFileExt(const AFileName: string; const AExt: string): string; +var + I: Integer; +begin + I := Length(AFileName); + while I >= 1 do + begin + if OrdAt(AFileName, I) = 46 then + begin + Result := Copy(AFileName, 1, I - 1) + AExt; + Exit; + end; + if OrdAt(AFileName, I) = 47 then + break; + I := I - 1; + end; + Result := AFileName + AExt; +end; + +""" + +def section(title): + return (f'\n{{ === {title} === }}\n\n') + +def _edit_class_body(text, cls, mutate): + """Find ` = class` (no parent), call mutate(body_lines) on the + list of lines between the header and the matching `end;`, and splice + the result back. Returns text unchanged if no match. Line-oriented + and O(n) — avoids regex backtracking on the 60k-line output.""" + lines = text.split('\n') + i = 0 + header = cls + ' = class' + while i < len(lines): + stripped = lines[i].strip() + if stripped == header or stripped.startswith(header + ' ') \ + or stripped.startswith(header + '\t'): + j = i + 1 + while j < len(lines) and lines[j].strip() != 'end;': + j += 1 + if j < len(lines): + lines[i + 1:j] = mutate(lines[i + 1:j]) + return '\n'.join(lines) + i += 1 + return text + +def postprocess(text): + """Apply vtable / override fixes so the migrated file compiles under + the self-hosted Blaise compiler. Idempotent and safe to apply in + incremental tests as well as the final output.""" + + # Inject `procedure Destroy; virtual;` into root classes whose + # descendants are used in `is` checks. + for cls, anchor in (('TASTNode', 'procedure TIfStmt.Destroy;'), + ('TTypeDesc', 'procedure TRecordTypeDesc.Destroy;')): + def add_virtual(body): + for ln in body: + if 'procedure Destroy;' in ln: + return body # already present + return body + [' procedure Destroy; virtual;'] + new_text = _edit_class_body(text, cls, add_virtual) + if new_text != text and f'procedure {cls}.Destroy;' not in new_text: + new_text = new_text.replace( + anchor, + f'procedure {cls}.Destroy;\nbegin\n\nend;\n\n' + anchor, 1) + text = new_text + + # Strip `override` from root classes that have no virtual base + # post-migration (their FPC source used `destructor Destroy; override` + # to override TObject's destructor, which no longer exists). + non_vtable_roots = ( + 'TObjectList', 'TStringList', 'TLexer', 'TParser', + 'TSymbol', 'TScope', 'TSymbolTable', 'TFieldInfo', 'TVTableEntry', + 'TPropertyInfo', 'TParamDesc', + 'TCaseBranch', 'TGenericFuncInstance', 'TGenericInstance', + 'TGenericInterfaceInstance', + 'TCodeGenQBE', 'TSemanticAnalyser', + ) + def strip_override(body): + return [ln.replace('procedure Destroy; override;', + 'procedure Destroy;') for ln in body] + for cls in non_vtable_roots: + text = _edit_class_body(text, cls, strip_override) + return text + +def test(path): + with open(path) as f: content = f.read() + content = postprocess(content) + with open('/tmp/_t.pas', 'w') as f: + f.write(content) + if not content.strip().endswith('end.'): + f.write('\nbegin\nend.\n') + r = subprocess.run( + ['/data/devel/new-pascal-compiler/compiler/target/blaise', + '--source', '/tmp/_t.pas', '--emit-ir'], + capture_output=True, text=True) + out = r.stdout + r.stderr + if out.startswith('#'): return True, 'OK' + return False, out.split('\n')[0] + +# Build +parts = [HEADER] + +# Classes +classes = basic(strip_fpc(read(f'{RTL}/Classes.pas'))) +parts.append(section('RTL: Collections')) +parts.append(classes) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"Classes: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uPasTokeniser +tok = transform_tokeniser(strip_fpc(read(f'{SRC}/uPasTokeniser.pas'))) +parts.append(section('uPasTokeniser')) +parts.append(tok) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uPasTokeniser: {'OK' if ok else msg}") +if not ok: + # Show context around the error + err_line = 0 + m = re.search(r'line (\d+)', msg) + if m: err_line = int(m.group(1)) + lines = ''.join(parts).split('\n') + if err_line > 5: + for i in range(max(0,err_line-3), min(len(lines), err_line+3)): + print(f" {i+1}: {lines[i]}") + sys.exit(1) + +# uLexer +lex = transform_lexer_in(basic(strip_fpc(read(f'{SRC}/uLexer.pas')))) +# Strip the FPC-only local OrdAt helper — self-hosted builds use the builtin. +lex = re.sub( + r'function OrdAt\(const S: string; I: Integer\): Integer;\s*\n' + r'begin\s*\n' + r'\s*Result := (?:Ord\(S\[I\]\)|S\[I\]);\s*\n' + r'end;\s*\n', '', lex) +parts.append(section('uLexer')) +parts.append(lex) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uLexer: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uSymbolTable +sym = transform_symtable_indexed(basic(strip_fpc(read(f'{SRC}/uSymbolTable.pas')))) +parts.append(section('uSymbolTable')) +parts.append(sym) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uSymbolTable: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uAST +ast = transform_ast(basic(strip_fpc(read(f'{SRC}/uAST.pas')))) +parts.append(section('uAST')) +parts.append(ast) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uAST: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uParser +par = transform_parser_in(basic(strip_fpc(read(f'{SRC}/uParser.pas')))) +parts.append(section('uParser')) +parts.append(par) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uParser: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uSemantic +sem = transform_semantic_assignments(transform_semantic_in(expand_with_stmts(basic(strip_fpc(read(f'{SRC}/uSemantic.pas')))))) +parts.append(section('uSemantic')) +parts.append(sem) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uSemantic: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# uCodeGenQBE +cg = transform_codegen_in(expand_with_stmts(expand_codegen_in_sets(basic(strip_fpc(patch_codegen_raw(read(f'{SRC}/uCodeGenQBE.pas'))))))) +parts.append(section('uCodeGenQBE')) +parts.append(cg) +parts.append('\n\n') +write(OUT, ''.join(parts)) +ok, msg = test(OUT) +print(f"uCodeGenQBE: {'OK' if ok else msg}") +if not ok: sys.exit(1) + +# Main program from Blaise.pas +main = basic(strip_fpc(read(f'{SRC}/Blaise.pas'))) +# String subscript char comparisons: Arg[N] = 'X' → OrdAt(Arg, N) = NN +main = re.sub(r"(\w+)\[([^\]]+)\]\s*<>\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) <> {ord(m.group(3))}", main) +main = re.sub(r"(\w+)\[([^\]]+)\]\s*=\s*'(.)'", + lambda m: f"OrdAt({m.group(1)}, {m.group(2)}) = {ord(m.group(3))}", main) +# Transform Blaise.pas: TProcess -> Exec, path utilities, file I/O +main = main.replace('TStringList.Create', 'TStringList.Create') # already OK +# TStringList.LoadFromFile -> replace with ReadFile +main = re.sub(r'(\w+)\.LoadFromFile\(([^)]+)\)', + lambda m: f"{m.group(1)}.Add(ReadFile({m.group(2)}))", main) +# TStringList.SaveToFile -> WriteFile +main = re.sub(r'(\w+)\.SaveToFile\(([^)]+)\)', + lambda m: f"WriteFile({m.group(2)}, {m.group(1)}.GetText)", main) +# IRFile write block: Source.Text := IR; Source.SaveToFile(IRFile) +# → WriteFile(IRFile, IR) — the SaveToFile transform already ran, so fix up +main = main.replace('Source.Text := IR;', '') +# After SaveToFile transform: WriteFile(IRFile, Source.GetText) → WriteFile(IRFile, IR) +main = main.replace('WriteFile(IRFile, Source.GetText)', 'WriteFile(IRFile, IR)') +# TProcess - replace RunProcess with Exec-based version +# Callers use: RunProcess('exe', [arg1, arg2, ...], MsgVar) +# → replace with a simple version that takes a pre-built command string +main = re.sub( + r'function RunProcess\(.*?\nend;', + '''function RunProcess(const ACmd: string; var AOutput: string): Integer; +begin + Result := Exec(ACmd); + AOutput := '' +end;''', + main, flags=re.DOTALL) +# Transform RunProcess callsites: RunProcess(exe, [arg1, arg2, ...], Msg) +# → build command string inline +def inline_runprocess(m): + exe = m.group(1).strip() + args_str = m.group(2).strip() + # Parse comma-separated args (simple, no nested brackets) + args = [a.strip() for a in args_str.split(',')] + cmd = exe + for a in args: + cmd = cmd + " + ' ' + " + a + return f"RunProcess({cmd}, Msg)" +main = re.sub( + r"RunProcess\(([^,]+),\s*\[([^\]]+)\],\s*Msg\)", + inline_runprocess, main) +# Remove StdErr references (write errors to stdout instead) +main = re.sub(r"WriteLn\(StdErr,\s*", "WriteLn(", main) +main = re.sub(r"Write\(StdErr,\s*", "Write(", main) +# 'on E: ExcType do' filter syntax not supported — strip the filter line +# and replace E.Message with Exception(CurrentException).Message +main = re.sub(r'^\s*on\s+\w+\s*:\s*\w+\s+do\s*$', '', main, flags=re.MULTILINE) +main = re.sub(r'\bE\.Message\b', 'CurrentExceptionMessage', main) +# ExtractFilePath, ChangeFileExt, IncludeTrailingPathDelimiter - implement inline +# These are used in FindRTL and CompileToNative +main = main.replace('ExtractFilePath(ParamStr(0))', + "Copy(ParamStr(0), 1, Length(ParamStr(0)) - Length('blaise'))") +# ChangeFileExt - simple string replace: strip last extension and add new one +# This is complex - leave as TODO for now, use format string approach +main = re.sub(r"ChangeFileExt\((\w+),\s*'\.(\w+)'\)", + lambda m: f"{m.group(1)} + '.{m.group(2)}'", main) +main = re.sub(r'IncludeTrailingPathDelimiter\(([^)]+)\)', r"(\1 + '/')", main) +# GetEnvironmentVariable → GetEnvVar (Blaise builtin name) +main = main.replace('GetEnvironmentVariable(', 'GetEnvVar(') +# TStringList.Text property → GetText method +main = main.replace('.Text', '.GetText') +# DeleteFile -> add as a builtin (we have it in the RTL as _Halt, need _DeleteFile) +main = main.replace('DeleteFile(', 'DeleteFile(') # keep for now + +# Remove TProcess class usage +main = re.sub(r'TProcess\s*:=.*?;', '', main) + +parts.append(section('Main program')) +parts.append(main) +parts.append('\nend.\n') # close the program + +# Apply vtable/override fixes to the assembled output (same postprocess +# used by incremental tests). +out = postprocess(''.join(parts)) +write(OUT, out) +ok, msg = test(OUT) +print(f"Main (Blaise.pas): {'OK' if ok else msg}") + +wc = len(out.split('\n')) +print(f"\nTotal: ~{wc} lines in {OUT}")