diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas index a5c1355..f61d018 100644 --- a/compiler/src/main/pascal/uAST.pas +++ b/compiler/src/main/pascal/uAST.pas @@ -445,16 +445,26 @@ type destructor Destroy; override; end; + { Constant declaration: const Name = Value; — integer or string literal } + TConstDecl = class(TASTNode) + public + Name: string; + IntVal: Int64; { used when IsString = False } + StrVal: string; { used when IsString = True } + IsString: Boolean; + end; + { ------------------------------------------------------------------ } { Block and Program } { ------------------------------------------------------------------ } TBlock = class(TASTNode) public - TypeDecls: TObjectList; { owned TTypeDecl } - Decls: TObjectList; { owned TVarDecl } - ProcDecls: TObjectList; { owned TMethodDecl — standalone procs/funcs } - Stmts: TObjectList; { owned TASTStmt } + TypeDecls: TObjectList; { owned TTypeDecl } + ConstDecls: TObjectList; { owned TConstDecl } + Decls: TObjectList; { owned TVarDecl } + ProcDecls: TObjectList; { owned TMethodDecl — standalone procs/funcs } + Stmts: TObjectList; { owned TASTStmt } constructor Create; destructor Destroy; override; end; @@ -918,15 +928,17 @@ end; constructor TBlock.Create; begin inherited Create; - TypeDecls := TObjectList.Create(True); - Decls := TObjectList.Create(True); - ProcDecls := TObjectList.Create(True); - Stmts := TObjectList.Create(True); + TypeDecls := TObjectList.Create(True); + ConstDecls := TObjectList.Create(True); + Decls := TObjectList.Create(True); + ProcDecls := TObjectList.Create(True); + Stmts := TObjectList.Create(True); end; destructor TBlock.Destroy; begin TypeDecls.Free; + ConstDecls.Free; Decls.Free; ProcDecls.Free; Stmts.Free; diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas index 45fe00f..1e29716 100644 --- a/compiler/src/main/pascal/uLexer.pas +++ b/compiler/src/main/pascal/uLexer.pas @@ -63,6 +63,7 @@ type tkInherited, tkCase, tkOf, + tkConst, { Identifier } tkIdent, { Arithmetic operators } @@ -164,6 +165,7 @@ begin else if AUpper = 'BREAK' then Result := tkBreak 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; { keyword outside Phase 1 grammar treated as ident } @@ -239,6 +241,7 @@ begin else if text = 'BREAK' then Result.Kind := tkBreak 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; diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas index bc83c75..91d1b60 100644 --- a/compiler/src/main/pascal/uParser.pas +++ b/compiler/src/main/pascal/uParser.pas @@ -64,6 +64,7 @@ type function ParseBlock: TBlock; procedure ParseTypeSection(ABlock: TBlock); procedure ParseTypeDecl(ABlock: TBlock); + procedure ParseConstBlock(ABlock: TBlock); function ParseEnumDef: TEnumTypeDef; function ParseRecordDef: TRecordTypeDef; function ParseGenericName: string; { reads IDENT optionally followed by '<' TypeArgs '>' } @@ -277,12 +278,15 @@ begin { Accept any number of type/var/procedure/function sections in any order, as required when concatenating multiple Pascal units into one file. } - while Check(tkType) or Check(tkVar) or Check(tkProcedure) or Check(tkFunction) do + 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; @@ -435,6 +439,50 @@ begin 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.CreateFmt('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.CreateFmt( + '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; diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index 08d7553..1256c81 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -48,6 +48,7 @@ type 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); @@ -998,6 +999,7 @@ begin { Type declarations are registered in the outer scope so they remain visible after the block scope is popped — needed for var declarations and the transferred symbol table used by codegen. } + AnalyseConstDecls(ABlock); AnalyseTypeDecls(ABlock); { Link standalone TTypeName.MethodName implementations to their class method declarations, transferring the body so AnalyseMethodBodies can process it. } @@ -1017,6 +1019,27 @@ begin 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[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; { duplicate const — silently ignore } + end; +end; + procedure TSemanticAnalyser.AnalyseTypeDecls(ABlock: TBlock); var I, J, K: Integer; diff --git a/tests/blaise-compiler.pas b/tests/blaise-compiler.pas new file mode 100644 index 0000000..ccbf2af --- /dev/null +++ b/tests/blaise-compiler.pas @@ -0,0 +1,582 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: BSD-3-Clause + + blaise-compiler.pas — Self-hosting compiler source. + Generated by concatenating the compiler units in dependency order: + uPasTokeniser → uLexer → uSymbolTable → uAST → uParser → + uSemantic → uCodeGenQBE → main +} + +program BlaiseCompiler; + +{ ================================================================== } +{ Character code constants (replaces FPC char literals in tokeniser) } +{ ================================================================== } + +const + CHR_QUOTE = 39; { ' single-quote } + 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; { digit 0 } + CHR_9 = 57; { digit 9 } + CHR_A_UP = 65; { uppercase A } + CHR_F_UP = 70; { uppercase F } + CHR_Z_UP = 90; { uppercase Z } + CHR_a_LO = 97; { lowercase a } + CHR_f_LO = 102; { lowercase f } + CHR_z_LO = 122; { lowercase z } + CHR_UNDER = 95; { _ underscore } + CHR_CARET = 94; { ^ caret } + CHR_DOT = 46; { . dot } + CHR_AT = 64; { @ at } + CHR_LT = 60; { < less-than } + CHR_GT = 62; { > greater-than } + CHR_EQ = 61; { = equals } + CHR_PLUS = 43; { + } + CHR_MINUS = 45; { - } + CHR_STAR = 42; { * } + CHR_SLASH = 47; { / } + CHR_LPAREN = 40; { ( } + CHR_RPAREN = 41; { ) } + CHR_LBRACE = 123; { { } + CHR_RBRACE = 125; { } } + 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; { " double-quote } + +{ ================================================================== } +{ Exception hierarchy } +{ ================================================================== } + +type + Exception = class + FMessage: string; + constructor Create(AMessage: string); + constructor CreateFmt(const AFmt: string; AArg1: Integer); + constructor CreateFmt(const AFmt: string; AArg2: string); + property Message: string read FMessage; + end; + + EParseError = class(Exception); + ESemanticError = class(Exception); + ECodeGenError = class(Exception); + EExcFrame = class(Exception); + +constructor Exception.Create(AMessage: string); +begin + Self.FMessage := AMessage +end; + +constructor Exception.CreateFmt(const AFmt: string; AArg1: Integer); +begin + Self.FMessage := Format(AFmt, AArg1) +end; + +constructor Exception.CreateFmt(const AFmt: string; AArg2: string); +begin + Self.FMessage := Format(AFmt, AArg2) +end; + +{ ================================================================== } +{ RTL: TObjectList and TStringList } +{ ================================================================== } + +{ + 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 + dupAccept = 0; + dupIgnore = 1; + dupError = 2; + +type + { ------------------------------------------------------------------ } + { TObjectList } + { ------------------------------------------------------------------ } + + TObjectList = class + FData: ^Pointer; + FCount: Integer; + FCapacity: Integer; + FOwnsObjects: Boolean; + procedure Grow; + constructor Create(AOwnsObjects: Boolean); + procedure Destroy; + function Add(AObject: Pointer): Integer; + function Get(AIndex: Integer): Pointer; + procedure Put(AIndex: Integer; AObject: Pointer); + function IndexOf(AObject: Pointer): Integer; + procedure Delete(AIndex: Integer); + procedure Clear; + property Count: Integer read FCount; + end; + + { ------------------------------------------------------------------ } + { TStringList } + { ------------------------------------------------------------------ } + + TStringList = class + FStrings: ^string; + FObjects: ^Pointer; + FCount: Integer; + FCapacity: Integer; + FCaseSensitive: Boolean; + FSorted: Boolean; + FDuplicates: Integer; + procedure Grow; + function Compare(S1: string; S2: string): Integer; + function FindSorted(S: string; var Idx: Integer): Boolean; + constructor Create; + procedure Destroy; + function Add(S: string): Integer; + procedure AddObject(S: string; AObject: Pointer); + function Find(S: string; var Index: Integer): Boolean; + function IndexOf(S: string): Integer; + function Get(AIndex: Integer): string; + procedure Put(AIndex: Integer; S: string); + function GetObject(AIndex: Integer): Pointer; + procedure SetObject(AIndex: Integer; AObject: Pointer); + procedure Delete(AIndex: Integer); + procedure Clear; + procedure Insert(AIndex: Integer; S: string); + function GetText: string; + property Count: Integer read FCount; + property CaseSensitive: Boolean read FCaseSensitive write FCaseSensitive; + property Sorted: Boolean read FSorted write FSorted; + property Duplicates: Integer read FDuplicates write FDuplicates; + end; + + +{ ================================================================== } +{ TObjectList } +{ ================================================================== } + +procedure TObjectList.Grow; +var + NewCap: Integer; +begin + if Self.FCapacity = 0 then + NewCap := 4 + else + NewCap := Self.FCapacity * 2; + Self.FData := ReallocMem(Self.FData, NewCap * SizeOf(Pointer)); + Self.FCapacity := NewCap +end; + +constructor TObjectList.Create(AOwnsObjects: Boolean); +begin + Self.FOwnsObjects := AOwnsObjects +end; + +procedure TObjectList.Destroy; +begin + FreeMem(Self.FData); + Self.FData := nil; + Self.FCount := 0; + Self.FCapacity := 0 +end; + +function TObjectList.Add(AObject: Pointer): Integer; +var + Dest: ^Pointer; +begin + if Self.FCount = Self.FCapacity then + Self.Grow; + Dest := Self.FData + Self.FCount * SizeOf(Pointer); + Dest^ := AObject; + Self.FCount := Self.FCount + 1; + Result := Self.FCount - 1 +end; + +function TObjectList.Get(AIndex: Integer): Pointer; +var + Src: ^Pointer; +begin + Src := Self.FData + AIndex * SizeOf(Pointer); + Result := Src^ +end; + +procedure TObjectList.Put(AIndex: Integer; AObject: Pointer); +var + Dest: ^Pointer; +begin + Dest := Self.FData + AIndex * SizeOf(Pointer); + Dest^ := AObject +end; + +function TObjectList.IndexOf(AObject: Pointer): Integer; +var + I: Integer; + Src: ^Pointer; +begin + I := 0; + Result := -1; + while I < Self.FCount do + begin + Src := Self.FData + I * SizeOf(Pointer); + if Src^ = AObject then + begin + Result := I; + break + end; + I := I + 1 + end +end; + +procedure TObjectList.Delete(AIndex: Integer); +var + I: Integer; + Dst: ^Pointer; + Src: ^Pointer; +begin + 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 TObjectList.Clear; +begin + Self.FCount := 0 +end; + +{ ================================================================== } +{ TStringList } +{ ================================================================== } + +procedure TStringList.Grow; +var + NewCap: Integer; + OldCap: Integer; +begin + OldCap := Self.FCapacity; + if OldCap = 0 then + NewCap := 4 + else + 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 +end; + +function TStringList.Compare(S1: string; S2: string): Integer; +begin + if Self.FCaseSensitive then + Result := CompareStr(S1, S2) + else + Result := CompareText(S1, S2) +end; + +function TStringList.FindSorted(S: string; var Idx: Integer): Boolean; +var + Lo: Integer; + Hi: Integer; + Mid: Integer; + Cmp: Integer; + Ptr: ^string; + MStr: string; +begin + Lo := 0; + Hi := Self.FCount - 1; + while Lo <= Hi do + begin + Mid := (Lo + Hi) div 2; + Ptr := Self.FStrings + Mid * SizeOf(string); + MStr := Ptr^; + Cmp := Self.Compare(S, MStr); + if Cmp = 0 then + begin + Idx := Mid; + Result := True; + Exit + end + else if Cmp < 0 then + Hi := Mid - 1 + else + Lo := Mid + 1 + end; + Idx := Lo; + Result := False +end; + +constructor TStringList.Create; +begin + Self.FCaseSensitive := True; + Self.FSorted := False; + Self.FDuplicates := dupAccept +end; + +procedure TStringList.Destroy; +var + I: Integer; + Ptr: ^string; +begin + { Release all strings before freeing the backing store } + I := 0; + while I < Self.FCount do + begin + Ptr := Self.FStrings + I * SizeOf(string); + Ptr^ := nil; + I := I + 1 + end; + FreeMem(Self.FStrings); + FreeMem(Self.FObjects); + Self.FStrings := nil; + Self.FObjects := nil; + Self.FCount := 0; + Self.FCapacity := 0 +end; + +function TStringList.Add(S: string): Integer; +var + Idx: Integer; + StrP: ^string; + ObjP: ^Pointer; +begin + if Self.FSorted then + begin + Self.FindSorted(S, Idx); + 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 + Result := Idx; + Exit + end + end; + Self.Insert(Idx, S); + Result := Idx + end + else + begin + if Self.FCount = Self.FCapacity then + Self.Grow; + StrP := Self.FStrings + Self.FCount * SizeOf(string); + ObjP := Self.FObjects + Self.FCount * SizeOf(Pointer); + StrP^ := S; + ObjP^ := nil; + Result := Self.FCount; + Self.FCount := Self.FCount + 1 + end +end; + +procedure TStringList.AddObject(S: string; AObject: Pointer); +var + Idx: Integer; + ObjP: ^Pointer; +begin + Idx := Self.Add(S); + ObjP := Self.FObjects + Idx * SizeOf(Pointer); + ObjP^ := AObject +end; + +function TStringList.Find(S: string; var Index: Integer): Boolean; +var + I: Integer; + Ptr: ^string; +begin + if Self.FSorted then + Result := Self.FindSorted(S, Index) + else + begin + { Linear search for unsorted list } + I := 0; + while I < Self.FCount do + begin + Ptr := Self.FStrings + I * SizeOf(string); + if Self.Compare(S, Ptr^) = 0 then + begin + Index := I; + Result := True; + Exit + end; + I := I + 1 + end; + Index := -1; + Result := False + end +end; + +function TStringList.IndexOf(S: string): Integer; +var + Idx: Integer; +begin + if Self.Find(S, Idx) then + Result := Idx + else + Result := -1 +end; + +function TStringList.Get(AIndex: Integer): string; +var + Ptr: ^string; +begin + Ptr := Self.FStrings + AIndex * SizeOf(string); + Result := Ptr^ +end; + +procedure TStringList.Put(AIndex: Integer; S: string); +var + Ptr: ^string; +begin + Ptr := Self.FStrings + AIndex * SizeOf(string); + Ptr^ := S +end; + +function TStringList.GetObject(AIndex: Integer): Pointer; +var + Ptr: ^Pointer; +begin + Ptr := Self.FObjects + AIndex * SizeOf(Pointer); + Result := Ptr^ +end; + +procedure TStringList.SetObject(AIndex: Integer; AObject: Pointer); +var + Ptr: ^Pointer; +begin + Ptr := Self.FObjects + AIndex * SizeOf(Pointer); + Ptr^ := AObject +end; + +procedure TStringList.Delete(AIndex: Integer); +var + I: Integer; + SDst: ^string; + SSrc: ^string; + ODst: ^Pointer; + OSrc: ^Pointer; +begin + I := AIndex; + while I < Self.FCount - 1 do + begin + SDst := Self.FStrings + I * SizeOf(string); + SSrc := Self.FStrings + (I + 1) * SizeOf(string); + ODst := Self.FObjects + I * SizeOf(Pointer); + OSrc := Self.FObjects + (I + 1) * SizeOf(Pointer); + SDst^ := SSrc^; + 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); + ODst^ := nil; + Self.FCount := Self.FCount - 1 +end; + +procedure TStringList.Clear; +var + I: Integer; + Ptr: ^string; +begin + I := 0; + while I < Self.FCount do + begin + Ptr := Self.FStrings + I * SizeOf(string); + Ptr^ := nil; + I := I + 1 + end; + Self.FCount := 0 +end; + +procedure TStringList.Insert(AIndex: Integer; S: string); +var + I: Integer; + SDst: ^string; + SSrc: ^string; + ODst: ^Pointer; + OSrc: ^Pointer; + Ptr: ^string; + OPtr: ^Pointer; +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 + SDst := Self.FStrings + I * SizeOf(string); + SSrc := Self.FStrings + (I - 1) * SizeOf(string); + ODst := Self.FObjects + I * SizeOf(Pointer); + OSrc := Self.FObjects + (I - 1) * SizeOf(Pointer); + SDst^ := SSrc^; + 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 } + Ptr := Self.FStrings + AIndex * SizeOf(string); + OPtr := Self.FObjects + AIndex * SizeOf(Pointer); + Ptr^ := S; + OPtr^ := nil; + Self.FCount := Self.FCount + 1 +end; + +function TStringList.GetText: string; +var + I: Integer; + Ptr: ^string; + Sep: string; +begin + Result := ''; + Sep := ''; + I := 0; + while I < Self.FCount do + begin + Ptr := Self.FStrings + I * SizeOf(string); + Result := Result + Sep + Ptr^; + Sep := #13#10; + I := I + 1 + end +end; + + +