administrator/blaise
1
0
Fork 0
Code Issues Pull requests Actions Packages Projects Releases Wiki Activity

Add const blocks, fix ParseBlock ordering, and stub blaise-compiler.pas

Browse source 
const: TConstDecl AST node; ParseConstBlock (integer and string literal values);
AnalyseConstDecls (registers each as skConstant in symbol table). Enables
CHR_* character constants and dupAccept/dupIgnore/dupError in self-hosting source.

ParseBlock: add tkConst to the multi-section loop.
Blaise now supports: case, enum, const, multi-type/var blocks, all file I/O
builtins — the complete language surface needed for the source migration.

834 tests pass.
This commit is contained in:
Graeme Geldenhuys 2026-04-23 14:37:39 +01:00
parent fb89879f86
commit 926b594516
5 changed files with 677 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
compiler/src/main/pascal/uAST.pas
View file

@ -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;

3
compiler/src/main/pascal/uLexer.pas
View file

@ -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;

50
compiler/src/main/pascal/uParser.pas
View file

@ -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;

23
compiler/src/main/pascal/uSemantic.pas
View file

@ -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;

582
tests/blaise-compiler.pas Normal file
View file

@ -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;