From 49a1a0f478e09af65e978b35c4c562428e1e5521 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Thu, 23 Apr 2026 15:24:13 +0100 Subject: [PATCH] Add implicit Self field access, OrdAt builtin, and migration infrastructure MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Implicit Self: bare field names inside methods (e.g. FPos := FPos + 1) now work without explicit Self. prefix. TIdentExpr.IsImplicitSelf / ImplicitFieldInfo flags set by AnalyseExpr when lookup fails but a class field matches; TAssignment.ImplicitSelfField set by AnalyseAssignment. Codegen emits loadl %_var_Self + offset for reads, storew/storel through Self + offset for writes. Required for migrating the compiler source which was written in FPC style without explicit Self. OrdAt(s, i): integer RTL function — returns ASCII ordinal of character at 1-based position i. Replaces FSource[FPos] (array indexing) in the migrated uPasTokeniser. Migration script (tests/blaise-compiler.pas): initial work-in-progress self-hosting source. Script handles: const→class body stripping, inline qualifier removal, inline-var removal, Exit(expr) expansion, shr/shl conversion, constructor/destructor→procedure, access modifier stripping, keyword array → TStringList/InitKeywords, FSource[expr] → OrdAt(FSource, expr), char-range in [...] → integer comparisons, repeat...until → while True. 834 tests pass. --- compiler/src/main/pascal/uAST.pas | 3 + compiler/src/main/pascal/uCodeGenQBE.pas | 54 ++ compiler/src/main/pascal/uParser.pas | 11 +- compiler/src/main/pascal/uSemantic.pas | 36 +- tests/blaise-compiler.pas | 667 +++++++++++++++++++++-- 5 files changed, 708 insertions(+), 63 deletions(-) diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index 77ec8d7..09494bb 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -51,6 +51,8 @@ type IsConstant: Boolean; { set by uSemantic — True if this ident is a skConstant symbol } ConstValue: Int64; { valid when IsConstant = True } IsNoArgFuncCall: Boolean; { set by uSemantic — bare ident that resolves to a 0-arg function } + IsImplicitSelf: Boolean; { set by uSemantic — bare field name implicitly referencing Self } + ImplicitFieldInfo: TObject; { TFieldInfo — not owned; valid when IsImplicitSelf } end; TFieldAccessExpr = class(TASTExpr) @@ -114,6 +116,7 @@ type was declared [Weak]; codegen emits a _WeakAssign in place of the strong addref/release pattern. } + ImplicitSelfField: TObject; { TFieldInfo — non-nil when LHS is bare field (implicit Self) } destructor Destroy; override; end; diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 7e26e1b..31c4b76 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -725,11 +725,34 @@ var LblOk: string; LblFail: string; LblEnd: string; + ISFld: TFieldInfo; + ISAddrT: string; begin if AAssign.Expr.ResolvedType = nil then raise ECodeGenError.CreateFmt( 'Expression in assignment to ''%s'' has no resolved type', [AAssign.Name]); + { Implicit Self.Field assignment: bare field name like FPos := ... } + 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 + EmitLine(Format(' storel %s, %s', [ValTemp, ObjTemp])); + Exit; + end; + { Interface as-cast: F := T as IFoo — use _GetItab for runtime itab lookup. ARC: the obj slot holds a strong reference to the backing class instance, so retain the new obj and release the prior contents of F's obj slot @@ -2018,6 +2041,9 @@ var FPtrTemp: string; SlotOff: Integer; NoArgCall: TFuncCallExpr; + ImplFld: TFieldInfo; + SelfT: string; + PtrT: string; begin if AExpr is TFuncCallExpr then begin @@ -2507,6 +2533,34 @@ begin else if AExpr is TIdentExpr then begin T := AllocTemp; + if TIdentExpr(AExpr).IsImplicitSelf then + begin + { Bare field name — equivalent to Self.FieldName: load Self, add offset } + 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).IsNoArgFuncCall then begin { Bare identifier resolving to a zero-arg function (no parens in source). diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index 91d1b60..3cb4a55 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -587,7 +587,13 @@ begin else Break; until False; - Expect(tkEnd); + { Empty class declaration: TFoo = class(TBase); has no body, no 'end' } + if Check(tkEnd) then + Advance + else if not (Check(tkSemicolon) or Check(tkEOF)) then + raise EParseError.CreateFmt( + 'Expected ''end'' in class definition at line %d col %d', + [FCurrent.Line, FCurrent.Col]); except Result.Free; raise; @@ -777,7 +783,8 @@ var begin repeat IsVarGrp := Check(tkVar); - if IsVarGrp then Advance; + if IsVarGrp then Advance + else if Check(tkConst) then Advance; { const params treated as value params } Names := TStringList.Create; try if not Check(tkIdent) then diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 3f5d9db..d477a58 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -1902,14 +1902,30 @@ end; procedure TSemanticAnalyser.AnalyseAssignment(AAssign: TAssignment); var - VarSym: TSymbol; + VarSym: TSymbol; + FldInfo: TFieldInfo; ExprType: TTypeDesc; begin VarSym := FTable.Lookup(AAssign.Name); if VarSym = nil then + begin + { Try implicit Self.Field } + 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 in [skVariable, skVarParameter]) then SemanticError( Format('''%s'' is not a variable', [AAssign.Name]), @@ -2462,7 +2478,8 @@ end; function TSemanticAnalyser.AnalyseExpr(AExpr: TASTExpr): TTypeDesc; var - Sym: TSymbol; + Sym: TSymbol; + FldInfo: TFieldInfo; begin if AExpr is TNilLiteral then Result := FTable.TypeNil @@ -2474,9 +2491,24 @@ begin begin Sym := FTable.Lookup(TIdentExpr(AExpr).Name); if Sym = nil then + begin + { Not in scope — try implicit Self.Field when inside a method } + 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; + end; SemanticError( Format('Undeclared identifier ''%s''', [TIdentExpr(AExpr).Name]), AExpr.Line, AExpr.Col); + end; TIdentExpr(AExpr).IsVarParam := (Sym.Kind = skVarParameter); if Sym.Kind = skConstant then begin diff --git a/tests/blaise-compiler.pas b/tests/blaise-compiler.pas index ec02cd8..286ed5e 100644 --- a/tests/blaise-compiler.pas +++ b/tests/blaise-compiler.pas @@ -1,85 +1,51 @@ { - Blaise - An Object Pascal Compiler — Self-hosting source + 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 - { Character code constants replacing FPC char literals in uPasTokeniser } - CHR_QUOTE = 39; { ' } - CHR_HASH = 35; { # } - CHR_DOLLAR = 36; { $ } - CHR_LF = 10; { line feed } - CHR_CR = 13; { carriage return } - CHR_TAB = 9; { tab } - CHR_SPACE = 32; { space } - CHR_0 = 48; { 0 } - CHR_9 = 57; { 9 } - CHR_A_UP = 65; { A } - CHR_F_UP = 70; { F } - CHR_Z_UP = 90; { Z } - CHR_a_LO = 97; { a } - CHR_f_LO = 102; { f } - CHR_z_LO = 122; { z } - 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_LBRACE = 123; (* open brace *) - CHR_RBRACE = 125; (* close brace *) - CHR_SEMI = 59; { ; } - CHR_COLON = 58; { : } - CHR_LBRACKET = 91; { [ } - CHR_RBRACKET = 93; { ] } - CHR_e_LO = 101; { e } - CHR_E_UP = 69; { E } - CHR_DQUOTE = 34; { " } - -{ ================================================================== } -{ Exception hierarchy } -{ ================================================================== } + 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; type Exception = class FMessage: string; - constructor Create(AMessage: string); - constructor CreateFmt(const AFmt: string; AArg: Integer); - constructor CreateFmt(const AFmt: string; AStr: string); + procedure Create(AMessage: string); + procedure CreateFmt(const AFmt: string; AArg: Integer); property Message: string read FMessage; end; EParseError = class(Exception); ESemanticError = class(Exception); ECodeGenError = class(Exception); -constructor Exception.Create(AMessage: string); +procedure Exception.Create(AMessage: string); begin Self.FMessage := AMessage end; -constructor Exception.CreateFmt(const AFmt: string; AArg: Integer); +procedure Exception.CreateFmt(const AFmt: string; AArg: Integer); begin Self.FMessage := Format(AFmt, AArg) end; -constructor Exception.CreateFmt(const AFmt: string; AStr: string); -begin - Self.FMessage := Format(AFmt, AStr) -end; -{ ================================================================== } -{ RTL Collections: TObjectList and TStringList } -{ ================================================================== } +{ === RTL: Collections === } { Blaise - An Object Pascal Compiler @@ -123,7 +89,7 @@ type FCapacity: Integer; FOwnsObjects: Boolean; procedure Grow; - constructor Create(AOwnsObjects: Boolean); + procedure Create(AOwnsObjects: Boolean); procedure Destroy; function Add(AObject: Pointer): Integer; function Get(AIndex: Integer): Pointer; @@ -149,7 +115,7 @@ type procedure Grow; function Compare(S1: string; S2: string): Integer; function FindSorted(S: string; var Idx: Integer): Boolean; - constructor Create; + procedure Create; procedure Destroy; function Add(S: string): Integer; procedure AddObject(S: string; AObject: Pointer); @@ -186,7 +152,7 @@ begin Self.FCapacity := NewCap end; -constructor TObjectList.Create(AOwnsObjects: Boolean); +procedure TObjectList.Create(AOwnsObjects: Boolean); begin Self.FOwnsObjects := AOwnsObjects end; @@ -330,7 +296,7 @@ begin Result := False end; -constructor TStringList.Create; +procedure TStringList.Create; begin Self.FCaseSensitive := True; Self.FSorted := False; @@ -570,3 +536,586 @@ end; + +{ === uPasTokeniser === } + + +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; + +{ + 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). +} + + + + +type + TFpgPasTokenKind = ( + fptkEOF, + fptkWhitespace, + fptkLineEnding, + fptkIdentifier, + fptkKeyword, + fptkNumber, + fptkString, + fptkComment, + fptkDirective, + fptkSymbol + ); + + 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 } + end; + + { TFpgPascalTokeniser } + + TFpgPascalTokeniser = class(TObject) + + FSource: string; + FPos: Integer; + FLine: Integer; + FLineStart: Integer; { FPos value at start of current line } + FToken: TFpgPasToken; + function Peek: Integer; + function PeekAt(AOffset: Integer): Integer; + procedure Advance; + procedure AdvanceLine; + procedure ReadWhitespace; + procedure ReadLineEnding; + procedure ReadIdentifierOrKeyword; + procedure ReadNumber; + procedure ReadString; + procedure ReadBraceCommentOrDirective; + procedure ReadParenStarCommentOrDirective; + procedure ReadLineComment; + procedure ReadSymbol; + + procedure Create; + procedure SetSource(const ASource: string); + function NextToken: TFpgPasToken; + function TokenText: string; + function TokenTextUpper: string; + property Token: TFpgPasToken read FToken; + property Source: string read FSource; + end; + +{ Returns True if AText is a Pascal keyword (case-insensitive). } +function PasIsKeyword(const AText: string): Boolean; + + + + +function PasIsKeyword(const AText: string): Boolean; +begin + if AText = '' then + begin Result := False; Exit end; + Result := BinarySearchKeyword(UpperCase(AText)); +end; + +{ TFpgPascalTokeniser } + +procedure TFpgPascalTokeniser.Create; +begin + inherited Create; + FSource := ''; + FPos := 1; + FLine := 1; + FLineStart := 1; +end; + +procedure TFpgPascalTokeniser.SetSource(const ASource: string); +begin + FSource := ASource; + FPos := 1; + FLine := 1; + FLineStart := 1; + FToken.Kind := fptkEOF; + FToken.Line := 1; + FToken.Column := 1; + FToken.Len := 0; + FToken.TextStart := 1; +end; + +function TFpgPascalTokeniser.Peek: Integer; +begin + if FPos <= Length(FSource) then + Result := OrdAt(FSource, FPos) + else + Result := 0; +end; + +function TFpgPascalTokeniser.PeekAt(AOffset: Integer): Integer; +var + p: Integer; +begin + p := FPos + AOffset; + if (p >= 1) and (p <= Length(FSource)) then + Result := OrdAt(FSource, p) + else + Result := 0; +end; + +procedure TFpgPascalTokeniser.Advance; +begin + FPos := FPos + 1; +end; + +procedure TFpgPascalTokeniser.AdvanceLine; +begin + FLine := FLine + 1; + FLineStart := FPos; +end; + +procedure TFpgPascalTokeniser.ReadWhitespace; +begin + FToken.Kind := fptkWhitespace; + while (FPos <= Length(FSource)) and (((OrdAt(FSource, FPos) = 32) or (OrdAt(FSource, FPos) = 9))) do + Advance; + FToken.Len := FPos - FToken.TextStart; +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) } + FToken.Len := FPos - FToken.TextStart; + AdvanceLine; +end; + +procedure TFpgPascalTokeniser.ReadIdentifierOrKeyword; +begin + while (FPos <= Length(FSource)) and + ((((OrdAt(FSource, FPos) >= 65) and (OrdAt(FSource, FPos) <= 90)) or ((OrdAt(FSource, FPos) >= 97) and (OrdAt(FSource, FPos) <= 122)) or ((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)) or (OrdAt(FSource, FPos) = 95))) do + Advance; + FToken.Len := FPos - FToken.TextStart; + if BinarySearchKeyword(UpperCase(TokenText)) then + FToken.Kind := fptkKeyword + else + FToken.Kind := fptkIdentifier; +end; + +procedure TFpgPascalTokeniser.ReadNumber; +var + c: Integer; +begin + FToken.Kind := fptkNumber; + c := OrdAt(FSource, FPos); + + 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 + Advance; + FToken.Len := FPos - FToken.TextStart; + Exit; + end; + + if c = 37 then + begin + { Binary: %[01]+ } + Advance; + while (FPos <= Length(FSource)) and (((OrdAt(FSource, FPos) = 48) or (OrdAt(FSource, FPos) = 49))) do + Advance; + FToken.Len := FPos - FToken.TextStart; + Exit; + end; + + 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; + FToken.Len := FPos - FToken.TextStart; + 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 + begin + Advance; { consume '.' } + 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; + if (FPos <= Length(FSource)) and (((OrdAt(FSource, FPos) = 43) or (OrdAt(FSource, FPos) = 45))) then + Advance; + while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)))) do + Advance; + end; + + FToken.Len := FPos - FToken.TextStart; +end; + +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 +begin + c := Peek; + if c = 39 then + begin + Advance; { opening quote } + 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 } + end + else if ((OrdAt(FSource, FPos) = 10) or (OrdAt(FSource, FPos) = 13)) then + Break { unterminated string at line end } + else + Advance; + end; + end + else if c = 35 then + begin + Advance; { consume # } + if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 36) then + begin + Advance; { hex char code } + 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; + end + else + begin + while (FPos <= Length(FSource)) and ((((OrdAt(FSource, FPos) >= 48) and (OrdAt(FSource, FPos) <= 57)))) do + Advance; + end; + end + else if c = 94 then + begin + Advance; { consume ^ } + 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; +end; + +procedure TFpgPascalTokeniser.ReadBraceCommentOrDirective; +begin + // Already at open-brace. Check next char for '$'. + if PeekAt(1) = '$' then + FToken.Kind := fptkDirective + else + FToken.Kind := fptkComment; + + Advance; // consume open-brace + while FPos <= Length(FSource) do + begin + if OrdAt(FSource, FPos) = 125 then + begin + Advance; + Break; + end + else if OrdAt(FSource, FPos) = 13 then + begin + Advance; + if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 10) then + Advance; + AdvanceLine; + end + else if OrdAt(FSource, FPos) = 10 then + begin + Advance; + AdvanceLine; + end + else + Advance; + end; + FToken.Len := FPos - FToken.TextStart; +end; + +procedure TFpgPascalTokeniser.ReadParenStarCommentOrDirective; +begin + { Already at '('. Next is '*'. Check char after '*' for '$'. } + if PeekAt(2) = '$' then + FToken.Kind := fptkDirective + else + FToken.Kind := fptkComment; + + Advance; { consume '(' } + Advance; { consume '*' } + while FPos <= Length(FSource) do + begin + if (OrdAt(FSource, FPos) = 42) and (PeekAt(1) = ')') then + begin + Advance; { consume '*' } + Advance; { consume ')' } + Break; + end + else if OrdAt(FSource, FPos) = 13 then + begin + Advance; + if (FPos <= Length(FSource)) and (OrdAt(FSource, FPos) = 10) then + Advance; + AdvanceLine; + end + else if OrdAt(FSource, FPos) = 10 then + begin + Advance; + AdvanceLine; + end + else + Advance; + end; + FToken.Len := FPos - FToken.TextStart; +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; + FToken.Len := FPos - FToken.TextStart; +end; + +procedure TFpgPascalTokeniser.ReadSymbol; +var + c, c2: Integer; +begin + FToken.Kind := fptkSymbol; + c := OrdAt(FSource, FPos); + c2 := PeekAt(1); + 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) + end; + + // Special: *= (if * was not followed by *) + if (c = 42) and (c2 <> 42) and (c2 = 61) then + Advance; + + FToken.Len := FPos - FToken.TextStart; +end; + +function TFpgPascalTokeniser.NextToken: TFpgPasToken; +var + c, c2: Integer; +begin + if FPos > Length(FSource) then + begin + FToken.Kind := fptkEOF; + FToken.Line := FLine; + FToken.Column := FPos - FLineStart + 1; + FToken.Len := 0; + FToken.TextStart := FPos; + Result := FToken; + 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; + Result := FToken; + Exit; + end; + + { Line endings } + if ((c = 13) or (c = 10)) then + begin + ReadLineEnding; + Result := FToken; + Exit; + end; + + { Identifiers and keywords } + if (((c >= 65) and (c <= 90)) or ((c >= 97) and (c <= 122)) or (c = 95)) then + begin + ReadIdentifierOrKeyword; + Result := FToken; + Exit; + end; + + { Numbers: digits or $ (hex) or % (binary) or & (octal) } + if (((c >= 48) and (c <= 57))) then + begin + ReadNumber; + Result := FToken; + Exit; + end; + if (c = 36) and ((((PeekAt(1) >= 48) and (PeekAt(1) <= 57)) or ((PeekAt(1) >= 65) and (PeekAt(1) <= 70)) or ((PeekAt(1) >= 97) and (PeekAt(1) <= 102)))) then + begin + ReadNumber; + Result := FToken; + Exit; + end; + if (c = 37) and (((PeekAt(1) = 48) or (PeekAt(1) = 49))) then + begin + ReadNumber; + Result := FToken; + Exit; + end; + if (c = 38) and ((((PeekAt(1) >= 48) and (PeekAt(1) <= 55)))) then + begin + ReadNumber; + Result := FToken; + Exit; + end; + + { Strings: ' or # — Clean Pascal does not support ^X control-char string escapes } + if ((c = 39) or (c = 35)) then + begin + ReadString; + Result := FToken; + Exit; + end; + + { Comments and directives } + if c = 123 then + begin + ReadBraceCommentOrDirective; + Result := FToken; + Exit; + end; + + c2 := PeekAt(1); + + if (c = 40) and (c2 = 42) then + begin + ReadParenStarCommentOrDirective; + Result := FToken; + Exit; + end; + + if (c = 47) and (c2 = 47) then + begin + ReadLineComment; + Result := FToken; + Exit; + end; + + { Symbols and operators } + ReadSymbol; + Result := FToken; +end; + +function TFpgPascalTokeniser.TokenText: string; +begin + if (FToken.TextStart >= 1) and (FToken.Len > 0) and + (FToken.TextStart + FToken.Len - 1 <= Length(FSource)) then + Result := Copy(FSource, FToken.TextStart, FToken.Len) + else + Result := ''; +end; + +function TFpgPascalTokeniser.TokenTextUpper: string; +begin + Result := UpperCase(TokenText); +end; + + +