, ...". }
- SelfTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp]));
- Result := Format('l %s', [SelfTemp]);
- for I := 0 to AArgs.Count - 1 do
- begin
- Par := TMethodParam(AMDecl.Params.Items[I]);
- if Par.IsVarParam then
- begin
- Result := Result + Format(', l %s',
- [EmitLValueAddr(TASTExpr(AArgs.Items[I]))]);
- Continue;
- end;
- if (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface) then
- begin
- if TASTExpr(AArgs.Items[I]).ResolvedType.Kind = tyClass then
- begin
- ArgTemp := EmitExpr(TASTExpr(AArgs.Items[I]));
- ArgTemp2 := '$itab_' +
- ClassSymNameOf(TASTExpr(AArgs.Items[I]).ResolvedType)
- + '_' + QBEMangle(Par.ResolvedType.Name);
- Result := Result + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
- end
- else
- Result := Result + InterfaceArgFragment(TASTExpr(AArgs.Items[I]));
- Continue;
- end;
- ArgTemp := EmitExpr(TASTExpr(AArgs.Items[I]));
- QType := QbeTypeOf(Par.ResolvedType);
- ArgTemp := CoerceArg(ArgTemp, TASTExpr(AArgs.Items[I]), QType);
- Result := Result + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]);
- end;
-end;
-
-procedure TCodeGenQBE.EmitInheritedCall(ACall: TInheritedCallStmt);
-var
- MDecl: TMethodDecl;
- ArgLine: string;
- ArgTemp: string;
- QType: string;
- PMark: Integer;
- RetType: TTypeDesc;
- FuncSym: string;
+ PMark: Integer;
begin
{ TObject inherited calls are no-ops — no method body exists }
if ACall.ResolvedMethod = nil then Exit;
- PMark := PendingReleaseMark();
- MDecl := TMethodDecl(ACall.ResolvedMethod);
- ArgLine := InheritedArgLine(MDecl, ACall.Args);
- RetType := MDecl.ResolvedReturnType;
- FuncSym := '$' + MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name);
+ PMark := PendingReleaseMark();
+ MDecl := TMethodDecl(ACall.ResolvedMethod);
- { A record / static-array return uses the sret ABI: the callee writes the
- result through a hidden first pointer argument. The statement form sets
- Result, so the destination is the function's own Result slot. Without
- this, the scalar path below would pass Self into the hidden sret slot and
- corrupt the heap (the base would write its managed fields over Self). }
- if (RetType <> nil) and (RetType.Kind = tyRecord) then
+ { Load Self from the current method's local slot }
+ SelfTemp := AllocTemp();
+ EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp]));
+
+ { Build arg string: l Self, then each explicit arg }
+ ArgLine := Format('l %s', [SelfTemp]);
+ for I := 0 to ACall.Args.Count - 1 do
begin
- EmitRecordReleaseFields(TRecordTypeDesc(RetType), '%_var_Result');
- EmitLine(Format(' call $memset(l %%_var_Result, w 0, l %d)',
- [RetType.ByteSize()]));
- EmitRecordReturnCallSite(FuncSym, ArgLine,
- TRecordTypeDesc(RetType), '%_var_Result');
- end
- else if (RetType <> nil) and (RetType.Kind = tyStaticArray) then
- EmitRecordReturnCallSite(FuncSym, ArgLine,
- TRecordTypeDesc(RetType), '%_var_Result')
+ Par := TMethodParam(MDecl.Params.Items[I]);
+ if Par.IsVarParam then
+ begin
+ { var/out param: pass the argument's address, not its value. }
+ ArgLine := ArgLine + Format(', l %s',
+ [EmitLValueAddr(TASTExpr(ACall.Args.Items[I]))]);
+ Continue;
+ end;
+ if (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface) then
+ begin
+ if TASTExpr(ACall.Args.Items[I]).ResolvedType.Kind = tyClass then
+ begin
+ ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
+ ArgTemp2 := '$itab_' +
+ ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
+ + '_' + QBEMangle(Par.ResolvedType.Name);
+ ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
+ end
+ else
+ ArgLine := ArgLine + InterfaceArgFragment(TASTExpr(ACall.Args.Items[I]));
+ Continue;
+ end;
+ ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
+ QType := QbeTypeOf(Par.ResolvedType);
+ ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
+ ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]);
+ end;
+
{ Always a direct (static) call — inherited bypasses vtable dispatch.
- Store a scalar parent return into %_var_Result so "inherited F;" as a
- statement sets Result in the overriding function. }
- else if (RetType <> nil) and (RetType.Kind <> tyVoid) then
+ If the parent method returns a value, store it into %_var_Result so that
+ "inherited F;" as a statement sets Result in the overriding function. }
+ if (MDecl.ResolvedReturnType <> nil) and
+ (MDecl.ResolvedReturnType.Kind <> tyVoid) then
begin
- QType := QbeTypeOf(RetType);
+ QType := QbeTypeOf(MDecl.ResolvedReturnType);
ArgTemp := AllocTemp();
- EmitLine(Format(' %s =%s call %s(%s)',
- [ArgTemp, QType, FuncSym, ArgLine]));
+ EmitLine(Format(' %s =%s call $%s(%s)',
+ [ArgTemp, QType, MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name), ArgLine]));
if QType = 'w' then
EmitLine(Format(' storew %s, %%_var_Result', [ArgTemp]))
else
EmitLine(Format(' storel %s, %%_var_Result', [ArgTemp]));
end
else
- EmitLine(Format(' call %s(%s)', [FuncSym, ArgLine]));
+ EmitLine(Format(' call $%s(%s)',
+ [MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name), ArgLine]));
FlushPendingReleases(PMark);
end;
function TCodeGenQBE.EmitInheritedCallExpr(ACall: TInheritedCallExpr): string;
var
- MDecl: TMethodDecl;
- ArgLine: string;
- QType: string;
- RetType: TTypeDesc;
- FuncSym: string;
+ MDecl: TMethodDecl;
+ SelfTemp: string;
+ ArgLine: string;
+ ArgTemp: string;
+ ArgTemp2: string;
+ Par: TMethodParam;
+ QType: string;
+ I: Integer;
begin
{ Expression form of `inherited Method(args)` — semantic guarantees a
non-void function. Same static-dispatch arg marshalling as
EmitInheritedCall, but the call result is RETURNED (not stored to
%_var_Result). }
- MDecl := TMethodDecl(ACall.ResolvedMethod);
- ArgLine := InheritedArgLine(MDecl, ACall.Args);
- RetType := MDecl.ResolvedReturnType;
- FuncSym := '$' + MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name);
+ MDecl := TMethodDecl(ACall.ResolvedMethod);
- { Record / static-array return: emit through the sret ABI into a fresh
- zeroed stack temporary and return its address. A record-typed assignment
- RHS is intercepted earlier via IsRecordCall (direct sret into the
- destination), so this path serves an inherited record return used directly
- as a sub-expression; IsRecordSretTempExpr marks the temporary so the
- consuming context releases its managed fields. }
- if (RetType <> nil) and (RetType.Kind in [tyRecord, tyStaticArray]) then
+ 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
- Result := AllocTemp();
- EmitLine(Format(' %s =l alloc8 %d', [Result, RetType.ByteSize()]));
- EmitLine(Format(' call $memset(l %s, w 0, l %d)',
- [Result, RetType.ByteSize()]));
- EmitRecordReturnCallSite(FuncSym, ArgLine, TRecordTypeDesc(RetType), Result);
- Exit;
+ Par := TMethodParam(MDecl.Params.Items[I]);
+ if Par.IsVarParam then
+ begin
+ ArgLine := ArgLine + Format(', l %s',
+ [EmitLValueAddr(TASTExpr(ACall.Args.Items[I]))]);
+ Continue;
+ end;
+ if (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface) then
+ begin
+ if TASTExpr(ACall.Args.Items[I]).ResolvedType.Kind = tyClass then
+ begin
+ ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
+ ArgTemp2 := '$itab_' +
+ ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
+ + '_' + QBEMangle(Par.ResolvedType.Name);
+ ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
+ end
+ else
+ ArgLine := ArgLine + InterfaceArgFragment(TASTExpr(ACall.Args.Items[I]));
+ Continue;
+ end;
+ ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
+ QType := QbeTypeOf(Par.ResolvedType);
+ ArgTemp := CoerceArg(ArgTemp, TASTExpr(ACall.Args.Items[I]), QType);
+ ArgLine := ArgLine + Format(', %s %s', [QbeParamTypeOf(Par.ResolvedType), ArgTemp]);
end;
- QType := QbeTypeOf(RetType);
+ QType := QbeTypeOf(MDecl.ResolvedReturnType);
Result := AllocTemp();
- EmitLine(Format(' %s =%s call %s(%s)', [Result, QType, FuncSym, ArgLine]));
+ EmitLine(Format(' %s =%s call $%s(%s)',
+ [Result, QType, MethodEmitName(MDecl, MDecl.OwnerTypeName, ACall.Name), ArgLine]));
end;
procedure TCodeGenQBE.EmitParamAllocs(AMethod: TMethodDecl;
@@ -7819,13 +7063,9 @@ var
I: Integer;
Par: TMethodParam;
begin
- { Self: store incoming pointer into a local slot. A STATIC method has no
- Self — skip the slot entirely. }
- if not AMethod.IsStatic then
- begin
- EmitLine(' %_var_Self =l alloc8 1');
- EmitLine(' storel %_par_Self, %_var_Self');
- end;
+ { Self: store incoming pointer into a local slot }
+ EmitLine(' %_var_Self =l alloc8 1');
+ EmitLine(' storel %_par_Self, %_var_Self');
{ Explicit params }
for I := 0 to AMethod.Params.Count - 1 do
@@ -7928,7 +7168,6 @@ procedure TCodeGenQBE.EmitMethodDef(const ATypeName: string;
AMethod: TMethodDecl);
var
Sig: string;
- ParSep: string;
I: Integer;
Par: TMethodParam;
FuncName: string;
@@ -7939,7 +7178,6 @@ var
SavedExitLbl: string;
ValTemp: string;
RC: TRecReturnClass;
- RetRec: TRecordTypeDesc;
begin
if AMethod.ResolvedQbeName <> '' then
FuncName := '$' + QBEMangle(AMethod.ResolvedQbeName)
@@ -7947,62 +7185,35 @@ begin
FuncName := '$' + QBEMangle(ATypeName + '_' + AMethod.Name);
IsFunc := AMethod.ResolvedReturnType <> nil;
- { RetRec drives the by-aggregate return ABI for both real records and
- method pointers (the latter via a synthetic two-pointer record). }
- if IsFunc then RetRec := AggRetRec(AMethod.ResolvedReturnType)
- else RetRec := nil;
RC := rcSret;
- if RetRec <> nil then
- RC := Self.ClassifyRecordReturn(RetRec);
+ if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then
+ RC := Self.ClassifyRecordReturn(TRecordTypeDesc(AMethod.ResolvedReturnType));
- { A STATIC (class-level) method takes no implicit Self. Its signature starts
- empty (or with just the sret pointer for aggregate returns). RetRec drives
- the by-aggregate return for both real records and method pointers (synthetic
- two-pointer record), so gate on RetRec rather than Kind = tyRecord. }
- if AMethod.IsStatic then
- begin
- Sig := '';
- if IsFunc and ((AMethod.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
- ((AMethod.ResolvedReturnType.Kind = tySet) and
- TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo())) then
- Sig := 'l %_par__sret'
- else if RetRec <> nil then
- { Sig is '' here, so EmitRecordReturnSignature yields just the sret ptr. }
- EmitRecordReturnSignature(Sig, RC);
- end
- else
- begin
- Sig := 'l %_par_Self';
- if IsFunc and ((AMethod.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
- ((AMethod.ResolvedReturnType.Kind = tySet) and
- TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo())) then
- Sig := 'l %_par__sret, l %_par_Self'
- else if RetRec <> nil then
- EmitRecordReturnSignature(Sig, RC);
- end;
+ Sig := 'l %_par_Self';
+ if IsFunc and ((AMethod.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
+ ((AMethod.ResolvedReturnType.Kind = tySet) and
+ TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo())) then
+ Sig := 'l %_par__sret, l %_par_Self'
+ else if IsFunc and (AMethod.ResolvedReturnType.Kind = tyRecord) then
+ EmitRecordReturnSignature(Sig, RC);
for I := 0 to AMethod.Params.Count - 1 do
begin
Par := TMethodParam(AMethod.Params.Items[I]);
- { A static method with a scalar return has an empty Sig at this point, so
- the first user parameter must NOT be prefixed with ', ' (that would emit
- 'function w $F(, w %x)', which QBE rejects as an invalid class specifier).
- The separator is empty only when nothing precedes this parameter. }
- if Sig <> '' then ParSep := ', ' else ParSep := '';
if Par.IsOpenArray then
- Sig := Sig + ParSep + Format('l %%_par_%s, l %%_par_%s_high',
+ Sig := Sig + Format(', l %%_par_%s, l %%_par_%s_high',
[Par.ParamName, Par.ParamName])
else if Par.IsVarParam then
- Sig := Sig + ParSep + Format('l %%_par_%s', [Par.ParamName])
+ Sig := Sig + Format(', l %%_par_%s', [Par.ParamName])
else if (Par.ResolvedType <> nil) and
(Par.ResolvedType.Kind = tyInterface) then
{ Interfaces are two-slot fat pointers (obj + itab); caller passes both,
callee allocs two local slots in EmitParamAllocs. Mirrors the
standalone-routine path so method dispatch and value-param ARC both
find %_var__obj / %_var_
_itab. }
- Sig := Sig + ParSep + Format('l %%_par_%s_obj, l %%_par_%s_itab',
+ Sig := Sig + Format(', l %%_par_%s_obj, l %%_par_%s_itab',
[Par.ParamName, Par.ParamName])
else
- Sig := Sig + ParSep + Format('%s %%_par_%s',
+ Sig := Sig + Format(', %s %%_par_%s',
[QbeParamTypeOf(Par.ResolvedType), Par.ParamName]);
end;
@@ -8013,9 +7224,10 @@ begin
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo()) then
EmitLine(Format('%sfunction %s(%s) {', [ExportPrefix(), FuncName, Sig]))
- else if RetRec <> nil then
+ else if AMethod.ResolvedReturnType.Kind = tyRecord then
begin
- RetDeclType := EmitRecordReturnDeclType(RetRec, RC);
+ RetDeclType := EmitRecordReturnDeclType(
+ TRecordTypeDesc(AMethod.ResolvedReturnType), RC);
if RetDeclType = '' then
EmitLine(Format('%sfunction %s(%s) {', [ExportPrefix(), FuncName, Sig]))
else
@@ -8075,8 +7287,8 @@ begin
{ For function methods, allocate/alias a zero-initialised Result slot }
if IsFunc then
begin
- if RetRec <> nil then
- EmitRecordReturnPrologue(RetRec, RC)
+ if AMethod.ResolvedReturnType.Kind = tyRecord then
+ EmitRecordReturnPrologue(TRecordTypeDesc(AMethod.ResolvedReturnType), RC)
else if AMethod.ResolvedReturnType.Kind = tyStaticArray then
begin
EmitLine(' %_var_Result =l copy %_par__sret');
@@ -8164,8 +7376,8 @@ begin
if IsFunc then
begin
- if RetRec <> nil then
- EmitRecordReturnEpilogue(RetRec, RC)
+ if AMethod.ResolvedReturnType.Kind = tyRecord then
+ EmitRecordReturnEpilogue(TRecordTypeDesc(AMethod.ResolvedReturnType), RC)
else if (AMethod.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
((AMethod.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(AMethod.ResolvedReturnType).IsJumbo()) then
@@ -8255,8 +7467,7 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
+ TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
CD := TClassTypeDef(TD.Def);
@@ -8270,12 +7481,12 @@ begin
if StrPos('<', RT.Parent.Name) >= 0 then
ParentStr := '$typeinfo_' + QBEMangle(RT.Parent.Name)
else
- ParentStr := '$typeinfo_' + ClassSymNameOf(RT.Parent);
+ ParentStr := '$typeinfo_' + ClassSymName(RT.Parent.Name);
end
else
ParentStr := '0';
if RT.ImplementsCount() > 0 then
- ImplStr := '$impllist_' + ClassSymNameForDecl(TD)
+ ImplStr := '$impllist_' + ClassSymName(TD.Name)
else
ImplStr := '0';
@@ -8287,7 +7498,7 @@ begin
Inc(PubCount);
if PubCount > 0 then
begin
- MethLine := 'data $methods_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(PubCount);
+ MethLine := 'data $methods_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(PubCount);
for J := 0 to CD.Methods.Count - 1 do
begin
MD := TMethodDecl(CD.Methods.Items[J]);
@@ -8298,30 +7509,30 @@ begin
end;
MethLine := MethLine + ' }';
EmitLine(MethLine);
- MethStr := '$methods_' + ClassSymNameForDecl(TD);
+ MethStr := '$methods_' + ClassSymName(TD.Name);
end
else
MethStr := '0';
if RT.ClassAttributeCount() > 0 then
begin
- AttrsLine := 'data $attrs_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
+ AttrsLine := 'data $attrs_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
for J := 0 to RT.ClassAttributeCount() - 1 do
AttrsLine := AttrsLine + ', l $typeinfo_' + ClassSymName(RT.ClassAttributeAt(J));
AttrsLine := AttrsLine + ' }';
EmitLine(AttrsLine);
- AttrsStr := '$attrs_' + ClassSymNameForDecl(TD);
+ AttrsStr := '$attrs_' + ClassSymName(TD.Name);
end
else
AttrsStr := '0';
- EmitLine('data $typeinfo_' + ClassSymNameForDecl(TD) +
+ EmitLine('data $typeinfo_' + ClassSymName(TD.Name) +
' = { l ' + ParentStr + ', l ' + ImplStr +
- ', l ' + EmitClassNameRefForDecl(TD) +
+ ', l ' + EmitClassNameRef(TD.Name) +
', l ' + MethStr +
', l ' + IntToStr(RT.TotalSize()) +
- ', l $_FieldCleanup_' + ClassSymNameForDecl(TD) +
- ', l $vtable_' + ClassSymNameForDecl(TD) +
+ ', l $_FieldCleanup_' + ClassSymName(TD.Name) +
+ ', l $vtable_' + ClassSymName(TD.Name) +
', l ' + AttrsStr + ' }');
end;
@@ -8381,8 +7592,7 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
+ 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;
@@ -8390,8 +7600,8 @@ begin
vtable is exported so the separately-assembled .opdf section can reference
it (the OPDF class record stores each class's VMTAddress); otherwise it
stays a local symbol, keeping non-debug output unchanged. }
- Line := VTableDataPrefix() + '$vtable_' + ClassSymNameForDecl(TD) +
- ' = { l $typeinfo_' + ClassSymNameForDecl(TD);
+ Line := VTableDataPrefix() + '$vtable_' + ClassSymName(TD.Name) +
+ ' = { l $typeinfo_' + ClassSymName(TD.Name);
for S := 0 to RT.VTableCount() - 1 do
begin
E := RT.VTableEntryAt(S);
@@ -8458,39 +7668,6 @@ begin
Result := '$' + ClassSymName(AClassName) + '_' + AMethName;
end;
-function TCodeGenQBE.ItabImplClassName(AProg: TProgram;
- const AClassName, AMethName: string): string;
-var
- CurName: string;
- I: Integer;
- TD: TTypeDecl;
- CD: TClassTypeDef;
- Found: Boolean;
-begin
- { Walk the class chain by name. Return the nearest class (self first) that
- declares AMethName; fall back to AClassName if not found anywhere. }
- Result := AClassName;
- CurName := AClassName;
- while CurName <> '' do
- begin
- CD := nil;
- for I := 0 to AProg.Block.TypeDecls.Count - 1 do
- begin
- TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
- if SameText(TD.Name, CurName) and (TD.Def is TClassTypeDef) then
- begin
- CD := TClassTypeDef(TD.Def);
- break;
- end;
- end;
- if CD = nil then Exit; { ancestor not in this compilation unit's decls }
- Found := Self.FindMethodInClassDef(CD, AMethName) <> nil;
- if Found then
- Exit(CurName);
- CurName := CD.ParentName;
- end;
-end;
-
procedure TCodeGenQBE.EmitInterfaceDefs(AProg: TProgram);
{ Emit typeinfo blocks for interfaces and itab/impllist blocks for class-interface pairs.
Interface typeinfo: data $typeinfo_IFoo = ( l 0 ) -- address IS the identity token
@@ -8521,7 +7698,7 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TInterfaceTypeDef) then Continue;
- EmitLine('data $typeinfo_' + ClassSymNameForDecl(TD) + ' = { l 0 }');
+ EmitLine('data $typeinfo_' + ClassSymName(TD.Name) + ' = { l 0 }');
end;
{ Typeinfo blocks for generic interface instantiations }
@@ -8536,8 +7713,7 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
+ TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
{ Skip only when neither this class NOR any ancestor implements an
@@ -8584,7 +7760,7 @@ begin
begin
IntfDesc := TInterfaceTypeDesc(EmitIntfs.Items[J]);
IntfMangle := QBEMangle(IntfDesc.Name);
- ItabLine := 'data $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle + ' = {';
+ ItabLine := 'data $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle + ' = {';
for K := 0 to IntfDesc.MethodCount() - 1 do
begin
MethName := IntfDesc.MethodName(K);
@@ -8596,11 +7772,8 @@ begin
overrides ($TLoud_Greet for an override, $TPerson_Greet for a
method inherited unchanged), so use it rather than blindly naming
$_ which would not exist for inherited methods
- (issue #130 bug3). A non-virtual interface method has no vtable
- slot, so resolve its declaring class by name-walking the AST chain
- and name $_. }
- MethRef := ItabMethodRef(ClassRT,
- ItabImplClassName(AProg, TD.Name, MethName), MethName);
+ (issue #130 bug3). }
+ MethRef := ItabMethodRef(ClassRT, TD.Name, MethName);
if K = 0 then
ItabLine := ItabLine + ' l ' + MethRef
else
@@ -8612,17 +7785,17 @@ begin
{ One impllist per class: NULL-terminated (typeinfo_intf, itab) pairs.
Includes ancestor interfaces so _GetItab(obj, typeinfo_IBase) resolves. }
- ImplLine := 'data $impllist_' + ClassSymNameForDecl(TD) + ' = {';
+ ImplLine := 'data $impllist_' + ClassSymName(TD.Name) + ' = {';
for J := 0 to EmitIntfs.Count - 1 do
begin
IntfDesc := TInterfaceTypeDesc(EmitIntfs.Items[J]);
IntfMangle := QBEMangle(IntfDesc.Name);
if J = 0 then
ImplLine := ImplLine + ' l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
- ', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle
+ ', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle
else
ImplLine := ImplLine + ', l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
- ', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle;
+ ', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle;
end;
ImplLine := ImplLine + ', l 0 }';
EmitLine(ImplLine);
@@ -8837,11 +8010,10 @@ begin
begin
TD := TTypeDecl(AProg.Block.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := AProg.SymbolTable.FindType(TD.Name);
+ TDesc := AProg.SymbolTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
- EmitFieldCleanupFn(ClassSymNameForDecl(TD), RT);
+ EmitFieldCleanupFn(ClassSymName(TD.Name), RT);
end;
for I := 0 to AProg.GenericInstances.Count - 1 do
begin
@@ -8949,7 +8121,6 @@ var
CapName: string;
NestedFuncName: string;
RC: TRecReturnClass;
- RetRec: TRecordTypeDesc;
begin
if ADecl.IsExternal then Exit; { no body to emit for external declarations }
if ADecl.Body = nil then Exit; { forward declaration — impl appears elsewhere }
@@ -8980,13 +8151,9 @@ begin
else
FuncName := '$' + QBEMangle(ADecl.Name);
IsFunc := ADecl.ResolvedReturnType <> nil;
- { RetRec drives the by-aggregate return ABI for both real records and
- method pointers (the latter via a synthetic two-pointer record). }
- if IsFunc then RetRec := AggRetRec(ADecl.ResolvedReturnType)
- else RetRec := nil;
RC := rcSret;
- if RetRec <> nil then
- RC := Self.ClassifyRecordReturn(RetRec);
+ if IsFunc and (ADecl.ResolvedReturnType.Kind = tyRecord) then
+ RC := Self.ClassifyRecordReturn(TRecordTypeDesc(ADecl.ResolvedReturnType));
if AExported or FExportAll or FOpdfMode then Prefix := 'export ' else Prefix := '';
{ Captured outer-scope variables are prepended as implicit pointer params.
@@ -9033,10 +8200,11 @@ begin
else Sig := 'l %_par__sret';
EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig]));
end
- else if RetRec <> nil then
+ else if ADecl.ResolvedReturnType.Kind = tyRecord then
begin
EmitRecordReturnSignature(Sig, RC);
- RetDeclType := EmitRecordReturnDeclType(RetRec, RC);
+ RetDeclType := EmitRecordReturnDeclType(
+ TRecordTypeDesc(ADecl.ResolvedReturnType), RC);
if RetDeclType = '' then
EmitLine(Format('%sfunction %s(%s) {', [Prefix, FuncName, Sig]))
else
@@ -9179,8 +8347,8 @@ begin
if IsFunc then
begin
- if RetRec <> nil then
- EmitRecordReturnPrologue(RetRec, RC)
+ if ADecl.ResolvedReturnType.Kind = tyRecord then
+ EmitRecordReturnPrologue(TRecordTypeDesc(ADecl.ResolvedReturnType), RC)
else if ADecl.ResolvedReturnType.Kind = tyStaticArray then
begin
EmitLine(' %_var_Result =l copy %_par__sret');
@@ -9277,8 +8445,8 @@ begin
if IsFunc then
begin
- if RetRec <> nil then
- EmitRecordReturnEpilogue(RetRec, RC)
+ if ADecl.ResolvedReturnType.Kind = tyRecord then
+ EmitRecordReturnEpilogue(TRecordTypeDesc(ADecl.ResolvedReturnType), RC)
else if (ADecl.ResolvedReturnType.Kind in [tyInterface, tyStaticArray]) or
((ADecl.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(ADecl.ResolvedReturnType).IsJumbo()) then
@@ -9333,74 +8501,6 @@ begin
TGenericFuncInstance(AProg.GenericFuncInstances.Items[I]).MethodDecl);
end;
-function TCodeGenQBE.EmitImplicitSelfProcFieldCall(AFieldInfo: TFieldInfo;
- APT: TProceduralTypeDesc; AArgs: TObjectList): string;
-var
- SelfTemp: string;
- SlotAddr: string;
- FPtrTemp: string;
- ArgTemp: string;
- DataTemp: string;
- ArgLine: string;
- QType: string;
- T: string;
- I: Integer;
-begin
- { Self pointer from the implicit Self parameter slot. }
- SelfTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %%_var_Self', [SelfTemp]));
- if AFieldInfo.Offset > 0 then
- begin
- SlotAddr := AllocTemp();
- EmitLine(Format(' %s =l add %s, %d', [SlotAddr, SelfTemp, AFieldInfo.Offset]));
- end
- else
- SlotAddr := SelfTemp;
- FPtrTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %s', [FPtrTemp, SlotAddr]));
- { 'of object' field: Data (Self) sits at +8 and becomes the first arg. }
- if APT.IsMethodPtr then
- begin
- ArgTemp := AllocTemp();
- EmitLine(Format(' %s =l add %s, 8', [ArgTemp, SlotAddr]));
- DataTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %s', [DataTemp, ArgTemp]));
- ArgLine := Format('l %s', [DataTemp]);
- end
- else
- ArgLine := '';
- for I := 0 to AArgs.Count - 1 do
- begin
- if ArgLine <> '' then ArgLine := ArgLine + ', ';
- { var/out parameters pass the argument's l-value address by reference. }
- if TProcParamInfo(APT.Params.Items[I]).IsVarParam then
- begin
- ArgTemp := EmitLValueAddr(TASTExpr(AArgs.Items[I]));
- ArgLine := ArgLine + Format('l %s', [ArgTemp]);
- end
- else
- begin
- ArgTemp := EmitExpr(TASTExpr(AArgs.Items[I]));
- QType := QbeTypeOf(TProcParamInfo(APT.Params.Items[I]).TypeDesc);
- ArgTemp := CoerceArg(ArgTemp, TASTExpr(AArgs.Items[I]), QType);
- ArgLine := ArgLine + Format('%s %s',
- [QbeParamTypeOf(TProcParamInfo(APT.Params.Items[I]).TypeDesc), ArgTemp]);
- end;
- end;
- if APT.ReturnType <> nil then
- begin
- QType := QbeTypeOf(APT.ReturnType);
- T := AllocTemp();
- EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FPtrTemp, ArgLine]));
- Result := T;
- end
- else
- begin
- EmitLine(Format(' call %s(%s)', [FPtrTemp, ArgLine]));
- Result := '';
- end;
-end;
-
procedure TCodeGenQBE.EmitProcCall(ACall: TProcCall);
var
UCaseName: string;
@@ -9421,15 +8521,6 @@ var
CallTgt: string;
begin
PMark := PendingReleaseMark();
- { Unqualified call to a procedural-typed field of the current class
- (implicit Self.Field) used as a statement. }
- if ACall.IsProcFieldCall then
- begin
- EmitImplicitSelfProcFieldCall(ACall.ProcFieldInfo,
- TProceduralTypeDesc(ACall.ResolvedProcType), ACall.Args);
- FlushPendingReleases(PMark);
- Exit;
- end;
{ Indirect call through a procedural-typed variable: load the function
pointer from the variable and call through it. For 'of object' types
the variable's slot is a 16-byte (Code, Data) block; load both halves
@@ -9517,7 +8608,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ArgTemp2 := '$itab_' +
- ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ArgTemp2]);
end
@@ -9597,7 +8688,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(ACall.Args.Items[I]));
ArgTemp2 := '$itab_' +
- ClassSymNameOf(TASTExpr(ACall.Args.Items[I]).ResolvedType)
+ ClassSymName(QBEMangle(TASTExpr(ACall.Args.Items[I]).ResolvedType.Name))
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format('l %s, l %s', [ArgTemp, ArgTemp2]);
end
@@ -10076,16 +9167,7 @@ begin
IsString := (ArgExpr.ResolvedType <> nil) and ArgExpr.ResolvedType.IsString();
ArgTemp := EmitExpr(ArgExpr);
if IsString then
- begin
- EmitLine(Format(' call $_SysWriteStr(w %s, l %s)', [FdLit, ArgTemp]));
- { A string argument that OWNS its reference (a call/concat result that
- returned a fresh +1 string) is borrowed by _SysWriteStr and nothing
- else holds it — release the transient here, or it leaks once per
- Write/WriteLn. Plain variables / literals are borrowed (ExprOwnsRef
- false) and must not be released. }
- if ExprOwnsRef(ArgExpr) then
- EmitLine(Format(' call $_StringRelease(l %s)', [ArgTemp]));
- end
+ EmitLine(Format(' call $_SysWriteStr(w %s, l %s)', [FdLit, ArgTemp]))
else if (ArgExpr.ResolvedType <> nil) and
(ArgExpr.ResolvedType.Kind = tyBoolean) then
EmitLine(Format(' call $_SysWriteBool(w %s, w %s)', [FdLit, ArgTemp]))
@@ -10220,7 +9302,6 @@ var
SetTmpB: string;
SetNB: Integer; { jumbo set bitmap byte count }
SetRS: Integer; { jumbo set slot size (RawSize, 8-rounded) }
- BaseReleaseTemp: string;
begin
PMark := PendingReleaseMark();
if AExpr is TFuncCallExpr then
@@ -11249,12 +10330,6 @@ begin
Exit(T);
end;
- { Unqualified call to a procedural-typed field of the current class
- (implicit Self.Field) used as an expression. }
- if FC.IsProcFieldCall then
- Exit(EmitImplicitSelfProcFieldCall(FC.ProcFieldInfo,
- TProceduralTypeDesc(FC.ResolvedProcType), FC.Args));
-
{ Indirect call through a procedural-typed variable: F() / F(args)
where F is declared 'var F: TProcType'. Load the function pointer
from F and call through it. Must precede the ResolvedDecl=nil
@@ -11421,16 +10496,6 @@ begin
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
- { Method-pointer return — a 16-byte [Code; Data] aggregate routed
- through the record-return ABI; the buffer address is the result. }
- if IsMethodPtrType(MDecl.ResolvedReturnType) then
- begin
- SretBuf := AllocTemp();
- EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
- EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
- EmitRecordCallSret(AExpr, SretBuf);
- Exit(SretBuf);
- end;
{ sret: jumbo-set-returning function — caller allocates a zero-init
bitmap buffer and passes its address as the hidden first parameter. }
if (MDecl.ResolvedReturnType.Kind = tySet) and
@@ -11567,61 +10632,6 @@ begin
begin
MCallExpr := TMethodCallExpr(AExpr);
- { Static (class-level) function call in expression position:
- TypeName.F(args). No Self; plain call to the mangled symbol, returning
- the result. v1: scalar/pointer return only (managed/record-return static
- functions can be added later via the record-return ABI path). }
- if MCallExpr.IsStaticCall and (MCallExpr.ResolvedMethod <> nil) then
- begin
- RT := TRecordTypeDesc(MCallExpr.ResolvedClassType);
- MDecl := TMethodDecl(MCallExpr.ResolvedMethod);
- ArgLine := '';
- ArgTemps := TStringList.Create();
- try
- for I := 0 to MCallExpr.Args.Count - 1 do
- begin
- Par := TMethodParam(MDecl.Params.Items[I]);
- if ArgLine <> '' then ArgLine := ArgLine + ', ';
- if Par.IsOpenArray then
- begin
- ArgTemps.Add('');
- ArgLine := ArgLine + OpenArrayArgFragment(TASTExpr(MCallExpr.Args.Items[I]));
- end
- else if Par.IsVarParam then
- begin
- ArgTemps.Add('');
- ArgLine := ArgLine + Format('l %s',
- [EmitLValueAddr(TASTExpr(MCallExpr.Args.Items[I]))]);
- end
- else if (Par.ResolvedType <> nil) and (Par.ResolvedType.Kind = tyInterface) then
- begin
- ArgTemps.Add('');
- ArgLine := ArgLine +
- InterfaceArgFragment(TASTExpr(MCallExpr.Args.Items[I]), Par.ResolvedType);
- end
- else
- begin
- ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
- ArgTemps.Add(ArgTemp);
- ArgLine := ArgLine + Format('%s %s',
- [QbeParamTypeOf(Par.ResolvedType), ArgTemp]);
- end;
- end;
- FuncName := '$' + MethodEmitName(MDecl, RT.Name, MCallExpr.Name);
- Result := AllocTemp();
- if MDecl.ResolvedReturnType <> nil then
- EmitLine(Format(' %s =%s call %s(%s)',
- [Result, QbeTypeOf(MDecl.ResolvedReturnType), FuncName, ArgLine]))
- else
- EmitLine(Format(' call %s(%s)', [FuncName, ArgLine]));
- EmitOwnedArgReleases(MCallExpr.Args, ArgTemps, MDecl.Params);
- ReleaseConstStringArgs(MCallExpr.Args, ArgTemps, MDecl.Params);
- finally
- ArgTemps.Free();
- end;
- Exit(Result);
- end;
-
{ Procedure-type field call expression: load (Code, Data) pair and
dispatch indirectly. Only applies to function-of-object fields that
return a value (otherwise they go through TMethodCallStmt). }
@@ -11666,30 +10676,14 @@ begin
for I := 0 to MCallExpr.Args.Count - 1 do
begin
if ArgLine <> '' then ArgLine := ArgLine + ', ';
- { var/out parameters are passed by reference — emit the argument's
- l-value address, not its value (otherwise the callee writes through
- a garbage pointer). }
- if TProcParamInfo(PT.Params.Items[I]).IsVarParam then
- begin
- ArgTemp := EmitLValueAddr(TASTExpr(MCallExpr.Args.Items[I]));
- ArgLine := ArgLine + Format('l %s', [ArgTemp]);
- end
- else
- begin
- ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
- QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
- ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QType);
- ArgLine := ArgLine + Format('%s %s',
- [QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
- end;
+ ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
+ QType := QbeTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc);
+ ArgTemp := CoerceArg(ArgTemp, TASTExpr(MCallExpr.Args.Items[I]), QType);
+ ArgLine := ArgLine + Format('%s %s',
+ [QbeParamTypeOf(TProcParamInfo(PT.Params.Items[I]).TypeDesc), ArgTemp]);
end;
- { Result width follows the field signature's return type. }
- if PT.ReturnType <> nil then
- QType := QbeTypeOf(PT.ReturnType)
- else
- QType := 'l';
T := AllocTemp();
- EmitLine(Format(' %s =%s call %s(%s)', [T, QType, FPtrTemp, ArgLine]));
+ EmitLine(Format(' %s =l call %s(%s)', [T, FPtrTemp, ArgLine]));
Exit(T);
end;
@@ -11755,16 +10749,16 @@ begin
else
begin
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)',
- [SelfTemp, RT.TotalSize(), ClassSymNameOf(RT)]));
+ [SelfTemp, RT.TotalSize(), ClassSymName(QBEMangle(RT.Name))]));
if RT.HasVTable() then
EmitLine(Format(' storel $vtable_%s, %s',
- [ClassSymNameOf(RT), SelfTemp]));
+ [ClassSymName(QBEMangle(RT.Name)), SelfTemp]));
end;
if FDebugMode then
begin
L := AllocTemp();
EmitLine(Format(' %s =l add $typeinfo_%s, 16',
- [L, ClassSymNameOf(RT)]));
+ [L, ClassSymName(QBEMangle(RT.Name))]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
@@ -11800,7 +10794,7 @@ begin
begin
ArgTemp := EmitExpr(TASTExpr(MCallExpr.Args.Items[I]));
ItabName := '$itab_' +
- ClassSymNameOf(TASTExpr(MCallExpr.Args.Items[I]).ResolvedType)
+ ClassSymName(QBEMangle(TASTExpr(MCallExpr.Args.Items[I]).ResolvedType.Name))
+ '_' + QBEMangle(Par.ResolvedType.Name);
ArgLine := ArgLine + Format(', l %s, l %s', [ArgTemp, ItabName]);
end
@@ -11948,16 +10942,6 @@ begin
EmitRecordCallSret(AExpr, SretBuf);
Exit(SretBuf);
end;
- { Method-pointer return — a 16-byte [Code; Data] aggregate routed
- through the record-return ABI; the buffer address is the result. }
- if IsMethodPtrType(MDecl.ResolvedReturnType) then
- begin
- SretBuf := AllocTemp();
- EmitLine(Format(' %s =l alloc8 16', [SretBuf]));
- EmitLine(Format(' call $memset(l %s, w 0, l 16)', [SretBuf]));
- EmitRecordCallSret(AExpr, SretBuf);
- Exit(SretBuf);
- end;
{ sret: jumbo-set-returning method }
if (MDecl.ResolvedReturnType.Kind = tySet) and
TSetTypeDesc(MDecl.ResolvedReturnType).IsJumbo() then
@@ -12173,8 +11157,6 @@ begin
EmitLine(Format(' %s =l add %s, 16', [T, Ptr]));
Ptr := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [Ptr, T]));
- if (FldAccess.Base <> nil) and ExprOwnsRef(FldAccess.Base) then
- EmitLine(Format(' call $_ClassRelease(l %s)', [L]));
Exit(Ptr);
end;
@@ -12197,8 +11179,6 @@ begin
{ typeinfo pointer at vtable[0] }
Ptr := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [Ptr, T]));
- if (FldAccess.Base <> nil) and ExprOwnsRef(FldAccess.Base) then
- EmitLine(Format(' call $_ClassRelease(l %s)', [L]));
Exit(Ptr);
end;
@@ -12223,23 +11203,6 @@ begin
EmitLine(Format(' %s =l add %s, 16', [ArgTemp, VTblTemp]));
EmitLine(Format(' %s =l loadl %s', [FPtrTemp, ArgTemp]));
EmitLine(Format(' %s =l call %s(l %s)', [T, FPtrTemp, L]));
- if (FldAccess.Base <> nil) and ExprOwnsRef(FldAccess.Base) then
- EmitLine(Format(' call $_ClassRelease(l %s)', [L]));
- Exit(T);
- end;
-
- { Static var read: TypeName.StaticVar — a plain global load of the mangled
- label. Checked BEFORE the chained-access branch: a qualified static var
- shaped by the parser as a Base-form access (Base is the bare class-name
- ident) still has IsClassVarRead set and must NOT be treated as a chained
- field of the metaclass. }
- if FldAccess.IsClassVarRead then
- begin
- QType := QbeTypeOf(FldAccess.ResolvedType);
- LoadInstr := LoadInstrFor(FldAccess.ResolvedType);
- T := AllocTemp();
- EmitLine(Format(' %s =%s %s $%s',
- [T, QType, LoadInstr, FldAccess.ClassVarEmitName]));
Exit(T);
end;
@@ -12251,10 +11214,6 @@ begin
begin
{ Zero-arg method on chained base }
L := EmitInstancePtr(FldAccess.Base);
- if ExprOwnsRef(FldAccess.Base) then
- BaseReleaseTemp := L
- else
- BaseReleaseTemp := '';
MDecl := TMethodDecl(FldAccess.ResolvedMethod);
if MDecl.ResolvedReturnType.Kind = tyRecord then
begin
@@ -12269,8 +11228,6 @@ begin
EmitLine(Format(' call $%s(l %s, l %s)',
[MethodEmitName(MDecl, MDecl.OwnerTypeName, FldAccess.FieldName),
SretBuf, L]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Result := SretBuf;
end
else
@@ -12280,17 +11237,11 @@ begin
EmitLine(Format(' %s =%s call $%s(l %s)',
[T, QType,
MethodEmitName(MDecl, MDecl.OwnerTypeName, FldAccess.FieldName), L]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Result := T;
end;
Exit;
end;
L := EmitInstancePtr(FldAccess.Base);
- if ExprOwnsRef(FldAccess.Base) then
- BaseReleaseTemp := L
- else
- BaseReleaseTemp := '';
{ Method-backed property read (indexed or non-indexed).
When FieldInfo is also non-nil, load the field value first — the getter
runs on the field's object, not the chained base. }
@@ -12320,8 +11271,6 @@ begin
else
EmitLine(Format(' %s =%s call %s(l %s)',
[T, QType, PropTgt, L]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(T);
end;
if FldAccess.FieldInfo = nil then
@@ -12348,17 +11297,11 @@ begin
T := AllocTemp();
EmitLine(Format(' %s =l add %s, %s', [T, Ptr, L]));
if TDynArrayTypeDesc(FldAccess.FieldInfo.TypeDesc).ElementType.Kind = tyRecord then
- begin
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(T);
- end;
QType := QbeTypeOf(TDynArrayTypeDesc(FldAccess.FieldInfo.TypeDesc).ElementType);
LoadInstr := LoadInstrFor(TDynArrayTypeDesc(FldAccess.FieldInfo.TypeDesc).ElementType);
L := AllocTemp();
EmitLine(Format(' %s =%s %s %s', [L, QType, LoadInstr, T]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(L);
end
else if FldAccess.FieldInfo.TypeDesc.Kind = tyStaticArray then
@@ -12379,17 +11322,11 @@ begin
T := AllocTemp();
EmitLine(Format(' %s =l add %s, %s', [T, L, Ptr]));
if SAT.ElementType.Kind = tyRecord then
- begin
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(T);
- end;
QType := QbeTypeOf(SAT.ElementType);
LoadInstr := LoadInstrFor(SAT.ElementType);
L := AllocTemp();
EmitLine(Format(' %s =%s %s %s', [L, QType, LoadInstr, T]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(L);
end;
end;
@@ -12402,41 +11339,11 @@ begin
else
Ptr := L;
if IsAggregateAddrType(FldAccess.FieldInfo.TypeDesc) then
- begin
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
Exit(Ptr);
- end;
QType := QbeTypeOf(FldAccess.FieldInfo.TypeDesc);
LoadInstr := LoadInstrFor(FldAccess.FieldInfo.TypeDesc);
T := AllocTemp();
EmitLine(Format(' %s =%s %s %s', [T, QType, LoadInstr, Ptr]));
- if BaseReleaseTemp <> '' then
- EmitLine(Format(' call $_ClassRelease(l %s)', [BaseReleaseTemp]));
- Exit(T);
- end;
- { Static var read: TypeName.StaticVar — a plain global load of the mangled
- label resolved by the semantic pass. }
- if FldAccess.IsClassVarRead then
- begin
- QType := QbeTypeOf(FldAccess.ResolvedType);
- LoadInstr := LoadInstrFor(FldAccess.ResolvedType);
- T := AllocTemp();
- EmitLine(Format(' %s =%s %s $%s',
- [T, QType, LoadInstr, FldAccess.ClassVarEmitName]));
- Exit(T);
- end;
- { Static property read: TypeName.StaticProp — call the static getter
- (no Self argument). }
- if FldAccess.IsStaticPropGet then
- begin
- MDecl := TMethodDecl(FldAccess.ResolvedMethod);
- QType := QbeTypeOf(MDecl.ResolvedReturnType);
- T := AllocTemp();
- EmitLine(Format(' %s =%s call $%s()',
- [T, QType,
- MethodEmitName(MDecl,
- TRecordTypeDesc(FldAccess.ResolvedClassType).Name, MDecl.Name)]));
Exit(T);
end;
if FldAccess.IsImplicitSelf then
@@ -12675,16 +11582,16 @@ begin
T := AllocTemp();
EmitLine(Format(' %s =l call $_ClassAlloc(l %d, l $_FieldCleanup_%s)',
[T, TRecordTypeDesc(FldAccess.ResolvedType).TotalSize(),
- ClassSymNameOf(FldAccess.ResolvedType)]));
+ ClassSymName(QBEMangle(FldAccess.ResolvedType.Name))]));
{ Store vtable pointer at offset 0 if this class has virtual methods }
if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable() then
EmitLine(Format(' storel $vtable_%s, %s',
- [ClassSymNameOf(FldAccess.ResolvedType), T]));
+ [ClassSymName(QBEMangle(FldAccess.ResolvedType.Name)), T]));
if FDebugMode then
begin
L := AllocTemp();
EmitLine(Format(' %s =l add $typeinfo_%s, 16',
- [L, ClassSymNameOf(FldAccess.ResolvedType)]));
+ [L, ClassSymName(QBEMangle(FldAccess.ResolvedType.Name))]));
R := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [R, L]));
EmitLine(Format(' call $_LeakTrackerRegister(l %s, l %s, l %s, l %d)',
@@ -13125,14 +12032,8 @@ begin
if (AExpr.ResolvedType <> nil) and
IsAggregateAddrType(AExpr.ResolvedType) then
begin
- { Aggregate: %_cap_Name holds the address of the enclosing variable's
- storage. For a captured plain local that IS the aggregate address.
- For a captured var/out param the enclosing slot holds the caller's
- pointer, so one extra load yields the aggregate address. }
- if TIdentExpr(AExpr).ParamMode <> pmNone then
- EmitLine(Format(' %s =l loadl %%_cap_%s', [T, TIdentExpr(AExpr).Name]))
- else
- EmitLine(Format(' %s =l copy %%_cap_%s', [T, TIdentExpr(AExpr).Name]));
+ { Aggregate: %_cap_Name is the storage address — return directly. }
+ EmitLine(Format(' %s =l copy %%_cap_%s', [T, TIdentExpr(AExpr).Name]));
Exit(T);
end;
case QType of
@@ -13160,7 +12061,7 @@ begin
{ Jumbo set value param: the QBE backend spills it into a local inline
bitmap slot (value semantics), so %_var_X IS the bitmap address —
return it directly without a load. }
- Exit(VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr))));
+ Exit(VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal));
end
else if (TIdentExpr(AExpr).ParamMode <> pmNone) and
(AExpr.ResolvedType <> nil) and
@@ -13192,7 +12093,7 @@ begin
IsAggregateAddrType(AExpr.ResolvedType) then
begin
{ Aggregate variable — return its storage address directly (no load). }
- Exit(VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr))));
+ Exit(VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal));
end
else if (AExpr.ResolvedType <> nil) and
(AExpr.ResolvedType.Kind = tyInterface) then
@@ -13217,14 +12118,14 @@ begin
QType := QbeTypeOf(AExpr.ResolvedType);
case QType of
'w': EmitLine(Format(' %s =w loadw %s',
- [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr)))]));
+ [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
'd': EmitLine(Format(' %s =d loadd %s',
- [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr)))]));
+ [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
's': EmitLine(Format(' %s =s loads %s',
- [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr)))]));
+ [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
else
EmitLine(Format(' %s =l loadl %s',
- [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal, IdentVarOwner(TIdentExpr(AExpr)))]));
+ [T, VarRef(TIdentExpr(AExpr).Name, TIdentExpr(AExpr).IsGlobal)]));
end;
end;
Result := T;
@@ -14209,10 +13110,43 @@ begin
end;
function TCodeGenQBE.QBEMangle(const AName: string): string;
+var
+ I: Integer;
+ C: Integer;
+ Clean: Boolean;
begin
- { Delegates to the shared backend-neutral mangler in blaise.codegen
- (formerly a per-character twin of the native backend's NativeMangle). }
- Result := CodegenMangle(AName);
+ { Fast path: the overwhelming majority of names contain none of the
+ mangled characters — return the input unchanged instead of rebuilding
+ it with one concat (and its ARC churn) per character. }
+ Clean := True;
+ for I := 0 to Length(AName) - 1 do
+ begin
+ C := StrAt(AName, I);
+ if (C = 60) or (C = 62) or (C = 44) or (C = 36) or (C = 64) or
+ (C = 94) or (C = 32) then
+ begin
+ Clean := False;
+ break;
+ end;
+ end;
+ if Clean then
+ Exit(AName);
+ Result := '';
+ for I := 0 to Length(AName) - 1 do
+ begin
+ C := StrAt(AName, I);
+ case C of
+ 60: Result := Result + '_'; { '<' }
+ 62: ; { '>' — skip }
+ 44: Result := Result + '_'; { ',' }
+ 32: Result := Result + '_'; { ' ' — e.g. 'class of T' }
+ 36: Result := Result + '_D_'; { '$' — overload delimiter }
+ 64: Result := Result + '_V_'; { '@' — var-param prefix }
+ 94: Result := Result + '_P_'; { '^' — pointer prefix }
+ else
+ Result := Result + Chr(C);
+ end;
+ end;
end;
function TCodeGenQBE.MethodEmitName(AMDecl: TMethodDecl;
@@ -14261,88 +13195,34 @@ begin
end;
end;
-function TCodeGenQBE.ClassUnitPrefixOwner(const AOwner: string): string;
-var
- I: Integer;
- Ch: string;
-begin
- Result := '';
- { Allowlist mirrors uSemantic.IsUnmangledUnit. }
- if AOwner = '' then Exit;
- { Program-scope classes keep bare names: uSemantic.CurrentUnitPrefix gives
- program-scope methods unprefixed ResolvedQbeNames, so reference sites
- (itabs, property setter calls) must not add a prefix either. }
- if (FProgramName <> '') and SameText(AOwner, FProgramName) then Exit;
- if SameText(AOwner, 'System') then Exit;
- if (Length(AOwner) >= 4) and SameText(Copy(AOwner, 0, 4), 'rtl.') then Exit;
- if (Length(AOwner) >= 7) and SameText(Copy(AOwner, 0, 7), 'blaise_') then Exit;
- for I := 0 to Length(AOwner) - 1 do
- begin
- Ch := Copy(AOwner, I, 1);
- if Ch = '.' then Result := Result + '_'
- else Result := Result + Ch;
- end;
- Result := Result + '_';
-end;
-
function TCodeGenQBE.ClassUnitPrefix(const AClassName: string): string;
var
Sym: TSymbol;
+ Owner: string;
+ I: Integer;
+ Ch: string;
begin
Result := '';
if FSymTable = nil then Exit;
Sym := FSymTable.Lookup(AClassName);
if Sym = nil then Exit;
- Result := ClassUnitPrefixOwner(Sym.OwningUnit);
-end;
-
-function TCodeGenQBE.ClassUnitPrefixOf(ADesc: TTypeDesc): string;
-begin
- { Mangle by the descriptor's own OwningUnit — correct even when a same-named
- type from another used unit won the flat slot (a name re-lookup would
- return the other unit's owner). Generic instances are emitted under their
- QBEMangle'd name with no unit prefix (see EmitTypeInfoDefs), so never prefix
- one — keep parity with the name-based reference form. }
- if (ADesc = nil) or (StrPos('<', ADesc.Name) >= 0) then
- Result := ''
- else
- Result := ClassUnitPrefixOwner(ADesc.OwningUnit);
-end;
-
-function TCodeGenQBE.ClassSymNameOf(ADesc: TTypeDesc): string;
-begin
- { QBEMangle the name to match ClassSymNameForDecl and the name-based
- ClassSymName(QBEMangle(...)) reference form, so a qualified reference to a
- cross-unit type resolves to the same symbol that type's definition emits. }
- if ADesc = nil then
- Result := ''
- else
- Result := ClassUnitPrefixOf(ADesc) + QBEMangle(ADesc.Name);
-end;
-
-function TCodeGenQBE.ClassSymNameForDecl(ATypeDecl: TTypeDecl): string;
-begin
- { A type's definition is always emitted under its own unit's codegen pass, so
- key the symbol on the unit currently being emitted (FCurrentUnitName). This
- is authoritative even when two used units share one descriptor for a
- same-named type, or in separate compilation where a name re-lookup would
- mis-mangle the loser as the flat-table winner. QBEMangle matches the
- reference-site form ClassSymName(QBEMangle(...)). }
- Result := ClassUnitPrefixOwner(FCurrentUnitName) + QBEMangle(ATypeDecl.Name);
-end;
-
-function TCodeGenQBE.EmitClassNameRefForDecl(ATypeDecl: TTypeDecl): string;
-var
- Sym: string;
-begin
- { Like EmitClassNameRef but keyed on the emitting unit (cross-unit last-wins
- safe), so two used units exporting a same-named class emit distinct $__cn_
- string blobs instead of colliding on the flat-table winner's symbol. }
- Sym := ClassSymNameForDecl(ATypeDecl);
- EmitLine(Format('%sdata $__cn_%s = { w -1, w %d, w %d, b "%s", b 0 }',
- [ExportPrefix(), Sym, Length(ATypeDecl.Name), Length(ATypeDecl.Name),
- ATypeDecl.Name]));
- Result := '$__cn_' + Sym + ' + 12';
+ Owner := Sym.OwningUnit;
+ { Allowlist mirrors uSemantic.IsUnmangledUnit. }
+ if Owner = '' then Exit;
+ { Program-scope classes keep bare names: uSemantic.CurrentUnitPrefix gives
+ program-scope methods unprefixed ResolvedQbeNames, so reference sites
+ (itabs, property setter calls) must not add a prefix either. }
+ if (FProgramName <> '') and SameText(Owner, FProgramName) then Exit;
+ if SameText(Owner, 'System') then Exit;
+ if (Length(Owner) >= 4) and SameText(Copy(Owner, 0, 4), 'rtl.') then Exit;
+ if (Length(Owner) >= 7) and SameText(Copy(Owner, 0, 7), 'blaise_') then Exit;
+ for I := 0 to Length(Owner) - 1 do
+ begin
+ Ch := Copy(Owner, I, 1);
+ if Ch = '.' then Result := Result + '_'
+ else Result := Result + Ch;
+ end;
+ Result := Result + '_';
end;
function TCodeGenQBE.PropAccessorTarget(const AOwnerType, AMethod: string;
@@ -14640,11 +13520,6 @@ var
E: TVTableEntry;
GII: TGenericInterfaceInstance;
SavedUnit: string;
- AllTD: TObjectList; { interface + implementation type decls, so a
- class declared in the implementation section
- gets its method bodies / typeinfo / vtable /
- _FieldCleanup / interface defs emitted too. }
- SavedDOU: string; { prior FSymTable.DefineOwningUnit, restored at end }
begin
{ No clears — output and string literal table accumulate across calls.
Counter resets are safe: QBE temps and block labels are function-scoped. }
@@ -14652,31 +13527,6 @@ begin
FLabelCount := 0;
FCurrentUnitName := AUnit.Name;
- { Establish THIS unit as the symbol-table viewing context so resolving the
- unit's own implementation-section (IsImplPrivate) types — for ClassUnitPrefix
- mangling and the typeinfo/vtable/_FieldCleanup emission loops below — is not
- suppressed by the cross-unit-leak guard in TSymbolTable.Lookup. Restored at
- the end. }
- SavedDOU := '';
- if FSymTable <> nil then
- begin
- SavedDOU := FSymTable.DefineOwningUnit;
- FSymTable.DefineOwningUnit := AUnit.Name;
- { Disable the analysis-time impl-private suppression in Lookup: at codegen
- the backend must resolve THIS unit's own implementation-section classes to
- emit their typeinfo/vtable/_FieldCleanup (see TSymbolTable.FInCodegen). }
- FSymTable.InCodegen := True;
- end;
-
- { Combined type-decl list (interface first, then implementation) — borrowed
- slots, not owned. Every per-type emission loop below iterates this so
- impl-section classes are emitted identically to interface ones. }
- AllTD := TObjectList.Create(False);
- for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
- AllTD.Add(AUnit.IntfBlock.TypeDecls.Items[I]);
- for I := 0 to AUnit.ImplBlock.TypeDecls.Count - 1 do
- AllTD.Add(AUnit.ImplBlock.TypeDecls.Items[I]);
-
CollectThreadVarNames(AUnit.IntfBlock);
CollectThreadVarNames(AUnit.ImplBlock);
@@ -14705,9 +13555,9 @@ begin
{ Class and record method bodies from interface type declarations.
After LinkClassMethodImpls the definition's TMethodDecl nodes
hold the bodies and parameter types are resolved by AnalyseMethodBodies. }
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if TD.Def is TClassTypeDef then
begin
CD := TClassTypeDef(TD.Def);
@@ -14732,15 +13582,14 @@ begin
{ Field cleanup functions — emitted here (inside redirect) because they
are function bodies, not data. Requires FSymTable to look up TRecordTypeDesc. }
if FSymTable <> nil then
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
+ TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
- EmitFieldCleanupFn(ClassSymNameForDecl(TD), RT);
+ EmitFieldCleanupFn(ClassSymName(TD.Name), RT);
end;
{ System-unit (TObject / TCustomAttribute) FieldCleanup stubs.
@@ -14751,9 +13600,9 @@ begin
collide across per-unit .o files, so skip them here — the main
program's AppendProgram emits the authoritative copies. }
if (not FSuppressSystemDefs) and (not FSystemDefsEmitted) and (FSymTable <> nil) then
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if TD.Def is TClassTypeDef then
begin
EmitLine('function $_FieldCleanup_TObject(l %self) {');
@@ -14815,17 +13664,12 @@ begin
All require FSymTable to look up resolved TRecordTypeDesc. }
if FSymTable <> nil then
begin
- { Re-assert the viewing context (see the init-block note below): method-body
- emission above can leave DefineOwningUnit pointing at a dependency unit,
- which would make ClassUnitPrefix emit this unit's own impl-section class
- typeinfo/vtable symbols under bare, unqualified names. }
- FSymTable.DefineOwningUnit := AUnit.Name;
{ Interface typeinfo blocks }
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if TD.Def is TInterfaceTypeDef then
- EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymNameForDecl(TD) + ' = { l 0 }');
+ EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymName(TD.Name) + ' = { l 0 }');
end;
{ System-unit (TObject / TCustomAttribute) typeinfo + vtable.
@@ -14833,9 +13677,9 @@ begin
on FSystemDefsEmitted. Skipped in separate-compilation mode
(FSuppressSystemDefs) — the main program provides these. }
if (not FSuppressSystemDefs) and (not FSystemDefsEmitted) then
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if TD.Def is TClassTypeDef then
begin
EmitLine('export data $typeinfo_TObject = { l 0, l 0, l ' +
@@ -14857,21 +13701,20 @@ begin
end;
{ Class typeinfo blocks — full 8-slot layout matching EmitTypeInfoDefs }
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
CD := TClassTypeDef(TD.Def);
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
+ TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if RT.Parent <> nil then
- ParentStr := '$typeinfo_' + ClassSymNameOf(RT.Parent)
+ ParentStr := '$typeinfo_' + ClassSymName(RT.Parent.Name)
else
ParentStr := '0';
if RT.ImplementsCount() > 0 then
- ImplStr := '$impllist_' + ClassSymNameForDecl(TD)
+ ImplStr := '$impllist_' + ClassSymName(TD.Name)
else
ImplStr := '0';
@@ -14881,7 +13724,7 @@ begin
Inc(PubCount);
if PubCount > 0 then
begin
- MethLine := ExportPrefix() + 'data $methods_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(PubCount);
+ MethLine := ExportPrefix() + 'data $methods_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(PubCount);
for J := 0 to CD.Methods.Count - 1 do
begin
MDecl := TMethodDecl(CD.Methods.Items[J]);
@@ -14892,30 +13735,30 @@ begin
end;
MethLine := MethLine + ' }';
EmitLine(MethLine);
- MethStr := '$methods_' + ClassSymNameForDecl(TD);
+ MethStr := '$methods_' + ClassSymName(TD.Name);
end
else
MethStr := '0';
if RT.ClassAttributeCount() > 0 then
begin
- AttrsLine := ExportPrefix() + 'data $attrs_' + ClassSymNameForDecl(TD) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
+ AttrsLine := ExportPrefix() + 'data $attrs_' + ClassSymName(TD.Name) + ' = { l ' + IntToStr(RT.ClassAttributeCount());
for J := 0 to RT.ClassAttributeCount() - 1 do
AttrsLine := AttrsLine + ', l $typeinfo_' + ClassSymName(RT.ClassAttributeAt(J));
AttrsLine := AttrsLine + ' }';
EmitLine(AttrsLine);
- AttrsStr := '$attrs_' + ClassSymNameForDecl(TD);
+ AttrsStr := '$attrs_' + ClassSymName(TD.Name);
end
else
AttrsStr := '0';
- EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymNameForDecl(TD) +
+ EmitLine(ExportPrefix() + 'data $typeinfo_' + ClassSymName(TD.Name) +
' = { l ' + ParentStr + ', l ' + ImplStr +
- ', l ' + EmitClassNameRefForDecl(TD) +
+ ', l ' + EmitClassNameRef(TD.Name) +
', l ' + MethStr +
', l ' + IntToStr(RT.TotalSize()) +
- ', l $_FieldCleanup_' + ClassSymNameForDecl(TD) +
- ', l $vtable_' + ClassSymNameForDecl(TD) +
+ ', l $_FieldCleanup_' + ClassSymName(TD.Name) +
+ ', l $vtable_' + ClassSymName(TD.Name) +
', l ' + AttrsStr + ' }');
end;
@@ -14923,17 +13766,16 @@ begin
so the abstract class's vtable links even when no subclass
overrides the method. Matches EmitVTableDefs behaviour for
program-level classes. }
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
+ TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
RT := TRecordTypeDesc(TDesc);
if not RT.HasVTable() then Continue;
- VLine := ExportPrefix() + 'data $vtable_' + ClassSymNameForDecl(TD) +
- ' = { l $typeinfo_' + ClassSymNameForDecl(TD);
+ VLine := ExportPrefix() + 'data $vtable_' + ClassSymName(TD.Name) +
+ ' = { l $typeinfo_' + ClassSymName(TD.Name);
for S := 0 to RT.VTableCount() - 1 do
begin
E := RT.VTableEntryAt(S);
@@ -15047,12 +13889,11 @@ begin
end;
{ Interface itab and impllist blocks for implementing classes }
- for I := 0 to AllTD.Count - 1 do
+ for I := 0 to AUnit.IntfBlock.TypeDecls.Count - 1 do
begin
- TD := TTypeDecl(AllTD.Items[I]);
+ TD := TTypeDecl(AUnit.IntfBlock.TypeDecls.Items[I]);
if not (TD.Def is TClassTypeDef) then Continue;
- TDesc := TTypeDesc(TD.ResolvedDesc);
- if TDesc = nil then TDesc := FSymTable.FindType(TD.Name);
+ TDesc := FSymTable.FindType(TD.Name);
if (TDesc = nil) or not (TDesc is TRecordTypeDesc) then Continue;
ClassRT := TRecordTypeDesc(TDesc);
if ClassRT.ImplementsCount() = 0 then Continue;
@@ -15060,7 +13901,7 @@ begin
begin
IntfDesc := ClassRT.ImplementsIntfAt(J);
IntfMangle := QBEMangle(IntfDesc.Name);
- ItabLine := ExportPrefix() + 'data $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle + ' = {';
+ ItabLine := ExportPrefix() + 'data $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle + ' = {';
for K := 0 to IntfDesc.MethodCount() - 1 do
begin
MethName := IntfDesc.MethodName(K);
@@ -15068,7 +13909,7 @@ begin
ClassRT.VTableEntryAt(ClassRT.FindVTableSlot(MethName)).IsAbstract then
ItabRef := '$_AbstractMethodError'
else
- ItabRef := '$' + ClassSymNameForDecl(TD) + '_' + MethName;
+ ItabRef := '$' + ClassSymName(TD.Name) + '_' + MethName;
if K = 0 then
ItabLine := ItabLine + ' l ' + ItabRef
else
@@ -15077,17 +13918,17 @@ begin
ItabLine := ItabLine + ' }';
EmitLine(ItabLine);
end;
- ImplLine := ExportPrefix() + 'data $impllist_' + ClassSymNameForDecl(TD) + ' = {';
+ ImplLine := ExportPrefix() + 'data $impllist_' + ClassSymName(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_' + IntfTypeInfoName(IntfDesc.Name) +
- ', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle
+ ', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle
else
ImplLine := ImplLine + ', l $typeinfo_' + IntfTypeInfoName(IntfDesc.Name) +
- ', l $itab_' + ClassSymNameForDecl(TD) + '_' + IntfMangle;
+ ', l $itab_' + ClassSymName(TD.Name) + '_' + IntfMangle;
end;
ImplLine := ImplLine + ', l 0 }';
EmitLine(ImplLine);
@@ -15107,16 +13948,6 @@ begin
{ Initialization section: emit as export function $_init() }
if (AUnit.InitStmts <> nil) and (AUnit.InitStmts.Count > 0) then
begin
- { Re-assert THIS unit as the viewing context. Method-body emission above
- (type resolution that walks the uses chain) can leave DefineOwningUnit
- pointing at a dependency unit; if the init block references one of THIS
- unit's own implementation-section (IsImplPrivate) classes — e.g. a
- metaclass value passed to a registrar — TSymbolTable.Lookup would
- otherwise suppress it as a cross-unit leak and ClassUnitPrefix would fall
- back to a bare, unqualified, undefined typeinfo symbol (silent link-time
- garbage). }
- if FSymTable <> nil then
- FSymTable.DefineOwningUnit := AUnit.Name;
FUnitInitNames.Add(AUnit.Name);
EmitLine('');
EmitLine('export function w $' + AUnit.Name + '_init() {');
@@ -15150,9 +13981,6 @@ begin
finally
IntfNames.Free();
end;
- AllTD.Free();
- if FSymTable <> nil then
- FSymTable.DefineOwningUnit := SavedDOU;
end;
procedure TCodeGenQBE.NoteDepInitUnit(const AUnitName: string; AHasInit: Boolean);
@@ -15378,9 +14206,6 @@ var
Adj: string;
Offset: string;
ElemPtr: string;
- VTblTemp: string;
- SlotPtr: string;
- FPtrTemp: string;
begin
if AExpr.Expr is TStringSubscriptExpr then
begin
@@ -15549,8 +14374,7 @@ begin
{ @Obj.MethodName — method-pointer construction. The semantic pass set
IsMethodPtr on the TFieldAccessExpr's ResolvedType when it detected this
pattern. Allocate a 16-byte block [code_ptr, data_ptr] on the stack,
- store the code pointer (vtable-resolved for a virtual/override method,
- the static label otherwise) and the object pointer, return the block. }
+ store the static method address and the object pointer, return the block. }
if (AExpr.Expr is TFieldAccessExpr) and
(TFieldAccessExpr(AExpr.Expr).ResolvedType <> nil) and
(TFieldAccessExpr(AExpr.Expr).ResolvedType.Kind = tyProcedural) and
@@ -15562,8 +14386,10 @@ begin
EmitLine(Format(' %s =l alloc8 16', [MBlock]));
DataSlot := AllocTemp();
EmitLine(Format(' %s =l add %s, 8', [DataSlot, MBlock]));
- { Compute the object (data) pointer first — a virtual method reads its
- code pointer from THIS instance's vtable.
+ { Store code pointer at offset 0 }
+ EmitLine(Format(' storel $%s, %s',
+ [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock]));
+ { Load and store the object pointer at offset 8.
Simple form: @VarName.Method — FldExpr.Base is nil; load via RecordName.
Chained form: @Expr.Method — FldExpr.Base is set; use EmitInstancePtr. }
if FldExpr.Base <> nil then
@@ -15573,26 +14399,6 @@ begin
ObjPtr := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ObjPtr, VarRef(FldExpr.RecordName, FldExpr.IsGlobal)]));
end;
- { Store the code pointer at offset 0. A virtual/override method must be
- resolved through the instance's vtable so @Obj.M captures the dynamic
- type's override — matching a direct Obj.M() call — instead of freezing
- the static address of the declared type. Slot 0 of the vtable is
- typeinfo, so method N is at offset (N+1)*8 (mirrors EmitMethodCall). }
- if MD.VTableSlot >= 0 then
- begin
- VTblTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %s', [VTblTemp, ObjPtr]));
- SlotPtr := AllocTemp();
- EmitLine(Format(' %s =l add %s, %d',
- [SlotPtr, VTblTemp, (MD.VTableSlot + 1) * 8]));
- FPtrTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %s', [FPtrTemp, SlotPtr]));
- EmitLine(Format(' storel %s, %s', [FPtrTemp, MBlock]));
- end
- else
- EmitLine(Format(' storel $%s, %s',
- [MethodEmitName(MD, MD.OwnerTypeName, FldExpr.FieldName), MBlock]));
- { Store the object pointer at offset 8. }
EmitLine(Format(' storel %s, %s', [ObjPtr, DataSlot]));
Exit(MBlock);
end;
@@ -15634,34 +14440,14 @@ begin
if AStmt.PropWriteInfo <> nil then
begin
DefProp := TPropertyInfo(AStmt.PropWriteInfo);
- if AStmt.IsImplicitSelf then
+ RecvTemp := AllocTemp();
+ EmitLine(Format(' %s =l loadl %s',
+ [RecvTemp, VarRef(AStmt.ArrayName, AStmt.IsGlobal)]));
+ if AStmt.IsVarParam then
begin
- { Self.Field[I] := V — load Self, reach the field slot, deref to the
- field's class object (the setter receiver). }
- RecvTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %%_var_Self', [RecvTemp]));
- if AStmt.ImplicitFieldInfo.Offset > 0 then
- begin
- ElemPtr := AllocTemp();
- EmitLine(Format(' %s =l add %s, %d',
- [ElemPtr, RecvTemp, AStmt.ImplicitFieldInfo.Offset]));
- RecvTemp := ElemPtr;
- end;
ElemPtr := AllocTemp();
EmitLine(Format(' %s =l loadl %s', [ElemPtr, RecvTemp]));
RecvTemp := ElemPtr;
- end
- else
- begin
- RecvTemp := AllocTemp();
- EmitLine(Format(' %s =l loadl %s',
- [RecvTemp, VarRef(AStmt.ArrayName, AStmt.IsGlobal)]));
- if AStmt.IsVarParam then
- begin
- ElemPtr := AllocTemp();
- EmitLine(Format(' %s =l loadl %s', [ElemPtr, RecvTemp]));
- RecvTemp := ElemPtr;
- end;
end;
IdxW := EmitExpr(AStmt.IndexExpr);
IdxQType := QbeTypeOf(DefProp.IndexTypeDesc);
diff --git a/compiler/src/main/pascal/blaise.codegen.target.pas b/compiler/src/main/pascal/blaise.codegen.target.pas
index 89ce215..e52861e 100644
--- a/compiler/src/main/pascal/blaise.codegen.target.pas
+++ b/compiler/src/main/pascal/blaise.codegen.target.pas
@@ -61,26 +61,6 @@ function TargetName(const ATarget: TTargetDesc): string;
{ True when the native backend can actually generate code for this target. }
function TargetHasNativeBackend(const ATarget: TTargetDesc): Boolean;
-{ True when the target is FREESTANDING — reached via direct syscalls with no
- libc, so it is always linked as a static ET_EXEC with a self-supplied _start
- and no PT_INTERP / libc NEEDED (Strategy B, see
- docs/freebsd-x86_64-backend-design.adoc). FreeBSD is freestanding; Linux
- links dynamic libc by default. Drives both the RTL unit-list selection
- (the kernel leaf is always pulled in) and the internal linker's static mode. }
-function TargetIsFreestanding(const ATarget: TTargetDesc): Boolean;
-
-{ Lower-case OS token used in the OS-specific RTL unit names, e.g.
- 'linux' / 'freebsd' in rtl.platform.layout., runtime.syscall..
- The single source of truth for the OS suffix, shared by the driver's RTL
- unit-list selection and the codegen backends' platform-layout-init call. }
-function TargetOSName(const ATarget: TTargetDesc): string;
-
-{ Assembler symbol of the target's platform-layout unit initialiser
- (rtl.platform.layout._init). The compiler emits a direct call to this
- from main so the compile-time --target's layout assigns GPlatformLayout first,
- regardless of the program's import graph. }
-function PlatformLayoutInitSym(const ATarget: TTargetDesc): string;
-
{ Platform constants derived from the target OS. }
function TargetLineEnding(const ATarget: TTargetDesc): string;
function TargetDirectorySeparator(const ATarget: TTargetDesc): string;
@@ -107,22 +87,14 @@ end;
function HostTarget: TTargetDesc;
begin
- { The host OS is a COMPILE-TIME property of this binary: a blaise built with
- `--target freebsd-x86_64` runs on FreeBSD, so its HostTarget must report
- FreeBSD. The OS conditional symbols are target-driven (injected by the
- driver from the resolved --target; see Blaise.pas and uLexer.SeedPredefines),
- the IFDEF FREEBSD below is true exactly when THIS compiler was built for
- FreeBSD. This is what lets a FreeBSD-hosted blaise default (no --target) to
- producing FreeBSD binaries — the basis of self-hosting on FreeBSD. }
-{$IFDEF FREEBSD}
- MakeTarget(osFreeBSD, cpuX86_64, Result);
-{$ELSE}
- {$IFDEF WINDOWS}
- MakeTarget(osWindows, cpuX86_64, Result);
- {$ELSE}
- MakeTarget(osLinux, cpuX86_64, Result);
- {$ENDIF}
-{$ENDIF}
+ { A '.exe' suffix on our own path means we are running on Windows (incl.
+ under wine). Unix hosts carry no extension; we can't cheaply tell
+ linux/macos/freebsd apart here, and only the Windows distinction matters
+ for tool extensions today, so default the unix case to linux. }
+ if LowerCase(ExtractFileExt(ParamStr(0))) = '.exe' then
+ MakeTarget(osWindows, cpuX86_64, Result)
+ else
+ MakeTarget(osLinux, cpuX86_64, Result);
end;
function PtrSize(const ATarget: TTargetDesc): Integer;
@@ -185,31 +157,6 @@ begin
Result := (ATarget.OS = osLinux) and (ATarget.CPU = cpuX86_64);
end;
-function TargetIsFreestanding(const ATarget: TTargetDesc): Boolean;
-begin
- { FreeBSD uses Strategy B — direct syscalls, no libc — so it is always a
- static, freestanding ET_EXEC. Other OSes link dynamic libc by default. }
- Result := (ATarget.OS = osFreeBSD);
-end;
-
-function TargetOSName(const ATarget: TTargetDesc): string;
-begin
- case ATarget.OS of
- osFreeBSD: Result := 'freebsd';
- osWindows: Result := 'windows';
- osMacOS: Result := 'macos';
- else
- Result := 'linux';
- end;
-end;
-
-function PlatformLayoutInitSym(const ATarget: TTargetDesc): string;
-begin
- { NativeMangle/QBE mangling of an rtl.* unit keeps the dotted name verbatim
- and appends '_init'; the layout unit is rtl.platform.layout.. }
- Result := 'rtl.platform.layout.' + TargetOSName(ATarget) + '_init';
-end;
-
function TargetLineEnding(const ATarget: TTargetDesc): string;
begin
case ATarget.OS of
diff --git a/compiler/src/main/pascal/blaise.codegen.toolkit.pas b/compiler/src/main/pascal/blaise.codegen.toolkit.pas
deleted file mode 100644
index afc3284..0000000
--- a/compiler/src/main/pascal/blaise.codegen.toolkit.pas
+++ /dev/null
@@ -1,234 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit blaise.codegen.toolkit;
-
-{ Multi-target toolkit + registry (docs/native-target-architecture.adoc).
-
- A TTargetToolkit is the Abstract Factory that produces the consistent
- *family* of per-target compiler-side objects: the native backend and the
- link target. Keeping them behind one factory guarantees the family is
- coherent — a FreeBSD backend paired with a Linux link target is a bug a
- registry-resolved toolkit cannot produce.
-
- TTargetRegistry maps a TTargetDesc to its toolkit. Adding a target is a new
- TTargetToolkit subclass plus one registration call — no existing dispatch is
- edited (Open/Closed). --target resolution and "does this target have a
- native backend?" both go through the registry, replacing the previous
- hard-coded case statements in blaise.codegen.native and
- blaise.codegen.target.
-
- This is the compiler-side half of the architecture. The runtime-side ports
- (TKernelABI / TPlatformLayout) live in the RTL and are introduced in later
- steps; they are not part of this unit. }
-
-interface
-
-uses
- SysUtils, Generics.Collections,
- blaise.codegen.target, blaise.codegen.native.backend, blaise.linker.elf;
-
-type
- { Abstract Factory for one target's compiler-side object family. }
- TTargetToolkit = class
- public
- { Canonical "-" name (matches blaise.codegen.target.TargetName). }
- function Name: string; virtual; abstract;
- { Construct the native backend for this target. Caller owns the result. }
- function MakeBackend: TNativeBackend; virtual; abstract;
- { Construct the link target (ELF header facts) for this target. Caller
- owns the result. }
- function MakeLinkTarget: TLinkTarget; virtual; abstract;
- end;
-
- { Linux x86_64 — the original (and, before FreeBSD, only) target. }
- TLinuxX86_64Toolkit = class(TTargetToolkit)
- public
- function Name: string; override;
- function MakeBackend: TNativeBackend; override;
- function MakeLinkTarget: TLinkTarget; override;
- end;
-
- { FreeBSD x86_64 — shares the System V AMD64 ABI and the x86_64 instruction
- selector with Linux, so MakeBackend reuses TX86_64Backend; only the link
- target's OS/ABI byte differs. The runtime/syscall divergence is handled
- in the RTL (TKernelABI / TPlatformLayout), not here. }
- TFreeBSDX86_64Toolkit = class(TTargetToolkit)
- public
- function Name: string; override;
- function MakeBackend: TNativeBackend; override;
- function MakeLinkTarget: TLinkTarget; override;
- end;
-
- { Toolkit registry. Owns the registered toolkit instances. A linear list
- is correct here: the target count is tiny (one per supported OS/CPU), so a
- name scan is cheaper than a hash map and avoids instantiating a generic
- map over a class type. }
- TTargetRegistry = class
- private
- FByName: TOrderedDictionary;
- public
- constructor Create;
- destructor Destroy; override;
- { Register a toolkit. Registry takes ownership. }
- procedure Register(AToolkit: TTargetToolkit);
- { Resolve the toolkit for ATarget, or nil if none is registered. }
- function Resolve(const ATarget: TTargetDesc): TTargetToolkit;
- end;
-
-{ The process-wide registry, populated in this unit's initialization. }
-function GTargetRegistry: TTargetRegistry;
-
-{ Resolve the toolkit for ATarget via the global registry (nil if unknown). }
-function ResolveToolkit(const ATarget: TTargetDesc): TTargetToolkit;
-
-{ True when ATarget has a registered native backend toolkit. Replacement for
- blaise.codegen.target.TargetHasNativeBackend, driven by the registry. }
-function RegisteredHasNativeBackend(const ATarget: TTargetDesc): Boolean;
-
-implementation
-
-uses
- blaise.codegen.native.x86_64;
-
-{ ---- TLinuxX86_64Toolkit --------------------------------------------- }
-
-function TLinuxX86_64Toolkit.Name: string;
-begin
- Result := 'linux-x86_64';
-end;
-
-function TLinuxX86_64Toolkit.MakeBackend: TNativeBackend;
-var
- T: TTargetDesc;
-begin
- MakeTarget(osLinux, cpuX86_64, T);
- Result := TX86_64Backend.Create(T);
-end;
-
-function TLinuxX86_64Toolkit.MakeLinkTarget: TLinkTarget;
-begin
- Result := LinuxX86_64Target();
-end;
-
-{ ---- TFreeBSDX86_64Toolkit ------------------------------------------- }
-
-function TFreeBSDX86_64Toolkit.Name: string;
-begin
- Result := 'freebsd-x86_64';
-end;
-
-function TFreeBSDX86_64Toolkit.MakeBackend: TNativeBackend;
-var
- T: TTargetDesc;
-begin
- MakeTarget(osFreeBSD, cpuX86_64, T);
- Result := TX86_64Backend.Create(T);
-end;
-
-function TFreeBSDX86_64Toolkit.MakeLinkTarget: TLinkTarget;
-begin
- Result := FreeBSDX86_64Target();
-end;
-
-{ ---- TTargetRegistry ------------------------------------------------- }
-
-constructor TTargetRegistry.Create;
-begin
- inherited Create();
- FByName := TOrderedDictionary.Create();
-end;
-
-destructor TTargetRegistry.Destroy;
-var
- I: Integer;
- Tk: TTargetToolkit;
-begin
- if FByName <> nil then
- begin
- for I := 0 to FByName.Count - 1 do
- begin
- Tk := FByName.Values[I];
- Tk.Free();
- end;
- FByName.Free();
- end;
- inherited Destroy();
-end;
-
-procedure TTargetRegistry.Register(AToolkit: TTargetToolkit);
-begin
- FByName.Items[AToolkit.Name()] := AToolkit;
-end;
-
-function TTargetRegistry.Resolve(const ATarget: TTargetDesc): TTargetToolkit;
-var
- Key: string;
- Tk: TTargetToolkit;
-begin
- Key := TargetName(ATarget);
- if FByName.TryGetValue(Key, Tk) then
- Result := Tk
- else
- Result := nil;
-end;
-
-{ ---- Global registry -------------------------------------------------- }
-
-var
- GRegistry: TTargetRegistry;
-
-{ Build the registry on first use. This unit's initialization section calls
- EnsureRegistry once at startup (single-threaded, before any worker thread is
- spawned), so the common path is a no-op nil check. The lazy guard also
- covers the case where a codegen unit's own initialization constructs a
- backend before this unit's initialization runs (link-order independence).
-
- Thread-safety note: the incremental compile worker pool is THREADS, not
- processes. The registry must be FULLY built before it is published to the
- global, or a second thread could observe a non-nil GRegistry whose toolkit
- list is still empty and wrongly conclude a target has no backend. Build
- into a local and assign the global last (publish-after-populate). }
-procedure EnsureRegistry;
-var
- R: TTargetRegistry;
-begin
- if GRegistry = nil then
- begin
- R := TTargetRegistry.Create();
- R.Register(TLinuxX86_64Toolkit.Create());
- R.Register(TFreeBSDX86_64Toolkit.Create());
- GRegistry := R;
- end;
-end;
-
-function GTargetRegistry: TTargetRegistry;
-begin
- EnsureRegistry();
- Result := GRegistry;
-end;
-
-function ResolveToolkit(const ATarget: TTargetDesc): TTargetToolkit;
-begin
- EnsureRegistry();
- Result := GRegistry.Resolve(ATarget);
-end;
-
-function RegisteredHasNativeBackend(const ATarget: TTargetDesc): Boolean;
-begin
- EnsureRegistry();
- Result := GRegistry.Resolve(ATarget) <> nil;
-end;
-
-initialization
- EnsureRegistry();
-
-finalization
- GRegistry.Free();
-
-end.
diff --git a/compiler/src/main/pascal/blaise.linker.elf.pas b/compiler/src/main/pascal/blaise.linker.elf.pas
index 7d76ddb..81644e8 100644
--- a/compiler/src/main/pascal/blaise.linker.elf.pas
+++ b/compiler/src/main/pascal/blaise.linker.elf.pas
@@ -37,14 +37,13 @@ unit blaise.linker.elf;
with Phase B alone.
Phase C — TLinker in dynamic mode (SetDynamic(True)) produces a
- PIE (ET_DYN) executable linked against libc. It generates GOT/PLT
- for undefined (libc) symbols, emits .dynamic/.dynsym/.dynstr/.hash
- sections, resolves R_X86_64_64 as R_X86_64_RELATIVE in .rela.dyn,
- handles R_X86_64_TPOFF32 for TLS, and merges any .init_array/
- .fini_array a linked object contributes. The entry point is _start,
- which the runtime archive supplies (blaise_start_x86_64.s) and which
- calls __libc_start_main with main as the program's entry — no system
- Scrt1.o / crtbegin / crtend / crti / crtn is needed (issue #142). }
+ PIE (ET_DYN) executable linked against libc. It reads CRT startup
+ objects, generates GOT/PLT for undefined (libc) symbols, emits
+ .dynamic/.dynsym/.dynstr/.hash sections, resolves R_X86_64_64 as
+ R_X86_64_RELATIVE in .rela.dyn, handles R_X86_64_TPOFF32 for TLS,
+ and merges .init_array/.fini_array from CRT objects. The entry
+ point is _start (from Scrt1.o), which calls __libc_start_main with
+ main as the program's entry. }
interface
@@ -84,10 +83,6 @@ type
{ Linux x86-64 ELF, non-PIE ET_EXEC. Caller frees. }
function LinuxX86_64Target: TLinkTarget;
- { FreeBSD x86-64 ELF. Same System V AMD64 machine/arch as Linux; differs
- only in EI_OSABI (9 = FreeBSD). Caller frees. }
-function FreeBSDX86_64Target: TLinkTarget;
-
type
{ One output section accumulating contributions from input objects. }
TMergedSection = class
@@ -615,13 +610,6 @@ begin
{ defaults already describe Linux x86-64 }
end;
-function FreeBSDX86_64Target: TLinkTarget;
-begin
- Result := TLinkTarget.Create();
- { Identical to Linux x86-64 except the OS/ABI byte in the ELF header. }
- Result.OSABI := ELFOSABI_FREEBSD;
-end;
-
{ ---- TLinker ----------------------------------------------------------- }
constructor TLinker.Create;
@@ -817,19 +805,12 @@ var
M: TMergedSection;
Addr: Int64;
HdrBytes: Int64;
- IsAlloc, IsExec, IsWrite, HasTlsSec: Boolean;
+ IsAlloc, IsExec, IsWrite: Boolean;
begin
- { Program headers: PT_LOAD x2 (exec run, write run), plus PT_TLS when the
- program has any TLS section (.tdata/.tbss). Reserve header space so the
- first section's file offset (= addr - base) clears the headers; otherwise
- the first section would overlap and overwrite the PT_TLS phdr. Phdr = 56. }
- HasTlsSec := False;
- for I := 0 to FMerger.Merged.Count - 1 do
- if (FMerger.Merged.Get(I).Flags and SHF_TLS) <> 0 then HasTlsSec := True;
- if HasTlsSec then
- HdrBytes := ELF64_EHDR_SIZE + 3 * 56
- else
- HdrBytes := ELF64_EHDR_SIZE + 2 * 56;
+ { Program-header count is known: PT_LOAD x2 (exec run, write run).
+ Reserve header space so the first section's file offset — which
+ equals (addr - base) — clears the headers. Elf64_Phdr = 56. }
+ HdrBytes := ELF64_EHDR_SIZE + 2 * 56;
{ Executable run: header bytes share its first page. }
Addr := FTarget.BaseAddr + HdrBytes;
@@ -851,16 +832,14 @@ begin
Self.PlaceSection(M, Addr);
end;
- { Writable run starts on a fresh page. TLS sections (.tdata/.tbss, SHF_TLS)
- are placed separately below and must be skipped here. }
+ { Writable run starts on a fresh page. }
Addr := LkAlignUp(Addr, FTarget.PageSize);
for I := 0 to FMerger.Merged.Count - 1 do
begin
M := FMerger.Merged.Get(I);
IsAlloc := (M.Flags and SHF_ALLOC) <> 0;
IsWrite := (M.Flags and SHF_WRITE) <> 0;
- if IsAlloc and IsWrite and (M.ShType <> SHT_NOBITS)
- and ((M.Flags and SHF_TLS) = 0) then
+ if IsAlloc and IsWrite and (M.ShType <> SHT_NOBITS) then
Self.PlaceSection(M, Addr);
end;
for I := 0 to FMerger.Merged.Count - 1 do
@@ -868,42 +847,9 @@ begin
M := FMerger.Merged.Get(I);
IsAlloc := (M.Flags and SHF_ALLOC) <> 0;
IsWrite := (M.Flags and SHF_WRITE) <> 0;
- if IsAlloc and IsWrite and (M.ShType = SHT_NOBITS)
- and ((M.Flags and SHF_TLS) = 0) then
+ if IsAlloc and IsWrite and (M.ShType = SHT_NOBITS) then
Self.PlaceSection(M, Addr);
end;
-
- { TLS sections (.tdata then .tbss). Mirror LayoutDynamic so a static ET_EXEC
- also gets a correct TLS block + FTlsAddr/FTlsSize for TPOFF relocations and
- the PT_TLS program header (which the freestanding _start reads to set up the
- thread pointer). }
- FTlsAddr := 0;
- FTlsSize := 0;
- FTlsAlign := 1;
- FTlsFileSize := 0;
- M := FMerger.FindMerged('.tdata');
- if M <> nil then
- begin
- Self.PlaceSection(M, Addr);
- FTlsAddr := Self.MergedAddr(M);
- FTlsFileSize := M.Size;
- FTlsSize := M.Size;
- if M.Align > FTlsAlign then FTlsAlign := M.Align;
- end;
- M := FMerger.FindMerged('.tbss');
- if M <> nil then
- begin
- Self.PlaceSection(M, Addr);
- if FTlsAddr = 0 then FTlsAddr := Self.MergedAddr(M);
- FTlsSize := FTlsSize + M.Size;
- if M.Align > FTlsAlign then FTlsAlign := M.Align;
- end;
- { Variant-II TLS: the thread pointer sits at the ALIGNED end of the block, and
- TPOFF32 is computed as (sym - FTlsAddr - FTlsSize). The freestanding _start
- places TP at AlignUp(memsz, align); align FTlsSize to match so both agree even
- when the raw section sum is not a multiple of FTlsAlign (else every threadvar
- read is off by the alignment padding). }
- FTlsSize := LkAlignUp(FTlsSize, FTlsAlign);
end;
function TLinker.FindSymbol(const AName: string): TLinkSymbol;
@@ -1571,9 +1517,6 @@ begin
FTlsSize := FTlsSize + M.Size;
if M.Align > FTlsAlign then FTlsAlign := M.Align;
end;
- { TP sits at the aligned end of the TLS block (variant II); align FTlsSize so
- TPOFF32 (sym - FTlsAddr - FTlsSize) matches the aligned thread pointer. }
- FTlsSize := LkAlignUp(FTlsSize, FTlsAlign);
{ Build .dynamic section. 'libc.so.6' is at offset 1 in .dynstr. }
FDynamicData := '';
@@ -1669,10 +1612,9 @@ begin
raise ELinker.Create('undefined reference to `' + Sym.Name + '''');
end;
-{ Patch the merged section bytes for every relocation. Static mode
- (Phase B) supports PC-relative and absolute forms (every symbol has a
- final link-time address in a non-PIE ET_EXEC); dynamic mode (Phase C)
- additionally handles GOT-relative and emits RELATIVE fixups. }
+{ Patch the merged section bytes for every relocation. In static
+ mode (Phase B) only PC-relative forms are supported; in dynamic mode
+ (Phase C) absolute, GOT-relative and TLS relocations are handled. }
procedure TLinker.ApplyRelocations;
var
Oi, Ri: Integer;
@@ -1722,52 +1664,28 @@ begin
R_X86_64_64:
begin
+ if not FDynamic then
+ raise ELinker.Create(Ctx + ': R_X86_64_64 relocation against `'
+ + Sym.Name + ''' needs dynamic linking');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S + Rel.Addend;
if M.ShType = SHT_NOBITS then
raise ELinker.Create(Ctx
+ ': relocation into a NOBITS section');
- { Patch the absolute 64-bit target address. In a non-PIE ET_EXEC
- (static mode) every symbol has a fixed load address, so this value
- is final and needs no run-time fixup. In PIE/dynamic mode the
- image base is unknown until load, so the same slot also gets an
- R_X86_64_RELATIVE entry in .rela.dyn for the loader to re-add the
- base. }
LkPatch64(M.Data, PFileOff, Val);
- if FDynamic then
- begin
- RE := TRelaDynEntry.Create();
- RE.VAddr := PAddr;
- RE.Addend := Val;
- FRelaDyn.Add(RE);
- end;
+ RE := TRelaDynEntry.Create();
+ RE.VAddr := PAddr;
+ RE.Addend := Val;
+ FRelaDyn.Add(RE);
end;
R_X86_64_32, R_X86_64_32S:
begin
+ if not FDynamic then
+ raise ELinker.Create(Ctx
+ + ': absolute 32-bit relocation unsupported in static mode');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S + Rel.Addend;
- if M.ShType = SHT_NOBITS then
- raise ELinker.Create(Ctx
- + ': relocation into a NOBITS section');
- { Resolvable in BOTH modes: static ET_EXEC links at a fixed base
- (0x400000) where every mapped address fits in 32 bits, and in
- PIE mode the patched value is the unslid link-time address
- (the OPDF reader applies the run-time slide itself; code never
- uses abs32 in PIE objects). Range-check like GNU ld does:
- R_X86_64_32 must fit zero-extended, R_X86_64_32S sign-extended. }
- if Rel.RelocType = R_X86_64_32 then
- begin
- if (Val < 0) or (Val > $FFFFFFFF) then
- raise ELinker.Create(Ctx
- + ': R_X86_64_32 overflow against ' + Sym.Name);
- end
- else
- begin
- if (Val < -2147483648) or (Val > 2147483647) then
- raise ELinker.Create(Ctx
- + ': R_X86_64_32S overflow against ' + Sym.Name);
- end;
LkPatch32(M.Data, PFileOff, Val and $FFFFFFFF);
end;
@@ -1789,12 +1707,10 @@ begin
end;
R_X86_64_TPOFF32:
- { Local-Exec TLS: the offset from the thread pointer (which points at
- the END of the static TLS block) down to this threadvar. This is the
- STATIC TLS model — it is resolvable at link time in both static and
- PIE/dynamic executables (the threadvar's position within the initial
- TLS block is fixed at link), so it needs no dynamic relocation. }
begin
+ if not FDynamic then
+ raise ELinker.Create(Ctx
+ + ': TLS relocation needs dynamic linking');
S := Self.ResolveSymbolAddr(Obj, Rel.SymIndex, Ctx);
Val := S - FTlsAddr + Rel.Addend - FTlsSize;
LkPatch32(M.Data, PFileOff, Val and $FFFFFFFF);
@@ -1868,12 +1784,7 @@ begin
Buf := Buf + LkLE(0, 4); { e_flags }
Buf := Buf + LkLE(ELF64_EHDR_SIZE, 2); { e_ehsize }
Buf := Buf + LkLE(56, 2); { e_phentsize }
- { 2 PT_LOAD, plus PT_TLS when the program has threadvars (so the static
- _start can set up the thread pointer from the PT_TLS init image). }
- if FTlsSize > 0 then
- Buf := Buf + LkLE(3, 2) { e_phnum }
- else
- Buf := Buf + LkLE(2, 2);
+ Buf := Buf + LkLE(2, 2); { e_phnum (2 PT_LOAD) }
Buf := Buf + LkLE(ELF64_SHDR_SIZE, 2); { e_shentsize }
Buf := Buf + LkLE(0, 2); { e_shnum (patched later) }
Buf := Buf + LkLE(0, 2); { e_shstrndx (patched later) }
@@ -1896,20 +1807,6 @@ begin
Buf := Buf + LkLE(WriteMemHi - WriteLo, 8); { p_memsz }
Buf := Buf + LkLE(PageSz, 8); { p_align }
- { PT_TLS — the initial TLS image (.tdata file bytes + .tbss zero size). The
- static _start reads this segment to build the per-thread block and set %fs.
- Only emitted when the program has threadvars (e_phnum reflects this). }
- if FTlsSize > 0 then
- begin
- Buf := Buf + LkLE(PT_TLS, 4) + LkLE(PF_R, 4);
- Buf := Buf + LkLE(Self.FileOffset(FTlsAddr), 8); { p_offset }
- Buf := Buf + LkLE(FTlsAddr, 8); { p_vaddr }
- Buf := Buf + LkLE(FTlsAddr, 8); { p_paddr }
- Buf := Buf + LkLE(FTlsFileSize, 8); { p_filesz (.tdata) }
- Buf := Buf + LkLE(FTlsSize, 8); { p_memsz (.tdata + .tbss) }
- Buf := Buf + LkLE(FTlsAlign, 8); { p_align }
- end;
-
{ Pad headers out to the first section's file offset (the exec run's
first byte sits at Self.FileOffset(ExecLo)). }
if Length(Buf) < Self.FileOffset(ExecLo) then
diff --git a/compiler/src/main/pascal/rtl.platform.layout.freebsd.pas b/compiler/src/main/pascal/rtl.platform.layout.freebsd.pas
deleted file mode 100644
index 84d3f62..0000000
--- a/compiler/src/main/pascal/rtl.platform.layout.freebsd.pas
+++ /dev/null
@@ -1,143 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit rtl.platform.layout.freebsd;
-
-// FreeBSD x86_64 struct layouts and OS constants — the concrete TPlatformLayout
-// adapter for FreeBSD (docs/native-target-architecture.adoc, Step 0b;
-// docs/freebsd-x86_64-backend-design.adoc, Step 2).
-//
-// This is the FreeBSD sibling of rtl.platform.layout.linux. The POSIX method
-// bodies in rtl.platform.posix are shared between Linux and FreeBSD; the only
-// per-target divergence is the struct stat layout and a handful of OS constant
-// values, both of which live here. No conditional compilation: the FreeBSD RTL
-// archive composes this unit in place of the Linux one.
-//
-// Layout pinned to FreeBSD 14.x amd64 (sys/sys/stat.h). It is identical on
-// FreeBSD 13.x: the ino_t/dev_t widening that changed struct stat landed in
-// FreeBSD 12 and has been stable since, so 13.x and 14.x share these offsets.
-//
-// struct stat offsets (FreeBSD amd64): st_mode at byte 24, st_size at byte 112,
-// st_mtim.tv_sec at byte 64. The buffer is sized at 224 bytes
-// (sizeof(struct stat)). These differ from Linux (48/88/144) — reusing the
-// Linux offsets here would read garbage file sizes and dates, the single most
-// error-prone item in the FreeBSD port.
-//
-// The O_CREAT / O_TRUNC / O_APPEND flag bits also differ from Linux; the rest
-// (S_*, SEEK_*, CLOCK_REALTIME, WNOHANG) happen to share Linux's values.
-
-interface
-
-uses
- rtl.platform;
-
-type
- TPlatformLayoutFreeBSDX86_64 = class(TPlatformLayout)
- public
- function O_RDONLY: Integer; override;
- function O_WRONLY: Integer; override;
- function O_RDWR: Integer; override;
- function O_CREAT: Integer; override;
- function O_TRUNC: Integer; override;
- function O_APPEND: Integer; override;
-
- function S_IFMT: Integer; override;
- function S_IFDIR: Integer; override;
-
- function SEEK_SET: Integer; override;
- function SEEK_CUR: Integer; override;
- function SEEK_END: Integer; override;
-
- function CLOCK_REALTIME: Integer; override;
- function WNOHANG: Integer; override;
-
- function StatBufSize: Integer; override;
- function StatSize(Buf: Pointer): Int64; override;
- function StatMtime(Buf: Pointer): Int64; override;
- function StatMode(Buf: Pointer): Integer; override;
- end;
-
-implementation
-
-const
- { FreeBSD 14.x amd64 struct stat field offsets (bytes). }
- STAT_OFF_MODE = 24; { st_mode (mode_t, u16) }
- STAT_OFF_MTIME = 64; { st_mtim.tv_sec (Int64) }
- STAT_OFF_SIZE = 112; { st_size (off_t, Int64) }
- STAT_SIZE = 224; { sizeof(struct stat) }
-
-function TPlatformLayoutFreeBSDX86_64.O_RDONLY: Integer; begin Result := 0; end;
-function TPlatformLayoutFreeBSDX86_64.O_WRONLY: Integer; begin Result := 1; end;
-function TPlatformLayoutFreeBSDX86_64.O_RDWR: Integer; begin Result := 2; end;
-function TPlatformLayoutFreeBSDX86_64.O_CREAT: Integer; begin Result := $0200; end;
-function TPlatformLayoutFreeBSDX86_64.O_TRUNC: Integer; begin Result := $0400; end;
-function TPlatformLayoutFreeBSDX86_64.O_APPEND: Integer; begin Result := $0008; end;
-
-function TPlatformLayoutFreeBSDX86_64.S_IFMT: Integer; begin Result := $F000; end;
-function TPlatformLayoutFreeBSDX86_64.S_IFDIR: Integer; begin Result := $4000; end;
-
-function TPlatformLayoutFreeBSDX86_64.SEEK_SET: Integer; begin Result := 0; end;
-function TPlatformLayoutFreeBSDX86_64.SEEK_CUR: Integer; begin Result := 1; end;
-function TPlatformLayoutFreeBSDX86_64.SEEK_END: Integer; begin Result := 2; end;
-
-function TPlatformLayoutFreeBSDX86_64.CLOCK_REALTIME: Integer; begin Result := 0; end;
-function TPlatformLayoutFreeBSDX86_64.WNOHANG: Integer; begin Result := 1; end;
-
-function TPlatformLayoutFreeBSDX86_64.StatBufSize: Integer;
-begin
- Result := STAT_SIZE;
-end;
-
-function TPlatformLayoutFreeBSDX86_64.StatSize(Buf: Pointer): Int64;
-var
- P: ^Int64;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_SIZE);
- Result := P^;
-end;
-
-function TPlatformLayoutFreeBSDX86_64.StatMtime(Buf: Pointer): Int64;
-var
- P: ^Int64;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_MTIME);
- Result := P^;
-end;
-
-function TPlatformLayoutFreeBSDX86_64.StatMode(Buf: Pointer): Integer;
-var
- P: ^Integer;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_MODE);
- Result := P^;
-end;
-
-{ Assign GPlatformLayout to the FreeBSD layout, once. Called from this unit's
- initialization (rtl.platform.layout.freebsd_init, which main invokes by-name
- for a FreeBSD --target) and from the weak _BlaisePlatformInit trampoline. The
- nil-guard keeps it a no-op on a host build that merely imports this unit (e.g.
- cp.test.platformlayout.freebsd), so it never clobbers the host layout. }
-procedure AssignLayoutFreeBSD;
-begin
- if GPlatformLayout = nil then
- GPlatformLayout := TPlatformLayoutFreeBSDX86_64.Create();
-end;
-
-{ Weak bootstrap-fallback trampoline — see the twin in rtl.platform.layout.linux
- for the full rationale. Defined WEAK so the linker keeps the first-seen (host)
- layout's copy when both units are linked. }
-procedure _BlaisePlatformInit; assembler; nostackframe;
-asm
- .weak _BlaisePlatformInit
- jmp AssignLayoutFreeBSD
-end;
-
-initialization
- AssignLayoutFreeBSD();
-
-end.
diff --git a/compiler/src/main/pascal/rtl.platform.layout.linux.pas b/compiler/src/main/pascal/rtl.platform.layout.linux.pas
deleted file mode 100644
index 3e8afa8..0000000
--- a/compiler/src/main/pascal/rtl.platform.layout.linux.pas
+++ /dev/null
@@ -1,136 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit rtl.platform.layout.linux;
-
-// Linux x86_64 struct layouts and OS constants — the concrete TPlatformLayout
-// adapter for Linux (docs/native-target-architecture.adoc, Step 0b).
-//
-// These are the values that previously lived as `const` declarations and the
-// TStatBuf record inside rtl.platform.posix.pas. Moving them behind the
-// TPlatformLayout port keeps the POSIX method bodies (which are shared with
-// FreeBSD) free of any Linux-specific layout assumption; the FreeBSD adapter
-// supplies its own offsets and flag values without conditional compilation.
-//
-// struct stat offsets below match the Linux x86_64 `struct stat`
-// (sys/stat.h): st_mode at byte 24, st_size at byte 48, st_mtime at byte 88.
-// The buffer is sized at 144 bytes (sizeof(struct stat) on Linux x86_64).
-
-interface
-
-uses
- rtl.platform;
-
-type
- TPlatformLayoutLinuxX86_64 = class(TPlatformLayout)
- public
- function O_RDONLY: Integer; override;
- function O_WRONLY: Integer; override;
- function O_RDWR: Integer; override;
- function O_CREAT: Integer; override;
- function O_TRUNC: Integer; override;
- function O_APPEND: Integer; override;
-
- function S_IFMT: Integer; override;
- function S_IFDIR: Integer; override;
-
- function SEEK_SET: Integer; override;
- function SEEK_CUR: Integer; override;
- function SEEK_END: Integer; override;
-
- function CLOCK_REALTIME: Integer; override;
- function WNOHANG: Integer; override;
-
- function StatBufSize: Integer; override;
- function StatSize(Buf: Pointer): Int64; override;
- function StatMtime(Buf: Pointer): Int64; override;
- function StatMode(Buf: Pointer): Integer; override;
- end;
-
-implementation
-
-const
- { Linux x86_64 struct stat field offsets (bytes). }
- STAT_OFF_MODE = 24; { st_mode (Integer) }
- STAT_OFF_SIZE = 48; { st_size (Int64) }
- STAT_OFF_MTIME = 88; { st_mtim.tv_sec (Int64) }
- STAT_SIZE = 144; { sizeof(struct stat) }
-
-function TPlatformLayoutLinuxX86_64.O_RDONLY: Integer; begin Result := 0; end;
-function TPlatformLayoutLinuxX86_64.O_WRONLY: Integer; begin Result := 1; end;
-function TPlatformLayoutLinuxX86_64.O_RDWR: Integer; begin Result := 2; end;
-function TPlatformLayoutLinuxX86_64.O_CREAT: Integer; begin Result := $40; end;
-function TPlatformLayoutLinuxX86_64.O_TRUNC: Integer; begin Result := $200; end;
-function TPlatformLayoutLinuxX86_64.O_APPEND: Integer; begin Result := $400; end;
-
-function TPlatformLayoutLinuxX86_64.S_IFMT: Integer; begin Result := $F000; end;
-function TPlatformLayoutLinuxX86_64.S_IFDIR: Integer; begin Result := $4000; end;
-
-function TPlatformLayoutLinuxX86_64.SEEK_SET: Integer; begin Result := 0; end;
-function TPlatformLayoutLinuxX86_64.SEEK_CUR: Integer; begin Result := 1; end;
-function TPlatformLayoutLinuxX86_64.SEEK_END: Integer; begin Result := 2; end;
-
-function TPlatformLayoutLinuxX86_64.CLOCK_REALTIME: Integer; begin Result := 0; end;
-function TPlatformLayoutLinuxX86_64.WNOHANG: Integer; begin Result := 1; end;
-
-function TPlatformLayoutLinuxX86_64.StatBufSize: Integer;
-begin
- Result := STAT_SIZE;
-end;
-
-function TPlatformLayoutLinuxX86_64.StatSize(Buf: Pointer): Int64;
-var
- P: ^Int64;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_SIZE);
- Result := P^;
-end;
-
-function TPlatformLayoutLinuxX86_64.StatMtime(Buf: Pointer): Int64;
-var
- P: ^Int64;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_MTIME);
- Result := P^;
-end;
-
-function TPlatformLayoutLinuxX86_64.StatMode(Buf: Pointer): Integer;
-var
- P: ^Integer;
-begin
- P := Pointer(PChar(Buf) + STAT_OFF_MODE);
- Result := P^;
-end;
-
-{ Assign GPlatformLayout to this target's layout, once. Called both from this
- unit's initialization (rtl.platform.layout.linux_init, which main invokes
- by-name for a Linux --target) and from the weak _BlaisePlatformInit trampoline
- below. }
-procedure AssignLayoutLinux;
-begin
- if GPlatformLayout = nil then
- GPlatformLayout := TPlatformLayoutLinuxX86_64.Create();
-end;
-
-{ Bootstrap fallback: a binary built by a codegen that does not yet emit main's
- direct, strong, by-name call to rtl.platform.layout._init reaches the
- layout through _SetArgs -> _BlaisePlatformInit instead. Emitted WEAK so that
- every concrete layout unit can define it without a duplicate-symbol link error
- when more than one is linked (e.g. a test that imports a non-host layout): the
- linker keeps the first-seen weak, which is the host layout BuildRTLUnitList
- links first. A tiny asm trampoline that tail-calls AssignLayout. }
-procedure _BlaisePlatformInit; assembler; nostackframe;
-asm
- .weak _BlaisePlatformInit
- jmp AssignLayoutLinux
-end;
-
-initialization
- AssignLayoutLinux();
-
-end.
diff --git a/compiler/src/main/pascal/runtime.atomic.pas b/compiler/src/main/pascal/runtime.atomic.pas
deleted file mode 100644
index d3f8e7f..0000000
--- a/compiler/src/main/pascal/runtime.atomic.pas
+++ /dev/null
@@ -1,53 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.atomic;
-
-// Atomic 32-bit add/sub primitives used by ARC reference counting.
-//
-// Inline-assembler port of runtime/src/main/asm/blaise_atomic_x86_64.s — the
-// bodies are now `asm … end` routines in this Pascal unit so the RTL builds
-// with Blaise's own internal assembler and needs no hand-written .s file
-// (docs/inline-asm-design.adoc, §"Migration of the .s files").
-//
-// Each returns the PREVIOUS value at Ptr (xadd semantics). System V AMD64:
-// arg1 Ptr -> %rdi, arg2 Delta -> %esi; the 32-bit result is returned in %eax.
-// `nostackframe` lets the asm body own the frame so the registers hold the
-// raw incoming arguments.
-
-interface
-
-{ Ptr addresses a 32-bit integer. Typed as Pointer (not a `PInteger` alias) so
- this unit does not export a type name that collides with the same alias in
- other RTL units when they are compiled together (e.g. blaise_arc's PInteger).
- The body reads/writes through %rdi regardless of the Pascal pointer type. }
-function _AtomicAddInt32(Ptr: Pointer; Delta: Integer): Integer;
-function _AtomicSubInt32(Ptr: Pointer; Delta: Integer): Integer;
-
-implementation
-
-{ return *Ptr (old); *Ptr += Delta — atomically. }
-function _AtomicAddInt32(Ptr: Pointer; Delta: Integer): Integer;
- assembler; nostackframe;
-asm
- movl %esi, %eax
- lock xaddl %eax, (%rdi)
- ret
-end;
-
-{ return *Ptr (old); *Ptr -= Delta — atomically (xadd of the negated delta). }
-function _AtomicSubInt32(Ptr: Pointer; Delta: Integer): Integer;
- assembler; nostackframe;
-asm
- negl %esi
- movl %esi, %eax
- lock xaddl %eax, (%rdi)
- ret
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.cstub.pas b/compiler/src/main/pascal/runtime.cstub.pas
deleted file mode 100644
index 84a0d09..0000000
--- a/compiler/src/main/pascal/runtime.cstub.pas
+++ /dev/null
@@ -1,105 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.cstub;
-
-// Freestanding C-library leaves the compiler and RTL emit calls to but which
-// are not syscalls: memcpy / memset / memcmp / strlen. In a libc-backed build
-// these come from libc; in a --static build this unit supplies them so no libc
-// is needed (docs/linux-syscall-migration.adoc).
-//
-// Architecture-neutral byte-at-a-time implementations. Correctness over speed:
-// these are the fallback for the freestanding build; if profiling shows the
-// allocator/string paths need it, an SSE/AVX memcpy can replace the loop later
-// (the inline-asm assembler already encodes the vector ops).
-//
-// Signatures match the C ABI the codegen assumes:
-// void* memcpy(void* dst, const void* src, size_t n) - returns dst
-// void* memset(void* dst, int c, size_t n) - returns dst
-// int memcmp(const void* a, const void* b, size_t n)
-// size_t strlen(const char* s)
-
-interface
-
-function memcpy(Dst, Src: Pointer; N: Int64): Pointer;
-function memset(Dst: Pointer; C: Integer; N: Int64): Pointer;
-function memcmp(A, B: Pointer; N: Int64): Integer;
-function strlen(S: PChar): Int64;
-
-implementation
-
-{ PChar indexing reads/writes a single byte as an Integer (see runtime.str), so
- these loops need no Char type (Blaise has none). }
-
-function memcpy(Dst, Src: Pointer; N: Int64): Pointer;
-var
- D, S: PChar;
- I: Int64;
-begin
- D := PChar(Dst);
- S := PChar(Src);
- I := 0;
- while I < N do
- begin
- D[I] := S[I];
- I := I + 1;
- end;
- Result := Dst;
-end;
-
-function memset(Dst: Pointer; C: Integer; N: Int64): Pointer;
-var
- D: PChar;
- I: Int64;
- B: Integer;
-begin
- D := PChar(Dst);
- B := C and $FF;
- I := 0;
- while I < N do
- begin
- D[I] := B;
- I := I + 1;
- end;
- Result := Dst;
-end;
-
-function memcmp(A, B: Pointer; N: Int64): Integer;
-var
- PA, PB: PChar;
- I: Int64;
- CA, CB: Integer;
-begin
- PA := PChar(A);
- PB := PChar(B);
- I := 0;
- while I < N do
- begin
- CA := PA[I] and $FF;
- CB := PB[I] and $FF;
- if CA <> CB then
- begin
- Result := CA - CB;
- Exit;
- end;
- I := I + 1;
- end;
- Result := 0;
-end;
-
-function strlen(S: PChar): Int64;
-var
- I: Int64;
-begin
- I := 0;
- while (S[I] and $FF) <> 0 do
- I := I + 1;
- Result := I;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.libc.freebsd.pas b/compiler/src/main/pascal/runtime.libc.freebsd.pas
deleted file mode 100644
index 8aef8f9..0000000
--- a/compiler/src/main/pascal/runtime.libc.freebsd.pas
+++ /dev/null
@@ -1,188 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.libc.freebsd;
-
-// libc-shaped leaves that are MORE than a raw syscall - they need logic the
-// kernel does not provide: env lookup, the libc-style return shapes, the
-// hw.ncpu sysctl. Built on the raw syscalls in runtime.syscall.freebsd.
-// Linked only in a static (libc-free) FreeBSD build
-// (docs/freebsd-x86_64-backend-design.adoc). The FreeBSD sibling of
-// runtime.libc.linux.
-//
-// These DEFINE the bare POSIX names (getcwd, getenv, time, waitpid, execvp,
-// sysconf) that rtl.platform.posix / runtime.thread import via `external name`,
-// so they resolve here instead of FreeBSD's libc.
-//
-// Deltas from the Linux sibling:
-// * time() has no SYS_time on FreeBSD; it reads CLOCK_REALTIME via
-// clock_gettime and returns tv_sec.
-// * sysconf(CPU count) uses sysctl(hw.ncpu) — FreeBSD has no
-// sched_getaffinity.
-// getcwd / getenv / waitpid / execvp are structurally identical (the syscall
-// leaf provides sys_getcwd / wait4 / execve / environ on both targets).
-
-interface
-
-uses
- runtime.syscall.freebsd; { provides `environ`, captured by _start }
-
-{ libc-shaped getcwd: returns Buf on success, nil on error (the raw syscall
- returns 0 / -errno). }
-function getcwd(Buf: PChar; Size: Int64): PChar;
-
-{ getenv: linear scan of `environ` for "Name=" returns a pointer to the value
- (just past '='), or nil if not present. }
-function getenv(Name: PChar): PChar;
-
-{ time(2): FreeBSD has no SYS_time — read CLOCK_REALTIME and return tv_sec. If
- T is non-nil the same value is written there (libc's optional out-param). }
-function time(T: Pointer): Int64;
-
-{ waitpid via wait4 with a NULL rusage. }
-function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
-
-{ execvp: execve the name with the current `environ` as envp. No $PATH search
- yet (matches the Linux sibling — the RTL only execs explicit paths). }
-function execvp(File_: PChar; Argv: Pointer): Integer;
-
-{ sysconf for the few names the RTL queries - currently only the online CPU
- count (_SC_NPROCESSORS_ONLN, passed as 84 by runtime.thread on every target),
- via sysctl(hw.ncpu). }
-function sysconf(Name: Integer): Int64;
-
-implementation
-
-type
- PPointer = ^Pointer;
- PInt64 = ^Int64;
-
-const
- { The token runtime.thread passes for the CPU-count query. It is an internal
- RTL contract value (runtime.thread hardcodes 84 on every target), NOT
- FreeBSD's libc _SC_NPROCESSORS_ONLN (58) — we never reach FreeBSD's libc. }
- _SC_NPROCESSORS_ONLN = 84;
- CLOCK_REALTIME = 0;
- { sysctl MIB for hw.ncpu (FreeBSD sys/sysctl.h): CTL_HW=6, HW_NCPU=3. }
- CTL_HW = 6;
- HW_NCPU = 3;
-
-{ --- small freestanding string helpers (no dependency on runtime.str) --- }
-
-function CStrLen(S: PChar): Int64;
-var I: Int64;
-begin
- I := 0;
- while (S[I] and $FF) <> 0 do I := I + 1;
- Result := I;
-end;
-
-{ Compare the "KEY=" prefix of an environ entry against Name (length NLen).
- Returns True when Entry starts with Name immediately followed by '='. }
-function EnvKeyMatches(Entry, Name: PChar; NLen: Int64): Boolean;
-var I: Int64;
-begin
- I := 0;
- while I < NLen do
- begin
- if (Entry[I] and $FF) <> (Name[I] and $FF) then Exit(False);
- if (Entry[I] and $FF) = 0 then Exit(False);
- I := I + 1;
- end;
- Result := (Entry[NLen] and $FF) = Ord('=');
-end;
-
-function getcwd(Buf: PChar; Size: Int64): PChar;
-var Rc: Int64;
-begin
- Rc := sys_getcwd(Buf, Size);
- if Rc < 0 then
- Result := nil
- else
- Result := Buf;
-end;
-
-function getenv(Name: PChar): PChar;
-var
- Entry: PChar;
- NLen, Off: Int64;
-begin
- Result := nil;
- if environ = nil then Exit;
- NLen := CStrLen(Name);
- { environ is a NULL-terminated array of PChar; read the I-th slot as a
- Pointer at environ + I*8 (PPointer deref, the RTL idiom - no [] on a typed
- pointer). }
- Off := 0;
- Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
- while Entry <> nil do
- begin
- if EnvKeyMatches(Entry, Name, NLen) then
- begin
- Result := PChar(Pointer(PChar(Entry) + NLen + 1)); { just past '=' }
- Exit;
- end;
- Off := Off + 8;
- Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
- end;
-end;
-
-function time(T: Pointer): Int64;
-var
- Ts: array[0..1] of Int64; { struct timespec: tv_sec (Int64), tv_nsec (long) }
- Rc: Integer;
- Out_: PInt64;
-begin
- Rc := clock_gettime(CLOCK_REALTIME, @Ts[0]);
- if Rc <> 0 then
- Result := -1
- else
- Result := Ts[0]; { tv_sec }
- if (T <> nil) and (Result >= 0) then
- begin
- Out_ := PInt64(T);
- Out_^ := Result; { libc's optional out-param: *T = tv_sec }
- end;
-end;
-
-function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
-begin
- Result := wait4(Pid, Status, Options, nil);
-end;
-
-function execvp(File_: PChar; Argv: Pointer): Integer;
-begin
- { No PATH search yet: execve the name directly (matches runtime.libc.linux —
- the RTL only execs explicit paths, e.g. system() builds "/bin/sh"). }
- Result := execve(File_, Argv, environ);
-end;
-
-function sysconf(Name: Integer): Int64;
-var
- Mib: array[0..1] of Integer; { the two-element MIB: CTL_HW, HW_NCPU }
- NCpu: Integer;
- OldLen: Int64; { size_t }
- Rc: Integer;
-begin
- if Name = _SC_NPROCESSORS_ONLN then
- begin
- Mib[0] := CTL_HW;
- Mib[1] := HW_NCPU;
- NCpu := 0;
- OldLen := SizeOf(NCpu); { 4 }
- Rc := sysctl(@Mib[0], 2, @NCpu, @OldLen, nil, 0);
- if (Rc <> 0) or (NCpu < 1) then
- Result := 1 { fall back to single CPU on error }
- else
- Result := NCpu;
- end
- else
- Result := -1;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.libc.linux.pas b/compiler/src/main/pascal/runtime.libc.linux.pas
deleted file mode 100644
index 9a4a1ef..0000000
--- a/compiler/src/main/pascal/runtime.libc.linux.pas
+++ /dev/null
@@ -1,175 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.libc.linux;
-
-// libc-shaped leaves that are MORE than a raw syscall - they need logic the
-// kernel does not provide: PATH/env lookup, the libc-style return shapes, etc.
-// Built on the raw syscalls in runtime.syscall.linux. Linked only in a
-// --static (libc-free) build (docs/linux-syscall-migration.adoc).
-//
-// These DEFINE the bare POSIX names (getcwd, getenv, ) that rtl.platform.posix
-// imports via `external name`, so they resolve here instead of libc.so.6.
-
-interface
-
-uses
- runtime.syscall.linux; { provides `environ`, captured by _start }
-
-{ libc-shaped getcwd: returns Buf on success, nil on error (the raw syscall
- returns a length / -errno). }
-function getcwd(Buf: PChar; Size: Int64): PChar;
-
-{ getenv: linear scan of `environ` for "Name=" returns a pointer to the value
- (just past '='), or nil if not present. }
-function getenv(Name: PChar): PChar;
-
-{ time(2) wrapper matching libc's signature (the raw syscall already supports the
- optional out-param, so this just forwards). }
-function time(T: Pointer): Int64;
-
-{ waitpid via wait4 with a NULL rusage. }
-function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
-
-{ execvp: search $PATH for File when it has no '/', then execve. Argv is the
- NULL-terminated argument vector; the current `environ` is passed as envp. }
-function execvp(File_: PChar; Argv: Pointer): Integer;
-
-{ sysconf for the few names the RTL queries - currently only the online CPU
- count (_SC_NPROCESSORS_ONLN = 84), via sched_getaffinity + popcount. }
-function sysconf(Name: Integer): Int64;
-
-implementation
-
-type
- PPointer = ^Pointer;
-
-const
- _SC_NPROCESSORS_ONLN = 84;
-
-{ --- small freestanding string helpers (no dependency on runtime.str) --- }
-
-function CStrLen(S: PChar): Int64;
-var I: Int64;
-begin
- I := 0;
- while (S[I] and $FF) <> 0 do I := I + 1;
- Result := I;
-end;
-
-{ Compare the "KEY=" prefix of an environ entry against Name (length NLen).
- Returns True when Entry starts with Name immediately followed by '='. }
-function EnvKeyMatches(Entry, Name: PChar; NLen: Int64): Boolean;
-var I: Int64;
-begin
- I := 0;
- while I < NLen do
- begin
- if (Entry[I] and $FF) <> (Name[I] and $FF) then Exit(False);
- if (Entry[I] and $FF) = 0 then Exit(False);
- I := I + 1;
- end;
- Result := (Entry[NLen] and $FF) = Ord('=');
-end;
-
-function getcwd(Buf: PChar; Size: Int64): PChar;
-var Rc: Int64;
-begin
- Rc := sys_getcwd(Buf, Size);
- if Rc < 0 then
- Result := nil
- else
- Result := Buf;
-end;
-
-function getenv(Name: PChar): PChar;
-var
- Entry: PChar;
- NLen, Off: Int64;
-begin
- Result := nil;
- if environ = nil then Exit;
- NLen := CStrLen(Name);
- { environ is a NULL-terminated array of PChar; read the I-th slot as a
- Pointer at environ + I*8 (PPointer deref, the RTL idiom - no [] on a typed
- pointer). }
- Off := 0;
- Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
- while Entry <> nil do
- begin
- if EnvKeyMatches(Entry, Name, NLen) then
- begin
- Result := PChar(Pointer(PChar(Entry) + NLen + 1)); { just past '=' }
- Exit;
- end;
- Off := Off + 8;
- Entry := PChar(PPointer(Pointer(PChar(environ) + Off))^);
- end;
-end;
-
-function time(T: Pointer): Int64;
-begin
- Result := sys_time(T);
-end;
-
-function waitpid(Pid: Integer; Status: Pointer; Options: Integer): Integer;
-begin
- Result := wait4(Pid, Status, Options, nil);
-end;
-
-function execvp(File_: PChar; Argv: Pointer): Integer;
-begin
- { No PATH search yet: execve the name directly. The RTL only execs
- absolute/relative program paths (system() builds "/bin/sh"), so this covers
- the present call sites. A bare program name resolves only relative to the
- CWD and otherwise fails with the kernel's ENOENT (never a silent wrong
- result); add a $PATH scan here if a bare-name exec call site appears. }
- Result := execve(File_, Argv, environ);
-end;
-
-{ Population count of a 1024-bit affinity mask (128 bytes), counting set CPUs. }
-function PopCountMask(Mask: PChar; NBytes: Int64): Int64;
-var
- I, J, Cnt: Int64;
- B: Integer;
-begin
- Cnt := 0;
- I := 0;
- while I < NBytes do
- begin
- B := Mask[I] and $FF;
- J := 0;
- while J < 8 do
- begin
- if (B and (1 shl J)) <> 0 then Cnt := Cnt + 1;
- J := J + 1;
- end;
- I := I + 1;
- end;
- Result := Cnt;
-end;
-
-function sysconf(Name: Integer): Int64;
-var
- Mask: array[0..127] of Byte; { 1024 CPUs worth of affinity bits }
- Rc: Integer;
-begin
- if Name = _SC_NPROCESSORS_ONLN then
- begin
- Rc := sched_getaffinity(0, 128, @Mask[0]);
- if Rc <= 0 then
- Result := 1 { fall back to single CPU on error }
- else
- Result := PopCountMask(PChar(@Mask[0]), Rc);
- if Result < 1 then Result := 1;
- end
- else
- Result := -1;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.libc2.freebsd.pas b/compiler/src/main/pascal/runtime.libc2.freebsd.pas
deleted file mode 100644
index 0649f12..0000000
--- a/compiler/src/main/pascal/runtime.libc2.freebsd.pas
+++ /dev/null
@@ -1,296 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.libc2.freebsd;
-
-// FreeBSD sibling of runtime.libc2.linux — the Tier 2 libc leaves that need real
-// logic, not a raw syscall:
-// * the atexit registry + `exit` (runs handlers then _exit)
-// * __cxa_atexit (register a handler)
-// * abort (raise SIGABRT, then _exit 134)
-// * gmtime_r / localtime_r / timegm (freestanding civil-calendar math, UTC)
-// * mkstemp (random-named O_CREAT|O_EXCL file)
-// * system (fork + execve /bin/sh -c + wait4)
-//
-// The civil-calendar math, the atexit registry, and the tm layout are all
-// target-invariant (struct tm is identical on Linux/FreeBSD amd64), so the only
-// differences from the Linux unit are the syscall leaf it builds on
-// (runtime.syscall.freebsd) and the FreeBSD O_* flag values. Linked only in a
-// --static (libc-free) FreeBSD build (docs/freebsd-x86_64-backend-design.adoc,
-// Step 4b).
-
-interface
-
-uses
- runtime.syscall.freebsd;
-
-{ __cxa_atexit(func, arg, dso_handle): register func(arg) to run at exit, LIFO.
- Returns 0 on success. dso_handle is ignored (single program, no DSO unload). }
-function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
-
-{ exit(code): run the registered handlers (LIFO), then _exit(code). This is the
- bare `exit` main's epilogue calls; it is a reserved word in Pascal, so the
- Pascal proc is _libc2_exit and the asm body publishes `exit`. }
-procedure _RunAtExitAndExit(Code: Integer);
-
-{ abort(): raise SIGABRT to self; if the signal is caught/ignored, force-exit
- with status 134 (128 + SIGABRT). }
-procedure abort;
-
-{ struct tm split/join (UTC). T points at a time_t (Int64 epoch seconds). }
-function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
-function localtime_r(T: Pointer; Tm: Pointer): Pointer;
-function timegm(Tm: Pointer): Int64;
-
-{ mkstemp(template): template ends with "XXXXXX"; replace with random chars and
- open O_CREAT|O_EXCL|O_RDWR mode 0600. Returns the fd or -1. }
-function mkstemp(Template: PChar): Integer;
-
-{ system(cmd): fork, child execve "/bin/sh -c ", parent wait4; returns the
- child's raw wait status (the RTL extracts the exit code). }
-function system(Cmd: PChar): Integer;
-
-implementation
-
-type
- PInt64 = ^Int64;
- PInteger = ^Integer;
-
-const
- SIGABRT = 6;
- O_RDWR = 2;
- { FreeBSD open(2) flag bits — differ from Linux ($40 / $80). See
- rtl.platform.layout.freebsd (O_CREAT=$0200, O_TRUNC=$0400, O_APPEND=$0008);
- O_EXCL is $0800 (sys/fcntl.h). }
- O_CREAT = $0200;
- O_EXCL = $0800;
- MAX_ATEXIT = 64;
-
-{ struct tm field byte offsets (SysV layout — identical on Linux and FreeBSD
- amd64; the RTL's TTm mirrors it):
- Sec@0 Min@4 Hour@8 MDay@12 Mon@16 Year@20 WDay@24 YDay@28 IsDST@32 (all int). }
-const
- TM_SEC=0; TM_MIN=4; TM_HOUR=8; TM_MDAY=12; TM_MON=16; TM_YEAR=20;
- TM_WDAY=24; TM_YDAY=28; TM_ISDST=32;
-
-{ --- atexit registry --- }
-
-var
- GAtExitFns: array[0..MAX_ATEXIT - 1] of Pointer;
- GAtExitArgs: array[0..MAX_ATEXIT - 1] of Pointer;
- GAtExitCount: Integer;
-
-function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
-begin
- if GAtExitCount >= MAX_ATEXIT then
- begin
- Result := -1;
- Exit;
- end;
- GAtExitFns[GAtExitCount] := Func;
- GAtExitArgs[GAtExitCount] := Arg;
- GAtExitCount := GAtExitCount + 1;
- Result := 0;
-end;
-
-{ Call a registered handler: void (*func)(void* arg). The handler is invoked
- with its arg in %rdi (a 0-arg Pascal handler simply ignores it). }
-procedure CallHandler(Func, Arg: Pointer); assembler; nostackframe;
-asm
- movq %rsi, %rax { Arg -> scratch; Func is in %rdi }
- movq %rdi, %r11 { Func }
- movq %rax, %rdi { Arg -> first C arg }
- jmp *%r11
-end;
-
-procedure _RunAtExitAndExit(Code: Integer);
-var
- I: Integer;
-begin
- { LIFO. }
- I := GAtExitCount - 1;
- while I >= 0 do
- begin
- if GAtExitFns[I] <> nil then
- CallHandler(GAtExitFns[I], GAtExitArgs[I]);
- I := I - 1;
- end;
- _exit(Code);
-end;
-
-{ Publish the bare `exit` symbol as a tail-call into _RunAtExitAndExit (Code is
- already in %edi). }
-procedure _libc2_exit(Code: Integer); assembler; nostackframe;
-asm
-.globl exit
-exit:
- jmp _RunAtExitAndExit
-end;
-
-procedure abort;
-begin
- kill(getpid(), SIGABRT);
- _exit(134);
-end;
-
-{ --- civil calendar (UTC), based on Howard Hinnant's days_from_civil --- }
-
-{ Days since 1970-01-01 for a y/m/d (proleptic Gregorian). }
-function DaysFromCivil(Y, M, D: Int64): Int64;
-var
- Era, Yoe, Doy, Doe: Int64;
- YY: Int64;
-begin
- if M <= 2 then YY := Y - 1 else YY := Y;
- if YY >= 0 then Era := YY div 400 else Era := (YY - 399) div 400;
- Yoe := YY - Era * 400;
- if M > 2 then Doy := (153 * (M - 3) + 2) div 5 + D - 1
- else Doy := (153 * (M + 9) + 2) div 5 + D - 1;
- Doe := Yoe * 365 + Yoe div 4 - Yoe div 100 + Doy;
- Result := Era * 146097 + Doe - 719468;
-end;
-
-{ Inverse: y/m/d from days-since-epoch. }
-procedure CivilFromDays(Z: Int64; var Y, M, D: Int64);
-var
- Era, Doe, Yoe, Doy, Mp: Int64;
-begin
- Z := Z + 719468;
- if Z >= 0 then Era := Z div 146097 else Era := (Z - 146096) div 146097;
- Doe := Z - Era * 146097;
- Yoe := (Doe - Doe div 1460 + Doe div 36524 - Doe div 146096) div 365;
- Y := Yoe + Era * 400;
- Doy := Doe - (365 * Yoe + Yoe div 4 - Yoe div 100);
- Mp := (5 * Doy + 2) div 153;
- D := Doy - (153 * Mp + 2) div 5 + 1;
- if Mp < 10 then M := Mp + 3 else M := Mp - 9;
- if M <= 2 then Y := Y + 1;
-end;
-
-procedure FillTm(T: Int64; Tm: Pointer);
-var
- Days, Secs, Y, M, D: Int64;
- P: PInteger;
-begin
- Days := T div 86400;
- Secs := T - Days * 86400;
- if Secs < 0 then
- begin
- Secs := Secs + 86400;
- Days := Days - 1;
- end;
- CivilFromDays(Days, Y, M, D);
-
- P := PInteger(Pointer(PChar(Tm) + TM_SEC)); P^ := Integer(Secs mod 60);
- P := PInteger(Pointer(PChar(Tm) + TM_MIN)); P^ := Integer((Secs div 60) mod 60);
- P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); P^ := Integer(Secs div 3600);
- P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); P^ := Integer(D);
- P := PInteger(Pointer(PChar(Tm) + TM_MON)); P^ := Integer(M - 1); { 0-based }
- P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); P^ := Integer(Y - 1900); { years since 1900 }
- { WDay: 1970-01-01 was a Thursday (4). }
- P := PInteger(Pointer(PChar(Tm) + TM_WDAY));
- P^ := Integer(((Days mod 7) + 4 + 7) mod 7);
- P := PInteger(Pointer(PChar(Tm) + TM_YDAY));
- P^ := Integer(Days - DaysFromCivil(Y, 1, 1));
- P := PInteger(Pointer(PChar(Tm) + TM_ISDST)); P^ := 0;
-end;
-
-function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
-begin
- FillTm(PInt64(T)^, Tm);
- Result := Tm;
-end;
-
-function localtime_r(T: Pointer; Tm: Pointer): Pointer;
-begin
- { No timezone database in the freestanding RTL - treat local as UTC. }
- Result := gmtime_r(T, Tm);
-end;
-
-function timegm(Tm: Pointer): Int64;
-var
- Y, M, D, Hh, Mm, Ss: Int64;
- P: PInteger;
-begin
- P := PInteger(Pointer(PChar(Tm) + TM_SEC)); Ss := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MIN)); Mm := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); Hh := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); D := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MON)); M := P^ + 1;
- P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); Y := P^ + 1900;
- Result := DaysFromCivil(Y, M, D) * 86400 + Hh * 3600 + Mm * 60 + Ss;
-end;
-
-{ --- mkstemp --- }
-
-function mkstemp(Template: PChar): Integer;
-const
- ALPHABET = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
-var
- Len, I, Tries, Got: Integer;
- N: Int64;
- RandBuf: array[0..5] of Byte;
- Fd: Integer;
-begin
- Len := 0;
- while (Template[Len] and $FF) <> 0 do Len := Len + 1;
- if Len < 6 then Exit(-1);
- Tries := 0;
- while Tries < 256 do
- begin
- { Fill all 6 bytes; getrandom may short-read, so loop until satisfied rather
- than leave stale/zero bytes that would weaken the random suffix. }
- Got := 0;
- while Got < 6 do
- begin
- N := getrandom(@RandBuf[Got], 6 - Got, 0);
- if N <= 0 then Continue; { EINTR / transient: retry }
- Got := Got + Integer(N);
- end;
- for I := 0 to 5 do
- Template[Len - 6 + I] := Ord(ALPHABET[(RandBuf[I] mod 62)]);
- Fd := open(Template, O_RDWR or O_CREAT or O_EXCL, 384); { 0600 }
- if Fd >= 0 then Exit(Fd);
- Tries := Tries + 1;
- end;
- Result := -1;
-end;
-
-{ --- system --- }
-
-function system(Cmd: PChar): Integer;
-var
- Pid, Status: Integer;
- Argv: array[0..3] of Pointer;
- ShPath, DashC: array[0..15] of Byte;
-begin
- { Build argv = /bin/sh, -c, cmd, NULL. The /bin/sh path and -c flag are short
- literals copied into local byte buffers so they have stable addresses. }
- ShPath[0]:=Ord('/'); ShPath[1]:=Ord('b'); ShPath[2]:=Ord('i'); ShPath[3]:=Ord('n');
- ShPath[4]:=Ord('/'); ShPath[5]:=Ord('s'); ShPath[6]:=Ord('h'); ShPath[7]:=0;
- DashC[0]:=Ord('-'); DashC[1]:=Ord('c'); DashC[2]:=0;
- Argv[0] := @ShPath[0];
- Argv[1] := @DashC[0];
- Argv[2] := Pointer(Cmd);
- Argv[3] := nil;
-
- Pid := fork();
- if Pid = 0 then
- begin
- { Child: replace image; on failure exit 127 like the shell. Forward the
- process environment so the spawned shell sees PATH/HOME/etc. }
- execve(PChar(@ShPath[0]), @Argv[0], environ);
- _exit(127);
- end;
- if Pid < 0 then Exit(-1);
- Status := 0;
- wait4(Pid, @Status, 0, nil);
- Result := Status;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.libc2.linux.pas b/compiler/src/main/pascal/runtime.libc2.linux.pas
deleted file mode 100644
index 8d1e601..0000000
--- a/compiler/src/main/pascal/runtime.libc2.linux.pas
+++ /dev/null
@@ -1,287 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.libc2.linux;
-
-// Tier 2 libc leaves that need real logic, not a raw syscall:
-// * the atexit registry + `exit` (runs handlers then exit_group)
-// * __cxa_atexit (register a handler)
-// * abort (raise SIGABRT, then exit_group 134)
-// * gmtime_r / localtime_r / timegm (freestanding civil-calendar math, UTC)
-// * mkstemp (random-named O_CREAT|O_EXCL file)
-// * system (fork + execve /bin/sh -c + wait4)
-//
-// Linked only in a --static (libc-free) build (docs/linux-syscall-migration.adoc).
-// Built on runtime.syscall.linux's raw syscalls.
-
-interface
-
-uses
- runtime.syscall.linux;
-
-{ __cxa_atexit(func, arg, dso_handle): register func(arg) to run at exit, LIFO.
- Returns 0 on success. dso_handle is ignored (single program, no DSO unload). }
-function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
-
-{ exit(code): run the registered handlers (LIFO), then exit_group(code). This
- is the bare `exit` main's epilogue calls; it is a reserved word in Pascal, so
- the Pascal proc is _libc2_exit and the asm/Pascal body publishes `exit`. }
-procedure _RunAtExitAndExit(Code: Integer);
-
-{ abort(): raise SIGABRT to self; if the signal is caught/ignored, force-exit
- with status 134 (128 + SIGABRT). }
-procedure abort;
-
-{ struct tm split/join (UTC). T points at a time_t (Int64 epoch seconds). }
-function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
-function localtime_r(T: Pointer; Tm: Pointer): Pointer;
-function timegm(Tm: Pointer): Int64;
-
-{ mkstemp(template): template ends with "XXXXXX"; replace with random chars and
- open O_CREAT|O_EXCL|O_RDWR mode 0600. Returns the fd or -1. }
-function mkstemp(Template: PChar): Integer;
-
-{ system(cmd): fork, child execve "/bin/sh -c ", parent wait4; returns the
- child's raw wait status (the RTL extracts the exit code). }
-function system(Cmd: PChar): Integer;
-
-implementation
-
-type
- PInt64 = ^Int64;
- PInteger = ^Integer;
-
-const
- SIGABRT = 6;
- O_RDWR = 2;
- O_CREAT = $40;
- O_EXCL = $80;
- MAX_ATEXIT = 64;
-
-{ struct tm field byte offsets (Linux/SysV layout the RTL's TTm mirrors):
- Sec@0 Min@4 Hour@8 MDay@12 Mon@16 Year@20 WDay@24 YDay@28 IsDST@32 (all int). }
-const
- TM_SEC=0; TM_MIN=4; TM_HOUR=8; TM_MDAY=12; TM_MON=16; TM_YEAR=20;
- TM_WDAY=24; TM_YDAY=28; TM_ISDST=32;
-
-{ --- atexit registry --- }
-
-var
- GAtExitFns: array[0..MAX_ATEXIT - 1] of Pointer;
- GAtExitArgs: array[0..MAX_ATEXIT - 1] of Pointer;
- GAtExitCount: Integer;
-
-function __cxa_atexit(Func, Arg, DsoHandle: Pointer): Integer;
-begin
- if GAtExitCount >= MAX_ATEXIT then
- begin
- Result := -1;
- Exit;
- end;
- GAtExitFns[GAtExitCount] := Func;
- GAtExitArgs[GAtExitCount] := Arg;
- GAtExitCount := GAtExitCount + 1;
- Result := 0;
-end;
-
-{ Call a registered handler: void (*func)(void* arg). The handler is invoked
- with its arg in %rdi (a 0-arg Pascal handler simply ignores it). }
-procedure CallHandler(Func, Arg: Pointer); assembler; nostackframe;
-asm
- movq %rsi, %rax { Arg -> scratch; Func is in %rdi }
- movq %rdi, %r11 { Func }
- movq %rax, %rdi { Arg -> first C arg }
- jmp *%r11
-end;
-
-procedure _RunAtExitAndExit(Code: Integer);
-var
- I: Integer;
-begin
- { LIFO. }
- I := GAtExitCount - 1;
- while I >= 0 do
- begin
- if GAtExitFns[I] <> nil then
- CallHandler(GAtExitFns[I], GAtExitArgs[I]);
- I := I - 1;
- end;
- _exit(Code);
-end;
-
-{ Publish the bare `exit` symbol as a tail-call into _RunAtExitAndExit (Code is
- already in %edi). }
-procedure _libc2_exit(Code: Integer); assembler; nostackframe;
-asm
-.globl exit
-exit:
- jmp _RunAtExitAndExit
-end;
-
-procedure abort;
-begin
- kill(getpid(), SIGABRT);
- _exit(134);
-end;
-
-{ --- civil calendar (UTC), based on Howard Hinnant's days_from_civil --- }
-
-{ Days since 1970-01-01 for a y/m/d (proleptic Gregorian). }
-function DaysFromCivil(Y, M, D: Int64): Int64;
-var
- Era, Yoe, Doy, Doe: Int64;
- YY: Int64;
-begin
- if M <= 2 then YY := Y - 1 else YY := Y;
- if YY >= 0 then Era := YY div 400 else Era := (YY - 399) div 400;
- Yoe := YY - Era * 400;
- if M > 2 then Doy := (153 * (M - 3) + 2) div 5 + D - 1
- else Doy := (153 * (M + 9) + 2) div 5 + D - 1;
- Doe := Yoe * 365 + Yoe div 4 - Yoe div 100 + Doy;
- Result := Era * 146097 + Doe - 719468;
-end;
-
-{ Inverse: y/m/d from days-since-epoch. }
-procedure CivilFromDays(Z: Int64; var Y, M, D: Int64);
-var
- Era, Doe, Yoe, Doy, Mp: Int64;
-begin
- Z := Z + 719468;
- if Z >= 0 then Era := Z div 146097 else Era := (Z - 146096) div 146097;
- Doe := Z - Era * 146097;
- Yoe := (Doe - Doe div 1460 + Doe div 36524 - Doe div 146096) div 365;
- Y := Yoe + Era * 400;
- Doy := Doe - (365 * Yoe + Yoe div 4 - Yoe div 100);
- Mp := (5 * Doy + 2) div 153;
- D := Doy - (153 * Mp + 2) div 5 + 1;
- if Mp < 10 then M := Mp + 3 else M := Mp - 9;
- if M <= 2 then Y := Y + 1;
-end;
-
-procedure FillTm(T: Int64; Tm: Pointer);
-var
- Days, Secs, Y, M, D: Int64;
- P: PInteger;
-begin
- Days := T div 86400;
- Secs := T - Days * 86400;
- if Secs < 0 then
- begin
- Secs := Secs + 86400;
- Days := Days - 1;
- end;
- CivilFromDays(Days, Y, M, D);
-
- P := PInteger(Pointer(PChar(Tm) + TM_SEC)); P^ := Integer(Secs mod 60);
- P := PInteger(Pointer(PChar(Tm) + TM_MIN)); P^ := Integer((Secs div 60) mod 60);
- P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); P^ := Integer(Secs div 3600);
- P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); P^ := Integer(D);
- P := PInteger(Pointer(PChar(Tm) + TM_MON)); P^ := Integer(M - 1); { 0-based }
- P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); P^ := Integer(Y - 1900); { years since 1900 }
- { WDay: 1970-01-01 was a Thursday (4). }
- P := PInteger(Pointer(PChar(Tm) + TM_WDAY));
- P^ := Integer(((Days mod 7) + 4 + 7) mod 7);
- P := PInteger(Pointer(PChar(Tm) + TM_YDAY));
- P^ := Integer(Days - DaysFromCivil(Y, 1, 1));
- P := PInteger(Pointer(PChar(Tm) + TM_ISDST)); P^ := 0;
-end;
-
-function gmtime_r(T: Pointer; Tm: Pointer): Pointer;
-begin
- FillTm(PInt64(T)^, Tm);
- Result := Tm;
-end;
-
-function localtime_r(T: Pointer; Tm: Pointer): Pointer;
-begin
- { No timezone database in the freestanding RTL - treat local as UTC. }
- Result := gmtime_r(T, Tm);
-end;
-
-function timegm(Tm: Pointer): Int64;
-var
- Y, M, D, Hh, Mm, Ss: Int64;
- P: PInteger;
-begin
- P := PInteger(Pointer(PChar(Tm) + TM_SEC)); Ss := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MIN)); Mm := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_HOUR)); Hh := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MDAY)); D := P^;
- P := PInteger(Pointer(PChar(Tm) + TM_MON)); M := P^ + 1;
- P := PInteger(Pointer(PChar(Tm) + TM_YEAR)); Y := P^ + 1900;
- Result := DaysFromCivil(Y, M, D) * 86400 + Hh * 3600 + Mm * 60 + Ss;
-end;
-
-{ --- mkstemp --- }
-
-function mkstemp(Template: PChar): Integer;
-const
- ALPHABET = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
-var
- Len, I, Tries, Got: Integer;
- N: Int64;
- RandBuf: array[0..5] of Byte;
- Fd: Integer;
-begin
- Len := 0;
- while (Template[Len] and $FF) <> 0 do Len := Len + 1;
- if Len < 6 then Exit(-1);
- Tries := 0;
- while Tries < 256 do
- begin
- { Fill all 6 bytes; getrandom may short-read, so loop until satisfied rather
- than leave stale/zero bytes that would weaken the random suffix. }
- Got := 0;
- while Got < 6 do
- begin
- N := getrandom(@RandBuf[Got], 6 - Got, 0);
- if N <= 0 then Continue; { EINTR / transient: retry }
- Got := Got + Integer(N);
- end;
- for I := 0 to 5 do
- Template[Len - 6 + I] := Ord(ALPHABET[(RandBuf[I] mod 62)]);
- Fd := open(Template, O_RDWR or O_CREAT or O_EXCL, 384); { 0600 }
- if Fd >= 0 then Exit(Fd);
- Tries := Tries + 1;
- end;
- Result := -1;
-end;
-
-{ --- system --- }
-
-function system(Cmd: PChar): Integer;
-var
- Pid, Status: Integer;
- Argv: array[0..3] of Pointer;
- ShPath, DashC: array[0..15] of Byte;
-begin
- { Build argv = /bin/sh, -c, cmd, NULL. The /bin/sh path and -c flag are short
- literals copied into local byte buffers so they have stable addresses. }
- ShPath[0]:=Ord('/'); ShPath[1]:=Ord('b'); ShPath[2]:=Ord('i'); ShPath[3]:=Ord('n');
- ShPath[4]:=Ord('/'); ShPath[5]:=Ord('s'); ShPath[6]:=Ord('h'); ShPath[7]:=0;
- DashC[0]:=Ord('-'); DashC[1]:=Ord('c'); DashC[2]:=0;
- Argv[0] := @ShPath[0];
- Argv[1] := @DashC[0];
- Argv[2] := Pointer(Cmd);
- Argv[3] := nil;
-
- Pid := fork();
- if Pid = 0 then
- begin
- { Child: replace image; on failure exit 127 like the shell. Forward the
- process environment so the spawned shell sees PATH/HOME/etc. }
- execve(PChar(@ShPath[0]), @Argv[0], environ);
- _exit(127);
- end;
- if Pid < 0 then Exit(-1);
- Status := 0;
- wait4(Pid, @Status, 0, nil);
- Result := Status;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.setjmp.pas b/compiler/src/main/pascal/runtime.setjmp.pas
deleted file mode 100644
index 2a7d9a3..0000000
--- a/compiler/src/main/pascal/runtime.setjmp.pas
+++ /dev/null
@@ -1,68 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.setjmp;
-
-// setjmp/longjmp for the exception runtime (try/except, try/finally).
-//
-// Inline-assembler port of runtime/src/main/asm/blaise_setjmp_x86_64.s — the
-// bodies move into `asm … end` routines so the RTL needs no hand-written .s
-// (docs/inline-asm-design.adoc, §"Migration of the .s files").
-//
-// The jmp_buf is a 64-byte block: callee-saved regs rbx/rbp/r12..r15 at
-// 0/8/16..40, the caller's RSP at 48, and the return address at 56.
-//
-// System V AMD64 arg registers: Buf -> %rdi, Val -> %esi. Both routines own
-// their frame (`nostackframe`); _blaise_setjmp captures the return address off
-// the stack and _blaise_longjmp restores RSP and jumps through the saved
-// return address, so a compiler-generated prologue must not intervene.
-
-interface
-
-function _blaise_setjmp(Buf: Pointer): Integer;
-procedure _blaise_longjmp(Buf: Pointer; Val: Integer);
-
-implementation
-
-{ Save the machine context into Buf; returns 0 on the direct call. }
-function _blaise_setjmp(Buf: Pointer): Integer; assembler; nostackframe;
-asm
- mov %rbx, (%rdi)
- mov %rbp, 8(%rdi)
- mov %r12, 16(%rdi)
- mov %r13, 24(%rdi)
- mov %r14, 32(%rdi)
- mov %r15, 40(%rdi)
- lea 8(%rsp), %rax
- mov %rax, 48(%rdi)
- mov (%rsp), %rax
- mov %rax, 56(%rdi)
- xor %eax, %eax
- ret
-end;
-
-{ Restore the context saved in Buf and resume there, returning Val (or 1 if
- Val is 0, mirroring C longjmp). }
-procedure _blaise_longjmp(Buf: Pointer; Val: Integer); assembler; nostackframe;
-asm
- mov %esi, %eax
- test %eax, %eax
- jnz .Llj_nonzero
- inc %eax
-.Llj_nonzero:
- mov (%rdi), %rbx
- mov 8(%rdi), %rbp
- mov 16(%rdi), %r12
- mov 24(%rdi), %r13
- mov 32(%rdi), %r14
- mov 40(%rdi), %r15
- mov 48(%rdi), %rsp
- jmp *56(%rdi)
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.start.pas b/compiler/src/main/pascal/runtime.start.pas
deleted file mode 100644
index 8c869aa..0000000
--- a/compiler/src/main/pascal/runtime.start.pas
+++ /dev/null
@@ -1,52 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.start;
-
-// Program entry point (x86_64, System V ABI, glibc-compatible).
-//
-// Inline-assembler port of runtime/src/main/asm/blaise_start_x86_64.s — _start
-// is now an `asm … end` routine so the RTL needs no hand-written .s
-// (docs/inline-asm-design.adoc, §"Migration of the .s files").
-//
-// This replaces the system Scrt1.o so the internal linker needs no
-// gcc-provided startup object (issue #142). The linker uses '_start' as the
-// ELF entry point; an unmangled unit-level routine named _start emits exactly
-// that symbol.
-//
-// On entry the kernel hands us the initial process stack:
-// (%rsp) argc 8(%rsp) argv[0] ... then NULL, envp, auxv
-// and %rdx holds rtld_fini for PIE images. We marshal these into the args
-// __libc_start_main(main, argc, argv, init=NULL, fini=NULL, rtld_fini,
-// stack_end) expects; glibc runs the init array, calls main(argc, argv, envp),
-// then exit(main's return). nostackframe: the body owns the whole frame.
-
-interface
-
-procedure _start;
-
-implementation
-
-procedure _start; assembler; nostackframe;
-asm
- endbr64
- xor %ebp, %ebp
- mov %rdx, %r9
- pop %rsi
- mov %rsp, %rdx
- and $0xfffffffffffffff0, %rsp
- push %rax
- push %rsp
- xor %r8d, %r8d
- xor %ecx, %ecx
- lea main(%rip), %rdi
- call __libc_start_main@PLT
- hlt
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.start.static.freebsd.pas b/compiler/src/main/pascal/runtime.start.static.freebsd.pas
deleted file mode 100644
index de6b2ba..0000000
--- a/compiler/src/main/pascal/runtime.start.static.freebsd.pas
+++ /dev/null
@@ -1,326 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.start.static.freebsd;
-
-// Freestanding _start for a static, libc-free FreeBSD ET_EXEC (the FreeBSD
-// kernel-leaf swap; docs/freebsd-x86_64-backend-design.adoc, Step 3/4c).
-//
-// The FreeBSD sibling of runtime.start.static.linux. A tiny asm trampoline
-// captures the initial stack pointer and tail-calls the Pascal _BlaiseStartC,
-// which:
-// 1. parses argc / argv / envp (the kernel's initial stack);
-// 2. sets up the static TLS block and the thread pointer (%fs) — required
-// before any threadvar (%fs-relative) access, which a static binary's
-// kernel does NOT do for us;
-// 3. captures `environ`;
-// 4. calls main(argc, argv);
-// 5. exits via the FreeBSD `exit` syscall (main itself calls exit, so this
-// is a guard).
-//
-// FreeBSD's process entry stack has the SAME shape as Linux: %rsp points at
-// argc, followed by argv[0..argc-1], a NULL, envp[], a NULL, then the ELF auxv.
-// (FreeBSD additionally passes an rtld cleanup pointer in %rdx for dynamic
-// binaries; it is 0 for a static ET_EXEC and we ignore it.)
-//
-// TLS setup locates PT_TLS via the program headers, which SetupTLS reads
-// DIRECTLY from this binary's own ELF header at the fixed non-PIE load base
-// ($400000) rather than via the kernel auxv AT_PHDR entry — a non-PIE ET_EXEC
-// always maps its header there, so this is exact and needs no auxv (identical
-// on Linux and FreeBSD). x86-64 TLS is variant II on both. The ONE FreeBSD
-// difference is how the %fs base is installed: Linux uses arch_prctl(
-// ARCH_SET_FS, tp); FreeBSD uses sysarch(AMD64_SET_FSBASE, &tp) — note it takes
-// a POINTER to the base value, not the value itself.
-//
-// x86-64 TLS (variant II): the thread pointer points at the TCB, which sits
-// ABOVE the TLS block; threadvars are at negative offsets from the TP. %fs:0
-// must hold the TP value itself (the TCB self-pointer). Layout we build:
-// [ TLS block: memsz bytes ][ TCB: 8-byte self-pointer ]
-// tp = block + memsz_aligned ; %fs = tp ; *(void**)tp = tp.
-
-interface
-
-uses
- runtime.syscall.freebsd; { _exit, sysarch, mmap/munmap + the `environ` global }
-
-procedure _start;
-
-{ The static TLS template, captured from PT_TLS at startup so each spawned thread
- can build its own TLS block (runtime.thread.static.freebsd uses these via
- thr_new's tls_base parameter). Zero TlsMemSz means the program has no
- thread-local storage. }
-var
- GTlsInitAddr: Pointer; { .tdata init image (= PT_TLS p_vaddr) }
- GTlsFileSz: Int64; { bytes to copy from the init image }
- GTlsMemSz: Int64; { total TLS size (.tdata + .tbss) }
- GTlsAlign: Int64; { PT_TLS alignment }
-
-{ Build a fresh TLS block for a new thread and return its thread pointer (the
- value thr_new installs as the new thread's %fs base via tls_base). Layout
- matches _start's SetupTLS: aligned TLS data followed by the TCB self-pointer.
- Returns nil when the program has no TLS. }
-function BuildThreadTLS: Pointer;
-
-{ Unmap a TLS block created by BuildThreadTLS, given the thread pointer it
- returned. Used to reclaim the block when thread creation fails after the TLS
- was built (the offset from TP back to the mmap base is the same alignment math
- BuildThreadTLS used, kept here so both sides agree). }
-procedure FreeThreadTLS(ATp: Pointer);
-
-{ The total size of a per-thread TLS block (aligned memsz + the TCB slot), which
- thr_new wants as tls_size. Returns 0 when the program has no TLS. }
-function ThreadTLSSize: Int64;
-
-implementation
-
-type
- PPointer = ^Pointer;
- PInt64 = ^Int64;
-
-const
- AMD64_SET_FSBASE = 129; { sysarch op — install the %fs base (verified vs
- FreeBSD 14 x86/include/sysarch.h) }
- PROT_RW = 3; { PROT_READ or PROT_WRITE }
- MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
- PT_TLS = 7;
-
-{ Our own ELF image. A non-PIE ET_EXEC is mapped at this fixed base (the
- linker's TLinkTarget.BaseAddr), so the ELF header — and through e_phoff the
- program-header table — is readable at compile-time-known addresses without
- the kernel auxv. }
- ELF_LOAD_BASE = $400000;
- EH_PHOFF = $20; { e_phoff (u64) — file offset of the phdr table }
- EH_PHENTSIZE = $36; { e_phentsize (u16) }
- EH_PHNUM = $38; { e_phnum (u16) }
-
-{ ELF64 Phdr field offsets. }
- PH_TYPE = 0; { p_type (u32) }
- PH_OFFSET = 8; { p_offset (u64) - file offset; == vaddr-base in our images }
- PH_VADDR = 16; { p_vaddr (u64) }
- PH_FILESZ = 32; { p_filesz (u64) }
- PH_MEMSZ = 40; { p_memsz (u64) }
- PH_ALIGN = 48; { p_align (u64) }
-
-{ Round X up to the next multiple of A (A a power of two, >= 1). }
-function AlignUp(X, A: Int64): Int64;
-begin
- if A < 1 then A := 1;
- Result := (X + A - 1) and (not (A - 1));
-end;
-
-{ Install the %fs base to Tp. FreeBSD: sysarch(AMD64_SET_FSBASE, &Tp) — the
- syscall takes the ADDRESS of the base value, not the value. }
-procedure SetFsBase(Tp: Pointer);
-var
- Base: Pointer;
-begin
- Base := Tp;
- sysarch(AMD64_SET_FSBASE, @Base);
-end;
-
-{ Locate the program headers, find PT_TLS, then build the static TLS block and
- set the thread pointer. No-op when the program has no TLS.
-
- We read the program-header table DIRECTLY from this binary's own ELF header,
- which sits at the fixed non-PIE load base (ELF_LOAD_BASE = $400000, the
- linker's TLinkTarget.BaseAddr): e_phoff at header offset 0x20, e_phentsize at
- 0x36, e_phnum at 0x38. A non-PIE ET_EXEC always maps its own ELF header at
- the fixed base (the first PT_LOAD covers file offset 0), so reading e_phoff
- there is exact and needs no kernel auxv — simpler and more self-contained than
- walking the auxv for AT_PHDR (which FreeBSD does supply, but relying on it
- couples startup to the auxv layout for no benefit on a non-PIE image). }
-procedure SetupTLS;
-var
- PhdrAddr, PhEnt, PhNum: Int64;
- EhEPhOff: PInt64;
- EhEPhEnt, EhEPhNum: ^Word;
- I: Int64;
- Ph: PChar;
- TlsVaddr, TlsFileSz, TlsMemSz, TlsAlign: Int64;
- PType: ^Integer;
- Block, Tp: Pointer;
- BlockSize: Int64;
- J: Int64;
- Src, Dst: PChar;
- TpSlot: PPointer;
-begin
- { Read e_phoff / e_phentsize / e_phnum from our own ELF header at the load
- base. e_phoff is a file offset; the first PT_LOAD maps file offset 0 to the
- load base, so the phdr table is at base + e_phoff. }
- EhEPhOff := PInt64(Pointer(ELF_LOAD_BASE + EH_PHOFF));
- EhEPhEnt := Pointer(ELF_LOAD_BASE + EH_PHENTSIZE);
- EhEPhNum := Pointer(ELF_LOAD_BASE + EH_PHNUM);
- PhdrAddr := ELF_LOAD_BASE + EhEPhOff^;
- PhEnt := EhEPhEnt^;
- PhNum := EhEPhNum^;
- if (PhdrAddr = 0) or (PhEnt = 0) or (PhNum = 0) then Exit;
-
- { Find PT_TLS among the program headers. }
- TlsVaddr := 0; TlsFileSz := 0; TlsMemSz := 0; TlsAlign := 8;
- I := 0;
- while I < PhNum do
- begin
- Ph := PChar(Pointer(PhdrAddr + I * PhEnt));
- PType := Pointer(Ph + PH_TYPE);
- if PType^ = PT_TLS then
- begin
- TlsVaddr := PInt64(Pointer(Ph + PH_VADDR))^;
- TlsFileSz := PInt64(Pointer(Ph + PH_FILESZ))^;
- TlsMemSz := PInt64(Pointer(Ph + PH_MEMSZ))^;
- TlsAlign := PInt64(Pointer(Ph + PH_ALIGN))^;
- Break;
- end;
- I := I + 1;
- end;
- if TlsMemSz = 0 then Exit;
-
- { Stash the template so BuildThreadTLS can reproduce this block per thread. }
- GTlsInitAddr := Pointer(TlsVaddr);
- GTlsFileSz := TlsFileSz;
- GTlsMemSz := TlsMemSz;
- GTlsAlign := TlsAlign;
-
- { Allocate block = aligned(memsz) + 16 (TCB self-pointer + slack). mmap
- zero-fills. }
- BlockSize := AlignUp(TlsMemSz, TlsAlign) + 16;
- Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Block) < 0 then Exit;
-
- { Copy the .tdata init image to the start of the block; .tbss stays zero. }
- Src := PChar(Pointer(TlsVaddr));
- Dst := PChar(Block);
- J := 0;
- while J < TlsFileSz do
- begin
- Dst[J] := Src[J];
- J := J + 1;
- end;
-
- { Thread pointer sits just past the TLS data (variant II); store the TCB
- self-pointer at *tp and set %fs. }
- Tp := Pointer(PChar(Block) + AlignUp(TlsMemSz, TlsAlign));
- TpSlot := PPointer(Tp);
- TpSlot^ := Tp;
- SetFsBase(Tp);
-end;
-
-{ Build a per-thread TLS block from the template captured at startup and return
- its thread pointer. Mirrors SetupTLS's block construction (variant II: TLS
- data, then the TCB self-pointer at the thread pointer). On FreeBSD the caller
- installs the returned TP as the new thread's %fs base via thr_new's tls_base. }
-function BuildThreadTLS: Pointer;
-var
- Block, Tp: Pointer;
- BlockSize, J: Int64;
- Src, Dst: PChar;
- TpSlot: PPointer;
-begin
- Result := nil;
- if GTlsMemSz = 0 then Exit;
- BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
- Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Block) < 0 then Exit;
- Src := PChar(GTlsInitAddr);
- Dst := PChar(Block);
- J := 0;
- while J < GTlsFileSz do
- begin
- Dst[J] := Src[J];
- J := J + 1;
- end;
- Tp := Pointer(PChar(Block) + AlignUp(GTlsMemSz, GTlsAlign));
- TpSlot := PPointer(Tp);
- TpSlot^ := Tp;
- Result := Tp;
-end;
-
-procedure FreeThreadTLS(ATp: Pointer);
-var
- Block: Pointer;
- BlockSize: Int64;
-begin
- if (ATp = nil) or (GTlsMemSz = 0) then Exit;
- Block := Pointer(PChar(ATp) - AlignUp(GTlsMemSz, GTlsAlign));
- BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
- munmap(Block, BlockSize);
-end;
-
-function ThreadTLSSize: Int64;
-begin
- if GTlsMemSz = 0 then
- Result := 0
- else
- Result := AlignUp(GTlsMemSz, GTlsAlign) + 16;
-end;
-
-{ Call the program's `main(argc, argv)` (emitted by the backend) and return its
- result. The asm thunk tail-jumps to the bare `main` symbol; argc/argv are
- already in %edi/%rsi (SysV), exactly what main expects. }
-function MainTrampoline(Argc: Integer; Argv: Pointer): Integer;
- assembler; nostackframe;
-asm
- jmp main
-end;
-
-
-
-{ The C-level entry. The kernel hands us the initial process stack: argc, then
- argv[], NULL, envp[], NULL, auxv. On FreeBSD the entry %rsp must be 16-byte
- aligned, and the kernel achieves that by inserting a ZERO PAD WORD immediately
- below argc when the argument-vector layout would otherwise leave argc at an
- 8-mod-16 address (this depends on the argc+envc pointer-count parity, so it
- varies between the shell-launched top-level and an execve'd child with a
- different environment). So argc is at [SP] usually, but at [SP+8] when a pad
- word is present. Detect the pad: a real argc is a small non-negative count
- and the slot after it (argv[0]) is a valid pointer; a pad word reads 0. If
- [SP] is 0 and [SP+8] is a plausible argc, skip the pad word. }
-procedure _BlaiseStartC(SP: Pointer);
-var
- Argc: Int64;
- Argv, Envp: Pointer;
- Ret: Integer;
-begin
- Argc := PInt64(SP)^;
- { Skip a kernel alignment pad word below argc, if present. }
- if Argc = 0 then
- begin
- if PInt64(Pointer(PChar(SP) + 8))^ > 0 then
- SP := Pointer(PChar(SP) + 8);
- Argc := PInt64(SP)^;
- end;
- Argv := Pointer(PChar(SP) + 8);
- { envp = &argv[argc+1] }
- Envp := Pointer(PChar(Argv) + (Argc + 1) * 8);
- environ := Envp;
-
- { TLS is set up by reading our own ELF program headers directly from this
- binary's ELF header at the fixed non-PIE load base (see SetupTLS). A
- non-PIE ET_EXEC always maps its own header there, so this is exact and
- needs no kernel auxv. }
- SetupTLS();
-
- Ret := MainTrampoline(Integer(Argc), Argv);
- _exit(Ret);
-end;
-
-{ The kernel entry. Capture %rsp (points at argc), align, and call the Pascal
- core. Never returns. }
-procedure _start; assembler; nostackframe;
-asm
- endbr64
- xor %ebp, %ebp
- movq %rsp, %rdi { SP -> first arg }
- andq $0xfffffffffffffff0, %rsp
- call _BlaiseStartC
- xorl %edi, %edi
- movq $1, %rax { SYS_exit(0) guard }
- syscall
- hlt
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.start.static.linux.pas b/compiler/src/main/pascal/runtime.start.static.linux.pas
deleted file mode 100644
index a0a5428..0000000
--- a/compiler/src/main/pascal/runtime.start.static.linux.pas
+++ /dev/null
@@ -1,260 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.start.static.linux;
-
-// Freestanding _start for a static, libc-free Linux ET_EXEC (the --static
-// kernel-leaf swap; docs/linux-syscall-migration.adoc).
-//
-// A tiny asm trampoline captures the initial stack pointer and tail-calls the
-// Pascal _BlaiseStartC, which:
-// 1. parses argc / argv / envp / the auxv (the kernel's initial stack);
-// 2. sets up the static TLS block and the thread pointer (%fs) - required
-// before any threadvar (%fs-relative) access, which a static binary's
-// kernel does NOT do for us;
-// 3. captures `environ`;
-// 4. calls main(argc, argv);
-// 5. exit_group with main's return (main itself calls exit, so this is a
-// guard).
-//
-// x86-64 TLS (variant II): the thread pointer points at the TCB, which sits
-// ABOVE the TLS block; threadvars are at negative offsets from the TP. %fs:0
-// must hold the TP value itself (the TCB self-pointer). Layout we build:
-// [ TLS block: memsz bytes ][ TCB: 8-byte self-pointer ]
-// tp = block + memsz_aligned ; %fs = tp ; *(void**)tp = tp.
-
-interface
-
-uses
- runtime.syscall.linux; { syscalls + the `environ` global }
-
-procedure _start;
-
-{ The static TLS template, captured from PT_TLS at startup so each spawned thread
- can build its own TLS block (runtime.thread.static.linux uses these via clone +
- CLONE_SETTLS). Zero TlsMemSz means the program has no thread-local storage. }
-var
- GTlsInitAddr: Pointer; { .tdata init image (= PT_TLS p_vaddr) }
- GTlsFileSz: Int64; { bytes to copy from the init image }
- GTlsMemSz: Int64; { total TLS size (.tdata + .tbss) }
- GTlsAlign: Int64; { PT_TLS alignment }
-
-{ Build a fresh TLS block for a new thread and return its thread pointer (the
- value to load into %fs). Layout matches _start's SetupTLS: aligned TLS data
- followed by the TCB self-pointer. Returns nil when the program has no TLS. }
-function BuildThreadTLS: Pointer;
-
-{ Unmap a TLS block created by BuildThreadTLS, given the thread pointer it
- returned. Used to reclaim the block when thread creation fails after the TLS
- was built (the offset from TP back to the mmap base is the same alignment math
- BuildThreadTLS used, kept here so both sides agree). }
-procedure FreeThreadTLS(ATp: Pointer);
-
-implementation
-
-type
- PPointer = ^Pointer;
- PInt64 = ^Int64;
-
-const
- ARCH_SET_FS = $1002;
- PROT_RW = 3; { PROT_READ or PROT_WRITE }
- MAP_PRIVANON = $22; { MAP_PRIVATE or MAP_ANONYMOUS }
- AT_NULL = 0;
- AT_PHDR = 3;
- AT_PHENT = 4;
- AT_PHNUM = 5;
- PT_TLS = 7;
-
-{ ELF64 Phdr field offsets. }
- PH_TYPE = 0; { p_type (u32) }
- PH_OFFSET = 8; { p_offset (u64) - file offset; == vaddr-base in our images }
- PH_VADDR = 16; { p_vaddr (u64) }
- PH_FILESZ = 32; { p_filesz (u64) }
- PH_MEMSZ = 40; { p_memsz (u64) }
- PH_ALIGN = 48; { p_align (u64) }
-
-{ Round X up to the next multiple of A (A a power of two, >= 1). }
-function AlignUp(X, A: Int64): Int64;
-begin
- if A < 1 then A := 1;
- Result := (X + A - 1) and (not (A - 1));
-end;
-
-{ Walk the auxv for PT_TLS via AT_PHDR/AT_PHENT/AT_PHNUM, then build the static
- TLS block and set the thread pointer. Auxv is an array of (Int64 tag, Int64
- val) pairs terminated by AT_NULL. No-op when the program has no TLS. }
-procedure SetupTLS(Auxv: Pointer);
-var
- P: PInt64;
- PhdrAddr, PhEnt, PhNum: Int64;
- I, Tag, Val: Int64;
- Ph: PChar;
- TlsVaddr, TlsFileSz, TlsMemSz, TlsAlign: Int64;
- PType: ^Integer;
- Block, Tp: Pointer;
- BlockSize: Int64;
- J: Int64;
- Src, Dst: PChar;
- TpSlot: PPointer;
-begin
- PhdrAddr := 0; PhEnt := 56; PhNum := 0;
- P := PInt64(Auxv);
- while True do
- begin
- Tag := P^;
- P := PInt64(Pointer(PChar(P) + 8));
- Val := P^;
- P := PInt64(Pointer(PChar(P) + 8));
- if Tag = AT_NULL then Break;
- if Tag = AT_PHDR then PhdrAddr := Val;
- if Tag = AT_PHENT then PhEnt := Val;
- if Tag = AT_PHNUM then PhNum := Val;
- end;
- if PhdrAddr = 0 then Exit;
-
- { Find PT_TLS among the program headers. }
- TlsVaddr := 0; TlsFileSz := 0; TlsMemSz := 0; TlsAlign := 8;
- I := 0;
- while I < PhNum do
- begin
- Ph := PChar(Pointer(PhdrAddr + I * PhEnt));
- PType := Pointer(Ph + PH_TYPE);
- if PType^ = PT_TLS then
- begin
- TlsVaddr := PInt64(Pointer(Ph + PH_VADDR))^;
- TlsFileSz := PInt64(Pointer(Ph + PH_FILESZ))^;
- TlsMemSz := PInt64(Pointer(Ph + PH_MEMSZ))^;
- TlsAlign := PInt64(Pointer(Ph + PH_ALIGN))^;
- Break;
- end;
- I := I + 1;
- end;
- if TlsMemSz = 0 then Exit;
-
- { Stash the template so BuildThreadTLS can reproduce this block per thread. }
- GTlsInitAddr := Pointer(TlsVaddr);
- GTlsFileSz := TlsFileSz;
- GTlsMemSz := TlsMemSz;
- GTlsAlign := TlsAlign;
-
- { Allocate block = aligned(memsz) + 8 (TCB self-pointer). mmap zero-fills. }
- BlockSize := AlignUp(TlsMemSz, TlsAlign) + 16;
- Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Block) < 0 then Exit;
-
- { Copy the .tdata init image to the start of the block; .tbss stays zero. }
- Src := PChar(Pointer(TlsVaddr));
- Dst := PChar(Block);
- J := 0;
- while J < TlsFileSz do
- begin
- Dst[J] := Src[J];
- J := J + 1;
- end;
-
- { Thread pointer sits just past the TLS data (variant II); store the TCB
- self-pointer at *tp and set %fs. }
- Tp := Pointer(PChar(Block) + AlignUp(TlsMemSz, TlsAlign));
- TpSlot := PPointer(Tp);
- TpSlot^ := Tp;
- arch_prctl(ARCH_SET_FS, Tp);
-end;
-
-{ Build a per-thread TLS block from the template captured at startup and return
- its thread pointer. Mirrors SetupTLS's block construction (variant II: TLS
- data, then the TCB self-pointer at the thread pointer). The caller installs
- the returned TP into %fs (clone's CLONE_SETTLS does that for a new thread). }
-function BuildThreadTLS: Pointer;
-var
- Block, Tp: Pointer;
- BlockSize, J: Int64;
- Src, Dst: PChar;
- TpSlot: PPointer;
-begin
- Result := nil;
- if GTlsMemSz = 0 then Exit;
- BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
- Block := mmap(nil, BlockSize, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Block) < 0 then Exit;
- Src := PChar(GTlsInitAddr);
- Dst := PChar(Block);
- J := 0;
- while J < GTlsFileSz do
- begin
- Dst[J] := Src[J];
- J := J + 1;
- end;
- Tp := Pointer(PChar(Block) + AlignUp(GTlsMemSz, GTlsAlign));
- TpSlot := PPointer(Tp);
- TpSlot^ := Tp;
- Result := Tp;
-end;
-
-procedure FreeThreadTLS(ATp: Pointer);
-var
- Block: Pointer;
- BlockSize: Int64;
-begin
- if (ATp = nil) or (GTlsMemSz = 0) then Exit;
- Block := Pointer(PChar(ATp) - AlignUp(GTlsMemSz, GTlsAlign));
- BlockSize := AlignUp(GTlsMemSz, GTlsAlign) + 16;
- munmap(Block, BlockSize);
-end;
-
-{ Call the program's `main(argc, argv)` (emitted by the backend) and return its
- result. The asm thunk tail-jumps to the bare `main` symbol; argc/argv are
- already in %edi/%rsi (SysV), exactly what main expects. }
-function MainTrampoline(Argc: Integer; Argv: Pointer): Integer;
- assembler; nostackframe;
-asm
- jmp main
-end;
-
-{ The C-level entry: SP points at the kernel's initial stack (argc at [SP]). }
-procedure _BlaiseStartC(SP: Pointer);
-var
- Argc: Int64;
- Argv, Envp, Auxv: Pointer;
- I: Int64;
- Ret: Integer;
-begin
- Argc := PInt64(SP)^;
- Argv := Pointer(PChar(SP) + 8);
- { envp = &argv[argc+1] }
- Envp := Pointer(PChar(Argv) + (Argc + 1) * 8);
- environ := Envp;
- { auxv follows envp's NULL terminator. }
- Auxv := Envp;
- I := 0;
- while PPointer(Pointer(PChar(Auxv) + I * 8))^ <> nil do
- I := I + 1;
- Auxv := Pointer(PChar(Auxv) + (I + 1) * 8);
-
- SetupTLS(Auxv);
-
- Ret := MainTrampoline(Integer(Argc), Argv);
- _exit(Ret);
-end;
-
-{ The kernel entry. Capture %rsp (points at argc), align, and call the Pascal
- core. Never returns. }
-procedure _start; assembler; nostackframe;
-asm
- endbr64
- xor %ebp, %ebp
- movq %rsp, %rdi { SP -> first arg }
- andq $0xfffffffffffffff0, %rsp
- call _BlaiseStartC
- xorl %edi, %edi
- movq $231, %rax { exit_group(0) guard }
- syscall
- hlt
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.syscall.freebsd.pas b/compiler/src/main/pascal/runtime.syscall.freebsd.pas
deleted file mode 100644
index 51b294f..0000000
--- a/compiler/src/main/pascal/runtime.syscall.freebsd.pas
+++ /dev/null
@@ -1,614 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.syscall.freebsd;
-
-// FreeBSD x86_64 direct-syscall kernel leaf — the libc replacement for a static,
-// libc-free FreeBSD ET_EXEC (docs/freebsd-x86_64-backend-design.adoc, Step 3/4).
-//
-// This is the FreeBSD sibling of runtime.syscall.linux. It DEFINES the bare
-// POSIX names that rtl.platform.posix references via `external name 'write'`
-// etc.; the FreeBSD RTL composition links it (the link-time swap) in place of
-// the Linux leaf, so the resulting binary reaches the kernel with raw
-// `syscall`s and needs no libc, no PT_INTERP.
-//
-// Step 4a scope: the file/process syscall leaves (open/close/read/write/lseek,
-// stat/fstat/mkdir/rmdir/unlink/rename/chdir/chmod, getpid/dup2/pipe/fork/
-// execve/wait4/kill/getcwd, mmap/munmap/nanosleep/clock_gettime), plus the
-// pre-existing `_exit`, `_sys_write` and `environ`. The harder leaves
-// (memcpy/memset, date math, the mmap allocator, threads) grow here in Steps
-// 4b/4c.
-//
-// System V AMD64 -> FreeBSD syscall ABI:
-// * syscall number in %rax; args in %rdi,%rsi,%rdx,%r10,%r8,%r9 (the 4th C
-// arg %rcx must be moved to %r10 — the `syscall` instruction clobbers %rcx).
-// * The syscall NUMBERS differ from Linux (exit=1, write=4, read=3, open=5,
-// close=6 — see sys/syscall.h); they are NOT Linux's. FreeBSD 12 renumbered
-// stat/fstat/lseek/mmap for the 64-bit-inode ("ino64") ABI; this leaf uses
-// the ino64 numbers to match the FreeBSD 14 224-byte `struct stat` that the
-// rtl.platform.layout.freebsd adapter expects.
-// * ERROR CONVENTION — the key FreeBSD difference from Linux. FreeBSD reports
-// errors via the CARRY FLAG: on error CF is set and %rax holds a POSITIVE
-// errno; on success CF is clear and %rax is the result. The Pascal call
-// sites in rtl.platform.posix expect the Linux -errno convention (they test
-// `if Fd < 0`, `< 0`, `<> 0`). So every leaf that can fail translates:
-// after `syscall`, `jae` past a `negq %rax` when CF is clear (success —
-// leave %rax untouched); when CF is set, `negq %rax` turns the positive
-// errno into -errno. Each body uses a UNIQUE local label (.Lok_xxx) so the
-// forward-local jumps do not collide when the unit assembles to one object.
-//
-// `nostackframe` lets each asm body own the frame so the registers hold the raw
-// incoming arguments unmodified.
-
-interface
-
-{ File descriptors. }
-function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
-function close(Fd: Integer): Integer;
-function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
-{ `write` collides with the Write/WriteLn builtin as a Pascal identifier, so the
- Pascal name is _sys_write; the asm body additionally emits a bare `write`
- label (.globl) so the linker symbol matches rtl.platform.posix's
- `external name 'write'`. Every other leaf's name is a valid Pascal identifier
- and needs no alias. }
-function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
-function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
-
-{ Filesystem. }
-function fstat(Fd: Integer; Buf: Pointer): Integer;
-{ FreeBSD's ino64 ABI has NO plain `stat` syscall — it is expressed as
- fstatat(AT_FDCWD, path, buf, 0). This wrapper sets up that call so the bare
- `stat` symbol posix imports still resolves. }
-function stat(Path: PChar; Buf: Pointer): Integer;
-function mkdir(Path: PChar; Mode: Integer): Integer;
-function rmdir(Path: PChar): Integer;
-function unlink(Path: PChar): Integer;
-function rename(OldPath, NewPath: PChar): Integer;
-function chdir(Path: PChar): Integer;
-function chmod(Path: PChar; Mode: Integer): Integer;
-
-{ Process. }
-function getpid: Integer;
-function dup2(OldFd, NewFd: Integer): Integer;
-{ FreeBSD deprecated the 2-arg pipe(2) (legacy 42); this calls pipe2(fds, 0). }
-function pipe(Fds: Pointer): Integer;
-
-{ Memory. }
-function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
- Offset: Int64): Pointer;
-function munmap(Addr: Pointer; Length: Int64): Integer;
-
-{ mremap(old, oldsz, newsz, flags): FreeBSD has NO in-place remap syscall, so
- this is a stub that always reports failure (MAP_FAILED = -1). runtime.mem's
- large-realloc path already treats an mremap failure as "grow the slow way":
- it allocates a fresh region, memcpy's the old contents across, and frees the
- old one (see the MapFailed fall-through in _BlaiseReallocMem). Exporting the
- `mremap` symbol as a failing stub therefore gives the allocator its no-mremap
- grow fallback with no allocator changes. Signature matches the Linux leaf so
- runtime.mem's `external name 'mremap'` binds on both targets. }
-function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
- NewAddr: Pointer): Pointer;
-
-{ Time. }
-function nanosleep(Req, Rem: Pointer): Integer;
-function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
-
-{ Process control + raw primitives the higher-level wrappers build on. }
-function fork: Integer;
-function execve(Path: PChar; Argv, Envp: Pointer): Integer;
-function wait4(Pid: Integer; Status: Pointer; Options: Integer;
- Rusage: Pointer): Integer;
-function kill(Pid, Sig: Integer): Integer;
-{ getrandom(buf, count, flags): fill buf with count random bytes; returns the
- count written or -errno. Used by mkstemp's random suffix. }
-function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
-{ Raw __getcwd(2): fills Buf (up to Size); returns 0 on success or -errno. The
- wrapper in the posix layer adapts that to libc's buffer-pointer contract. }
-function sys_getcwd(Buf: PChar; Size: Int64): Int64;
-
-{ Raw __sysctl(2) — SYS 202. FreeBSD's structured kernel-state query; the
- freestanding sysconf (runtime.libc.freebsd) reads hw.ncpu through it since
- FreeBSD has no sched_getaffinity. 6-arg syscall (arg4 %rcx -> %r10); returns
- 0 on success or -errno (CF-translated). }
-function sysctl(Name: Pointer; NameLen: Integer; OldP: Pointer;
- OldLenP: Pointer; NewP: Pointer; NewLen: Int64): Integer;
-
-{ Threads + TLS (Step 4c) — the FreeBSD primitives runtime.thread.static.freebsd
- and runtime.start.static.freebsd build on. These have no Linux equivalents
- (Linux uses clone/futex/arch_prctl); the numbers are FreeBSD-specific. }
-
-{ sysarch(op, parms) — SYS 165. The FreeBSD way to set the %fs base for TLS:
- op = AMD64_SET_FSBASE (129), parms = a POINTER to the base value (NOT the value
- itself). Returns 0 on success or -errno (CF-translated). }
-function sysarch(Op: Integer; Parms: Pointer): Integer;
-
-{ _umtx_op(obj, op, val, uaddr, uaddr2) — SYS 454. The FreeBSD futex analogue.
- op = UMTX_OP_WAIT_UINT_PRIVATE (15) blocks while obj^ = val (returns at once if
- obj^ <> val, like futex); op = UMTX_OP_WAKE_PRIVATE (16) wakes up to val waiters
- on obj. 5-arg syscall: arg4 (uaddr) arrives in %rcx -> moved to %r10. }
-function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
-
-{ thr_new(param, param_size) — SYS 455. Creates a new thread from a filled-in
- `struct thr_param` (param_size = sizeof = 104 on amd64). The FreeBSD analogue
- of clone(2). Returns 0 on success or -errno. }
-function thr_new(Param: Pointer; ParamSize: Integer): Integer;
-
-{ thr_exit(state) — SYS 431. Terminates JUST the calling thread (NOT the whole
- process — that is exit(2)/SYS_exit). If state is non-nil the kernel writes 1
- there and _umtx_op-wakes it; we clear/wake the join word ourselves and pass nil.
- Never returns. }
-procedure thr_exit(State: Pointer);
-
-{ _exit(2) — SYS_exit = 1. Terminates the process; never returns. The
- unit-level routine name `_exit` already emits the unmangled `_exit` symbol that
- satisfies posix's `external name '_exit'`. }
-procedure _exit(Code: Integer);
-
-{ The current process environment (envp), captured by _start. rtl.platform.posix
- / getenv walk this NULL-terminated array. Defined here (as on Linux) so the
- kernel leaf owns it. }
-var
- environ: Pointer;
-
-implementation
-
-{ ---- FreeBSD x86_64 syscall numbers (FreeBSD 14 sys/sys/syscall.h). ----
- Verified against
- https://raw.githubusercontent.com/freebsd/freebsd-src/release/14.0.0/sys/sys/syscall.h
- ino64 variants used where FreeBSD 12 renumbered (fstat=551, lseek=478,
- mmap=477; stat has no ino64 syscall — expressed via fstatat=552). }
-const
- SYS_exit = 1;
- SYS_fork = 2;
- SYS_read = 3;
- SYS_write = 4;
- SYS_open = 5;
- SYS_close = 6;
- SYS_wait4 = 7;
- SYS_unlink = 10;
- SYS_chdir = 12;
- SYS_chmod = 15;
- SYS_getpid = 20;
- SYS_kill = 37;
- SYS_munmap = 73;
- SYS_dup2 = 90;
- SYS_rename = 128;
- SYS_mkdir = 136;
- SYS_rmdir = 137;
- SYS_getcwd = 326; { __getcwd }
- SYS_sysctl = 202; { __sysctl (hw.ncpu for sysconf) }
- SYS_getrandom = 563;
- SYS_clock_gettime = 232;
- SYS_nanosleep = 240;
- SYS_mmap = 477; { ino64 (legacy freebsd6 mmap = 197) }
- SYS_lseek = 478; { ino64 (legacy lseek = 199) }
- SYS_fstat = 551; { ino64 (legacy freebsd11_fstat = 189) }
- SYS_fstatat = 552; { ino64 (legacy freebsd11_fstatat = 493) }
- SYS_pipe2 = 542; { pipe(2) legacy 42 deprecated }
- SYS_execve = 59;
- SYS_sysarch = 165; { %fs-base setup for TLS (AMD64_SET_FSBASE) }
- SYS_thr_exit = 431; { terminate ONE thread (NOT exit(2)) }
- SYS_umtx_op = 454; { the FreeBSD futex analogue }
- SYS_thr_new = 455; { the FreeBSD clone(2) analogue }
- AT_FDCWD = -100; { dirfd for path-relative *at() syscalls at cwd }
-{ The asm bodies use literal immediates (the assembler needs a literal, not a
- symbol); the const block above documents the number-to-name mapping. }
-
-function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $5, %rax { SYS_open }
- syscall
- jae .Lok_open { CF clear = success }
- negq %rax { CF set = error: errno -> -errno }
-.Lok_open:
- ret
-end;
-
-function close(Fd: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $6, %rax { SYS_close }
- syscall
- jae .Lok_close
- negq %rax
-.Lok_close:
- ret
-end;
-
-function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
- assembler; nostackframe;
-asm
- movq $3, %rax { SYS_read }
- syscall
- jae .Lok_read
- negq %rax
-.Lok_read:
- ret
-end;
-
-{ write CAN fail; posix's write-loop expects a negative return on error, so it
- gets CF-translation too. }
-function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
- assembler; nostackframe;
-asm
-.globl write
-write:
- movq $4, %rax { SYS_write }
- syscall
- jae .Lok_write
- negq %rax
-.Lok_write:
- ret
-end;
-
-function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
- assembler; nostackframe;
-asm
- movq $478, %rax { SYS_lseek (ino64) }
- syscall
- jae .Lok_lseek
- negq %rax
-.Lok_lseek:
- ret
-end;
-
-function fstat(Fd: Integer; Buf: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $551, %rax { SYS_fstat (ino64) }
- syscall
- jae .Lok_fstat
- negq %rax
-.Lok_fstat:
- ret
-end;
-
-{ stat(path, buf) -> fstatat(AT_FDCWD, path, buf, 0). Incoming: %rdi=Path,
- %rsi=Buf. Shift to the fstatat argument layout: dirfd(%rdi)=AT_FDCWD,
- path(%rsi)=Path, buf(%rdx)=Buf, flag(%r10)=0. arg4 goes straight to %r10
- (the syscall's 4th kernel register); no %rcx move is needed since we build
- the arguments here rather than receive four C args. }
-function stat(Path: PChar; Buf: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq %rsi, %rdx { buf -> arg3 }
- movq %rdi, %rsi { path -> arg2 }
- movq $-100, %rdi { AT_FDCWD -> arg1 (dirfd) }
- xorq %r10, %r10 { flag = 0 -> arg4 }
- movq $552, %rax { SYS_fstatat (ino64) }
- syscall
- jae .Lok_stat
- negq %rax
-.Lok_stat:
- ret
-end;
-
-function mkdir(Path: PChar; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $136, %rax { SYS_mkdir }
- syscall
- jae .Lok_mkdir
- negq %rax
-.Lok_mkdir:
- ret
-end;
-
-function chmod(Path: PChar; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $15, %rax { SYS_chmod }
- syscall
- jae .Lok_chmod
- negq %rax
-.Lok_chmod:
- ret
-end;
-
-function rmdir(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $137, %rax { SYS_rmdir }
- syscall
- jae .Lok_rmdir
- negq %rax
-.Lok_rmdir:
- ret
-end;
-
-function unlink(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $10, %rax { SYS_unlink }
- syscall
- jae .Lok_unlink
- negq %rax
-.Lok_unlink:
- ret
-end;
-
-function rename(OldPath, NewPath: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $128, %rax { SYS_rename }
- syscall
- jae .Lok_rename
- negq %rax
-.Lok_rename:
- ret
-end;
-
-function chdir(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $12, %rax { SYS_chdir }
- syscall
- jae .Lok_chdir
- negq %rax
-.Lok_chdir:
- ret
-end;
-
-function getpid: Integer;
- assembler; nostackframe;
-asm
- movq $20, %rax { SYS_getpid }
- syscall
- ret { getpid never fails; no CF translation }
-end;
-
-function dup2(OldFd, NewFd: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $90, %rax { SYS_dup2 }
- syscall
- jae .Lok_dup2
- negq %rax
-.Lok_dup2:
- ret
-end;
-
-{ pipe(fds) -> pipe2(fds, 0). Incoming: %rdi=Fds; add flags=0 in %rsi. }
-function pipe(Fds: Pointer): Integer;
- assembler; nostackframe;
-asm
- xorq %rsi, %rsi { flags = 0 }
- movq $542, %rax { SYS_pipe2 }
- syscall
- jae .Lok_pipe
- negq %rax
-.Lok_pipe:
- ret
-end;
-
-{ mmap has 6 args; arg4 (Flags) arrives in %rcx (C ABI) but the kernel wants it
- in %r10. Move it before the syscall.
-
- Flag translation: the shared allocator (runtime.mem) and other callers pass
- the LINUX MAP_ANONYMOUS bit (0x20); FreeBSD's MAP_ANON is 0x1000. Without
- MAP_ANON the kernel treats the mapping as file-backed on fd -1 and fails with
- EBADF (then the caller derefs the -errno result and SIGSEGVs). So if the
- Linux anon bit is set, clear it and set FreeBSD's — keeping runtime.mem
- OS-agnostic (it uses one canonical, Linux-shaped flag set; the per-OS leaf
- reconciles it). 0x1000 already set (e.g. from runtime.start.static.freebsd)
- passes through untouched. }
-function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
- Offset: Int64): Pointer;
- assembler; nostackframe;
-asm
- testl $0x20, %ecx { Linux MAP_ANONYMOUS present? }
- jz .Lnoanon_mmap
- andl $0xffffffdf, %ecx { clear 0x20 }
- orl $0x1000, %ecx { set FreeBSD MAP_ANON }
-.Lnoanon_mmap:
- movq %rcx, %r10
- movq $477, %rax { SYS_mmap (ino64) }
- syscall
- jae .Lok_mmap
- negq %rax
-.Lok_mmap:
- ret
-end;
-
-function munmap(Addr: Pointer; Length: Int64): Integer;
- assembler; nostackframe;
-asm
- movq $73, %rax { SYS_munmap }
- syscall
- jae .Lok_munmap
- negq %rax
-.Lok_munmap:
- ret
-end;
-
-{ mremap: no FreeBSD in-place-remap syscall. Always return MAP_FAILED (-1) so
- the allocator takes its alloc-new-copy-free fallback (see the interface note). }
-function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
- NewAddr: Pointer): Pointer;
-begin
- Result := Pointer(-1);
-end;
-
-function nanosleep(Req, Rem: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $240, %rax { SYS_nanosleep }
- syscall
- jae .Lok_nanosleep
- negq %rax
-.Lok_nanosleep:
- ret
-end;
-
-function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $232, %rax { SYS_clock_gettime }
- syscall
- jae .Lok_clock_gettime
- negq %rax
-.Lok_clock_gettime:
- ret
-end;
-
-{ FreeBSD fork(2) has a two-register return the libc wrapper normalises and a
- raw syscall must replicate: the kernel returns the child pid in %rax for the
- PARENT with %edx = 0, but for the CHILD it returns the PARENT's pid in %rax
- with %edx = 1 as the child indicator. Without zeroing the child's %eax when
- %edx != 0, the child sees a non-zero "pid" and every `if fork() = 0 then
- (child path)` check runs the PARENT branch in the child — so a spawned
- subprocess never execve's its target and the parent reaps exit 127. Mirror
- libc: if %edx != 0, this is the child -> return 0. }
-function fork: Integer;
- assembler; nostackframe;
-asm
- movq $2, %rax { SYS_fork }
- syscall
- jae .Lok_fork
- negq %rax
- ret
-.Lok_fork:
- testl %edx, %edx { %edx = 1 in the child, 0 in the parent }
- jz .Lparent_fork
- xorl %eax, %eax { child: return 0 }
-.Lparent_fork:
- ret
-end;
-
-function execve(Path: PChar; Argv, Envp: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $59, %rax { SYS_execve }
- syscall
- jae .Lok_execve
- negq %rax
-.Lok_execve:
- ret
-end;
-
-{ wait4 has 4 args; arg4 (Rusage) arrives in %rcx -> move to %r10. }
-function wait4(Pid: Integer; Status: Pointer; Options: Integer;
- Rusage: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $7, %rax { SYS_wait4 }
- syscall
- jae .Lok_wait4
- negq %rax
-.Lok_wait4:
- ret
-end;
-
-function kill(Pid, Sig: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $37, %rax { SYS_kill }
- syscall
- jae .Lok_kill
- negq %rax
-.Lok_kill:
- ret
-end;
-
-function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
- assembler; nostackframe;
-asm
- movq $563, %rax { SYS_getrandom }
- syscall
- jae .Lok_getrandom
- negq %rax
-.Lok_getrandom:
- ret
-end;
-
-function sys_getcwd(Buf: PChar; Size: Int64): Int64;
- assembler; nostackframe;
-asm
- movq $326, %rax { SYS___getcwd }
- syscall
- jae .Lok_getcwd
- negq %rax
-.Lok_getcwd:
- ret
-end;
-
-{ __sysctl(name, namelen, oldp, oldlenp, newp, newlen) — 6 args; SYS 202. arg4
- (oldlenp) arrives in %rcx and must move to %r10 (syscall clobbers %rcx). }
-function sysctl(Name: Pointer; NameLen: Integer; OldP: Pointer;
- OldLenP: Pointer; NewP: Pointer; NewLen: Int64): Integer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $202, %rax { SYS___sysctl }
- syscall
- jae .Lok_sysctl
- negq %rax
-.Lok_sysctl:
- ret
-end;
-
-{ sysarch(op, parms) — 2 args, both in %rdi/%rsi already; SYS 165. Used with
- AMD64_SET_FSBASE to set the %fs base to the thread pointer. }
-function sysarch(Op: Integer; Parms: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $165, %rax { SYS_sysarch }
- syscall
- jae .Lok_sysarch
- negq %rax
-.Lok_sysarch:
- ret
-end;
-
-{ _umtx_op(obj, op, val, uaddr, uaddr2) — 5 args; arg4 (uaddr) arrives in %rcx
- (C ABI) but the kernel wants it in %r10. Move it before the syscall. SYS 454. }
-function _umtx_op(Obj: Pointer; Op, Val: Integer; Uaddr, Uaddr2: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $454, %rax { SYS__umtx_op }
- syscall
- jae .Lok_umtx
- negq %rax
-.Lok_umtx:
- ret
-end;
-
-{ thr_new(param, param_size) — 2 args, both in %rdi/%rsi already; SYS 455. }
-function thr_new(Param: Pointer; ParamSize: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $455, %rax { SYS_thr_new }
- syscall
- jae .Lok_thr_new
- negq %rax
-.Lok_thr_new:
- ret
-end;
-
-{ thr_exit(state) — SYS 431. Terminates JUST this thread; never returns, so no
- CF translation is needed. State arrives in %rdi (nil in our use). }
-procedure thr_exit(State: Pointer); assembler; nostackframe;
-asm
- movq $431, %rax { SYS_thr_exit }
- syscall
- ret
-end;
-
-{ _exit(code) — SYS_exit = 1. Terminates the process; never returns, so no
- CF translation is needed. }
-procedure _exit(Code: Integer); assembler; nostackframe;
-asm
- movq $1, %rax { SYS_exit }
- syscall
- ret
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.syscall.linux.pas b/compiler/src/main/pascal/runtime.syscall.linux.pas
deleted file mode 100644
index 0476da1..0000000
--- a/compiler/src/main/pascal/runtime.syscall.linux.pas
+++ /dev/null
@@ -1,426 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.syscall.linux;
-
-// Linux x86_64 direct-syscall kernel leaf - the libc replacement for the thin
-// 1:1 syscall wrappers (docs/linux-syscall-migration.adoc).
-//
-// This unit DEFINES the bare POSIX names (open, read, write, ) that
-// rtl.platform.posix.pas references via `external name 'open'` etc. When it is
-// linked into a program (the --static link-time swap), those symbols resolve
-// here as raw `syscall` stubs instead of being imported from libc.so.6 - so the
-// resulting binary is a freestanding static ET_EXEC with no libc, no PT_INTERP.
-//
-// System V AMD64 -> Linux syscall ABI:
-// * syscall number in %rax; the `syscall` instruction returns in %rax.
-// * Argument registers DIFFER between the C ABI and the kernel ABI on the 4th
-// argument: C passes arg4 in %rcx, the kernel expects it in %r10 (the
-// `syscall` instruction itself clobbers %rcx). Wrappers with >= 4 args
-// therefore `movq %rcx, %r10` first. Args 1-3 (%rdi,%rsi,%rdx) and 5-6
-// (%r8,%r9) are already in the right registers.
-// * The kernel returns -errno on error (a small negative value). libc would
-// translate that to a -1 return + `errno`; the existing Pascal call sites
-// test `if result < 0` / `if Fd < 0`, which a raw -errno also satisfies, so
-// no errno table is needed for these leaves.
-//
-// `nostackframe` lets each asm body own the frame so the registers hold the raw
-// incoming arguments unmodified.
-
-interface
-
-{ File descriptors. }
-function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
-function close(Fd: Integer): Integer;
-function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
-{ `write` collides with the Write/WriteLn builtin as a Pascal identifier, so the
- Pascal name is _sys_write; the asm body additionally emits a bare `write`
- label (.globl) so the linker symbol matches rtl.platform.posix's
- `external name 'write'`. Every other leaf's name is a valid Pascal identifier
- and needs no alias. }
-function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
-function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
-
-{ Filesystem. }
-function fstat(Fd: Integer; Buf: Pointer): Integer;
-function stat(Path: PChar; Buf: Pointer): Integer;
-function mkdir(Path: PChar; Mode: Integer): Integer;
-function rmdir(Path: PChar): Integer;
-function unlink(Path: PChar): Integer;
-function rename(OldPath, NewPath: PChar): Integer;
-function chdir(Path: PChar): Integer;
-function chmod(Path: PChar; Mode: Integer): Integer;
-
-{ Process. }
-function getpid: Integer;
-function dup2(OldFd, NewFd: Integer): Integer;
-function pipe(Fds: Pointer): Integer;
-
-{ Memory. }
-function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
- Offset: Int64): Pointer;
-function munmap(Addr: Pointer; Length: Int64): Integer;
-{ mremap(old, oldsz, newsz, flags, newaddr) - 5 args; raw syscall. }
-function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
- NewAddr: Pointer): Pointer;
-
-{ Time. }
-function nanosleep(Req, Rem: Pointer): Integer;
-function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
-
-{ Process control + raw primitives the higher-level wrappers (runtime.libc.linux)
- build on. These are the bare syscalls; the libc-shaped versions (execvp with
- PATH search, waitpid, system, ) live in the wrapper unit. }
-function fork: Integer;
-function execve(Path: PChar; Argv, Envp: Pointer): Integer;
-function wait4(Pid: Integer; Status: Pointer; Options: Integer;
- Rusage: Pointer): Integer;
-function sched_getaffinity(Pid: Integer; CpuSetSize: Int64;
- Mask: Pointer): Integer;
-{ futex(2): the kernel primitive the threads leaf builds mutexes and join on.
- 6-arg syscall; arg4 (Timeout) arrives in %rcx -> moved to %r10. Returns 0 or
- a count on success, -errno on error. Op = FUTEX_WAIT(0) / FUTEX_WAKE(1). }
-function futex(Uaddr: Pointer; Op, Val: Integer; Timeout: Pointer;
- Uaddr2: Pointer; Val3: Integer): Integer;
-function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
-function arch_prctl(Code: Integer; Addr: Pointer): Integer;
-function kill(Pid, Sig: Integer): Integer;
-{ Raw time(2): returns seconds since the epoch; if T is non-nil it is also
- written there. The kernel syscall handles the out-param itself. }
-function sys_time(T: Pointer): Int64;
-{ Raw getcwd(2): fills Buf (up to Size), returns the length INCLUDING the NUL on
- success or -errno. (libc's getcwd returns the buffer pointer - the wrapper in
- runtime.libc.linux adapts that.) }
-function sys_getcwd(Buf: PChar; Size: Int64): Int64;
-
-{ _exit(2) - exit_group, terminates all threads, runs NO atexit handlers.
- The bare `exit` (which DOES run atexit handlers, called by main's epilogue) is
- defined by runtime.libc2.linux alongside the registry, not here. }
-procedure _exit(Code: Integer);
-
-{ The process environment vector (NULL-terminated array of "KEY=VALUE" PChars),
- captured by the freestanding _start from the initial stack. Lives in this
- base unit (not the higher libc wrapper) so _start can use ONLY this unit and
- avoid a diamond import; runtime.libc.linux's getenv/execvp read it. }
-var
- environ: Pointer;
-
-implementation
-
-{ ---- Linux x86_64 syscall numbers (arch/x86/entry/syscalls). ---- }
-const
- SYS_read = 0;
- SYS_write = 1;
- SYS_open = 2;
- SYS_close = 3;
- SYS_stat = 4;
- SYS_fstat = 5;
- SYS_lseek = 8;
- SYS_mmap = 9;
- SYS_munmap = 11;
- SYS_pipe = 22;
- SYS_dup2 = 33;
- SYS_nanosleep = 35;
- SYS_getpid = 39;
- SYS_rename = 82;
- SYS_mkdir = 83;
- SYS_chmod = 90;
- SYS_rmdir = 84;
- SYS_unlink = 87;
- SYS_chdir = 80;
- SYS_clock_gettime = 228;
- SYS_exit_group = 231;
- SYS_mremap = 25;
- SYS_fork = 57;
- SYS_execve = 59;
- SYS_wait4 = 61;
- SYS_kill = 62;
- SYS_getcwd = 79;
- SYS_sched_getaffinity = 204;
- SYS_futex = 202;
- SYS_arch_prctl = 158;
- SYS_time = 201;
- SYS_getrandom = 318;
-{ The asm bodies use literal immediates (the assembler needs a literal, not a
- symbol); the const block above documents the number-to-name mapping. }
-
-function open(Path: PChar; Flags: Integer; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $2, %rax { SYS_open }
- syscall
- ret
-end;
-
-function close(Fd: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $3, %rax { SYS_close }
- syscall
- ret
-end;
-
-function read(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
- assembler; nostackframe;
-asm
- movq $0, %rax { SYS_read }
- syscall
- ret
-end;
-
-function _sys_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64;
- assembler; nostackframe;
-asm
-.globl write
-write:
- movq $1, %rax { SYS_write }
- syscall
- ret
-end;
-
-function lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64;
- assembler; nostackframe;
-asm
- movq $8, %rax { SYS_lseek }
- syscall
- ret
-end;
-
-function fstat(Fd: Integer; Buf: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $5, %rax { SYS_fstat }
- syscall
- ret
-end;
-
-function stat(Path: PChar; Buf: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $4, %rax { SYS_stat }
- syscall
- ret
-end;
-
-function mkdir(Path: PChar; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $83, %rax { SYS_mkdir }
- syscall
- ret
-end;
-
-function chmod(Path: PChar; Mode: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $90, %rax { SYS_chmod }
- syscall
- ret
-end;
-
-function rmdir(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $84, %rax { SYS_rmdir }
- syscall
- ret
-end;
-
-function unlink(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $87, %rax { SYS_unlink }
- syscall
- ret
-end;
-
-function rename(OldPath, NewPath: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $82, %rax { SYS_rename }
- syscall
- ret
-end;
-
-function chdir(Path: PChar): Integer;
- assembler; nostackframe;
-asm
- movq $80, %rax { SYS_chdir }
- syscall
- ret
-end;
-
-function getpid: Integer;
- assembler; nostackframe;
-asm
- movq $39, %rax { SYS_getpid }
- syscall
- ret
-end;
-
-function dup2(OldFd, NewFd: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $33, %rax { SYS_dup2 }
- syscall
- ret
-end;
-
-function pipe(Fds: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $22, %rax { SYS_pipe }
- syscall
- ret
-end;
-
-{ mmap has 6 args; arg4 (Flags) arrives in %rcx (C ABI) but the kernel wants it
- in %r10. Move it before the syscall. }
-function mmap(Addr: Pointer; Length: Int64; Prot, Flags, Fd: Integer;
- Offset: Int64): Pointer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $9, %rax { SYS_mmap }
- syscall
- ret
-end;
-
-function munmap(Addr: Pointer; Length: Int64): Integer;
- assembler; nostackframe;
-asm
- movq $11, %rax { SYS_munmap }
- syscall
- ret
-end;
-
-function nanosleep(Req, Rem: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $35, %rax { SYS_nanosleep }
- syscall
- ret
-end;
-
-function clock_gettime(ClockId: Integer; Ts: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $228, %rax { SYS_clock_gettime }
- syscall
- ret
-end;
-
-{ mremap has 5 args; arg4 (Flags) arrives in %rcx -> move to %r10. }
-function mremap(OldAddr: Pointer; OldSize, NewSize: Int64; Flags: Integer;
- NewAddr: Pointer): Pointer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $25, %rax { SYS_mremap }
- syscall
- ret
-end;
-
-function fork: Integer;
- assembler; nostackframe;
-asm
- movq $57, %rax { SYS_fork }
- syscall
- ret
-end;
-
-function execve(Path: PChar; Argv, Envp: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $59, %rax { SYS_execve }
- syscall
- ret
-end;
-
-{ wait4 has 4 args; arg4 (Rusage) arrives in %rcx -> move to %r10. }
-function wait4(Pid: Integer; Status: Pointer; Options: Integer;
- Rusage: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $61, %rax { SYS_wait4 }
- syscall
- ret
-end;
-
-function sched_getaffinity(Pid: Integer; CpuSetSize: Int64;
- Mask: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $204, %rax { SYS_sched_getaffinity }
- syscall
- ret
-end;
-
-{ futex has 6 args; arg4 (Timeout) arrives in %rcx -> move to %r10. }
-function futex(Uaddr: Pointer; Op, Val: Integer; Timeout: Pointer;
- Uaddr2: Pointer; Val3: Integer): Integer;
- assembler; nostackframe;
-asm
- movq %rcx, %r10
- movq $202, %rax { SYS_futex }
- syscall
- ret
-end;
-
-function getrandom(Buf: Pointer; Count: Int64; Flags: Integer): Int64;
- assembler; nostackframe;
-asm
- movq $318, %rax { SYS_getrandom }
- syscall
- ret
-end;
-
-function arch_prctl(Code: Integer; Addr: Pointer): Integer;
- assembler; nostackframe;
-asm
- movq $158, %rax { SYS_arch_prctl }
- syscall
- ret
-end;
-
-function kill(Pid, Sig: Integer): Integer;
- assembler; nostackframe;
-asm
- movq $62, %rax { SYS_kill }
- syscall
- ret
-end;
-
-function sys_time(T: Pointer): Int64;
- assembler; nostackframe;
-asm
- movq $201, %rax { SYS_time }
- syscall
- ret
-end;
-
-function sys_getcwd(Buf: PChar; Size: Int64): Int64;
- assembler; nostackframe;
-asm
- movq $79, %rax { SYS_getcwd }
- syscall
- ret
-end;
-
-{ _exit(2): terminate immediately via exit_group, running no atexit handlers.
- Code arrives in %edi; exit_group reads its status from %rdi. }
-procedure _exit(Code: Integer);
- assembler; nostackframe;
-asm
- movq $231, %rax { SYS_exit_group }
- syscall
- ret
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.thread.static.freebsd.pas b/compiler/src/main/pascal/runtime.thread.static.freebsd.pas
deleted file mode 100644
index d7e52d0..0000000
--- a/compiler/src/main/pascal/runtime.thread.static.freebsd.pas
+++ /dev/null
@@ -1,317 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.thread.static.freebsd;
-
-// Real POSIX threads for the FreeBSD --static (libc-free) build, implemented
-// directly on the thr_new(2) and _umtx_op(2) syscalls
-// (docs/freebsd-x86_64-backend-design.adoc, Step 4c). The FreeBSD sibling of
-// runtime.thread.static.linux — the threads leaf that lets a static FreeBSD
-// binary spawn worker threads (the compiler's TCompileWorker = class(TThread)).
-//
-// DEFINES the bare pthread_* names that runtime.weak, runtime.thread and
-// classes.pas import via `external name`. The FreeBSD RTL composition links
-// this unit (the link-time swap) in place of the Linux thread leaf / libc.
-//
-// Mutex: TARGET-INVARIANT — a 3-state futex mutex (Drepper, "Futexes Are
-// Tricky"), copied verbatim from the Linux unit. The caller's mutex buffer is
-// reused as the wait word (first Integer): 0 = unlocked, 1 = locked (no
-// waiters), 2 = locked (waiters present). ONLY the kernel wait/wake primitive
-// differs: Linux futex(WAIT/WAKE) -> FreeBSD _umtx_op(WAIT_UINT_PRIVATE=15 /
-// WAKE_PRIVATE=16). WAIT_UINT returns at once if *word <> val (like futex), so
-// the loop structure is identical.
-//
-// Thread: thr_new(2) with a filled `struct thr_param` (amd64 sizeof = 104). Each
-// thread gets a fresh mmap'd stack + its own variant-II TLS block (built from
-// the startup template; installed as the new thread's %fs base via thr_param's
-// tls_base) so threadvar access (exception frames, the allocator) is per-thread.
-//
-// JOIN — the key FreeBSD difference from Linux. thr_new provides NO
-// CLONE_CHILD_CLEARTID-style "clear-and-wake the tid word on exit"; child_tid is
-// only written ONCE, on create, and never cleared on exit. So we use a dedicated
-// JOIN word in the control block: the child's exit trampoline sets JoinWord = 1
-// and _umtx_op-WAKEs it as its LAST act before thr_exit; pthread_join
-// _umtx_op-WAITs on it while it reads 0. thr_exit (SYS 431) terminates JUST the
-// thread — NOT exit(2)/SYS_exit, which would kill the whole process.
-//
-// Known limitation (same as the Linux leaf): a joined thread's TLS block is not
-// unmapped — freeing it from the exiting thread is unsafe (the thread runs on it
-// until thr_exit) and the join side cannot know its address. A small bounded
-// per-thread leak, acceptable for the finite worker pools the compiler spawns.
-
-interface
-
-uses
- runtime.syscall.freebsd, { mmap, _umtx_op, thr_new, thr_exit numbers }
- runtime.start.static.freebsd; { BuildThreadTLS - the per-thread TLS template }
-
-{ Mutex - the buffer's first Integer is the wait word. }
-function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
-function pthread_mutex_lock(Mutex: Pointer): Integer;
-function pthread_mutex_unlock(Mutex: Pointer): Integer;
-function pthread_mutex_destroy(Mutex: Pointer): Integer;
-
-{ Thread create / join. *Thread receives an opaque handle (a control-block
- pointer); pthread_join consumes it. }
-function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
-function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
-
-implementation
-
-type
- PInteger = ^Integer;
- PInt64 = ^Int64;
-
-const
- { Mutex wait-word states. }
- MX_UNLOCKED = 0;
- MX_LOCKED = 1;
- MX_CONTENDED = 2;
-
- { _umtx_op operations (FreeBSD 14 sys/sys/umtx.h; verified). }
- UMTX_OP_WAIT_UINT_PRIVATE = 15; { block while *obj = val }
- UMTX_OP_WAKE_PRIVATE = 16; { wake up to `val` waiters on obj }
-
- PROT_RW = 3; { PROT_READ or PROT_WRITE }
- MAP_PRIVANON = $1002; { FreeBSD MAP_PRIVATE ($0002) or MAP_ANON ($1000) }
- STACK_SIZE = 1024 * 1024; { 1 MiB per worker thread }
-
- { struct thr_param amd64 field offsets (FreeBSD 14 sys/sys/thr.h; verified). }
- TP_START_FUNC = 0; { void (*)(void*) }
- TP_ARG = 8; { void* }
- TP_STACK_BASE = 16; { char* }
- TP_STACK_SIZE = 24; { size_t }
- TP_TLS_BASE = 32; { char* }
- TP_TLS_SIZE = 40; { size_t }
- TP_CHILD_TID = 48; { long* }
- TP_PARENT_TID = 56; { long* }
- TP_FLAGS = 64; { int (+ 4 bytes pad) }
- TP_RTP = 72; { struct rtprio* }
- TP_SPARE0 = 80; { void*[3] -> 80,88,96 }
- THR_PARAM_SIZE = 104; { sizeof(struct thr_param) on amd64 }
-
-{ The per-thread control block lives at the base of the mmap'd region.
- StartRoutine/Arg are the real entry the trampoline calls; JoinWord is the
- _umtx_op join word (child sets 1 + WAKEs on exit, parent WAITs while it reads 0);
- TidWord is thr_new's child_tid (LONG* = 8 bytes on FreeBSD, so Int64 — the
- kernel writes the 8-byte TID here on create; unlike Linux it is NOT cleared on
- exit, hence the separate JoinWord). MapBase/MapSize record the region for
- munmap after join. }
-type
- PThreadCB = ^TThreadCB;
- TThreadCB = record
- StartRoutine: Pointer;
- Arg: Pointer;
- JoinWord: Integer;
- Pad: Integer;
- TidWord: Int64;
- MapBase: Pointer;
- MapSize: Int64;
- end;
-
-{ ------------------------------------------------------------------ }
-{ Mutex - 3-state futex (TARGET-INVARIANT; copied from the Linux leaf) }
-{ ------------------------------------------------------------------ }
-
-{ Atomic compare-and-swap on an Integer: if Ptr^ = Expected set it to NewVal;
- returns the value that was in Ptr^ before the attempt. }
-function CAS(Ptr: Pointer; Expected, NewVal: Integer): Integer;
- assembler; nostackframe;
-asm
- movl %esi, %eax { %eax = Expected (cmpxchg compares against %eax) }
- lock cmpxchgl %edx, (%rdi)
- ret
-end;
-
-{ Atomic exchange: store NewVal into Ptr^, return the previous value. }
-function Xchg(Ptr: Pointer; NewVal: Integer): Integer;
- assembler; nostackframe;
-asm
- movl %esi, %eax
- xchgl %eax, (%rdi)
- ret
-end;
-
-function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
-var
- P: PInteger;
-begin
- P := PInteger(Mutex);
- P^ := MX_UNLOCKED;
- Result := 0;
-end;
-
-function pthread_mutex_lock(Mutex: Pointer): Integer;
-var
- C: Integer;
-begin
- { Fast path: uncontended acquire. }
- C := CAS(Mutex, MX_UNLOCKED, MX_LOCKED);
- if C <> MX_UNLOCKED then
- begin
- { Contended. Mark the lock contended and sleep until it is free. }
- if C <> MX_CONTENDED then
- C := Xchg(Mutex, MX_CONTENDED);
- while C <> MX_UNLOCKED do
- begin
- { WAIT_UINT_PRIVATE blocks while *Mutex = MX_CONTENDED (returns at once if
- it already changed) — the FreeBSD analogue of FUTEX_WAIT. }
- _umtx_op(Mutex, UMTX_OP_WAIT_UINT_PRIVATE, MX_CONTENDED, nil, nil);
- C := Xchg(Mutex, MX_CONTENDED);
- end;
- end;
- Result := 0;
-end;
-
-function pthread_mutex_unlock(Mutex: Pointer): Integer;
-begin
- { If there were waiters (state 2), wake one after releasing. }
- if Xchg(Mutex, MX_UNLOCKED) = MX_CONTENDED then
- _umtx_op(Mutex, UMTX_OP_WAKE_PRIVATE, 1, nil, nil);
- Result := 0;
-end;
-
-function pthread_mutex_destroy(Mutex: Pointer): Integer;
-begin
- Result := 0;
-end;
-
-{ ------------------------------------------------------------------ }
-{ Thread create / join - thr_new(2) + _umtx_op(2) }
-{ ------------------------------------------------------------------ }
-
-{ Call Entry(Arg) — a raw indirect call so the trampoline can invoke the
- caller-supplied StartRoutine held only as a Pointer. Entry arrives in %rdi,
- Arg in %rsi; shuffle Arg to %rdi and call Entry. }
-procedure CallEntry(Entry, Arg: Pointer); assembler; nostackframe;
-asm
- movq %rdi, %r11 { Entry }
- movq %rsi, %rdi { Arg -> first arg }
- call *%r11 { Entry(Arg) }
- ret
-end;
-
-{ The thread's entry point (thr_param.start_func). The kernel starts the new
- thread here with %rdi = thr_param.arg (our control-block pointer), on the fresh
- stack, with the thread's own %fs already installed (tls_base). We call the real
- StartRoutine(Arg), then set JoinWord = 1 and _umtx_op-WAKE it so pthread_join
- unblocks, then thr_exit(nil) to terminate JUST this thread. }
-procedure _thr_trampoline(CBPtr: Pointer);
-var
- CB: PThreadCB;
- Entry: Pointer;
-begin
- CB := PThreadCB(CBPtr);
- Entry := CB^.StartRoutine;
- CallEntry(Entry, CB^.Arg);
- { Terminate this thread AND signal the joiner in one kernel step: pass the
- join word as thr_exit's `state`. The kernel does `suword(state, 1)` +
- umtx-wake on it AFTER the thread has stopped executing on its stack — so the
- joiner cannot free the stack while this thread is still running on it. (The
- previous code set JoinWord + WAKEd here, on the stack, BEFORE thr_exit, which
- let pthread_join munmap the shared stack/CB region out from under this still-
- live thread → SIGSEGV during teardown. Never touch the stack after the wake;
- let thr_exit's kernel-side wake be the last event on this word.) }
- thr_exit(@CB^.JoinWord);
-end;
-
-{ Store an 8-byte value at Base + Offset (used to fill struct thr_param). }
-procedure PokeQ(Base: Pointer; Offset: Integer; Value: Int64);
-var
- Slot: PInt64;
-begin
- Slot := PInt64(Pointer(PChar(Base) + Offset));
- Slot^ := Value;
-end;
-
-function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
-var
- Region: Pointer;
- CB: PThreadCB;
- StackTop: Pointer;
- Tls: Pointer;
- Param: array[0..THR_PARAM_SIZE - 1] of Byte;
- ParamP: Pointer;
- R: Integer;
- HandleSlot: PInt64;
-begin
- { One mapping holds the control block (at the base) and the thread stack
- (above it). mmap zero-fills, so JoinWord starts at 0. }
- Region := mmap(nil, STACK_SIZE, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Region) < 0 then
- begin
- Result := 11; { EAGAIN }
- Exit;
- end;
- CB := PThreadCB(Region);
- CB^.StartRoutine := StartRoutine;
- CB^.Arg := Arg;
- CB^.JoinWord := 0;
- CB^.TidWord := 0;
- CB^.MapBase := Region;
- CB^.MapSize := STACK_SIZE;
-
- { Stack grows down from the top of the region; keep it 16-byte aligned. }
- StackTop := Pointer(PChar(Region) + STACK_SIZE);
- StackTop := Pointer(Int64(StackTop) and (not Int64(15)));
-
- { Each thread needs its own TLS block for threadvar access. }
- Tls := BuildThreadTLS();
-
- { Fill struct thr_param on the stack (zero-init first so flags/rtp/spare = 0). }
- ParamP := @Param[0];
- PokeQ(ParamP, TP_START_FUNC, Int64(Pointer(@_thr_trampoline)));
- PokeQ(ParamP, TP_ARG, Int64(CB));
- PokeQ(ParamP, TP_STACK_BASE, Int64(Region));
- { stack_size = distance from the region base to the aligned stack top. }
- PokeQ(ParamP, TP_STACK_SIZE, Int64(StackTop) - Int64(Region));
- PokeQ(ParamP, TP_TLS_BASE, Int64(Tls));
- PokeQ(ParamP, TP_TLS_SIZE, ThreadTLSSize());
- PokeQ(ParamP, TP_CHILD_TID, Int64(@CB^.TidWord));
- PokeQ(ParamP, TP_PARENT_TID, Int64(@CB^.TidWord));
- PokeQ(ParamP, TP_FLAGS, 0); { flags = 0 (+ pad) }
- PokeQ(ParamP, TP_RTP, 0); { rtp = nil -> default scheduling }
- PokeQ(ParamP, TP_SPARE0, 0);
- PokeQ(ParamP, TP_SPARE0 + 8, 0);
- PokeQ(ParamP, TP_SPARE0 + 16, 0);
-
- R := thr_new(ParamP, THR_PARAM_SIZE);
- if R < 0 then
- begin
- munmap(Region, STACK_SIZE);
- FreeThreadTLS(Tls); { reclaim the per-thread TLS block too }
- Result := 11; { EAGAIN }
- Exit;
- end;
-
- { Hand the caller the control-block pointer as the opaque thread handle. }
- HandleSlot := PInt64(Thread);
- HandleSlot^ := Int64(CB);
- Result := 0;
-end;
-
-function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
-var
- CB: PThreadCB;
- W: Integer;
-begin
- CB := PThreadCB(Pointer(Thread));
- { The child sets JoinWord = 1 and _umtx_op-WAKEs it as its last act before
- thr_exit. WAIT while it still reads 0. WAIT_UINT returns at once if the word
- already changed, so no wake can be missed. }
- W := CB^.JoinWord;
- while W = 0 do
- begin
- _umtx_op(@CB^.JoinWord, UMTX_OP_WAIT_UINT_PRIVATE, 0, nil, nil);
- W := CB^.JoinWord;
- end;
- munmap(CB^.MapBase, CB^.MapSize);
- Result := 0;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.thread.static.linux.pas b/compiler/src/main/pascal/runtime.thread.static.linux.pas
deleted file mode 100644
index 9692dcc..0000000
--- a/compiler/src/main/pascal/runtime.thread.static.linux.pas
+++ /dev/null
@@ -1,283 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.thread.static.linux;
-
-// Real POSIX threads for the --static (libc-free) build, implemented directly on
-// the clone(2) and futex(2) syscalls (docs/linux-syscall-migration.adoc). This
-// is the threads leaf that lets a static binary spawn worker threads - the last
-// piece needed for the compiler to self-host as a libc-free static ET_EXEC.
-//
-// DEFINES the bare pthread_* / sysconf names that runtime.weak, runtime.thread
-// and classes.pas import via `external name`. The non-static build resolves the
-// same names from libc.so; the --static link swaps in this unit instead.
-//
-// Mutex: a 3-state futex mutex (Drepper, "Futexes Are Tricky"). The caller's
-// 48-byte pthread_mutex_t buffer is reused as the futex word (first Integer):
-// 0 = unlocked, 1 = locked (no waiters), 2 = locked (waiters present).
-//
-// Thread: clone(2) with CLONE_VM|FS|FILES|SIGHAND|THREAD|SYSVSEM|SETTLS plus
-// CLONE_PARENT_SETTID|CHILD_CLEARTID. Each thread gets a fresh mmap'd stack
-// and its own TLS block (variant II) built from the startup template, so
-// threadvar access (exception frames, the allocator) is per-thread. The
-// kernel clears the child-tid futex word on thread exit; pthread_join
-// futex-waits on it.
-//
-// Known limitation: a joined thread's TLS block (mmap'd by BuildThreadTLS) is
-// not unmapped - freeing it from the exiting thread is unsafe (the thread runs
-// on it until exit) and the join side cannot know its address. This is a small
-// bounded per-thread leak, acceptable for the finite worker pools the compiler
-// spawns; a thread-registry sweep can reclaim it later if needed.
-
-interface
-
-uses
- runtime.syscall.linux, { mmap, futex, clone numbers }
- runtime.start.static.linux; { BuildThreadTLS - the per-thread TLS template }
-
-{ Mutex - the buffer's first Integer is the futex word. }
-function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
-function pthread_mutex_lock(Mutex: Pointer): Integer;
-function pthread_mutex_unlock(Mutex: Pointer): Integer;
-function pthread_mutex_destroy(Mutex: Pointer): Integer;
-
-{ Thread create / join. *Thread receives an opaque handle (a control-block
- pointer); pthread_join consumes it. }
-function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
-function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
-
-{ sysconf is provided by runtime.libc.linux (sched_getaffinity + popcount); it is
- not redefined here. }
-
-implementation
-
-type
- PInteger = ^Integer;
- PInt64 = ^Int64;
-
-const
- { Mutex futex states. }
- MX_UNLOCKED = 0;
- MX_LOCKED = 1;
- MX_CONTENDED = 2;
-
- { futex ops. }
- FUTEX_WAIT = 0;
- FUTEX_WAKE = 1;
-
- { clone(2) flags for a thread sharing the address space. }
- CLONE_VM = $00000100;
- CLONE_FS = $00000200;
- CLONE_FILES = $00000400;
- CLONE_SIGHAND = $00000800;
- CLONE_THREAD = $00010000;
- CLONE_SYSVSEM = $00040000;
- CLONE_SETTLS = $00080000;
- CLONE_PARENT_SETTID = $00100000;
- CLONE_CHILD_CLEARTID = $00200000;
- THREAD_CLONE_FLAGS =
- CLONE_VM or CLONE_FS or CLONE_FILES or CLONE_SIGHAND or
- CLONE_THREAD or CLONE_SYSVSEM or CLONE_SETTLS or
- CLONE_PARENT_SETTID or CLONE_CHILD_CLEARTID;
-
- PROT_RW = 3; { PROT_READ or PROT_WRITE }
- MAP_PRIVANON = $22; { MAP_PRIVATE or MAP_ANONYMOUS }
- STACK_SIZE = 1024 * 1024; { 1 MiB per worker thread }
-
-{ The per-thread control block lives at the base of the mmap'd region. TidWord
- is the CLONE_CHILD_CLEARTID / CLONE_PARENT_SETTID futex word (the kernel writes
- the new TID here on create and clears it on exit); MapBase/MapSize record the
- region for munmap after join. }
-type
- PThreadCB = ^TThreadCB;
- TThreadCB = record
- TidWord: Integer;
- Pad: Integer;
- MapBase: Pointer;
- MapSize: Int64;
- end;
-
-{ ------------------------------------------------------------------ }
-{ Mutex - 3-state futex }
-{ ------------------------------------------------------------------ }
-
-{ Atomic compare-and-swap on an Integer: if Ptr^ = Expected set it to NewVal;
- returns the value that was in Ptr^ before the attempt. }
-function CAS(Ptr: Pointer; Expected, NewVal: Integer): Integer;
- assembler; nostackframe;
-asm
- movl %esi, %eax { %eax = Expected (cmpxchg compares against %eax) }
- lock cmpxchgl %edx, (%rdi)
- ret
-end;
-
-{ Atomic exchange: store NewVal into Ptr^, return the previous value. }
-function Xchg(Ptr: Pointer; NewVal: Integer): Integer;
- assembler; nostackframe;
-asm
- movl %esi, %eax
- xchgl %eax, (%rdi)
- ret
-end;
-
-function pthread_mutex_init(Mutex, Attr: Pointer): Integer;
-var
- P: PInteger;
-begin
- P := PInteger(Mutex);
- P^ := MX_UNLOCKED;
- Result := 0;
-end;
-
-function pthread_mutex_lock(Mutex: Pointer): Integer;
-var
- C: Integer;
-begin
- { Fast path: uncontended acquire. }
- C := CAS(Mutex, MX_UNLOCKED, MX_LOCKED);
- if C <> MX_UNLOCKED then
- begin
- { Contended. Mark the lock contended and sleep until it is free. }
- if C <> MX_CONTENDED then
- C := Xchg(Mutex, MX_CONTENDED);
- while C <> MX_UNLOCKED do
- begin
- futex(Mutex, FUTEX_WAIT, MX_CONTENDED, nil, nil, 0);
- C := Xchg(Mutex, MX_CONTENDED);
- end;
- end;
- Result := 0;
-end;
-
-function pthread_mutex_unlock(Mutex: Pointer): Integer;
-begin
- { If there were waiters (state 2), wake one after releasing. }
- if Xchg(Mutex, MX_UNLOCKED) = MX_CONTENDED then
- futex(Mutex, FUTEX_WAKE, 1, nil, nil, 0);
- Result := 0;
-end;
-
-function pthread_mutex_destroy(Mutex: Pointer): Integer;
-begin
- Result := 0;
-end;
-
-{ ------------------------------------------------------------------ }
-{ Thread create / join - clone(2) + futex(2) }
-{ ------------------------------------------------------------------ }
-
-{ Raw clone of a thread. Returns the child TID in the parent, 0 in the child.
- The child resumes here on its own stack (ChildStack) with %rax = 0, then this
- routine, in the child branch, calls Entry(EntryArg) and exits the thread.
-
- Args (SysV): %rdi=Flags, %rsi=ChildStack(top), %rdx=ParentTid,
- %rcx=ChildTid, %r8=Tls, %r9=Entry, [stack]=EntryArg.
-
- The child stack is pre-seeded (below) with Entry and EntryArg so the child can
- reach them after clone without relying on register state surviving across the
- syscall: the child pops them off its own stack. }
-function _clone_thread(Flags: Int64; ChildStack, ParentTid, ChildTid,
- Tls, Entry, EntryArg: Pointer): Int64;
- assembler; nostackframe;
-asm
- { Seed Entry and EntryArg onto the child stack; the 7th arg EntryArg }
- { arrived on our stack at 8(%rsp) (return addr at 0(%rsp)). }
- movq 8(%rsp), %rax { %rax = EntryArg }
- subq $16, %rsi { %rsi = ChildStack top; grow down for the seeds }
- movq %r9, 0(%rsi) { [child_sp+0] = Entry }
- movq %rax, 8(%rsi) { [child_sp+8] = EntryArg }
-
- { clone kernel ABI: arg4 (ChildTid) came in %rcx -> move to %r10. }
- movq %rcx, %r10
- movq $56, %rax { SYS_clone }
- syscall
-
- testq %rax, %rax
- jnz .Lparent { parent: %rax = child tid }
-
- { child: on the new stack, %rsp = seeded child_sp. }
- popq %rax { %rax = Entry }
- popq %rdi { %rdi = EntryArg (1st arg to Entry) }
- xorq %rbp, %rbp { terminate the call chain for unwinders }
- call *%rax { Entry(EntryArg) }
-
- { Thread done: exit(0) this thread only (NOT exit_group). }
- xorl %edi, %edi
- movq $60, %rax { SYS_exit }
- syscall
- hlt
-
-.Lparent:
- ret
-end;
-
-function pthread_create(Thread, Attr, StartRoutine, Arg: Pointer): Integer;
-var
- Region: Pointer;
- CB: PThreadCB;
- StackTop: Pointer;
- Tls: Pointer;
- Tid: Int64;
- HandleSlot: PInt64;
-begin
- { One mapping holds the control block (at the base) and the thread stack
- (above it). mmap zero-fills, so TidWord starts at 0. }
- Region := mmap(nil, STACK_SIZE, PROT_RW, MAP_PRIVANON, -1, 0);
- if Int64(Region) < 0 then
- begin
- Result := 11; { EAGAIN }
- Exit;
- end;
- CB := PThreadCB(Region);
- CB^.MapBase := Region;
- CB^.MapSize := STACK_SIZE;
-
- { Stack grows down from the top of the region; keep it 16-byte aligned. }
- StackTop := Pointer(PChar(Region) + STACK_SIZE);
- StackTop := Pointer(Int64(StackTop) and (not Int64(15)));
-
- { Each thread needs its own TLS block for threadvar access. }
- Tls := BuildThreadTLS();
-
- Tid := _clone_thread(THREAD_CLONE_FLAGS, StackTop,
- @CB^.TidWord, { CLONE_PARENT_SETTID -> our TidWord }
- @CB^.TidWord, { CLONE_CHILD_CLEARTID -> same word }
- Tls, StartRoutine, Arg);
- if Tid < 0 then
- begin
- munmap(Region, STACK_SIZE);
- FreeThreadTLS(Tls); { reclaim the per-thread TLS block too }
- Result := 11; { EAGAIN }
- Exit;
- end;
-
- { Hand the caller the control-block pointer as the opaque thread handle. }
- HandleSlot := PInt64(Thread);
- HandleSlot^ := Int64(CB);
- Result := 0;
-end;
-
-function pthread_join(Thread: Int64; RetVal: Pointer): Integer;
-var
- CB: PThreadCB;
- Tid: Integer;
-begin
- CB := PThreadCB(Pointer(Thread));
- { The kernel clears TidWord (CLONE_CHILD_CLEARTID) and futex-wakes it when the
- thread exits. Wait until it reads 0. }
- Tid := CB^.TidWord;
- while Tid <> 0 do
- begin
- futex(@CB^.TidWord, FUTEX_WAIT, Tid, nil, nil, 0);
- Tid := CB^.TidWord;
- end;
- munmap(CB^.MapBase, CB^.MapSize);
- Result := 0;
-end;
-
-end.
diff --git a/compiler/src/main/pascal/runtime.utf8.pas b/compiler/src/main/pascal/runtime.utf8.pas
deleted file mode 100644
index 7e73405..0000000
--- a/compiler/src/main/pascal/runtime.utf8.pas
+++ /dev/null
@@ -1,147 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit runtime.utf8;
-
-// UTF-8 code-point counter — SIMD-accelerated (AVX2 with an SSE2 fallback and
-// a scalar tail), with a one-time CPUID probe for AVX2.
-//
-// Inline-assembler port of runtime/src/main/asm/blaise_utf8_x86_64.s — the body
-// (and its threshold/flag data) move into an `asm … end` routine so the RTL
-// builds with Blaise's own internal assembler and needs no hand-written .s
-// (docs/inline-asm-design.adoc, §"Migration of the .s files"). This was the
-// last .s file; with it gone the RTL is pure Pascal + inline asm.
-//
-// Counts UTF-8 code points by counting bytes that are NOT continuation bytes
-// (a byte is a continuation byte iff its top two bits are 10, i.e. signed value
-// in [-128,-65]); the SIMD paths compare against the threshold -65 (0xBF).
-//
-// System V AMD64: Data -> %rdi, Len -> %esi; result (count) in %eax.
-
-interface
-
-function _Utf8CountCodePoints(Data: Pointer; Len: Integer): Integer;
-
-implementation
-
-function _Utf8CountCodePoints(Data: Pointer; Len: Integer): Integer;
- assembler; nostackframe;
-asm
- testl %esi, %esi
- jle .Lreturn_zero
- movl %esi, %ecx
- xorl %eax, %eax
- xorl %edx, %edx
- cmpl $0, .Lavx2_checked(%rip)
- jne .Lavx2_known
- call .Lcheck_avx2
- xorl %eax, %eax
-.Lavx2_known:
- cmpl $0, .Lavx2_flag(%rip)
- je .Lsse2_entry
- cmpl $32, %ecx
- jb .Lsse2_entry
- vpcmpeqb %ymm2, %ymm2, %ymm2
- vpsrlw $1, %ymm2, %ymm2
- vpaddw %ymm2, %ymm2, %ymm1
- vpcmpeqb %ymm2, %ymm2, %ymm2
- vpsllw $7, %ymm2, %ymm1
- vpcmpeqb %ymm1, %ymm1, %ymm1
- vmovdqa .Lthreshold_avx(%rip), %ymm1
- vpxor %ymm3, %ymm3, %ymm3
-.Lavx2_loop:
- vmovdqu (%rdi, %rdx), %ymm0
- vpcmpgtb %ymm1, %ymm0, %ymm2
- vpabsb %ymm2, %ymm2
- vpaddb %ymm2, %ymm3, %ymm3
- addl $32, %edx
- subl $32, %ecx
- cmpl $32, %ecx
- jge .Lavx2_loop
- vpxor %ymm4, %ymm4, %ymm4
- vpsadbw %ymm4, %ymm3, %ymm3
- vextracti128 $1, %ymm3, %xmm4
- vpaddq %xmm4, %xmm3, %xmm3
- vpshufd $0x0E, %xmm3, %xmm4
- vpaddq %xmm4, %xmm3, %xmm3
- vmovd %xmm3, %r8d
- addl %r8d, %eax
- vzeroupper
- jmp .Lsse2_entry
-.Lsse2_entry:
- cmpl $16, %ecx
- jb .Lscalar_entry
- movdqa .Lthreshold_sse(%rip), %xmm1
- pxor %xmm3, %xmm3
-.Lsse2_loop:
- movdqu (%rdi, %rdx), %xmm0
- movdqa %xmm0, %xmm2
- pcmpgtb %xmm1, %xmm2
- pabsb %xmm2, %xmm2
- paddb %xmm2, %xmm3
- addl $16, %edx
- subl $16, %ecx
- cmpl $16, %ecx
- jge .Lsse2_loop
- pxor %xmm4, %xmm4
- psadbw %xmm4, %xmm3
- movd %xmm3, %r8d
- pshufd $0x0E, %xmm3, %xmm3
- movd %xmm3, %r9d
- addl %r8d, %eax
- addl %r9d, %eax
-.Lscalar_entry:
- testl %ecx, %ecx
- jle .Lreturn
-.Lscalar_loop:
- movzbl (%rdi, %rdx), %r8d
- movl %r8d, %r9d
- andl $0xC0, %r9d
- cmpl $0x80, %r9d
- setne %r9b
- movzbl %r9b, %r9d
- addl %r9d, %eax
- incl %edx
- decl %ecx
- jnz .Lscalar_loop
-.Lreturn:
- ret
-.Lreturn_zero:
- xorl %eax, %eax
- ret
-.Lcheck_avx2:
- pushq %rbx
- pushq %rcx
- pushq %rdx
- movl $7, %eax
- xorl %ecx, %ecx
- cpuid
- testl $0x20, %ebx
- setne %al
- movzbl %al, %eax
- movl %eax, .Lavx2_flag(%rip)
- movl $1, .Lavx2_checked(%rip)
- popq %rdx
- popq %rcx
- popq %rbx
- ret
-.section .rodata
-.balign 32
-.Lthreshold_avx:
- .fill 32, 1, 0xBF
-.balign 16
-.Lthreshold_sse:
- .fill 16, 1, 0xBF
-.section .data
-.Lavx2_checked:
- .long 0
-.Lavx2_flag:
- .long 0
-end;
-
-end.
diff --git a/compiler/src/main/pascal/uAST.pas b/compiler/src/main/pascal/uAST.pas
index 597f4e5..e9de2c9 100644
--- a/compiler/src/main/pascal/uAST.pas
+++ b/compiler/src/main/pascal/uAST.pas
@@ -94,10 +94,6 @@ type
pmJumboSetValue { by-value jumbo (>64) set param: by-ref aggregate ABI }
);
- { TMemberVisibility is declared in uSymbolTable (so the symbol-table
- descriptors can carry it without a circular unit dependency); uAST re-uses
- that type for the parser-level AST member decls. }
-
TIdentExpr = class(TASTExpr)
public
Name: string;
@@ -117,31 +113,12 @@ type
ConstArraySymbol: string; { set by uSemantic — non-empty when this ident resolves
to an array const; the mangled QBE data-label codegen
must reference instead of $Name. }
- QualifierUnit: string; { set by the parser — non-empty when written as a
- unit-qualified reference 'Unit.Symbol'. uSemantic
- resolves the name against this specific unit's
- exports (per-unit cache) instead of the uses chain,
- so a same-named const in another unit can't shadow it. }
- ResolvedOwnerUnit: string; { set by uSemantic — for a module-scope global var,
- the owning unit of the symbol actually resolved (the
- uses-chain last-wins winner for a bare ref, or the
- named unit for a qualified ref). Codegen mangles the
- global's storage symbol with this owner so two used
- units exporting the same var name reference distinct
- slots. Not serialised — recomputed at analysis time;
- empty falls back to the bare-name resolution. }
end;
TFieldAccessExpr = class(TASTExpr)
public
RecordName: string; { used when Base = nil (leaf access) }
FieldName: string;
- QualifierUnit: string; { set by the parser — non-empty when the
- base type was written unit-qualified, e.g.
- 'Unit.TEnum.Member' or 'Unit.TFoo.StaticVar'.
- uSemantic resolves RecordName against this
- specific unit's exports (directed lookup)
- instead of the flat last-wins winner. }
Base: TASTExpr; { owned — when non-nil, chained access (e.g. A.B.C) }
FieldInfo: TFieldInfo; { set by uSemantic — nil for constructor calls }
IsConstant: Boolean; { set by uSemantic — TypeName.ConstName resolves to a class constant }
@@ -168,15 +145,6 @@ type
PropIndexExpr: TASTExpr; { owned — non-nil = indexed property read (e.g. List.Items[i]) }
IsCharAccess: Boolean; { set by uSemantic — PropIndexExpr indexes a string field: S.Field[N] }
IsArrayAccess: Boolean; { set by uSemantic — PropIndexExpr subscripts an array field: R.Arr[I] }
- IsClassVarRead: Boolean; { set by uSemantic — TypeName.StaticVar read; lower as a global load of ClassVarEmitName }
- ClassVarEmitName: string; { mangled global label for an IsClassVarRead access }
- IsStaticPropGet: Boolean; { set by uSemantic — TypeName.StaticProp read; ResolvedMethod is the static getter }
- BackingFieldRedirect: Boolean; { set by uSemantic — FieldName was rewritten from a
- property name to its (possibly private) backing
- field; visibility was already enforced on the
- property, so re-analysis of this node must NOT
- re-check the backing field's visibility. Transient
- analysis flag — not serialised. }
destructor Destroy; override;
end;
@@ -261,10 +229,6 @@ type
_WeakAssign in place of the strong
addref/release pattern. }
ImplicitSelfField: TObject; { TFieldInfo — non-nil when LHS is bare field (implicit Self) }
- ResolvedOwnerUnit: string; { set by uSemantic — owning unit of a module-scope global
- var target; codegen mangles the store address with it so
- same-named cross-unit globals write distinct slots. See
- the matching field on TIdentExpr. }
destructor Destroy; override;
end;
@@ -283,14 +247,6 @@ type
destructor Destroy; override;
end;
- { An inline-assembler block: the verbatim text of one `asm` ... `end` body.
- The front end never interprets Code — it is GNU/AT&T assembly handed to the
- backend's assembler verbatim (see docs/inline-asm-design.adoc). }
- TAsmStmt = class(TASTStmt)
- public
- Code: string; { verbatim assembly text between asm and end }
- end;
-
TWhileStmt = class(TASTStmt)
public
Condition: TASTExpr; { owned }
@@ -451,16 +407,6 @@ type
FieldName has been rewritten to the SETTER method;
codegen dispatches it through the itab with Expr
as the single argument }
- IsClassVarWrite: Boolean; { set by uSemantic — qualified STATIC (class-level)
- variable write 'TFoo.StaticVar := V'. The target is
- the single shared global emitted under
- ClassVarEmitName; codegen lowers it exactly like a
- bare global store (delegates to EmitAssignment),
- ignoring RecordName/FieldName. }
- [Unretained] ClassVarLhsType: TTypeDesc; { set with IsClassVarWrite — the
- static var's type, for the delegated store. }
- ClassVarEmitName: string; { set with IsClassVarWrite — the mangled data-label
- of the static var's storage slot. }
destructor Destroy; override;
end;
@@ -512,10 +458,6 @@ type
IsIndirectCall: Boolean; { set by uSemantic — Name is a procedural-typed variable }
IndirectCallIsGlobal: Boolean; { set by uSemantic — when IsIndirectCall, variable is global }
[Unretained] ResolvedProcType: TObject; { TProceduralTypeDesc — not owned; valid when IsIndirectCall }
- IsProcFieldCall: Boolean; { set by uSemantic — unqualified Name is a
- procedural-typed field of the current class
- (implicit Self.Field), called as a statement }
- [Unretained] ProcFieldInfo: TFieldInfo; { not owned — the procedural field, when IsProcFieldCall }
constructor Create;
destructor Destroy; override;
end;
@@ -539,10 +481,6 @@ type
IsBuiltinHasClassAttr: Boolean; { set by uSemantic — HasClassAttribute builtin }
HasClassAttrClass: string; { class name for arg 1 (class being queried) }
HasClassAttrAttr: string; { attribute class name for arg 2 }
- IsProcFieldCall: Boolean; { set by uSemantic — unqualified Name is a
- procedural-typed field of the current class
- (implicit Self.Field), used as an expression }
- [Unretained] ProcFieldInfo: TFieldInfo; { not owned — the procedural field, when IsProcFieldCall }
constructor Create;
destructor Destroy; override;
end;
@@ -600,9 +538,6 @@ type
IsBuiltinToString: Boolean; { set by uSemantic — built-in TObject.ToString virtual dispatch }
IsConstructorCall: Boolean; { set by uSemantic — metaclass-var Create in stmt position }
IsMetaclassDispatch: Boolean; { set by uSemantic — receiver is a metaclass var }
- IsStaticCall: Boolean; { set by uSemantic — TypeName.StaticMethod(): a static
- (class-level) call with NO Self. Codegen lowers it as a
- plain call to the mangled method symbol, no receiver. }
IsProcFieldCall: Boolean; { set by uSemantic — Name is a procedural-typed field of
the receiver, invoked directly (F.Handler;). Codegen
loads the (Code, Data) pair from the field slot and
@@ -751,14 +686,6 @@ type
TTypeAliasDef = class(TASTTypeDef)
public
TypeName: string;
- { When the RHS was a named integer subrange (type TIdx = lo..hi;) the alias
- target is the narrowest fitting standard integer type (in TypeName), but
- the original lo..hi bounds are retained here as compile-time metadata so
- the array-index resolver can fold array[TIdx] -> array[lo..hi]. The value
- still behaves as its underlying int (unchecked); only the bounds are kept. }
- IsSubrange: Boolean;
- SubrangeLow: Int64;
- SubrangeHigh: Int64;
end;
{ Set type definition: type TOptions = set of TEnum; }
@@ -789,29 +716,14 @@ type
Attributes: TStringList; { owned — see TVarDecl.Attributes. }
IsWeak: Boolean; { set by uSemantic when [Weak] is resolved. }
IsUnretained: Boolean; { set by uSemantic when [Unretained] is resolved. }
- IsClassVar: Boolean; { set by uParser — declared `static var` (a.k.a.
- class variable): one shared storage slot for the
- whole type, not a per-instance field. Lowered to
- a global slot by uSemantic; never gets an instance
- offset. }
- ClassVarEmitName: string; { set by uSemantic for an IsClassVar field — the
- mangled global data-label (CurrentUnitPrefix +
- Class + '_' + Name). Single source of truth so
- BOTH backends emit the slot under the exact label
- the read/write sites use, without re-deriving the
- unit prefix. }
- Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
- section; default mvPublic. Enforced by
- uSemantic's member-access checks. }
constructor Create;
destructor Destroy; override;
end;
TRecordTypeDef = class(TASTTypeDef)
public
- Fields: TObjectList; { owned TFieldDecl }
- Methods: TObjectList; { owned TMethodDecl }
- ConstDecls: TObjectList; { owned TConstDecl — record-level constants (static const) }
+ Fields: TObjectList; { owned TFieldDecl }
+ Methods: TObjectList; { owned TMethodDecl }
IsPacked: Boolean; { True iff declared `packed record` — disables
field alignment padding and tail padding;
ARC-managed fields (string/class/intf) still
@@ -894,16 +806,7 @@ type
consumed by codegen for cross-unit references. }
IsExternal: Boolean; { declared with 'external' directive — no body }
ExternalName: string; { C symbol name from 'external name ''c_foo'''; empty = use Pascal name }
- ExternalLib: string; { library from 'external ''c'' name ''malloc'''; bare name, link layer expands per platform. Also recorded unit-level in LinkLibs. }
- NoStackFrame: Boolean; { declared 'nostackframe' — body is an asm
- block that owns the whole frame; codegen
- emits no compiler prologue/epilogue }
IsRecordMethod: Boolean; { set by uSemantic — owner type is a record (not a class) }
- IsStatic: Boolean; { set by uParser — declared `static` (class method):
- no implicit Self; type-associated dispatch.
- Distinct from VTableSlot's "static dispatch"
- (= non-virtual); a static method also never
- receives a Self pointer. }
VTableSlot: Integer; { -1 = static; >=0 = vtable index (set by uSemantic) }
TypeParams: TStringList; { non-nil = generic function template; owns param names }
TypeParamConstraints: TStringList; { parallel to TypeParams; '' = unconstrained,
@@ -925,12 +828,6 @@ type
CallingConv: string; { set by uParser — 'cdecl'/'stdcall'/'register'/'pascal'/
'safecall' directive (lowercased); '' = default }
OwningUnit: string; { set by uSemantic / uSemanticImport — unit that declares this routine }
- IsImplOnly: Boolean; { set by uSemantic — standalone routine declared only in a unit's
- implementation section (no interface forward). Such routines are
- PRIVATE to the unit; overload resolution must not treat another
- unit's same-named impl-only routine as a competing candidate. }
- Visibility: TMemberVisibility; { set by uParser from the enclosing visibility section
- when this is a class/record method; default mvPublic. }
constructor Create;
destructor Destroy; override;
end;
@@ -939,18 +836,12 @@ type
public
ObjectName: string;
Name: string; { method name }
- QualifierUnit: string; { set by the parser — unit of a qualified
- receiver type 'Unit.Type.Method(...)', so a
- constructor on a cross-unit same-named type
- resolves against that specific unit. }
Args: TObjectList; { owned TASTExpr }
ObjExpr: TASTExpr; { owned — receiver expression when ObjectName = '' }
[Unretained] ResolvedClassType: TTypeDesc; { not owned; set by uSemantic }
[Unretained] ResolvedMethod: TObject; { TMethodDecl — not owned }
IsConstructorCall: Boolean; { set by uSemantic — TypeName.Create(args) }
IsMetaclassDispatch: Boolean; { set by uSemantic — receiver is a metaclass var }
- IsStaticCall: Boolean; { set by uSemantic — TypeName.StaticMethod(): static
- (class-level) call with NO Self; plain call to mangled name }
IsGlobal: Boolean; { set by uSemantic — ObjectName is a program-level global }
IsVarParam: Boolean; { set by uSemantic — ObjectName is a var/out parameter }
IsBuiltinToString: Boolean; { set by uSemantic — built-in TObject.ToString virtual dispatch }
@@ -972,10 +863,6 @@ type
IndexParamName: string; { '' = non-indexed property }
IndexTypeName: string; { type name of the index parameter; '' when non-indexed }
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
- IsStatic: Boolean; { set by uParser — declared `static`: sugar over a
- static getter/setter; no implicit Self. }
- Visibility: TMemberVisibility; { set by uParser from the enclosing visibility
- section; default mvPublic. }
end;
TClassTypeDef = class(TASTTypeDef)
@@ -987,8 +874,6 @@ type
Methods: TObjectList; { owned TMethodDecl }
Properties: TObjectList; { owned TPropertyDecl }
Attributes: TStringList; { owned — class-level custom attribute names e.g. 'Threaded' }
- IsForward: Boolean; { True for a forward decl 'TFoo = class;' (no ancestor,
- no body) — completed by the full decl later in scope }
constructor Create;
destructor Destroy; override;
end;
@@ -1049,7 +934,6 @@ type
ParentName: string;
Methods: TObjectList; { owned TMethodDecl — forward signatures only }
Properties: TObjectList; { owned TPropertyDecl — accessors are interface methods }
- IsForward: Boolean; { True for a forward decl 'IFoo = interface;' — completed later in scope }
constructor Create;
destructor Destroy; override;
end;
@@ -1100,28 +984,9 @@ type
public
Name: string;
Def: TASTTypeDef; { owned }
- [Unretained] ResolvedDesc: TObject; { TTypeDesc — set by uSemantic to the
- descriptor created for THIS decl. Lets
- codegen emit a unit's own type even when
- a same-named type from another used unit
- won the flat-table slot (FindType by name
- would return the other unit's desc). }
destructor Destroy; override;
end;
- { A library this compilation unit must be linked against — collected by the
- parser from every 'external ''lib''' declaration (interface OR
- implementation). Hoisted to the unit level so an implementation-private
- import still records its link dependency: the private routine stays out of
- the .bif, but the library it needs is serialised via
- TUnitInterface.LinkLibs and propagates to any program that uses the unit.
- LibName is the bare name ('c', 'kernel32') — the link layer expands it per
- platform (-l on ELF, .dll on PE). }
- TLinkLibDecl = class(TASTNode)
- public
- LibName: string;
- end;
-
{ ------------------------------------------------------------------ }
{ Block and Program }
{ ------------------------------------------------------------------ }
@@ -1137,7 +1002,6 @@ type
GenericMethodInstances: TObjectList; { owned TGenericMethodInstance — populated by uSemantic }
GenericIntfInstances: TObjectList; { owned TGenericInterfaceInstance — populated by uSemantic }
GenericRecordInstances: TObjectList; { owned TGenericRecordInstance — populated by uSemantic }
- LinkLibs: TObjectList; { owned TLinkLibDecl — libraries to link, collected by the parser }
constructor Create;
destructor Destroy; override;
end;
@@ -1161,7 +1025,6 @@ type
GenericMethodInstances: TObjectList;
GenericIntfInstances: TObjectList;
GenericRecordInstances: TObjectList;
- LinkLibs: TObjectList; { owned TLinkLibDecl — libraries to link, collected by the parser }
constructor Create;
destructor Destroy; override;
end;
@@ -1571,9 +1434,8 @@ end;
constructor TRecordTypeDef.Create;
begin
inherited Create();
- Fields := TObjectList.Create(True);
- Methods := TObjectList.Create(True);
- ConstDecls := TObjectList.Create(True);
+ Fields := TObjectList.Create(True);
+ Methods := TObjectList.Create(True);
end;
destructor TRecordTypeDef.Destroy;
@@ -1868,7 +1730,6 @@ begin
GenericMethodInstances := TObjectList.Create(True);
GenericIntfInstances := TObjectList.Create(True);
GenericRecordInstances := TObjectList.Create(True);
- LinkLibs := TObjectList.Create(True);
end;
destructor TConstDecl.Destroy;
@@ -1899,7 +1760,6 @@ begin
GenericMethodInstances := TObjectList.Create(True);
GenericIntfInstances := TObjectList.Create(True);
GenericRecordInstances := TObjectList.Create(True);
- LinkLibs := TObjectList.Create(True);
end;
destructor TUnit.Destroy;
@@ -2355,19 +2215,6 @@ begin
Result.Names.Add(ASrc.Names.Strings[I]);
for I := 0 to ASrc.Attributes.Count - 1 do
Result.Attributes.Add(ASrc.Attributes.Strings[I]);
- { Carry the resolved semantic flags through the export clone. Without
- these, the .bif encoder sees defaults: a [Weak]/[Unretained] field
- round-trips as a plain owning field, and a `static var` loses both its
- class-var marker and its mangled emit label — so a cross-unit consumer
- cannot register the shared global. }
- Result.IsWeak := ASrc.IsWeak;
- Result.IsUnretained := ASrc.IsUnretained;
- Result.IsClassVar := ASrc.IsClassVar;
- Result.ClassVarEmitName := ASrc.ClassVarEmitName;
- { Visibility must survive the export clone or a cross-unit consumer would see
- every imported field as public and enforcement would silently disappear at
- the unit boundary. }
- Result.Visibility := ASrc.Visibility;
end;
function ClonePropertyDecl(ASrc: TPropertyDecl): TPropertyDecl;
@@ -2379,11 +2226,6 @@ begin
Result.WriteName := ASrc.WriteName;
Result.IndexParamName := ASrc.IndexParamName;
Result.IndexTypeName := ASrc.IndexTypeName;
- { IsDefault round-trips the `default` directive; IsStatic marks a static
- property whose accessors take no Self. Both were silently dropped. }
- Result.IsDefault := ASrc.IsDefault;
- Result.IsStatic := ASrc.IsStatic;
- Result.Visibility := ASrc.Visibility;
end;
function CloneTypeDecl(ASrc: TTypeDecl): TTypeDecl;
@@ -2496,14 +2338,8 @@ begin
Result.IsPublished := ASrc.IsPublished;
Result.IsExternal := ASrc.IsExternal;
Result.ExternalName := ASrc.ExternalName;
- Result.ExternalLib := ASrc.ExternalLib;
Result.CallingConv := ASrc.CallingConv;
Result.IsRecordMethod := ASrc.IsRecordMethod;
- { Static (class-level) methods take no implicit Self. Dropping this in the
- export clone made every cross-unit static method look like a normal
- instance method, so TypeName.StaticMethod() resolution failed. }
- Result.IsStatic := ASrc.IsStatic;
- Result.Visibility := ASrc.Visibility;
for I := 0 to ASrc.Params.Count - 1 do
Result.Params.Add(CloneMethodParam(TMethodParam(ASrc.Params.Items[I])));
if ASrc.TypeParams <> nil then
@@ -2550,9 +2386,6 @@ begin
begin
TA := TTypeAliasDef.Create();
TA.TypeName := TTypeAliasDef(ASrc).TypeName;
- TA.IsSubrange := TTypeAliasDef(ASrc).IsSubrange;
- TA.SubrangeLow := TTypeAliasDef(ASrc).SubrangeLow;
- TA.SubrangeHigh := TTypeAliasDef(ASrc).SubrangeHigh;
Result := TA;
end
else if ASrc is TSetTypeDef then
@@ -2615,7 +2448,6 @@ begin
if ASrc = nil then begin Result := nil; Exit; end;
Result := TClassTypeDef.Create();
Result.ParentName := ASrc.ParentName;
- Result.IsForward := ASrc.IsForward;
for I := 0 to ASrc.ImplementsNames.Count - 1 do
Result.ImplementsNames.Add(ASrc.ImplementsNames.Strings[I]);
for I := 0 to ASrc.ConstDecls.Count - 1 do
@@ -2656,7 +2488,6 @@ begin
if ASrc = nil then begin Result := nil; Exit; end;
Result := TInterfaceTypeDef.Create();
Result.ParentName := ASrc.ParentName;
- Result.IsForward := ASrc.IsForward;
for I := 0 to ASrc.Methods.Count - 1 do
Result.Methods.Add(CloneMethodDecl(TMethodDecl(ASrc.Methods.Items[I])));
for I := 0 to ASrc.Properties.Count - 1 do
diff --git a/compiler/src/main/pascal/uCompilerId.pas b/compiler/src/main/pascal/uCompilerId.pas
index 7cd91cf..b238b20 100644
--- a/compiler/src/main/pascal/uCompilerId.pas
+++ b/compiler/src/main/pascal/uCompilerId.pas
@@ -24,7 +24,7 @@ unit uCompilerId;
interface
const
- COMPILER_ID = 'blaise-0.13.0-SNAPSHOT+bif2';
+ COMPILER_ID = 'blaise-0.12.0+bif2';
implementation
diff --git a/compiler/src/main/pascal/uConfig.pas b/compiler/src/main/pascal/uConfig.pas
index b2192f1..81e596a 100644
--- a/compiler/src/main/pascal/uConfig.pas
+++ b/compiler/src/main/pascal/uConfig.pas
@@ -15,22 +15,10 @@ uses
function FindConfigFile: string;
-{ Parse blaise.cfg lines. Recognised keys (KEY=VALUE, '#' comments, blank lines
- ignored): `unit-path=` appends to APaths; `rtl-src=` sets ARtlSrc.
- A relative VALUE is resolved against ABaseDir (the config file's directory).
- ARtlSrc is only written when an rtl-src line is present (left unchanged
- otherwise), so a caller can pre-seed it and let the config override only if
- set. }
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
- APaths: TStringList; var ARtlSrc: string); overload;
+ APaths: TStringList);
-{ Convenience overload for callers that only want unit-paths (ignores rtl-src). }
-procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
- APaths: TStringList); overload;
-
-{ Load the resolved blaise.cfg: appends unit-path entries to APaths and returns
- any rtl-src via ARtlSrc (unchanged if the file has none / no file). }
-procedure LoadConfigPaths(APaths: TStringList; var ARtlSrc: string);
+procedure LoadConfigPaths(APaths: TStringList);
implementation
@@ -53,38 +41,8 @@ begin
Result := '';
end;
-{ Resolve a blaise.cfg path value. An absolute path (leading '/') is used as
- is; a leading '~' or '~/' expands to $HOME (so a config can name paths under
- the user's home directory); anything else is relative and resolved against
- ABaseDir (the config file's own directory). }
-function ResolveCfgPath(const AValue, ABaseDir: string): string;
-var
- Home: string;
-begin
- if Length(AValue) = 0 then
- Exit('');
- { Home expansion: '~' alone, or a '~/...' prefix. }
- if (Copy(AValue, 0, 1) = '~') and
- ((Length(AValue) = 1) or (Copy(AValue, 1, 1) = '/')) then
- begin
- Home := GetEnvironmentVariable('HOME');
- if Home <> '' then
- begin
- if Length(AValue) = 1 then
- Exit(Home);
- { drop the '~', keep the rest (which starts with '/') }
- Exit(IncludeTrailingPathDelimiter(Home) + Copy(AValue, 2, Length(AValue)));
- end;
- { No $HOME — leave '~' untouched rather than mis-resolving. }
- Exit(AValue);
- end;
- if Copy(AValue, 0, 1) = '/' then
- Exit(AValue);
- Result := IncludeTrailingPathDelimiter(ABaseDir) + AValue;
-end;
-
procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
- APaths: TStringList; var ARtlSrc: string);
+ APaths: TStringList);
var
I: Integer;
Line: string;
@@ -105,24 +63,17 @@ begin
Key := Trim(Copy(Line, 0, EqPos));
Value := Trim(Copy(Line, EqPos + 1, Length(Line)));
if SameText(Key, 'unit-path') then
- APaths.Add(ResolveCfgPath(Value, ABaseDir))
- else if SameText(Key, 'rtl-src') then
- ARtlSrc := ResolveCfgPath(Value, ABaseDir)
+ begin
+ if (Length(Value) > 0) and (Copy(Value, 0, 1) <> '/') then
+ Value := IncludeTrailingPathDelimiter(ABaseDir) + Value;
+ APaths.Add(Value);
+ end
else
; { silently skip unrecognised keys }
end;
end;
-procedure ParseConfigLines(ALines: TStringList; const ABaseDir: string;
- APaths: TStringList);
-var
- IgnoredRtlSrc: string;
-begin
- IgnoredRtlSrc := '';
- ParseConfigLines(ALines, ABaseDir, APaths, IgnoredRtlSrc);
-end;
-
-procedure LoadConfigPaths(APaths: TStringList; var ARtlSrc: string);
+procedure LoadConfigPaths(APaths: TStringList);
var
CfgFile: string;
Lines: TStringList;
@@ -135,7 +86,7 @@ begin
try
Lines.LoadFromFile(CfgFile);
BaseDir := ExtractFilePath(CfgFile);
- ParseConfigLines(Lines, BaseDir, APaths, ARtlSrc);
+ ParseConfigLines(Lines, BaseDir, APaths);
finally
Lines.Free();
end;
diff --git a/compiler/src/main/pascal/uDebugOPDF.pas b/compiler/src/main/pascal/uDebugOPDF.pas
index 8244b37..235c0a4 100644
--- a/compiler/src/main/pascal/uDebugOPDF.pas
+++ b/compiler/src/main/pascal/uDebugOPDF.pas
@@ -63,8 +63,6 @@ type
procedure EmitLocalVars(ABlock: TBlock; AScopeID: Integer);
procedure EmitFunctionScope_Main(AScopeID, ADeclIdx: Integer);
procedure EmitUnitDirectory;
- procedure EmitRuntimeHelper(AKind: Integer; const ASymbol: string);
- procedure EmitRuntimeHelpers;
procedure EmitPointer(AType: TPointerTypeDesc);
procedure EmitArray(AType: TTypeDesc);
procedure EmitSet(AType: TSetTypeDesc);
@@ -74,7 +72,6 @@ type
procedure EmitConstantsFromList(AList: TObjectList);
procedure EmitTypesFromBlock(ABlock: TBlock);
procedure EmitGlobalVarsFromList(AList: TObjectList);
- procedure EmitStaticVarsFromBlock(ABlock: TBlock);
procedure EmitAllTypes;
procedure EmitGlobalVars;
procedure EmitFunctionScopes;
@@ -132,16 +129,9 @@ const
REC_SET = 18;
REC_UNITDIR = 19;
REC_CONSTANT = 20;
- REC_RUNTIMEHELPER = 25;
-
- { TRuntimeHelperKind ordinals (mirror opdf_types.TRuntimeHelperKind) }
- RHK_STRING_RELEASE = 0;
- RHK_DYNARRAY_RELEASE = 1;
SK_INTEGER = 0;
SK_BOOLEAN = 1;
- { SK_CHAR = 2; SK_WIDECHAR = 3; — reserved by the OPDF spec, not emitted yet }
- SK_FLOAT = 4; { Single, Double — pdr renders via TFloatEvaluator }
LOC_RBP = 1;
LOC_RBP_INDIRECT = 3; { frame slot holds the value's address }
@@ -197,44 +187,6 @@ begin
FDone := False;
end;
-{ Escape a raw string value for a GNU-as / internal-assembler `.ascii "..."`
- literal. A string CONSTANT's value is arbitrary user text — it may contain a
- double-quote, backslash, `#`, or control characters, any of which would break
- the surrounding `.ascii "" # Value` line (an unescaped `"` closes the
- literal early, leaving `..." # Value` as a garbage mnemonic). We emit the
- C-style escapes both assemblers understand. The OPDF ValueLen field is the
- RAW byte count (Length before escaping), which `.ascii` with these escapes
- reproduces exactly, so escaping does not change the emitted byte length. }
-function EscapeAsciiStr(const S: string): string;
-var
- I, B: Integer;
-begin
- Result := '';
- for I := 0 to Length(S) - 1 do
- begin
- B := OrdAt(S, I) and $FF;
- case B of
- Ord('\'): Result := Result + '\\';
- Ord('"'): Result := Result + '\"';
- 10: Result := Result + '\n';
- 13: Result := Result + '\r';
- 9: Result := Result + '\t';
- else
- { Printable ASCII passes through; anything else (including '#', which is a
- comment start OUTSIDE a quoted literal but harmless inside one, and any
- non-printable byte) is emitted as a 3-digit octal escape so the line
- stays a single well-formed token. }
- if (B >= 32) and (B < 127) then
- Result := Result + Chr(B)
- else
- Result := Result + '\' +
- Chr(Ord('0') + ((B shr 6) and 7)) +
- Chr(Ord('0') + ((B shr 3) and 7)) +
- Chr(Ord('0') + (B and 7));
- end;
- end;
-end;
-
function TOPDFEmitter.ActiveSymTable: TSymbolTable;
begin
if FUnit <> nil then
@@ -409,8 +361,7 @@ begin
if HasBeenEmitted(CName) then Exit;
case AType.Kind of
tyInteger, tyInt64, tyUInt32, tyUInt64,
- tySmallInt, tyWord, tyByte, tyBoolean,
- tyDouble, tySingle:
+ tySmallInt, tyWord, tyByte, tyBoolean:
EmitPrimitive(AType);
tyString:
EmitUtf8Str();
@@ -448,10 +399,6 @@ begin
tyBoolean: begin SubKind := SK_BOOLEAN; IsSigned := 0; end;
tyInt64, tyInteger, tySmallInt:
begin SubKind := SK_INTEGER; IsSigned := 1; end;
- tyDouble, tySingle:
- { Single (4B) / Double (8B) — pdr keys off SubKind=skFloat
- and reads the IEEE 754 value by SizeInBytes. }
- begin SubKind := SK_FLOAT; IsSigned := 1; end;
else
SubKind := SK_INTEGER; IsSigned := 0;
end;
@@ -706,28 +653,6 @@ begin
EmitStrField(FuncName);
end;
-procedure TOPDFEmitter.EmitRuntimeHelper(AKind: Integer; const ASymbol: string);
-begin
- { recRuntimeHelper: 1-byte kind + 8-byte linker-resolved RTL entry-point
- address. Lets the debugger inject a call to the RTL release routine for a
- +1 transient an injected property getter returns — see uDebugOPDF rationale
- and opdf-specification.adoc (recRuntimeHelper = 25). }
- L('');
- L(' # recRuntimeHelper: ' + ASymbol);
- EmitRecHdr(REC_RUNTIMEHELPER, 9);
- L(' .byte ' + IntToStr(AKind) + ' # Kind');
- L(' .quad ' + ASymbol + ' # Address (linker-resolved)');
-end;
-
-procedure TOPDFEmitter.EmitRuntimeHelpers;
-begin
- { Emitted once per binary (program object only). The RTL release routines
- are global symbols the linker resolves; the addresses land in the same
- image as the OPDF section, so the ASLR slide applies uniformly. }
- EmitRuntimeHelper(RHK_STRING_RELEASE, '_StringRelease');
- EmitRuntimeHelper(RHK_DYNARRAY_RELEASE, '_DynArrayRelease');
-end;
-
procedure TOPDFEmitter.EmitParameters(AMethod: TMethodDecl);
var
I: Integer;
@@ -1050,7 +975,6 @@ var
ReadType, WriteType: Integer;
RecSize: Integer;
RF: TFieldInfo;
- ReadMethSym, WriteMethSym: string;
begin
if AClass.Properties.Count = 0 then Exit;
ClassTypeID := GetOrAllocTypeID(AClass.Name);
@@ -1078,23 +1002,8 @@ begin
else
WriteType := PAT_NONE;
- { Method-backed accessors carry the getter/setter SYMBOL name so the
- debugger can resolve it via FindFunctionByName (which matches against the
- recFunctionScope name = the mangled symbol) and inject the call. The
- symbol is the same one written as ReadAddr/WriteAddr below. }
- if ReadType = PAT_METHOD then
- ReadMethSym := MangledClassSym(AClass.Name) + '_' + PI.ReadMethod
- else
- ReadMethSym := '';
- if WriteType = PAT_METHOD then
- WriteMethSym := MangledClassSym(AClass.Name) + '_' + PI.WriteMethod
- else
- WriteMethSym := '';
-
- { Fixed-size payload (30 bytes) + the three variable-length strings.
- 4(ClassTypeID)+4(PropTypeID)+1(ReadType)+1(WriteType)+8(ReadAddr)+
- 8(WriteAddr)+2(ReadMethodNameLen)+2(WriteMethodNameLen)+2(NameLen). }
- RecSize := 32 + Length(ReadMethSym) + Length(WriteMethSym) + Length(PI.Name);
+ RecSize := 28 + Length(PI.Name);
+ { 4(ClassTypeID)+4(PropTypeID)+1(ReadType)+1(WriteType)+8(ReadAddr)+8(WriteAddr)+2(NameLen) }
L('');
L(' # recProperty: ' + PI.Name);
@@ -1132,14 +1041,7 @@ begin
else
L(' .quad 0 # WriteAddr (none)');
- { The reader (TDefProperty) expects all three length words FIRST, then the
- three strings in order: ReadMethodName, WriteMethodName, Name. }
- L(' .word ' + IntToStr(Length(ReadMethSym)) + ' # ReadMethodNameLen');
- L(' .word ' + IntToStr(Length(WriteMethSym)) + ' # WriteMethodNameLen');
- L(' .word ' + IntToStr(Length(PI.Name)) + ' # NameLen');
- EmitNameData(ReadMethSym);
- EmitNameData(WriteMethSym);
- EmitNameData(PI.Name);
+ EmitStrField(PI.Name);
end;
end;
@@ -1182,7 +1084,7 @@ begin
L(' .word ' + IntToStr(Length(C.StrVal)) + ' # ValueLen');
EmitNameLen(C.Name);
if Length(C.StrVal) > 0 then
- L(' .ascii "' + EscapeAsciiStr(C.StrVal) + '" # Value');
+ L(' .ascii "' + C.StrVal + '" # Value');
EmitNameData(C.Name);
end
else
@@ -1310,58 +1212,15 @@ begin
end;
end;
-{ Static (class-level) variables are shared global pointer/value slots, not
- instance fields, so they are not in any block's var-decl list and EmitFields
- (instance fields only) skips them. Emit one recGlobalVar per IsClassVar field
- under its mangled ClassVarEmitName so a debugger can print TFoo.FInstance. }
-procedure TOPDFEmitter.EmitStaticVarsFromBlock(ABlock: TBlock);
-var
- I, K, N: Integer;
- TD: TTypeDecl;
- Flds: TObjectList;
- FDecl: TFieldDecl;
- Nm: string;
-begin
- if ABlock = nil then Exit;
- for I := 0 to ABlock.TypeDecls.Count - 1 do
- begin
- TD := TTypeDecl(ABlock.TypeDecls.Items[I]);
- Flds := nil;
- if TD.Def is TClassTypeDef then
- Flds := TClassTypeDef(TD.Def).Fields
- else if TD.Def is TRecordTypeDef then
- Flds := TRecordTypeDef(TD.Def).Fields;
- if Flds = nil then Continue;
- for K := 0 to Flds.Count - 1 do
- begin
- FDecl := TFieldDecl(Flds.Items[K]);
- if not FDecl.IsClassVar then Continue;
- for N := 0 to FDecl.Names.Count - 1 do
- begin
- if (FDecl.ClassVarEmitName <> '') and (FDecl.Names.Count = 1) then
- Nm := FDecl.ClassVarEmitName
- else
- Continue; { multi-name static vars carry no per-name emit label yet }
- EmitGlobalVar(Nm, FDecl.ResolvedType);
- end;
- end;
- end;
-end;
-
procedure TOPDFEmitter.EmitGlobalVars;
begin
if FUnit <> nil then
begin
EmitGlobalVarsFromList(FUnit.IntfBlock.Decls);
EmitGlobalVarsFromList(FUnit.ImplBlock.Decls);
- EmitStaticVarsFromBlock(FUnit.IntfBlock);
- EmitStaticVarsFromBlock(FUnit.ImplBlock);
end
else if FProgram <> nil then
- begin
EmitGlobalVarsFromList(FProgram.Block.Decls);
- EmitStaticVarsFromBlock(FProgram.Block);
- end;
end;
procedure TOPDFEmitter.SetFacts(AFacts: TDbgFacts);
@@ -1718,10 +1577,6 @@ begin
EmitAllTypes();
EmitGlobalVars();
EmitConstants();
- { recRuntimeHelper records are emitted ONLY by the program object (one set
- per binary) — the RTL release routines are global symbols, not per-unit. }
- if FProgram <> nil then
- EmitRuntimeHelpers();
EmitFunctionScopes();
PatchTotalRecords();
PatchUnitDirRecordCount();
diff --git a/compiler/src/main/pascal/uLexer.pas b/compiler/src/main/pascal/uLexer.pas
index b158803..cb1094b 100644
--- a/compiler/src/main/pascal/uLexer.pas
+++ b/compiler/src/main/pascal/uLexer.pas
@@ -115,12 +115,7 @@ type
tkDot,
tkDotDot, { .. — array bounds separator and case range }
tkCaret, { ^ — pointer dereference / pointer type prefix }
- tkAt, { @ — address-of operator }
- tkAsmBlock { whole 'asm' ... 'end' block; Value holds the verbatim
- assembly text (the front end never tokenises it).
- Appended at the enum's END so adding it shifts no
- existing ordinal (set-of-TTokenKind literals elsewhere
- depend on stable ordinals). }
+ tkAt { @ — address-of operator }
);
TToken = record
@@ -136,7 +131,6 @@ type
FFilename: string;
FDefines: TStringList; { conditional-compilation symbols, case-insensitive }
function MapKeyword(const AUpper: string): TTokenKind;
- function CodepointToUtf8(ACodepoint: Integer): string;
function UnescapeString(const ARaw: string): string;
function ProcessTextBlock(const ARaw: string): string;
function DirectiveName(const AText: string): string;
@@ -147,7 +141,6 @@ type
procedure SeedPredefines;
procedure SkipToElseOrEndif;
procedure SkipToEndif;
- function ReadAsmBody: string;
public
constructor Create(const ASource: string; const AFilename: string = '');
destructor Destroy; override;
@@ -155,8 +148,6 @@ type
{ Define a conditional-compilation symbol before lexing (e.g. from the
-d command-line flag). Case-insensitive. }
procedure AddDefine(const ASym: string);
- { Drop the host OS predefines so a cross-target's OS symbol replaces them. }
- procedure ClearOSDefines;
function Next: TToken;
end;
@@ -193,29 +184,15 @@ end;
{ Seed the always-on predefined conditional symbols. BLAISE identifies this
compiler (the headline use case: cross-compiler IFDEF BLAISE / ELSE / ENDIF);
- the CPU/OS symbols mirror the FPC family so portable source compiles unchanged.
- The OS symbols follow the HOST this compiler was built for, via compile-time
- conditional compilation, so a FreeBSD-built blaise seeds FREEBSD (matching
- HostTarget), which is what makes it default to producing FreeBSD binaries.
- A cross-target does not re-seed these; source that switches on the target OS
- is rare and the RTL selects per-target units structurally (BuildRTLUnitList),
- not via conditional compilation. }
+ the CPU/OS symbols mirror the FPC family so portable source compiles
+ unchanged. Targets beyond Linux/x86-64 will extend this set. }
procedure TLexer.SeedPredefines;
begin
Self.DefineSymbol('BLAISE');
Self.DefineSymbol('CPUX86_64');
Self.DefineSymbol('CPUAMD64'); { FPC's alias for the same target }
-{$IFDEF FREEBSD}
- Self.DefineSymbol('FREEBSD');
- Self.DefineSymbol('UNIX');
-{$ELSE}
- {$IFDEF WINDOWS}
- Self.DefineSymbol('WINDOWS');
- {$ELSE}
Self.DefineSymbol('LINUX');
Self.DefineSymbol('UNIX');
- {$ENDIF}
-{$ENDIF}
end;
function TLexer.IsDefined(const ASym: string): Boolean;
@@ -238,17 +215,6 @@ begin
FDefines.Delete(Idx);
end;
-{ Remove all OS predefines seeded for the host, so a cross --target's OS symbol
- can take their place (the driver calls this before applying target defines). }
-procedure TLexer.ClearOSDefines;
-begin
- Self.UndefSymbol('LINUX');
- Self.UndefSymbol('FREEBSD');
- Self.UndefSymbol('WINDOWS');
- Self.UndefSymbol('DARWIN');
- Self.UndefSymbol('UNIX');
-end;
-
procedure TLexer.AddDefine(const ASym: string);
begin
Self.DefineSymbol(UpperCase(ASym));
@@ -263,7 +229,6 @@ begin
else if AUpper = 'THREADVAR' then Result := tkThreadVar
else if AUpper = 'BEGIN' then Result := tkBegin
else if AUpper = 'END' then Result := tkEnd
- else if AUpper = 'ASM' then Result := tkAsmBlock
else if AUpper = 'TYPE' then Result := tkType
else if AUpper = 'RECORD' then Result := tkRecord
else if AUpper = 'PACKED' then Result := tkPacked
@@ -380,50 +345,14 @@ begin
Result := tkIdent; { keyword outside Phase 1 grammar treated as ident }
end;
-function TLexer.CodepointToUtf8(ACodepoint: Integer): string;
-{ Encode a Unicode scalar value as its UTF-8 byte sequence. A `#nnnn` / `#$hhhh`
- literal denotes a codepoint (NOT a raw byte), so the string it contributes is
- that codepoint's UTF-8 encoding: #65 -> 'A' (1 byte), #$20AC -> 3 bytes,
- #$1F600 -> 4 bytes. Rejects values outside 0..U+10FFFF and the surrogate
- range U+D800..U+DFFF, which are not valid scalar values. }
-var
- N: Integer;
-begin
- N := ACodepoint;
- if (N < 0) or (N > $10FFFF) or ((N >= $D800) and (N <= $DFFF)) then
- raise Exception.Create(Format(
- 'Invalid Unicode codepoint in character literal: %d (must be 0..$10FFFF, '
- + 'excluding surrogates $D800..$DFFF)', [N]));
- if N <= $7F then
- Result := Chr(N)
- else if N <= $7FF then
- Result := Chr($C0 or (N shr 6))
- + Chr($80 or (N and $3F))
- else if N <= $FFFF then
- Result := Chr($E0 or (N shr 12))
- + Chr($80 or ((N shr 6) and $3F))
- + Chr($80 or (N and $3F))
- else
- Result := Chr($F0 or (N shr 18))
- + Chr($80 or ((N shr 12) and $3F))
- + Chr($80 or ((N shr 6) and $3F))
- + Chr($80 or (N and $3F));
-end;
-
function TLexer.UnescapeString(const ARaw: string): string;
{ ARaw is the full source span. Handles: 'text' with '' → ' escaping,
-<<<<<<< HEAD
- #nnnn / #$hhhh Unicode-codepoint literals (decimal or hex, UTF-8 encoded),
- and concatenated runs like 'abc'#13#10'def'. Uses OrdAt (0-based) so the body
- parses under both FPC and the self-hosted Blaise compiler. }
-=======
#nn numeric char literals (decimal), and concatenated runs like
'abc'#13#10'def'. Uses OrdAt (0-based) so the body parses under both
FPC and the self-hosted Blaise compiler.
UTF-8 note: Cyrillic characters inside quoted strings are preserved
as-is since string content is opaque to the tokeniser. }
->>>>>>> version-0.12.0
var
I, Len, N, C: Integer;
begin
@@ -459,34 +388,18 @@ begin
end;
end;
end
- else if C = 35 then { '#' — a Unicode codepoint, decimal #nnnn or hex #$hhhh }
+ else if C = 35 then { '#' }
begin
I := I + 1;
N := 0;
- if (I < Len) and (OrdAt(ARaw, I) = 36) then { '$' -> hexadecimal }
+ 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;
- while I < Len do
- begin
- C := OrdAt(ARaw, I);
- if (C >= 48) and (C <= 57) then N := N * 16 + (C - 48)
- else if (C >= 65) and (C <= 70) then N := N * 16 + (C - 55) { A-F }
- else if (C >= 97) and (C <= 102) then N := N * 16 + (C - 87) { a-f }
- else Break;
- I := I + 1;
- end;
- end
- else
- begin
- 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;
end;
- Result := Result + CodepointToUtf8(N);
+ Result := Result + Chr(N);
end
else
I := I + 1;
@@ -686,42 +599,6 @@ begin
end;
end;
-{ Called immediately after the 'asm' keyword token was produced (FTok.Token is
- that keyword). Drives the tokeniser forward to the matching 'end' keyword and
- returns the verbatim source text between the two — assembly is not Pascal, so
- nothing in the block is re-interpreted. Only a standalone 'end' KEYWORD token
- terminates the block (an 'end' inside an asm '#' line comment is a comment
- token, never a keyword, so it is ignored). The terminating 'end' token is
- consumed; normal tokenising resumes after it. }
-function TLexer.ReadAsmBody: string;
-var
- raw: TFpgPasToken;
- BlockStart: Integer; { 1-based source index of the first char after 'asm' }
- EndStart: Integer; { 1-based source index of the terminating 'end' }
-begin
- { FTok.Token is the 'asm' keyword; the body begins right after it. }
- BlockStart := FTok.Token.TextStart + FTok.Token.Len;
- EndStart := -1;
- while True do
- begin
- raw := FTok.NextToken();
- if raw.Kind = fptkEOF then
- begin
- { Unterminated block: capture to end of source. }
- EndStart := Length(FTok.Source) + 1;
- Break;
- end;
- if (raw.Kind = fptkKeyword) and (FTok.TokenTextUpper() = 'END') then
- begin
- EndStart := FTok.Token.TextStart;
- Break;
- end;
- end;
- { Slice [BlockStart, EndStart) — Copy is 0-based, so subtract 1 from the
- 1-based start; length is EndStart - BlockStart. }
- Result := Copy(FTok.Source, BlockStart - 1, EndStart - BlockStart);
-end;
-
function TLexer.Next: TToken;
var
raw: TFpgPasToken;
@@ -781,14 +658,7 @@ begin
begin
text := FTok.TokenTextUpper();
Result.Kind := MapKeyword(text);
- if Result.Kind = tkAsmBlock then
- { Capture the whole 'asm' ... 'end' block as verbatim text — its
- content is GNU/AT&T assembly, not Pascal, so it must not be
- tokenised. ReadAsmBody drives the tokeniser to the matching
- 'end' and slices the raw source. }
- Result.Value := Self.ReadAsmBody()
- else
- Result.Value := FTok.TokenText();
+ Result.Value := FTok.TokenText();
end;
fptkIdentifier:
@@ -955,7 +825,6 @@ begin
tkOut: Result := 'out';
tkConstructor: Result := 'constructor';
tkDestructor: Result := 'destructor';
- tkAsmBlock: Result := 'asm block';
tkIdent: Result := 'identifier';
tkPlus: Result := '+';
tkMinus: Result := '-';
diff --git a/compiler/src/main/pascal/uParser.pas b/compiler/src/main/pascal/uParser.pas
index 2f495f7..f0ba1a5 100644
--- a/compiler/src/main/pascal/uParser.pas
+++ b/compiler/src/main/pascal/uParser.pas
@@ -50,31 +50,7 @@ type
FCurrent: TToken;
FLookahead: TToken; { one-token lookahead }
FLookahead2: TToken; { two-token lookahead for generic disambiguation }
- FAhead: array of TToken; { tokens beyond FLookahead2 (FIFO), filled on
- demand by PeekTok for unbounded lookahead }
- FUsedUnits: TStringList; { unit names from every 'uses' clause, plus implicit
- 'System'. Consulted purely as a syntactic name list
- to recognise 'UnitName.Symbol' — no symbol lookup. }
- FLinkLibs: TObjectList; { non-owning ref to the current TUnit/TProgram.LinkLibs;
- external 'lib' decls append a TLinkLibDecl here as they
- are parsed (any section). nil outside a unit/program. }
- { Record a 'link library X' dependency on the unit/program being parsed. }
- procedure AddLinkLib(const ALibName: string; ALine, ACol: Integer);
- function IsUsedUnit(const AName: string): Boolean;
- function IsUnitPrefix(const AName: string): Boolean;
- { Unbounded lookahead, exposed as scalar accessors (0 = FCurrent). A
- TToken-returning peek is deliberately avoided — TToken carries a managed
- string, and returning it by value would create transient managed records
- in the hot matcher path. }
- procedure EnsureAhead(N: Integer);
- function PeekKindAt(N: Integer): TTokenKind;
- function PeekValueAt(N: Integer): string;
- function PeekLineAt(N: Integer): Integer;
- function PeekColAt(N: Integer): Integer;
- function TryCollapseUnitQualifier(var AName: string;
- var ALine, ACol: Integer;
- out AUnit: string): Boolean;
procedure Advance;
function PeekKind(): TTokenKind;
function PeekKind2(): TTokenKind; { two tokens ahead }
@@ -83,7 +59,7 @@ type
function CheckUnitNamePart: Boolean;
function ParseTypeName: string; { reads Ident optionally followed by '<' ArgList '>' }
function SubrangeAhead: Boolean; { current token starts an integer-literal subrange: IntLit.. or -IntLit.. }
- function ParseIntegerSubrangeBaseType(out ALo, AHi: Int64): string; { parse lo..hi, return narrowest fitting standard integer type and the bounds }
+ function ParseIntegerSubrangeBaseType: string; { parse lo..hi, return narrowest fitting standard integer type }
function ReadConstBoundText: string; { read an array bound: literal, ident, or expr }
function ParseAnonEnumName: string; { parse '(a,b,c)' → encoded member-list string }
@@ -91,7 +67,6 @@ type
procedure ParseUsesList(AList: TStringList);
procedure ParseUses(AProg: TProgram);
function ParseBlock: TBlock;
- function ParseAsmBody: TBlock;
procedure ParseTypeSection(ABlock: TBlock);
procedure ParseTypeDecl(ABlock: TBlock);
procedure ParseConstBlock(AList: TObjectList);
@@ -146,7 +121,6 @@ type
procedure ParseMethodCallArgList(ACall: TMethodCallStmt);
public
constructor Create(ALexer: TLexer);
- destructor Destroy; override;
function Parse: TProgram;
function ParseUnit: TUnit;
{ True iff the primed first token is `unit` — caller forks to
@@ -160,37 +134,16 @@ constructor TParser.Create(ALexer: TLexer);
begin
inherited Create();
FLexer := ALexer;
- FUsedUnits := TStringList.Create();
- { 'System' is implicitly used by every compilation unit. }
- FUsedUnits.Add('System');
FCurrent := FLexer.Next();
FLookahead := FLexer.Next();
FLookahead2 := FLexer.Next();
end;
-destructor TParser.Destroy;
-begin
- FUsedUnits.Free();
- inherited Destroy();
-end;
-
procedure TParser.Advance;
-var
- I: Integer;
begin
FCurrent := FLookahead;
FLookahead := FLookahead2;
- { Drain the on-demand lookahead buffer first (tokens PeekTok pre-read), so
- consumption order is preserved; fall back to the lexer when it is empty. }
- if Length(FAhead) > 0 then
- begin
- FLookahead2 := FAhead[0];
- for I := 1 to High(FAhead) do
- FAhead[I - 1] := FAhead[I];
- SetLength(FAhead, Length(FAhead) - 1);
- end
- else
- FLookahead2 := FLexer.Next();
+ FLookahead2 := FLexer.Next();
end;
function TParser.PeekKind(): TTokenKind;
@@ -203,180 +156,6 @@ begin
Result := FLookahead2.Kind;
end;
-{ Ensure the on-demand lookahead buffer holds enough tokens that conceptual
- index N (>= 3) maps to FAhead[N - 3]. Tokens are pulled from the lexer and
- held (FIFO) until consumed by Advance. Lets the unit-qualifier matcher
- inspect a whole dotted chain of any depth before consuming any of it. }
-procedure TParser.EnsureAhead(N: Integer);
-var
- T: TToken;
-begin
- while Length(FAhead) < (N - 2) do
- begin
- T := FLexer.Next();
- SetLength(FAhead, Length(FAhead) + 1);
- FAhead[High(FAhead)] := T;
- end;
-end;
-
-{ Kind of the token N positions ahead of FCurrent (0=FCurrent, 1=FLookahead,
- 2=FLookahead2, 3+ from FAhead). }
-function TParser.PeekKindAt(N: Integer): TTokenKind;
-begin
- case N of
- 0: Exit(FCurrent.Kind);
- 1: Exit(FLookahead.Kind);
- 2: Exit(FLookahead2.Kind);
- end;
- EnsureAhead(N);
- Result := FAhead[N - 3].Kind;
-end;
-
-{ Value text of the token N positions ahead. }
-function TParser.PeekValueAt(N: Integer): string;
-begin
- case N of
- 0: Exit(FCurrent.Value);
- 1: Exit(FLookahead.Value);
- 2: Exit(FLookahead2.Value);
- end;
- EnsureAhead(N);
- Result := FAhead[N - 3].Value;
-end;
-
-function TParser.PeekLineAt(N: Integer): Integer;
-begin
- case N of
- 0: Exit(FCurrent.Line);
- 1: Exit(FLookahead.Line);
- 2: Exit(FLookahead2.Line);
- end;
- EnsureAhead(N);
- Result := FAhead[N - 3].Line;
-end;
-
-function TParser.PeekColAt(N: Integer): Integer;
-begin
- case N of
- 0: Exit(FCurrent.Col);
- 1: Exit(FLookahead.Col);
- 2: Exit(FLookahead2.Col);
- end;
- EnsureAhead(N);
- Result := FAhead[N - 3].Col;
-end;
-
-{ Case-insensitive membership test against the parsed 'uses' names. }
-{ Append a 'link library ALibName' dependency to the unit/program being parsed.
- Duplicates are tolerated — the exporter dedupes when building the .bif set. }
-procedure TParser.AddLinkLib(const ALibName: string; ALine, ACol: Integer);
-var
- LL: TLinkLibDecl;
-begin
- if (FLinkLibs = nil) or (ALibName = '') then Exit;
- LL := TLinkLibDecl.Create();
- LL.LibName := ALibName;
- LL.Line := ALine;
- LL.Col := ACol;
- FLinkLibs.Add(LL);
-end;
-
-function TParser.IsUsedUnit(const AName: string): Boolean;
-var
- I: Integer;
-begin
- for I := 0 to FUsedUnits.Count - 1 do
- if SameText(FUsedUnits.Strings[I], AName) then
- Exit(True);
- Result := False;
-end;
-
-{ True iff AName is a used unit OR a dotted prefix of one (some used unit equals
- AName or begins with 'AName.'). Lets the matcher stop extending a candidate
- the moment it can no longer complete any unit name. }
-function TParser.IsUnitPrefix(const AName: string): Boolean;
-var
- I: Integer;
- U: string;
-begin
- for I := 0 to FUsedUnits.Count - 1 do
- begin
- U := FUsedUnits.Strings[I];
- if SameText(U, AName) then Exit(True);
- { U begins with 'AName.' — StrHead is 0-based (Blaise strings are 0-indexed). }
- if (Length(U) > Length(AName) + 1) and
- SameText(StrHead(U, Length(AName) + 1), AName + '.') then Exit(True);
- end;
- Result := False;
-end;
-
-{ Recognise a unit-qualified reference 'Unit.Symbol' where Unit is the LONGEST
- dotted prefix (starting at AName) that exactly names a used unit and is
- followed by a trailing '.Symbol'. The 'uses' name list bounds how far to
- scan, so any unit-name depth works (System.SysUtils.Foo, A.B.C.D.Sym, ...).
-
- Cursor on entry: AName has just been consumed, so FCurrent is the '.' before
- the first extra component. Component idents after AName therefore sit at peek
- indices 1, 3, 5, ... with the separating dots at 0, 2, 4, ...
-
- On a match the unit name and its trailing dot are consumed, AName/ALine/ACol
- become the bare Symbol (cursor left just past it), and the caller proceeds as
- if it had read an unqualified reference. On no match NOTHING is consumed, so
- a same-prefixed record/field chain (My.Pkg := x) is left intact — the required
- trailing '.Symbol' is what distinguishes the two. }
-function TParser.TryCollapseUnitQualifier(var AName: string;
- var ALine, ACol: Integer; out AUnit: string): Boolean;
-var
- Cand, BestUnit: string;
- Comps, BestComps, J, DotIdx, IdentIdx: Integer;
-begin
- Result := False;
- AUnit := '';
- BestUnit := '';
- Cand := AName;
- Comps := 0;
- if IsUsedUnit(Cand) then
- begin
- BestComps := 0;
- BestUnit := Cand;
- end
- else
- BestComps := -1;
- { Greedily absorb '.ident' components while the candidate stays a viable unit
- prefix; remember the longest position that is an exact used-unit match. }
- J := 1;
- while True do
- begin
- DotIdx := 2 * (J - 1);
- IdentIdx := 2 * J - 1;
- if (PeekKindAt(DotIdx) <> tkDot) or (PeekKindAt(IdentIdx) <> tkIdent) then
- Break;
- if not IsUnitPrefix(Cand + '.' + PeekValueAt(IdentIdx)) then
- Break;
- Cand := Cand + '.' + PeekValueAt(IdentIdx);
- Comps := J;
- if IsUsedUnit(Cand) then
- begin
- BestComps := Comps;
- BestUnit := Cand;
- end;
- Inc(J);
- end;
- if BestComps < 0 then Exit; { AName does not lead to a used unit }
- { A trailing '.Symbol' must follow the matched unit, else this is a bare unit
- reference or a same-prefixed value chain — leave it for the normal parser. }
- DotIdx := 2 * BestComps;
- IdentIdx := 2 * BestComps + 1;
- if (PeekKindAt(DotIdx) <> tkDot) or (PeekKindAt(IdentIdx) <> tkIdent) then
- Exit;
- AName := PeekValueAt(IdentIdx);
- ALine := PeekLineAt(IdentIdx);
- ACol := PeekColAt(IdentIdx);
- AUnit := BestUnit;
- for J := 1 to IdentIdx + 1 do Advance(); { consume unit name, dot, symbol }
- Result := True;
-end;
-
function TParser.ReadConstBoundText: string;
var
Depth: Integer;
@@ -656,7 +435,7 @@ begin
Result := False;
end;
-function TParser.ParseIntegerSubrangeBaseType(out ALo, AHi: Int64): string;
+function TParser.ParseIntegerSubrangeBaseType: string;
var
Lo, Hi: Int64;
Neg: Boolean;
@@ -689,8 +468,6 @@ begin
raise EParseError.Create(Format(
'Subrange %d..%d is descending at line %d col %d in %s',
[Lo, Hi, FCurrent.Line, FCurrent.Col, FLexer.Filename]));
- ALo := Lo;
- AHi := Hi;
{ Pick the narrowest standard type covering [Lo, Hi]. }
if Lo >= 0 then
begin
@@ -789,7 +566,6 @@ end;
function TParser.ParseProgram: TProgram;
begin
Result := TProgram.Create();
- FLinkLibs := Result.LinkLibs; { collect external 'lib' deps into the program }
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
@@ -841,7 +617,6 @@ begin
Advance();
end;
AList.Add(UName);
- FUsedUnits.Add(UName);
while Check(tkComma) do
begin
Advance();
@@ -860,7 +635,6 @@ begin
Advance();
end;
AList.Add(UName);
- FUsedUnits.Add(UName);
end;
Expect(tkSemicolon);
end;
@@ -881,9 +655,7 @@ begin
as required when concatenating multiple Pascal units into one file. }
while Check(tkType) or Check(tkVar) or Check(tkThreadVar) or
Check(tkProcedure) or Check(tkFunction) or Check(tkConst) or
- Check(tkConstructor) or Check(tkDestructor) or
- (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure])) do
+ Check(tkConstructor) or Check(tkDestructor) do
begin
if Check(tkType) then
ParseTypeSection(Result)
@@ -911,11 +683,7 @@ end;
procedure TParser.ParseTypeSection(ABlock: TBlock);
begin
Expect(tkType);
- while (Check(tkIdent) or Check(tkLBracket)) and
- { Stop the type section at a leading `static function/procedure` — that
- is an out-of-line static-method implementation, not a type decl. }
- not (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure])) do
+ while Check(tkIdent) or Check(tkLBracket) do
ParseTypeDecl(ABlock);
end;
@@ -931,8 +699,6 @@ var
IsGeneric: Boolean;
Constraint: string;
ClassAttrs: TStringList;
- SubLo: Int64;
- SubHi: Int64;
begin
ClassAttrs := TStringList.Create();
try
@@ -1103,10 +869,7 @@ begin
record/array layout correct (TByte is byte-sized) while the value
behaves as an ordinary integer. }
AD := TTypeAliasDef.Create();
- AD.TypeName := Self.ParseIntegerSubrangeBaseType(SubLo, SubHi);
- AD.IsSubrange := True;
- AD.SubrangeLow := SubLo;
- AD.SubrangeHigh := SubHi;
+ AD.TypeName := Self.ParseIntegerSubrangeBaseType();
TD.Def := AD;
end
else if Check(tkArray) or Check(tkCaret) or Check(tkIdent) then
@@ -1345,21 +1108,6 @@ begin
Expect(tkConst);
while Check(tkIdent) do
begin
- { Stop at a class/record section keyword: a const section inside a class or
- record body is terminated by the next visibility/`static` section or by a
- `property` member. A genuine const decl is always `IDENT (':' | '=')`, so
- if the current identifier is a section keyword and is NOT immediately
- followed by `:` or `=`, it begins the next section, not another const.
- (Top-level const blocks never hit this: they are followed by `var`/`type`/
- `begin`, which are not tkIdent.) }
- if (SameText(FCurrent.Value, 'private') or
- SameText(FCurrent.Value, 'protected') or
- SameText(FCurrent.Value, 'public') or
- SameText(FCurrent.Value, 'published') or
- SameText(FCurrent.Value, 'static') or
- SameText(FCurrent.Value, 'property')) and
- not (PeekKind() in [tkColon, tkEquals]) then
- Break;
CD := TConstDecl.Create();
CD.Line := FCurrent.Line;
CD.Col := FCurrent.Col;
@@ -1966,112 +1714,25 @@ end;
function TParser.ParseRecordDef: TRecordTypeDef;
var
- MethDecl: TMethodDecl;
- CurrStatic: Boolean; { current section's static (class-level) association }
- CurrVisibility: TMemberVisibility; { current section's visibility }
- LocalStatic: Boolean;
- FieldCountBefore: Integer;
- FieldIdx: Integer;
+ MethDecl: TMethodDecl;
begin
Result := TRecordTypeDef.Create();
- CurrStatic := False;
- CurrVisibility := mvPublic;
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Expect(tkRecord);
repeat
- { Bare `static var` / `static const` SECTION keyword. `static` is a soft
- keyword: a section qualifier only when followed by `var`/`const`; a
- field literally named `Static` (`Static: Integer;`) falls through. }
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkVar, tkConst]) then
+ if Check(tkIdent) or Check(tkLBracket) then
+ ParseFieldDecl(Result.Fields)
+ else if Check(tkFunction) then
begin
- CurrStatic := True;
- Advance(); { the following var/const section belongs to this static section }
- end
- { Optional `strict` soft keyword before private/protected (record fields). }
- else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
- (PeekKind() = tkIdent) and
- (SameText(PeekValueAt(1), 'private') or
- SameText(PeekValueAt(1), 'protected')) then
- begin
- Advance(); { consume `strict` }
- if SameText(FCurrent.Value, 'private') then
- CurrVisibility := mvStrictPrivate
- else
- CurrVisibility := mvStrictProtected;
- CurrStatic := False;
- Advance(); { consume private/protected }
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure]) then
- begin
- CurrStatic := True;
- Advance();
- end;
- end
- else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
- (PeekKind() = tkIdent) and
- (SameText(PeekValueAt(1), 'public') or
- SameText(PeekValueAt(1), 'published')) then
- raise EParseError.Create(Format(
- 'Only ''private'' or ''protected'' may be ''strict'' at line %d col %d in %s',
- [FCurrent.Line, FCurrent.Col, FLexer.Filename]))
- { Visibility section keywords, with an optional trailing `static`.
- A new visibility section resets static. }
- else if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
- SameText(FCurrent.Value, 'public') or
- SameText(FCurrent.Value, 'protected')) then
- begin
- if SameText(FCurrent.Value, 'private') then
- CurrVisibility := mvPrivate
- else if SameText(FCurrent.Value, 'protected') then
- CurrVisibility := mvProtected
- else
- CurrVisibility := mvPublic;
- CurrStatic := False;
- Advance();
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure]) then
- begin
- CurrStatic := True;
- Advance();
- end;
- end
- else if Check(tkConst) then
- ParseConstBlock(Result.ConstDecls)
- else if Check(tkVar) then
- Advance() { optional `var` keyword before field declarations }
- { Method declarations — before the field branch so a leading `static`
- prefix is not mistaken for a field name. }
- else if Check(tkFunction) or Check(tkProcedure) or
- (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure])) then
- begin
- LocalStatic := CurrStatic;
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') then
- begin
- LocalStatic := True;
- Advance();
- end;
- if Check(tkFunction) then
- MethDecl := ParseMethodDecl(True)
- else
- MethDecl := ParseMethodDecl(False);
- MethDecl.IsStatic := LocalStatic;
- MethDecl.Visibility := CurrVisibility;
+ MethDecl := ParseMethodDecl(True);
Result.Methods.Add(MethDecl);
end
- else if Check(tkIdent) or Check(tkLBracket) then
+ else if Check(tkProcedure) then
begin
- FieldCountBefore := Result.Fields.Count;
- ParseFieldDecl(Result.Fields);
- for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
- begin
- if CurrStatic then
- TFieldDecl(Result.Fields.Items[FieldIdx]).IsClassVar := True;
- TFieldDecl(Result.Fields.Items[FieldIdx]).Visibility := CurrVisibility;
- end;
+ MethDecl := ParseMethodDecl(False);
+ Result.Methods.Add(MethDecl);
end
else
Break;
@@ -2116,42 +1777,24 @@ end;
function TParser.ParseClassDef: TClassTypeDef;
var
- CurrPublished: Boolean;
- CurrVisibility: TMemberVisibility; { current section's visibility }
- CurrStatic: Boolean; { current section's static (class-level) association }
- LocalStatic: Boolean; { effective static for the member being parsed }
- MethDecl: TMethodDecl;
- PropDecl: TPropertyDecl;
- FieldCountBefore: Integer;
- FieldIdx: Integer;
+ CurrPublished: Boolean;
+ MethDecl: TMethodDecl;
begin
Result := TClassTypeDef.Create();
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Expect(tkClass);
- { Forward class declaration: the keyword `class` immediately followed by
- `;` (no ancestor clause, no body). `class(TBase);` and `class end;` are
- complete empty classes, not forwards. The full declaration later in the
- same type scope completes it (see uSemantic.AnalyseTypeDecls). }
- if Check(tkSemicolon) then
- begin
- Result.IsForward := True;
- Exit;
- end;
if Check(tkLParen) then
begin
Advance();
- { First name may be a plain class name, a unit-qualified ancestor
- (Unit.TParent), or a generic interface name like IFoo. ParseTypeName
- already absorbs the unit qualifier and (nested) generic arguments, so a
- qualified ancestor disambiguates a same-named type via the resolver. }
- Result.ParentName := ParseTypeName();
+ { First name may be a plain class name or a generic interface name like IFoo }
+ Result.ParentName := ParseGenericName();
{ Additional names after a comma are implemented interface names }
while Check(tkComma) do
begin
Advance();
- Result.ImplementsNames.Add(ParseTypeName());
+ Result.ImplementsNames.Add(ParseGenericName());
end;
Expect(tkRParen);
end;
@@ -2161,155 +1804,35 @@ begin
(private/public/protected/published) update CurrPublished, which
is then attached to each method decl so codegen can emit a
published-method table entry. }
- CurrPublished := False;
- CurrVisibility := mvPublic;
- CurrStatic := False;
+ CurrPublished := False;
repeat
- { Optional `strict` soft keyword preceding `private`/`protected`. `strict`
- is not a real token — recognise it only at section start, immediately
- before `private` or `protected`, so an ordinary identifier named `strict`
- elsewhere is unaffected. `strict public`, `strict published` and bare
- `strict` are errors. }
- if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
- (PeekKind() = tkIdent) and
- (SameText(PeekValueAt(1), 'private') or
- SameText(PeekValueAt(1), 'protected')) then
- begin
- Advance(); { consume `strict`; the following private/protected sets visibility }
- if SameText(FCurrent.Value, 'private') then
- CurrVisibility := mvStrictPrivate
- else
- CurrVisibility := mvStrictProtected;
- CurrPublished := False;
- CurrStatic := False;
- Advance(); { consume the private/protected keyword }
- { Optional trailing `static` section qualifier — `strict private static var`. }
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- ((PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure,
- tkConstructor, tkDestructor]) or
- ((PeekKind() = tkIdent) and SameText(PeekValueAt(1), 'property'))) then
- begin
- CurrStatic := True;
- Advance();
- end;
- end
- { `strict` not followed by private/protected is an error inside a class body. }
- else if Check(tkIdent) and SameText(FCurrent.Value, 'strict') and
- (PeekKind() = tkIdent) and
- (SameText(PeekValueAt(1), 'public') or
- SameText(PeekValueAt(1), 'published')) then
- raise EParseError.Create(Format(
- 'Only ''private'' or ''protected'' may be ''strict'' at line %d col %d in %s',
- [FCurrent.Line, FCurrent.Col, FLexer.Filename]))
- { Visibility section keyword (private/public/protected/published),
- optionally followed by a `static` qualifier. A visibility keyword
- resets the static section (you must re-state `static` after it). }
- else if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
+ if Check(tkIdent) and (SameText(FCurrent.Value, 'private') or
SameText(FCurrent.Value, 'public') or
SameText(FCurrent.Value, 'protected') or
SameText(FCurrent.Value, 'published')) then
begin
CurrPublished := SameText(FCurrent.Value, 'published');
- if SameText(FCurrent.Value, 'private') then
- CurrVisibility := mvPrivate
- else if SameText(FCurrent.Value, 'protected') then
- CurrVisibility := mvProtected
- else if SameText(FCurrent.Value, 'published') then
- CurrVisibility := mvPublished
- else
- CurrVisibility := mvPublic;
- CurrStatic := False; { a new visibility section is non-static unless
- `static` follows }
Advance(); { consume the visibility modifier }
- { Optional trailing `static` section qualifier. `static` is a soft
- keyword: treat it as a qualifier only when it introduces a static
- member (followed by var/const/method/property), NOT when it is a
- field literally named `Static` (`private Static: Boolean;`). }
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- ((PeekKind() in [tkVar, tkConst, tkFunction, tkProcedure,
- tkConstructor, tkDestructor]) or
- ((PeekKind() = tkIdent) and SameText(PeekValueAt(1), 'property'))) then
- begin
- CurrStatic := True;
- Advance();
- end;
- end
- { Bare `static` SECTION keyword — `static var` / `static const` only.
- `static` is a soft keyword: it acts as a section qualifier only when
- immediately followed by `var` or `const`. Followed by anything else
- (e.g. `Static: Boolean;` — a field literally named Static, or `Static,`)
- it is an ordinary field identifier and falls through to the field
- branch. The `static function/procedure/property` PREFIX forms are
- handled in the method/property branches below. }
- else if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkVar, tkConst]) then
- begin
- CurrStatic := True;
- Advance(); { consume `static`; the following `var`/`const` section is
- part of this static section }
end
else if Check(tkConst) then
ParseConstBlock(Result.ConstDecls)
else if Check(tkVar) then
Advance() { optional 'var' keyword before field declarations — consume and continue }
- else if (Check(tkIdent) and SameText(FCurrent.Value, 'property')) or
- (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() = tkIdent) and SameText(PeekValueAt(1), 'property')) then
+ else 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
begin
- LocalStatic := CurrStatic;
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') then
- begin
- LocalStatic := True;
- Advance(); { consume per-member `static` prefix }
- end;
- PropDecl := ParsePropertyDecl();
- PropDecl.IsStatic := LocalStatic;
- PropDecl.Visibility := CurrVisibility;
- Result.Properties.Add(PropDecl);
- end
- { Method declarations — checked BEFORE the generic field branch so that a
- leading `static` prefix on a method is not mistaken for a field name. }
- else if Check(tkFunction) or Check(tkProcedure) or
- Check(tkConstructor) or Check(tkDestructor) or
- (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure, tkConstructor, tkDestructor])) then
- begin
- LocalStatic := CurrStatic;
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') then
- begin
- LocalStatic := True;
- Advance(); { consume per-member `static` prefix }
- end;
- if Check(tkConstructor) or Check(tkDestructor) then
- begin
- if LocalStatic then
- raise EParseError.Create(Format(
- 'A constructor or destructor cannot be declared static at line %d col %d in %s'
- + ' — Blaise has no type-initialiser (class constructor); use the unit'
- + ' initialization/finalization sections',
- [FCurrent.Line, FCurrent.Col, FLexer.Filename]));
- MethDecl := ParseMethodDecl(False);
- end
- else if Check(tkFunction) then
- MethDecl := ParseMethodDecl(True)
- else
- MethDecl := ParseMethodDecl(False);
+ MethDecl := ParseMethodDecl(True);
MethDecl.IsPublished := CurrPublished;
- MethDecl.IsStatic := LocalStatic;
- MethDecl.Visibility := CurrVisibility;
Result.Methods.Add(MethDecl);
end
- else if Check(tkIdent) or Check(tkLBracket) then
+ else if Check(tkProcedure) or Check(tkConstructor) or Check(tkDestructor) then
begin
- FieldCountBefore := Result.Fields.Count;
- ParseFieldDecl(Result.Fields);
- { Stamp class-var flag and visibility on every field this decl produced. }
- for FieldIdx := FieldCountBefore to Result.Fields.Count - 1 do
- begin
- if CurrStatic then
- TFieldDecl(Result.Fields.Items[FieldIdx]).IsClassVar := True;
- TFieldDecl(Result.Fields.Items[FieldIdx]).Visibility := CurrVisibility;
- end;
+ MethDecl := ParseMethodDecl(False);
+ MethDecl.IsPublished := CurrPublished;
+ Result.Methods.Add(MethDecl);
end
else
Break;
@@ -2334,13 +1857,6 @@ begin
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
Expect(tkIntf);
- { Forward interface declaration `IFoo = interface;` — no parent, no body,
- completed later in the same type scope. }
- if Check(tkSemicolon) then
- begin
- Result.IsForward := True;
- Exit;
- end;
if Check(tkLParen) then
begin
Advance();
@@ -2549,15 +2065,6 @@ begin
begin
Result.IsExternal := True;
Advance();
- { optional: a library name string — external 'c' name 'malloc'.
- Records a unit-level link dependency (works for implementation
- imports too, so the private routine's library still propagates). }
- if Check(tkStringLit) then
- begin
- Result.ExternalLib := FCurrent.Value;
- AddLinkLib(FCurrent.Value, FCurrent.Line, FCurrent.Col);
- Advance();
- end;
{ optional: name 'c_symbol' }
if Check(tkIdent) and SameText(FCurrent.Value, 'name') then
begin
@@ -2588,9 +2095,9 @@ begin
SameText(FCurrent.Value, 'pascal') or
SameText(FCurrent.Value, 'safecall') or
SameText(FCurrent.Value, 'reintroduce') or
+ SameText(FCurrent.Value, 'static') or
SameText(FCurrent.Value, 'final') or
SameText(FCurrent.Value, 'assembler') or
- SameText(FCurrent.Value, 'nostackframe') or
SameText(FCurrent.Value, 'forward') or
SameText(FCurrent.Value, 'deprecated') or
SameText(FCurrent.Value, 'platform') or
@@ -2598,8 +2105,6 @@ begin
begin
if SameText(FCurrent.Value, 'inline') then
Result.IsInline := True
- else if SameText(FCurrent.Value, 'nostackframe') then
- Result.NoStackFrame := True
else if SameText(FCurrent.Value, 'forward') then
IsForward := True
else if SameText(FCurrent.Value, 'cdecl') or
@@ -2624,16 +2129,7 @@ begin
proc. Without this guard the forward decl swallowed the real
implementation (and everything up to the program's 'end.') as its body
(issue #130 bug2). }
- if (not Result.IsExternal) and (not IsForward) and Check(tkAsmBlock) then
- begin
- { Inline-assembler body: the lexer already captured the whole asm ... end
- block as one tkAsmBlock token whose Value is the verbatim text. Wrap it
- in a TBlock holding a single TAsmStmt; semantic treats it as opaque and
- codegen emits the text verbatim. }
- Result.Body := Self.ParseAsmBody();
- Expect(tkSemicolon);
- end
- else if (not Result.IsExternal) and (not IsForward) and
+ if (not Result.IsExternal) and (not IsForward) and
(Check(tkBegin) or Check(tkVar) or Check(tkType) or Check(tkConst) or
(ACanHaveNestedProcs and (Check(tkProcedure) or Check(tkFunction)))) then
begin
@@ -2646,21 +2142,6 @@ begin
end;
end;
-{ Build a TBlock whose sole statement is the TAsmStmt for the current
- tkAsmBlock token, then consume that token. }
-function TParser.ParseAsmBody: TBlock;
-var
- Stmt: TAsmStmt;
-begin
- Result := TBlock.Create();
- Stmt := TAsmStmt.Create();
- Stmt.Line := FCurrent.Line;
- Stmt.Col := FCurrent.Col;
- Stmt.Code := FCurrent.Value;
- Result.Stmts.Add(Stmt);
- Advance(); { consume the tkAsmBlock token }
-end;
-
procedure TParser.ParseParamList(AParams: TObjectList);
var
Par: TMethodParam;
@@ -2768,24 +2249,11 @@ end;
procedure TParser.ParseStandaloneDecl(ABlock: TBlock);
var
- IsFunc: Boolean;
- IsStat: Boolean;
- MD: TMethodDecl;
+ IsFunc: Boolean;
+ MD: TMethodDecl;
begin
- { Leading `static` on an out-of-line implementation: `static function T.M ...`.
- Consume it and record the static-ness on the parsed decl, where it is later
- reconciled against the in-class declaration. }
- IsStat := False;
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure]) then
- begin
- IsStat := True;
- Advance();
- end;
IsFunc := Check(tkFunction);
MD := ParseMethodDecl(IsFunc, True); { True = may have nested proc/func decls }
- if IsStat then
- MD.IsStatic := True;
ABlock.ProcDecls.Add(MD);
end;
@@ -3021,7 +2489,6 @@ end;
function TParser.ParseStmt: TASTStmt;
var
Name: string;
- QualUnit: string; { matched unit from a 'Unit.Symbol' target; unused here }
Line, Col: Integer;
Call: TProcCall;
Assign: TAssignment;
@@ -3176,13 +2643,6 @@ begin
Col := FCurrent.Col;
Advance();
- { Unit-qualified statement target 'Unit.Symbol' (Unit may be dotted to any
- depth). Collapse to the bare symbol so the rest of the statement parser
- treats it as an unqualified procedure call or assignment target resolved
- through the uses chain. No-op (consumes nothing) for a same-prefixed
- record/field chain — see TryCollapseUnitQualifier. }
- TryCollapseUnitQualifier(Name, Line, Col, QualUnit);
-
if Check(tkLBracket) then
begin
{ Subscript on the statement LHS. Three shapes:
@@ -3721,20 +3181,6 @@ begin
if not Check(tkRParen) then
ParseMethodCallArgList(MCall);
Expect(tkRParen);
- end
- else if not Check(tkDot) then
- begin
- { Bare 'Obj.Method' with no '(' and no further '.' chain — a
- parameterless method call written without its mandatory parentheses.
- (A following '.' is a post-call/field chain handled just below; a
- terminating bare reference is the error case.) Every call carries ()
- even with no arguments — see language-rationale.adoc, "Mandatory
- parentheses on zero-argument calls". }
- MCall.Free();
- MCall := nil;
- raise EParseError.Create(Format(
- 'Bare reference to ''%s.%s'' requires () for a call at line %d col %d in %s',
- [Name, SecondIdent, Line, Col, FLexer.Filename]));
end;
{ Post-method chain: Name.Method(args).Field := value or .Method2(args) }
if Check(tkDot) then
@@ -3909,13 +3355,11 @@ begin
FCallNode.Free();
Exit(Call);
end;
- { Bare identifier in statement position with no '(' — a parameterless
- procedure/function call written without its mandatory parentheses.
- Every call carries () even with no arguments (see language-rationale.adoc,
- "Mandatory parentheses on zero-argument calls"). }
- raise EParseError.Create(Format(
- 'Bare reference to ''%s'' requires () for a call at line %d col %d in %s',
- [Name, Line, Col, FLexer.Filename]));
+ Call := TProcCall.Create();
+ Call.Line := Line;
+ Call.Col := Col;
+ Call.Name := Name;
+ Result := Call;
end;
end;
@@ -4266,24 +3710,20 @@ begin
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
Result.Name := FCurrent.Value;
Advance();
- { Mandatory parentheses: 'inherited Method' is a call and must carry ()
- even with no arguments (see language-rationale.adoc, "Mandatory
- parentheses on zero-argument calls"). }
- if not Check(tkLParen) then
- raise EParseError.Create(Format(
- 'Bare reference to ''%s'' requires () for a call at line %d col %d in %s',
- [Result.Name, FCurrent.Line, FCurrent.Col, FLexer.Filename]));
- Advance();
- if not Check(tkRParen) then
+ if Check(tkLParen) then
begin
- Result.Args.Add(ParseExpr());
- while Check(tkComma) do
+ Advance();
+ if not Check(tkRParen) then
begin
- Advance();
Result.Args.Add(ParseExpr());
+ while Check(tkComma) do
+ begin
+ Advance();
+ Result.Args.Add(ParseExpr());
+ end;
end;
+ Expect(tkRParen);
end;
- Expect(tkRParen);
except
Result.Free();
raise;
@@ -4525,14 +3965,6 @@ begin
begin
Result.IsExternal := True;
Advance();
- { optional library name — external 'c' name 'malloc' (records a
- unit-level link dependency). }
- if Check(tkStringLit) then
- begin
- Result.ExternalLib := FCurrent.Value;
- AddLinkLib(FCurrent.Value, FCurrent.Line, FCurrent.Col);
- Advance();
- end;
if Check(tkIdent) and SameText(FCurrent.Value, 'name') then
begin
Advance();
@@ -4585,7 +4017,6 @@ var
InitStmt: TASTStmt;
begin
Result := TUnit.Create();
- FLinkLibs := Result.LinkLibs; { collect external 'lib' deps into the unit }
try
Result.Line := FCurrent.Line;
Result.Col := FCurrent.Col;
@@ -4633,18 +4064,9 @@ begin
ParseUsesList(Result.ImplUsedUnits); { implementation-only deps — loaded but not re-exported }
while Check(tkProcedure) or Check(tkFunction) or
Check(tkConstructor) or Check(tkDestructor) or
- Check(tkVar) or Check(tkThreadVar) or Check(tkConst) or Check(tkType) or
- (Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure])) do
+ Check(tkVar) or Check(tkThreadVar) or Check(tkConst) or Check(tkType) do
begin
- if Check(tkIdent) and SameText(FCurrent.Value, 'static') and
- (PeekKind() in [tkFunction, tkProcedure]) then
- { Out-of-line static-method body in the implementation section:
- `static function T.M ...`. Mirror the program-level standalone path
- (ParseStandaloneDecl) — consume `static`, parse the routine, mark it
- IsStatic so it reconciles against the in-class static declaration. }
- ParseStandaloneDecl(Result.ImplBlock)
- else if Check(tkFunction) then
+ if Check(tkFunction) then
Result.ImplBlock.ProcDecls.Add(ParseMethodDecl(True, True))
else if Check(tkVar) or Check(tkThreadVar) then
ParseVarBlock(Result.ImplBlock)
@@ -4876,7 +4298,6 @@ var
Inner: TASTExpr;
Name: string;
SecondName: string;
- QualUnit: string;
Line, Col: Integer;
ZeroNode: TIntLiteral;
NegNode: TBinaryExpr;
@@ -4902,24 +4323,20 @@ begin
[FCurrent.Line, FCurrent.Col, FLexer.Filename]));
InhNode.Name := FCurrent.Value;
Advance();
- { Mandatory parentheses: 'inherited Method' is a call and must carry
- () even with no arguments (see language-rationale.adoc, "Mandatory
- parentheses on zero-argument calls"). }
- if not Check(tkLParen) then
- raise EParseError.Create(Format(
- 'Bare reference to ''%s'' requires () for a call at line %d col %d in %s',
- [InhNode.Name, FCurrent.Line, FCurrent.Col, FLexer.Filename]));
- Advance();
- if not Check(tkRParen) then
+ if Check(tkLParen) then
begin
- InhNode.Args.Add(Self.ParseExpr());
- while Check(tkComma) do
+ Advance();
+ if not Check(tkRParen) then
begin
- Advance();
InhNode.Args.Add(Self.ParseExpr());
+ while Check(tkComma) do
+ begin
+ Advance();
+ InhNode.Args.Add(Self.ParseExpr());
+ end;
end;
+ Expect(tkRParen);
end;
- Expect(tkRParen);
Result := InhNode;
end;
tkAt:
@@ -4999,15 +4416,6 @@ begin
Line := FCurrent.Line;
Col := FCurrent.Col;
Advance();
- { Unit-qualified reference 'Unit.Symbol' (Unit may be dotted to any
- depth). Collapse to the bare Symbol and reposition the origin to it,
- so everything below resolves Symbol through the uses chain as an
- unqualified reference — a free call when '(' follows, otherwise a
- plain identifier / indexed / chained / generic access. No-op for a
- same-prefixed record/field chain. QualUnit captures the matched
- unit so a plain identifier can be resolved against that unit's own
- exports (see IdNode.QualifierUnit below). }
- TryCollapseUnitQualifier(Name, Line, Col, QualUnit);
{ Generic constructor: TypeName.Method or diamond TypeName<>.Method
Heuristic: '<' followed by IDENT followed by '>' or ',' is treated as
generic type args. '<>' (empty) is the diamond operator — type args
@@ -5100,7 +4508,6 @@ begin
MCallNode.Col := Col;
MCallNode.ObjectName := Name;
MCallNode.Name := SecondName;
- MCallNode.QualifierUnit := QualUnit;
Advance();
if not Check(tkRParen) then
begin
@@ -5122,7 +4529,6 @@ begin
FldNode.Col := Col;
FldNode.RecordName := Name;
FldNode.FieldName := SecondName;
- FldNode.QualifierUnit := QualUnit;
Result := FldNode;
{ Indexed property read: Ident.Prop[idx] }
if Check(tkLBracket) then
@@ -5261,7 +4667,6 @@ begin
IdNode.Line := Line;
IdNode.Col := Col;
IdNode.Name := Name;
- IdNode.QualifierUnit := QualUnit;
Result := IdNode;
end;
{ Postfix dereference: Expr^ and optional Expr^.Field chaining }
diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas
index f947aa3..8cb8ef9 100644
--- a/compiler/src/main/pascal/uSemantic.pas
+++ b/compiler/src/main/pascal/uSemantic.pas
@@ -27,16 +27,6 @@ uses
type
ESemanticError = class(Exception);
- { One entry in the enum-member reverse index: the enum type a member
- belongs to, the member's ordinal value, and a monotonic declaration
- rank (higher = declared later, wins the context-free ambiguity
- fallback). Owned by TSemanticAnalyser.FEnumMemberRefs. }
- TEnumMemberRef = class
- EnumDesc: TEnumTypeDesc;
- Ordinal: Int64;
- Order: Integer;
- end;
-
TSemanticAnalyser = class(TUsesChainProvider)
private
FTable: TSymbolTable;
@@ -74,15 +64,6 @@ type
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) }
- FCurrentMethodOwner: TRecordTypeDesc; { declaring type of the method body
- currently being analysed — set for
- BOTH instance and STATIC methods.
- Unlike FCurrentClass (nil inside a
- static body so implicit-Self refs
- fail), this is used only by member-
- visibility checks so a strict-private
- member is reachable from its own
- type's static methods too. }
{ Type-parameter names in scope while analysing an instantiated generic
body (T, K, V, ...). These are registered as skType aliases (T=Integer)
so the body resolves, but they are NOT user-declared types, so a local
@@ -94,13 +75,6 @@ type
FArrayConstCounter: Integer; { counter for generating unique array-const data labels }
FAnonEnumCounter: Integer; { counter for unique anonymous-enum type names (inline 'set of (a,b,c)') }
FCurrentUnitName: string; { name of the unit/program currently being analysed }
- FMethodOwnerHint: string; { receiver owning-unit hint for the NEXT
- ResolveMethodOverload call, consumed and
- cleared at its start. Disambiguates a
- method on a cross-unit same-named type to
- the receiver's actual unit. A field, not
- a parameter, to keep ResolveMethodOverload
- within the 6-register call ABI. }
FCurrentEnclosingDecl: TMethodDecl; { the innermost standalone proc/func currently being analysed;
nil at program level. Used to set EnclosingDecl on nested procs. }
FUnitIfaces: TStringList; { owned list (case-insensitive) — keys are unit
@@ -125,21 +99,6 @@ type
source order. Lookup walks this list right-to-left
("last in uses wins"); System is the final fallback.
Empty during pure import phases. }
- FEnumMemberIndex: TStringList; { owned (case-insensitive, dupAccept) — reverse
- index of enum member names. Strings[I] is a
- member name, Objects[I] a TEnumMemberRef giving
- its enum type + ordinal + declaration order.
- A name may appear more than once (the same
- member name in several enums); resolution
- picks by context, uniqueness, or last-wins.
- Replaces the old bare skConstant registration
- — enum members are no longer flat globals. }
- FEnumMemberRefs: TObjectList; { owns the TEnumMemberRef holders pointed at by
- FEnumMemberIndex.Objects (TStringList does not
- own its Objects). }
- FEnumOrderCounter: Integer; { monotonic rank stamped on each member as it is
- registered; higher = declared later = wins the
- context-free ambiguity fallback. }
{ Add ADecl to FProcIndex under key AName, auto-tagging
ADecl.OwningUnit from FCurrentUnitName if not already set.
@@ -153,37 +112,12 @@ type
IndexOf can return a same-named decl from an imported unit. }
function IndexOfProcInUnit(const AName, AUnitName: string): Integer;
- { The emitted/imported link symbol for a standalone routine: the
- `external name` for an external binding (defaulting to the Pascal name),
- else ResolvedQbeName (bare name for unmangled RTL units) or the name. }
- function EffectiveLinkName(A: TMethodDecl): string;
-
- { True when A and B denote the SAME underlying link symbol with the same
- arity, where AT LEAST one side is an external binding. Covers two units
- each declaring `external name 'strlen'` AND a binding (`external name
- '_BlaiseGetMem'`) targeting a real function exported by an unmangled RTL
- unit. Used to collapse false "ambiguous overload" / "duplicate
- identifier" errors in the multi-unit flat-merge. }
- function SameLinkSymbol(A, B: TMethodDecl): Boolean;
-
{ True when A and B are two declarations of the SAME external C function —
both external, same effective link name, same arity. Used to collapse the
false "ambiguous overload" that arises when two units each privately
declare e.g. `external name 'strlen'`. }
function SameExternalDecl(A, B: TMethodDecl): Boolean;
- { True when every candidate in AList collapses to the same link symbol as
- the first (per SameLinkSymbol). Used when arg scoring is unavailable
- (zero-arity early path). }
- function AllSameExternalDecl(AList: TObjectList): Boolean;
-
- { True when the global scope already holds a symbol that denotes the SAME
- external C function as ANew — e.g. two units each declaring
- `function _BlaiseGetMem(...): Pointer; external name '_BlaiseGetMem';`.
- Such a re-declaration is benign (one underlying symbol), not a genuine
- duplicate identifier. Returns False for anything but matching externals. }
- function BenignDuplicateExternal(ANew: TMethodDecl): Boolean;
-
{ Overload-group plumbing (see FProcGroups/FMethodGroups). Every
FProcIndex/FMethodIndex AddObject must go through the Add*GroupEntry
sibling so the groups stay complete; FProcIndex.Objects[] rewrites go
@@ -280,11 +214,7 @@ type
procedure AnalyseStandaloneDecls(ABlock: TBlock);
procedure AnalyseStandaloneBodies(ABlock: TBlock);
procedure AnalyseStandaloneDecl(ADecl: TMethodDecl);
- procedure CollectCaptures(ADecl: TMethodDecl; AOuterDecl: TMethodDecl);
- { Add AName to ADecl.CapturedVars if it names an enclosing variable
- (member of AOuterVars) not already recorded. }
- procedure MaybeCaptureName(ADecl: TMethodDecl; AOuterVars: TStringList;
- const AName: string);
+ procedure CollectCaptures(ADecl: TMethodDecl; AOuterBlock: TBlock);
{ Inlining: after bodies are analysed, mark each TMethodDecl whose body
qualifies for codegen-side inlining. Conservative: primitive params
+ return + locals only; no try/loops/raise/nested defs; small body.
@@ -307,8 +237,6 @@ type
procedure AnalyseFieldAssignment(AAssign: TFieldAssignment);
function TryAnalyseFieldElemWrite(AAssign: TFieldAssignment;
AFldInfo: TFieldInfo): Boolean;
- function TryLowerDefaultPropertyWrite(AAssign: TFieldAssignment;
- AMemberType: TTypeDesc): Boolean;
function FloatBuiltinArgType(const AName: string; AArgType: TTypeDesc;
ALine, ACol: Integer): TTypeDesc;
procedure AnalyseProcCall(ACall: TProcCall);
@@ -362,8 +290,6 @@ type
function AnalyseExpr(AExpr: TASTExpr): TTypeDesc;
function AnalyseBinaryExpr(ABin: TBinaryExpr): TTypeDesc;
function AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
- function TryLowerDefaultPropertyIndex(AAccess: TFieldAccessExpr;
- APropInfo: TPropertyInfo): TTypeDesc;
function AnalyseIsExpr(AExpr: TIsExpr): TTypeDesc;
function AnalyseAsExpr(AExpr: TAsExpr): TTypeDesc;
function AnalyseSupportsExpr(AExpr: TSupportsExpr): TTypeDesc;
@@ -500,107 +426,6 @@ type
the chain without going through the flat global. }
function FindUnitSymbol(const AUnitName, ASymName: string): TSymbol;
- { Directed lookup — "look in unit AUnit for the symbol AName".
- This is THE single entry point for every unit-qualified reference
- 'Unit.Symbol' (idents, type names, statement targets): a unit
- prefix means resolve against that specific unit's exports, never
- the flat table or the uses chain. Returns the symbol AUnit
- exports under AName (of any kind — const/var/type/routine), or nil
- when AUnit exports no such name. Consults the per-unit cache
- first, then the unit's interface as a fallback for symbols not yet
- harvested into the cache. }
- function ResolveQualified(const AUnit, AName: string): TSymbol;
-
- { Define a module-scope global (interface var) with cross-unit
- last-in-uses-wins semantics, mirroring AnalyseConstDecls. On a
- clean Define the symbol is registered in the per-unit cache; on a
- cross-unit collision the prior unit's symbol is detached (kept alive
- in the per-unit cache so a qualified Unit.Var reference still reaches
- it) and this unit's symbol is installed as the flat winner. Same-unit
- redeclaration and module-name markers stay hard errors. }
- procedure DefineGlobalLastWins(ASym: TSymbol; ALine, ACol: Integer);
-
- { Define a type name with the same cross-unit last-found-wins rule as
- DefineGlobalLastWins: a collision against a type owned by a DIFFERENT
- used unit detaches the prior type (kept in the per-unit cache so a
- qualified Unit.Type reference still reaches it) and installs this unit's
- type as the flat winner; a same-unit redeclaration or a non-unit/module
- collision stays the hard 'Duplicate type name' error. }
- procedure DefineTypeLastWins(ASym: TSymbol; ATypeDecl: TTypeDecl;
- ALine, ACol: Integer);
-
- { Record one enum member in the reverse index (FEnumMemberIndex).
- Called once per member as its enum type is analysed. Enum members
- are NOT registered as bare global symbols any more — a bare member
- name resolves through ResolveEnumMember instead. }
- procedure RegisterEnumMember(const AName: string;
- AEnum: TEnumTypeDesc; AOrdinal: Int64);
-
- { Resolve a bare enum member name to (enum type, ordinal). Cascade:
- AExpectedType (an enum, or set-of-enum) names the enum -> that one;
- else a single candidate -> that one; else the latest-declared
- candidate (last-wins). Returns nil when no enum has the member.
- AExpectedType may be nil (no context, e.g. Ord/const-fold). }
- function ResolveEnumMember(const AName: string;
- AExpectedType: TTypeDesc): TEnumMemberRef;
-
- { Context-directed resolution of a bare enum-member identifier. If AExpr
- is an unresolved TIdentExpr that is not a normal symbol and names a
- member of (or compatible with) AExpectedType, mark it constant in place
- and return True; the caller then reads AExpr.ResolvedType and must NOT
- call AnalyseExpr on it again. Returns False for anything else, leaving
- AExpr untouched for the normal expression path. }
- function TryResolveBareEnumIdent(AExpr: TASTExpr;
- AExpectedType: TTypeDesc): Boolean;
-
- { Analyse AExpr, first giving a bare enum-member identifier the chance to
- resolve against AExpectedType (the known target/element/parameter type).
- Returns the expression's resolved type. Use this anywhere an expression
- is analysed into a context whose enum type is already known. }
- function AnalyseExprHinted(AExpr: TASTExpr;
- AExpectedType: TTypeDesc): TTypeDesc;
-
- { How many enums declare a member of this name. >1 means a bare,
- context-free reference is ambiguous and must be qualified. }
- function EnumMemberCandidateCount(const AName: string): Integer;
-
- { Comma-separated names of every enum that declares a member AName, in
- declaration order — used to spell out an ambiguity in diagnostics. }
- function EnumMemberOwners(const AName: string): string;
-
- { Enum hint for a bare member passed as call argument APos to a routine
- named AName with AArity actuals. Walks the overload candidates and,
- among those whose parameter at APos is an enum (or set-of-enum) that
- actually declares AMember, returns that enum when exactly one distinct
- enum qualifies — so a bare shared member is steered to the only enum the
- call could accept. Returns nil when zero or several enums qualify (the
- arg then falls to the context-free last-wins path). }
- { The enum a single parameter would accept for a bare member: the param's
- enum (or set-of-enum base) when it declares AMember and the decl can take
- AArity actuals; nil otherwise. }
- function EnumOfParamAccepting(ADecl: TMethodDecl; AArity, APos: Integer;
- const AMember: string): TTypeDesc;
- function EnumArgHint(const AName: string; AArity, APos: Integer;
- const AMember: string): TTypeDesc;
- { Like EnumArgHint but walks the method overload set up the inheritance
- chain of ATypeName (mirrors ResolveMethodOverload's candidate walk). }
- function EnumMethodArgHint(const ATypeName, AMethodName: string;
- AArity, APos: Integer;
- const AMember: string): TTypeDesc;
- { True if AArg is a bare identifier that names an enum member and is not a
- real symbol — i.e. a candidate for context-directed enum resolution. }
- function BareEnumArgCandidate(AArg: TASTExpr): Boolean;
-
- { Pre-pass over a call's actuals: pin any bare, context-free enum-member
- argument to the enum its target routine expects at that position, before
- the args are analysed bottom-up. Lets Foo(meVal) reach the meVal of
- Foo's parameter enum even when meVal is shared by several enums, and
- keeps the no-warning path for an otherwise-ambiguous bare member. }
- procedure HintBareEnumArgs(const AName: string; AArgs: TObjectList);
- { As HintBareEnumArgs, for a method call on a receiver of type ATypeName. }
- procedure HintBareEnumMethodArgs(const ATypeName, AMethodName: string;
- AArgs: TObjectList);
-
{ Reserve a module name in the current scope (issue #84). Defines
an skModule marker so any same-scope declaration of that name
fails the normal duplicate check, matching FPC/Delphi. A failed
@@ -661,39 +486,6 @@ type
const AMemberName: string;
ALine, ACol: Integer);
- { Core visibility predicate. Single source of truth applied by both
- the unqualified uses-chain probe and the qualified member-access
- asserts. ADeclaringUnit / ADeclaringType identify where the member
- was declared; AFromClass is the class whose method body we are in
- (or nil at unit/free-routine level). }
- function MemberVisibleTo(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AFromUnit: string;
- AFromClass: TRecordTypeDesc): Boolean;
-
- { Richer qualified-access assert that carries the member's visibility
- and declaring type. On invisible, hard error. }
- procedure AssertMemberVisibleV(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AMemberName: string;
- ALine, ACol: Integer);
-
- { Visibility enforcement for a STATIC (class-level) variable access. Like
- AssertMemberVisibleV but treats the current method's declaring type as the
- "from" class even inside a static method (FCurrentClass is nil there), so a
- strict-private static var stays reachable from its own type's static
- methods. }
- procedure AssertStaticVarVisible(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AMemberName: string;
- ALine, ACol: Integer);
-
- { Qualified instance/class method-call visibility enforcement. AMDecl is
- the resolved TMethodDecl (via ResolveMethodOverload or FindMethodDecl);
- reads its Visibility / OwningUnit / OwnerTypeName. No-op when AMDecl is
- nil. Constructors are exempt (always reachable for instantiation). }
- procedure EnforceMethodVisible(AMDecl: TObject; ALine, ACol: Integer);
-
{ Uses-chain lookup for *unqualified* identifiers. Walks
FCurrentUsesChain right-to-left ("last in uses wins"); for
each chain entry whose TUnitInterface advertises AName via
@@ -714,15 +506,14 @@ type
implementation
-{ Float<->string conversion uses the RTL's pure-Pascal _DoubleToStr / _StrToDouble,
- NOT libc's snprintf / strtod. snprintf is a genuinely variadic function;
- declaring it with a fixed Double parameter violates the SysV x86-64 variadic ABI
- (the %al vector-register count is left unset), so glibc may read the double from
- the wrong place and emit a wrong string (environment-dependent miscompilation of
- folded float constants — passes locally, fails in CI). Routing both directions
- through the RTL also drops the last libc dependency in this path, so a --static
- (libc-free) build of the compiler links without strtod. }
-function _StrToDouble(S: Pointer): Double; external name '_StrToDouble';
+{ Double->string conversion uses the RTL's pure-Pascal _DoubleToStr, NOT libc's
+ snprintf. snprintf is a genuinely variadic function; declaring it with a fixed
+ Double parameter violates the SysV x86-64 variadic ABI (the %al vector-register
+ count is left unset), so glibc may read the double from the wrong place and emit
+ a wrong string. The symptom is environment-dependent miscompilation of folded
+ float constants (passes locally, fails in CI). _DoubleToStr is FormatFloat(.,15),
+ i.e. %.15g, and is ABI-safe. strtod is NOT variadic, so it is kept as-is. }
+function _strtod(S: PChar; EndPtr: Pointer): Double; external name 'strtod';
function _DoubleToStr(V: Double): string; external name '_DoubleToStr';
function RawDoubleToStr(V: Double): string;
@@ -732,7 +523,7 @@ end;
function RawStrToDouble(const S: string): Double;
begin
- Result := _StrToDouble(PChar(S));
+ Result := _strtod(PChar(S), nil);
end;
function TSemanticAnalyser.GetSymbolTable: TSymbolTable;
@@ -753,11 +544,6 @@ begin
FMethodGroups := TStringList.Create();
FMethodGroups.CaseSensitive := False;
FGroupKeepAlive := TObjectList.Create(False);
- FEnumMemberIndex := TStringList.Create();
- FEnumMemberIndex.CaseSensitive := False;
- FEnumMemberIndex.Duplicates := dupAccept;
- FEnumMemberRefs := TObjectList.Create(True); { owns the holders }
- FEnumOrderCounter := 0;
FGenericFuncTemplates := TStringList.Create();
FGenericFuncTemplates.CaseSensitive := False;
FGenericMethodTemplates := TStringList.Create();
@@ -790,8 +576,6 @@ begin
{ Releasing the keep-alive releases every group list; the group string
lists themselves only hold raw pointers. }
FGroupKeepAlive.Free();
- FEnumMemberRefs.Free(); { frees the holders }
- FEnumMemberIndex.Free();
FProcGroups.Free();
FMethodGroups.Free();
FProcIndex.Free();
@@ -808,264 +592,6 @@ begin
raise ESemanticError.Create(Format('%s at line %d col %d', [AMsg, ALine, ACol]));
end;
-procedure TSemanticAnalyser.RegisterEnumMember(const AName: string;
- AEnum: TEnumTypeDesc; AOrdinal: Int64);
-var
- Ref: TEnumMemberRef;
-begin
- Ref := TEnumMemberRef.Create();
- Ref.EnumDesc := AEnum;
- Ref.Ordinal := AOrdinal;
- Inc(FEnumOrderCounter);
- Ref.Order := FEnumOrderCounter;
- FEnumMemberRefs.Add(Ref); { owns Ref }
- FEnumMemberIndex.AddObject(AName, Ref); { non-owning view, dupAccept }
-end;
-
-function TSemanticAnalyser.ResolveEnumMember(const AName: string;
- AExpectedType: TTypeDesc): TEnumMemberRef;
-var
- I: Integer;
- Ref: TEnumMemberRef;
- Best: TEnumMemberRef;
- Count: Integer;
- WantEnum: TEnumTypeDesc;
-begin
- Result := nil;
- { An expected set-of-enum context narrows to its element enum. }
- WantEnum := nil;
- if AExpectedType <> nil then
- begin
- if AExpectedType is TEnumTypeDesc then
- WantEnum := TEnumTypeDesc(AExpectedType)
- else if (AExpectedType is TSetTypeDesc) and
- (TSetTypeDesc(AExpectedType).BaseType is TEnumTypeDesc) then
- WantEnum := TEnumTypeDesc(TSetTypeDesc(AExpectedType).BaseType);
- end;
-
- Best := nil;
- Count := 0;
- for I := 0 to FEnumMemberIndex.Count - 1 do
- begin
- if not SameText(FEnumMemberIndex.Strings[I], AName) then Continue;
- Ref := TEnumMemberRef(FEnumMemberIndex.Objects[I]);
- { Context hit: an enum the caller asked for wins outright. }
- if (WantEnum <> nil) and (Ref.EnumDesc = WantEnum) then
- Exit(Ref);
- Inc(Count);
- { Track the latest-declared candidate for the context-free fallback. }
- if (Best = nil) or (Ref.Order > Best.Order) then
- Best := Ref;
- end;
-
- if Count = 0 then Exit(nil); { no enum has this member }
- { One candidate -> unambiguous; many -> last-declared wins. }
- Result := Best;
-end;
-
-function TSemanticAnalyser.TryResolveBareEnumIdent(AExpr: TASTExpr;
- AExpectedType: TTypeDesc): Boolean;
-var
- Ref: TEnumMemberRef;
-begin
- Result := False;
- if not (AExpr is TIdentExpr) then Exit;
- { Already resolved (e.g. a set range expanded into constant members). }
- if TIdentExpr(AExpr).IsConstant then Exit;
- { A real symbol of that name always wins — do not shadow it with an enum. }
- if FTable.Lookup(TIdentExpr(AExpr).Name) <> nil then Exit;
- Ref := ResolveEnumMember(TIdentExpr(AExpr).Name, AExpectedType);
- if Ref = nil then Exit;
- TIdentExpr(AExpr).IsConstant := True;
- TIdentExpr(AExpr).ConstValue := Ref.Ordinal;
- TIdentExpr(AExpr).ResolvedType := Ref.EnumDesc;
- AExpr.ResolvedType := Ref.EnumDesc;
- Result := True;
-end;
-
-function TSemanticAnalyser.AnalyseExprHinted(AExpr: TASTExpr;
- AExpectedType: TTypeDesc): TTypeDesc;
-begin
- if TryResolveBareEnumIdent(AExpr, AExpectedType) then
- Result := AExpr.ResolvedType
- else
- Result := AnalyseExpr(AExpr);
-end;
-
-function TSemanticAnalyser.EnumMemberCandidateCount(const AName: string): Integer;
-var
- I: Integer;
-begin
- Result := 0;
- for I := 0 to FEnumMemberIndex.Count - 1 do
- if SameText(FEnumMemberIndex.Strings[I], AName) then
- Inc(Result);
-end;
-
-function TSemanticAnalyser.EnumMemberOwners(const AName: string): string;
-var
- I: Integer;
- Ref: TEnumMemberRef;
-begin
- Result := '';
- for I := 0 to FEnumMemberIndex.Count - 1 do
- if SameText(FEnumMemberIndex.Strings[I], AName) then
- begin
- Ref := TEnumMemberRef(FEnumMemberIndex.Objects[I]);
- if Result <> '' then
- Result := Result + ', ';
- Result := Result + Ref.EnumDesc.Name;
- end;
-end;
-
-function TSemanticAnalyser.EnumOfParamAccepting(ADecl: TMethodDecl;
- AArity, APos: Integer; const AMember: string): TTypeDesc;
-var
- Par: TMethodParam;
- PT: TTypeDesc;
- Enum: TEnumTypeDesc;
- M: Integer;
-begin
- Result := nil;
- if (ADecl = nil) or (APos < 0) or (APos >= ADecl.Params.Count) then Exit;
- { An overload that cannot take this many actuals is not a candidate. }
- if ADecl.Params.Count < AArity then Exit;
- Par := TMethodParam(ADecl.Params.Items[APos]);
- PT := Par.ResolvedType;
- if PT = nil then Exit;
- if PT is TEnumTypeDesc then
- Enum := TEnumTypeDesc(PT)
- else if (PT is TSetTypeDesc) and
- (TSetTypeDesc(PT).BaseType is TEnumTypeDesc) then
- Enum := TEnumTypeDesc(TSetTypeDesc(PT).BaseType)
- else
- Exit;
- { Only an enum that actually declares the bare member can accept it. }
- for M := 0 to Enum.Members.Count - 1 do
- if SameText(Enum.Members.Strings[M], AMember) then
- Exit(Enum);
-end;
-
-function TSemanticAnalyser.EnumArgHint(const AName: string;
- AArity, APos: Integer; const AMember: string): TTypeDesc;
-var
- I: Integer;
- Enum: TTypeDesc;
- Found: TTypeDesc;
-begin
- Result := nil;
- Found := nil;
- for I := 0 to FProcIndex.Count - 1 do
- begin
- if not SameText(FProcIndex.Strings[I], AName) then Continue;
- Enum := EnumOfParamAccepting(TMethodDecl(FProcIndex.Objects[I]),
- AArity, APos, AMember);
- if Enum = nil then Continue;
- if Found = nil then
- Found := Enum
- else if Found <> Enum then
- Exit(nil); { several enums could accept it — not a unique hint }
- end;
- Result := Found;
-end;
-
-function TSemanticAnalyser.EnumMethodArgHint(const ATypeName, AMethodName: string;
- AArity, APos: Integer; const AMember: string): TTypeDesc;
-var
- CurrName: string;
- Sym: TSymbol;
- RT: TRecordTypeDesc;
- Grp: TObjectList;
- K: Integer;
- Cand: TMethodDecl;
- Enum: TTypeDesc;
- Found: TTypeDesc;
- SawHiding: Boolean;
-begin
- Result := nil;
- Found := nil;
- CurrName := ATypeName;
- { Walk the inheritance chain exactly as ResolveMethodOverload does: a
- non-`overload` method at a level hides inherited same-named methods. }
- while CurrName <> '' do
- begin
- Grp := GroupOf(FMethodGroups, CurrName + '.' + AMethodName);
- SawHiding := False;
- if Grp <> nil then
- for K := 0 to Grp.Count - 1 do
- begin
- Cand := TMethodDecl(Grp.Items[K]);
- if not Cand.IsOverload then SawHiding := True;
- Enum := EnumOfParamAccepting(Cand, AArity, APos, AMember);
- if Enum <> nil then
- begin
- if Found = nil then
- Found := Enum
- else if Found <> Enum then
- Exit(nil);
- end;
- end;
- if SawHiding then Break;
- 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 := Found;
-end;
-
-function TSemanticAnalyser.BareEnumArgCandidate(AArg: TASTExpr): Boolean;
-begin
- Result := False;
- if not (AArg is TIdentExpr) then Exit;
- if TIdentExpr(AArg).IsConstant then Exit;
- { A real symbol of that name always wins. }
- if FTable.Lookup(TIdentExpr(AArg).Name) <> nil then Exit;
- { Only worth steering when the name is a known enum member. }
- Result := EnumMemberCandidateCount(TIdentExpr(AArg).Name) > 0;
-end;
-
-procedure TSemanticAnalyser.HintBareEnumArgs(const AName: string;
- AArgs: TObjectList);
-var
- I: Integer;
- Arg: TASTExpr;
- Hint: TTypeDesc;
-begin
- if AArgs = nil then Exit;
- for I := 0 to AArgs.Count - 1 do
- begin
- Arg := TASTExpr(AArgs.Items[I]);
- if not BareEnumArgCandidate(Arg) then Continue;
- Hint := EnumArgHint(AName, AArgs.Count, I, TIdentExpr(Arg).Name);
- if Hint <> nil then
- TryResolveBareEnumIdent(Arg, Hint);
- end;
-end;
-
-procedure TSemanticAnalyser.HintBareEnumMethodArgs(const ATypeName,
- AMethodName: string; AArgs: TObjectList);
-var
- I: Integer;
- Arg: TASTExpr;
- Hint: TTypeDesc;
-begin
- if AArgs = nil then Exit;
- for I := 0 to AArgs.Count - 1 do
- begin
- Arg := TASTExpr(AArgs.Items[I]);
- if not BareEnumArgCandidate(Arg) then Continue;
- Hint := EnumMethodArgHint(ATypeName, AMethodName, AArgs.Count, I,
- TIdentExpr(Arg).Name);
- if Hint <> nil then
- TryResolveBareEnumIdent(Arg, Hint);
- end;
-end;
-
function TSemanticAnalyser.AttrMatches(const AAttrName, ACanonical: string): Boolean;
{ An attribute name matches a canonical form if it equals the canonical
name case-insensitively, or if it equals Attribute (the
@@ -1498,80 +1024,23 @@ begin
Result := -1;
end;
-function TSemanticAnalyser.EffectiveLinkName(A: TMethodDecl): string;
-begin
- if A = nil then
- begin
- Result := '';
- Exit;
- end;
- if A.IsExternal then
- begin
- { External binding: link symbol is the `external name`, else Pascal name. }
- if A.ExternalName <> '' then Result := A.ExternalName
- else Result := A.Name;
- end
- else
- begin
- { Real routine: emitted symbol is ResolvedQbeName when set (bare name for
- unmangled RTL units blaise_*/rtl.*), else the Pascal name. }
- if A.ResolvedQbeName <> '' then Result := A.ResolvedQbeName
- else Result := A.Name;
- end;
-end;
-
-function TSemanticAnalyser.SameLinkSymbol(A, B: TMethodDecl): Boolean;
-begin
- Result := False;
- if (A = nil) or (B = nil) then Exit;
- { At least one side must be an external binding — two distinct real routines
- that merely share a name are a genuine clash, not the same symbol. }
- if not (A.IsExternal or B.IsExternal) then Exit;
- if A.Params.Count <> B.Params.Count then Exit;
- Result := SameText(Self.EffectiveLinkName(A), Self.EffectiveLinkName(B));
-end;
-
function TSemanticAnalyser.SameExternalDecl(A, B: TMethodDecl): Boolean;
+var
+ LinkA, LinkB: string;
begin
Result := False;
if (A = nil) or (B = nil) then Exit;
if not (A.IsExternal and B.IsExternal) then Exit;
- Result := Self.SameLinkSymbol(A, B);
-end;
-
-function TSemanticAnalyser.AllSameExternalDecl(AList: TObjectList): Boolean;
-var
- I: Integer;
- First: TMethodDecl;
-begin
- Result := False;
- if (AList = nil) or (AList.Count < 2) then Exit;
- First := TMethodDecl(AList.Items[0]);
- for I := 1 to AList.Count - 1 do
- if not Self.SameLinkSymbol(First, TMethodDecl(AList.Items[I])) then
- Exit;
- Result := True;
-end;
-
-function TSemanticAnalyser.BenignDuplicateExternal(ANew: TMethodDecl): Boolean;
-var
- Existing: TSymbol;
-begin
- Result := False;
- if ANew = nil then Exit;
- { Only an external binding can benignly duplicate an existing symbol. }
- if not ANew.IsExternal then Exit;
- { The clash was detected in the global scope (interface symbols define at
- scope depth 1), so resolve the colliding symbol there directly — the
- uses-chain Lookup could otherwise return a shadowing symbol from a
- different scope. }
- Existing := FTable.GlobalScope().LookupLocal(ANew.Name);
- if Existing = nil then Exit;
- if not (Existing.Kind in [skProcedure, skFunction]) then Exit;
- if Existing.Decl = nil then Exit;
- { Same underlying link symbol — e.g. an `external name '_BlaiseGetMem'`
- binding targeting the real _BlaiseGetMem exported by blaise_mem. }
- Result := Self.SameLinkSymbol(TMethodDecl(Existing.Decl), ANew);
+ if A.Params.Count <> B.Params.Count then Exit;
+ if A.ExternalName <> '' then
+ LinkA := A.ExternalName
+ else
+ LinkA := A.Name;
+ if B.ExternalName <> '' then
+ LinkB := B.ExternalName
+ else
+ LinkB := B.Name;
+ Result := SameText(LinkA, LinkB);
end;
procedure TSemanticAnalyser.BuildUsesChain(AUsedUnits: TStringList);
@@ -1608,7 +1077,7 @@ var
I: Integer;
begin
FProg := AProg;
- FlushPendingGenericInstances();
+ FlushPendingGenericInstances;
FCurrentUnitName := AProg.Name;
BuildUsesChain(AProg.UsedUnits);
FTable.UsesChainProvider := Self;
@@ -1642,7 +1111,7 @@ var
begin
FCurrentUnitName := AUnit.Name;
FCurrentUnit := AUnit;
- FlushPendingGenericInstances();
+ FlushPendingGenericInstances;
FTable.PushScope();
try
{ The unit's own name and the names of directly used units are
@@ -1663,7 +1132,7 @@ begin
*before* any FindTypeOrInstantiate call can clone an instance, or the
instance is born with nil bodies and codegen emits no function for it. }
LinkGenericClassMethodImpls(AUnit.ImplBlock);
- RepairEarlyGenericInstances();
+ RepairEarlyGenericInstances;
{ Register interface-section global variables — visible to impl bodies. }
for I := 0 to AUnit.IntfBlock.Decls.Count - 1 do
@@ -1743,14 +1212,8 @@ begin
if not FTable.Define(Sym) then
begin
Sym.Free();
- { Two units may each export the same external C binding (e.g.
- `external name '_BlaiseGetMem'`). The flat-merge shares one
- global scope, so the second Define collides — but it denotes ONE
- underlying symbol, not a real duplicate. Tolerate it; otherwise
- report the genuine clash. }
- if not BenignDuplicateExternal(MDecl) then
- SemanticError(Format('Duplicate identifier ''%s''', [MDecl.Name]),
- MDecl.Line, MDecl.Col);
+ SemanticError(Format('Duplicate identifier ''%s''', [MDecl.Name]),
+ MDecl.Line, MDecl.Col);
end;
end;
@@ -1890,7 +1353,6 @@ begin
else
begin
{ Impl-only declaration — register symbol and index it }
- ImplDecl.IsImplOnly := True;
if ImplDecl.IsOverload then
ImplDecl.ResolvedQbeName := CurrentUnitPrefix() + ImplDecl.Name + '$' + MangleParamSig(ImplDecl)
else
@@ -1974,7 +1436,7 @@ var
begin
FCurrentUnitName := AUnit.Name;
FCurrentUnit := AUnit;
- FlushPendingGenericInstances();
+ FlushPendingGenericInstances;
BuildUsesChain(AUnit.UsedUnits);
FTable.UsesChainProvider := Self;
{ Auto-tag every global Define within this unit's analysis with the
@@ -1997,7 +1459,7 @@ begin
the cloned instance method is born without a body and codegen emits
no function — leaving call sites referencing an undefined symbol. }
LinkGenericClassMethodImpls(AUnit.ImplBlock);
- RepairEarlyGenericInstances();
+ RepairEarlyGenericInstances;
{ Register interface-section global variables. Marked IsGlobal so
codegen emits them as data-segment slots rather than stack allocs;
@@ -2016,7 +1478,12 @@ begin
Sym := TSymbol.Create(VDecl.Names.Strings[J], skVariable, ParType);
Sym.IsGlobal := True;
Sym.IsThreadVar := VDecl.IsThreadVar;
- DefineGlobalLastWins(Sym, VDecl.Line, VDecl.Col);
+ if not FTable.Define(Sym) then
+ begin
+ Sym.Free();
+ SemanticError(Format('Duplicate identifier ''%s''',
+ [VDecl.Names.Strings[J]]), VDecl.Line, VDecl.Col);
+ end;
end;
end;
@@ -2067,43 +1534,11 @@ begin
if not FTable.Define(Sym) then
begin
Sym.Free();
- { Same-external collapse — see the note on the parallel AnalyseUnit
- path: two units exporting the same `external name 'X'` binding share
- one underlying symbol, so a Define collision there is benign. }
- if not BenignDuplicateExternal(MDecl) then
- SemanticError(Format('Duplicate identifier ''%s''', [MDecl.Name]),
- MDecl.Line, MDecl.Col);
+ SemanticError(Format('Duplicate identifier ''%s''', [MDecl.Name]),
+ MDecl.Line, MDecl.Col);
end;
end;
- { Register impl-section TYPE declarations BEFORE linking class method bodies,
- so a class declared in the implementation section has its methods registered
- in FMethodGroups when LinkClassMethodImpls looks them up (otherwise every
- impl-section class method reports "not declared in class").
-
- These are registered in the GLOBAL scope (not the pushed impl scope below)
- so the type symbols survive to codegen — EmitClassSection / EmitUnit walk
- the AST TypeDecls but ClassUnitPrefix's symbol Lookup must still find the
- class to derive its unit-qualified _FieldCleanup/vtable/typeinfo names.
- Marking them IsImplPrivate (DefineImplPrivate context) keeps them visible
- only to THIS unit: Lookup suppresses them while any other unit is analysed,
- so they do not leak into unrelated units through the flat global scope.
- The unit's own bodies still resolve them via layer 3 (owner = current
- unit); code generation resolves them by setting the emitted unit as the
- table's viewing context.
-
- Only TYPES are hoisted. Impl-section consts stay in the pushed scope below
- (layer-1 visible to the unit's own bodies, never global, so they never need
- suppression); LinkClassMethodImpls needs only the types. An impl-section
- type that sizes itself on an impl-section const is not currently supported
- and would report "Unknown type" — no codebase unit relies on it. }
- FTable.DefineImplPrivate := True;
- try
- AnalyseTypeDecls(AUnit.ImplBlock);
- finally
- FTable.DefineImplPrivate := False;
- end;
-
{ Link class method bodies from ImplBlock to the class type method decls
registered by AnalyseTypeDecls. Generic-class linking happened earlier
so instances can clone bodies at instantiation time. }
@@ -2112,14 +1547,13 @@ begin
{ --- Implementation section -------------------------------------------
Push a scope so impl-only standalone symbols don't leak globally.
Class method bodies are analysed inside this scope so they can call
- impl-only helpers (e.g. TStringList.SetText -> SplitIntoList).
- (Impl-section type decls were already processed above.) }
+ impl-only helpers (e.g. TStringList.SetText -> SplitIntoList). }
FTable.PushScope();
try
- { Register impl-section consts + global variables. Consts stay in this
- pushed scope (layer-1 visible to the unit's own bodies); globals are
- marked IsGlobal so codegen emits them as data-segment slots. }
+ { Register impl-section global variables — marked IsGlobal so codegen
+ emits them as data-segment slots rather than stack allocations. }
AnalyseConstDecls(AUnit.ImplBlock);
+ AnalyseTypeDecls(AUnit.ImplBlock);
AnalyseArrayConstDecls(AUnit.ImplBlock);
for I := 0 to AUnit.ImplBlock.Decls.Count - 1 do
begin
@@ -2228,7 +1662,6 @@ begin
else
begin
{ Impl-only declaration — register in impl scope (does not persist) }
- ImplDecl.IsImplOnly := True;
if ImplDecl.IsOverload then
ImplDecl.ResolvedQbeName := CurrentUnitPrefix() + ImplDecl.Name + '$' + MangleParamSig(ImplDecl)
else
@@ -2249,13 +1682,8 @@ begin
end;
end;
- { Analyse class method bodies — impl-only helpers now visible above.
- ImplBlock is analysed too so a class declared in the implementation
- section has its method bodies type-checked (otherwise field/param
- references inside them carry no ResolvedType and codegen aborts with
- "no resolved type"). }
+ { Analyse class method bodies — impl-only helpers now visible above }
AnalyseMethodBodies(AUnit.IntfBlock);
- AnalyseMethodBodies(AUnit.ImplBlock);
{ Verify every interface declaration has a matching implementation }
for I := 0 to AUnit.IntfBlock.ProcDecls.Count - 1 do
@@ -2398,35 +1826,6 @@ begin
Result := nil;
end;
-function TSemanticAnalyser.ResolveQualified(const AUnit,
- AName: string): TSymbol;
-begin
- Result := nil;
- if (AUnit = '') or (FTable = nil) then Exit;
-
- { 1. Per-unit cache: direct keyed retrieval — the symbol AUnit defined.
- This is what disambiguates two units exporting the same name (a
- collision winner is evicted from the flat table but kept here). }
- Result := FindUnitSymbol(AUnit, AName);
- if Result <> nil then Exit;
-
- { 2. Flat-table fallback: covers paths/harnesses that populate the flat
- global but not the per-unit cache (the cache is only filled by the
- driver's RegisterUnitIface loop; the in-process test harness skips
- it). Accept the symbol unless it demonstrably belongs to a DIFFERENT
- unit — same leniency as the LookupViaUsesChain fallback: an empty
- OwningUnit is treated as a match, a non-empty mismatch is rejected. }
- FTable.BypassUsesChain := True;
- try
- Result := FTable.Lookup(AName);
- finally
- FTable.BypassUsesChain := False;
- end;
- if (Result <> nil) and (Result.OwningUnit <> '')
- and not SameText(Result.OwningUnit, AUnit) then
- Result := nil;
-end;
-
function TSemanticAnalyser.LookupViaUsesChain(const AName: string): TSymbol;
var
I: Integer;
@@ -2482,10 +1881,13 @@ function TSemanticAnalyser.IsVisibleFromUnit(ASym: TSymbol;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
begin
- { Free (non-member) symbols default to public — the symbol carries no
- per-member visibility, so the uses-chain probe never rejects on this
- path. Class/record member visibility is enforced at the qualified- and
- unqualified-member access sites via MemberVisibleTo / AssertMemberVisibleV. }
+ { Stub — see declaration in interface section. When private/
+ protected modifiers arrive on class members:
+ - private: Result := (AFromUnit = ASym.OwningUnit);
+ - protected: Result := (AFromUnit = ASym.OwningUnit)
+ or (AFromClass <> nil)
+ and AFromClassDescendsFromDeclarer(...);
+ Free symbols default to public so AFromClass is ignored for them. }
Result := True;
end;
@@ -2493,78 +1895,16 @@ function TSemanticAnalyser.IsVisibleFromUnit(const AMemberOwningUnit: string;
const AFromUnit: string;
AFromClass: TRecordTypeDesc): Boolean;
begin
- { String-flavor — same rationale as the TSymbol form. }
+ { String-flavor stub. Same future logic as the TSymbol form,
+ keyed on the AMemberOwningUnit string directly. }
Result := True;
end;
-function TSemanticAnalyser.MemberVisibleTo(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AFromUnit: string;
- AFromClass: TRecordTypeDesc): Boolean;
-var
- C: TRecordTypeDesc;
-begin
- case AVisibility of
- mvPublic, mvPublished:
- Result := True;
-
- mvPrivate:
- { Unit-scoped: visible to any code in the declaring unit. A member
- whose declaring unit is unknown (empty) is treated as same-unit —
- program-scope types and pre-visibility imports must not be locked out. }
- Result := (ADeclaringUnit = '') or SameText(ADeclaringUnit, AFromUnit);
-
- mvProtected:
- begin
- { Same unit OR AFromClass is the declaring type or a descendant of it. }
- Result := (ADeclaringUnit = '') or SameText(ADeclaringUnit, AFromUnit);
- if not Result then
- begin
- C := AFromClass;
- while C <> nil do
- begin
- if SameText(C.Name, ADeclaringType) then
- begin
- Result := True;
- Break;
- end;
- C := C.Parent;
- end;
- end;
- end;
-
- mvStrictPrivate:
- { Visible only from the declaring TYPE's own methods. }
- Result := (AFromClass <> nil) and SameText(AFromClass.Name, ADeclaringType);
-
- mvStrictProtected:
- begin
- { Declaring type or any descendant's methods, regardless of unit. }
- Result := False;
- C := AFromClass;
- while C <> nil do
- begin
- if SameText(C.Name, ADeclaringType) then
- begin
- Result := True;
- Break;
- end;
- C := C.Parent;
- end;
- end;
- else
- Result := True;
- end;
-end;
-
procedure TSemanticAnalyser.AssertMemberVisible(const AMemberOwningUnit: string;
AClassContext: TRecordTypeDesc;
const AMemberName: string;
ALine, ACol: Integer);
begin
- { Legacy unit-only assert — no per-member visibility available here, so it
- never rejects. Retained for call sites that lack the descriptor; the
- visibility-bearing AssertMemberVisibleV does the real enforcement. }
if not IsVisibleFromUnit(AMemberOwningUnit, FCurrentUnitName, AClassContext) then
SemanticError(
Format('Identifier ''%s'' is not accessible from this context',
@@ -2572,54 +1912,6 @@ begin
ALine, ACol);
end;
-procedure TSemanticAnalyser.EnforceMethodVisible(AMDecl: TObject;
- ALine, ACol: Integer);
-var
- M: TMethodDecl;
-begin
- if AMDecl = nil then Exit;
- M := TMethodDecl(AMDecl);
- { A constructor is always reachable (you must be able to instantiate the
- type); enforcing visibility on Create would block legitimate construction. }
- if SameText(M.Name, 'Create') then Exit;
- AssertMemberVisibleV(M.Visibility, M.OwningUnit, M.OwnerTypeName,
- M.Name, ALine, ACol);
-end;
-
-procedure TSemanticAnalyser.AssertMemberVisibleV(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AMemberName: string;
- ALine, ACol: Integer);
-begin
- if not MemberVisibleTo(AVisibility, ADeclaringUnit, ADeclaringType,
- FCurrentUnitName, FCurrentClass) then
- SemanticError(
- Format('''%s'' is not accessible from here', [AMemberName]),
- ALine, ACol);
-end;
-
-procedure TSemanticAnalyser.AssertStaticVarVisible(AVisibility: TMemberVisibility;
- const ADeclaringUnit, ADeclaringType: string;
- const AMemberName: string;
- ALine, ACol: Integer);
-var
- FromClass: TRecordTypeDesc;
-begin
- { Static-var access uses the declaring type of the CURRENT METHOD as the
- "from" class, so a strict-private static var is reachable from its own
- type's STATIC methods too (those leave FCurrentClass nil to suppress
- implicit Self, but FCurrentMethodOwner still names the owner). }
- if FCurrentClass <> nil then
- FromClass := FCurrentClass
- else
- FromClass := FCurrentMethodOwner;
- if not MemberVisibleTo(AVisibility, ADeclaringUnit, ADeclaringType,
- FCurrentUnitName, FromClass) then
- SemanticError(
- Format('''%s'' is not accessible from here', [AMemberName]),
- ALine, ACol);
-end;
-
procedure TSemanticAnalyser.LinkClassMethodImpls(ABlock: TBlock);
var
I, J, K: Integer;
@@ -2673,16 +1965,9 @@ begin
Match := nil;
Grp := GroupOf(FMethodGroups, Key);
if Grp <> nil then
- begin
- { Prefer a declaration owned by the unit whose impl body this is: with
- cross-unit type last-wins the group can also hold a same-named method
- on another used unit's same-named type. }
for K := 0 to Grp.Count - 1 do
begin
CD := TMethodDecl(Grp.Items[K]);
- if (CD.OwningUnit <> '') and (FCurrentUnitName <> '') and
- not SameText(CD.OwningUnit, FCurrentUnitName) then
- Continue;
if CD.IsOverload then
begin
if MangleParamSig(CD) = ImplSig then
@@ -2698,28 +1983,6 @@ begin
Break;
end;
end;
- { Fallback: no declaration is owned by the current unit — e.g. a generic
- instance whose template (and method decls) live in another unit. Match
- by signature regardless of owner, preserving the pre-last-wins behaviour. }
- if Match = nil then
- for K := 0 to Grp.Count - 1 do
- begin
- CD := TMethodDecl(Grp.Items[K]);
- if CD.IsOverload then
- begin
- if MangleParamSig(CD) = ImplSig then
- begin
- Match := CD;
- Break;
- end;
- end
- else
- begin
- Match := CD;
- Break;
- end;
- end;
- end;
if Match = nil then
SemanticError(
Format('Method ''%s'' is not declared in class ''%s''',
@@ -3143,10 +2406,10 @@ function TSemanticAnalyser.SynthAnonEnum(const AMemberList: string): TEnumTypeDe
var
Inner: string;
Members: TStringList;
+ ExistSym: TSymbol;
EnumName: string;
- Cand: TEnumTypeDesc;
- Matches: Boolean;
- K, CPos, IxI: Integer;
+ MSym: TSymbol;
+ K, CPos: Integer;
begin
{ Strip the surrounding parentheses and split on commas. }
Inner := AMemberList;
@@ -3174,25 +2437,19 @@ begin
SemanticError(Format(
'Anonymous enumeration has %d members; set types support at most 256',
[Members.Count]), 0, 0);
- { Reuse an already-synthesised identical enum: scan the reverse index for an
- enum (named or anonymous) whose member list matches exactly, so the same
- inline `set of (a,b,c)` written twice yields one compatible set type.
- Sharing a member name with an unrelated enum is no longer a collision. }
- for IxI := 0 to FEnumMemberIndex.Count - 1 do
+ { Reuse an already-synthesised identical enum: if the first member is a
+ defined enum constant whose enum has exactly these members, return it. }
+ ExistSym := FTable.Lookup(Members.Strings[0]);
+ if (ExistSym <> nil) and (ExistSym.Kind = skConstant) and
+ (ExistSym.TypeDesc <> nil) and (ExistSym.TypeDesc.Kind = tyEnum) and
+ (TEnumTypeDesc(ExistSym.TypeDesc).Members.Count = Members.Count) then
begin
- if not SameText(FEnumMemberIndex.Strings[IxI], Members.Strings[0]) then
- Continue;
- Cand := TEnumMemberRef(FEnumMemberIndex.Objects[IxI]).EnumDesc;
- if Cand.Members.Count <> Members.Count then Continue;
- Matches := True;
+ Result := TEnumTypeDesc(ExistSym.TypeDesc);
for K := 0 to Members.Count - 1 do
- if not SameText(Cand.Members.Strings[K], Members.Strings[K]) then
- begin
- Matches := False;
- Break;
- end;
- if Matches then
- Exit(Cand);
+ if not SameText(Result.Members.Strings[K], Members.Strings[K]) then
+ SemanticError(Format('Duplicate identifier ''%s''',
+ [Members.Strings[K]]), 0, 0);
+ Exit;
end;
Inc(FAnonEnumCounter);
EnumName := Format('$anonenum_%d', [FAnonEnumCounter]);
@@ -3200,7 +2457,14 @@ begin
for K := 0 to Members.Count - 1 do
begin
Result.Members.Add(Members.Strings[K]);
- RegisterEnumMember(Members.Strings[K], Result, K);
+ MSym := TSymbol.Create(Members.Strings[K], skConstant, Result);
+ MSym.ConstValue := K;
+ if not FTable.Define(MSym) then
+ begin
+ MSym.Free();
+ SemanticError(Format('Duplicate identifier ''%s''',
+ [Members.Strings[K]]), 0, 0);
+ end;
end;
FTable.DefineGlobal(TSymbol.Create(EnumName, skType, Result));
finally
@@ -3224,24 +2488,6 @@ var
DAT: TDynArrayTypeDesc;
I, LtPos, DotPos: Integer;
begin
- { Unit-qualified type 'Unit.TypeName' — resolve against that specific unit's
- own exports FIRST, before the flat FindType below (which strips the
- qualifier and binds the tail through the uses chain, i.e. to the cross-unit
- last-wins winner). Only short-circuits on a directed hit; a miss (the
- common single-definition case, or a dotted stdlib qualifier the per-unit
- cache has not harvested) falls through to the existing resolution. }
- LtPos := StrPos('<', AName);
- if LtPos < 0 then LtPos := Length(AName);
- DotPos := -1;
- for I := 0 to LtPos - 1 do
- if StrAt(AName, I) = Ord('.') then DotPos := I;
- if DotPos >= 0 then
- begin
- Sym := ResolveQualified(Copy(AName, 0, DotPos),
- StrCopyTail(AName, DotPos + 1));
- if (Sym <> nil) and (Sym.Kind = skType) and (Sym.TypeDesc <> nil) then
- Exit(Sym.TypeDesc);
- end;
Result := FTable.FindType(AName);
if Result <> nil then Exit;
{ Dynamic array: 'array of TypeName' — create on demand. Key cache by
@@ -3288,26 +2534,9 @@ begin
Result := SAT;
end;
end
- else if (IdxTD <> nil) and IdxTD.IsSubrange and (BaseType <> nil) then
- begin
- { Named integer subrange index (type TIdx = lo..hi; array[TIdx] of T):
- the subrange supplies the index range; fold to array[lo..hi] of T,
- exactly parallel to the enum branch's array[0..N-1]. }
- LVal := IdxTD.SubrangeLow;
- HVal := IdxTD.SubrangeHigh;
- CanonName := Format('array[%d..%d] of %s', [LVal, HVal, BaseType.Name]);
- Result := FTable.FindType(CanonName);
- if Result = nil then
- begin
- SAT := FTable.NewStaticArrayType(BaseType, LVal, HVal);
- Sym := TSymbol.Create(CanonName, skType, SAT);
- FTable.DefineGlobal(Sym);
- Result := SAT;
- end;
- end
else if IdxTD = nil then
SemanticError(Format('Unknown index type ''%s''', [IdxName]), 0, 0)
- else if (IdxTD.Kind <> tyEnum) and (not IdxTD.IsSubrange) then
+ else if IdxTD.Kind <> tyEnum then
SemanticError(Format('''%s'' is not an enumeration type', [IdxName]), 0, 0);
Exit;
end;
@@ -3461,16 +2690,6 @@ begin
DotPos := I;
if DotPos >= 0 then
begin
- { Unit-qualified type 'Unit.TypeName' — directed lookup against that
- unit's own exports first, so two units declaring the same type name
- are disambiguated. Falls back to bare-tail resolution via the uses
- chain when that unit's per-unit cache has no such type (covers dotted
- stdlib qualifiers like System.SysUtils.TFoo whose iface key differs
- from the dotted prefix, and qualified generic instances). }
- Sym := ResolveQualified(Copy(AName, 0, DotPos),
- StrCopyTail(AName, DotPos + 1));
- if (Sym <> nil) and (Sym.Kind = skType) and (Sym.TypeDesc <> nil) then
- Exit(Sym.TypeDesc);
Result := FindTypeOrInstantiate(StrCopyTail(AName, DotPos + 1));
Exit;
end;
@@ -3694,7 +2913,6 @@ begin
for J := 0 to FDecl.Names.Count - 1 do
NewFDecl.Names.Add(FDecl.Names.Strings[J]);
NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args);
- NewFDecl.Visibility := FDecl.Visibility;
ClonedCD.Fields.Add(NewFDecl);
end;
@@ -3711,7 +2929,6 @@ begin
NewMDecl.OwnerTypeName := ATypeName;
NewMDecl.IsVirtual := MDecl.IsVirtual;
NewMDecl.IsOverride := MDecl.IsOverride;
- NewMDecl.Visibility := MDecl.Visibility;
if (MDecl.Body <> nil) and (not DeferBodies) then
begin
NewMDecl.Body := CloneBlock(MDecl.Body);
@@ -3754,7 +2971,6 @@ begin
NewPDecl.IndexParamName := PDecl.IndexParamName;
NewPDecl.IndexTypeName := SubstTypeParam(PDecl.IndexTypeName, Templ.ParamNames, Args);
NewPDecl.IsDefault := PDecl.IsDefault;
- NewPDecl.Visibility := PDecl.Visibility;
ClonedCD.Properties.Add(NewPDecl);
end;
@@ -3778,9 +2994,6 @@ begin
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
- RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
- RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
- RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
end
@@ -3831,9 +3044,6 @@ begin
begin
FldName := NewFDecl.Names.Strings[K];
RT.AddField(FldName, FldType);
- RT.FindField(FldName).Visibility := NewFDecl.Visibility;
- RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
- RT.FindField(FldName).DeclaringType := ATypeName;
end;
end;
@@ -3924,10 +3134,6 @@ begin
if NewPDecl.IndexTypeName <> '' then
PropInfo.IndexTypeDesc := FindTypeOrInstantiate(NewPDecl.IndexTypeName);
PropInfo.IsDefault := NewPDecl.IsDefault;
- PropInfo.IsStatic := NewPDecl.IsStatic;
- PropInfo.Visibility := NewPDecl.Visibility;
- PropInfo.DeclaringUnit := FCurrentUnitName;
- PropInfo.DeclaringType := ATypeName;
RT.AddProperty(PropInfo);
end;
@@ -4069,7 +3275,6 @@ begin
for J := 0 to FDecl.Names.Count - 1 do
NewFDecl.Names.Add(FDecl.Names.Strings[J]);
NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args);
- NewFDecl.Visibility := FDecl.Visibility;
ClonedRD.Fields.Add(NewFDecl);
end;
@@ -4080,7 +3285,6 @@ begin
NewMDecl.Name := MDecl.Name;
NewMDecl.OwnerTypeName := ATypeName;
NewMDecl.IsRecordMethod := True;
- NewMDecl.Visibility := MDecl.Visibility;
if (MDecl.Body <> nil) and (not DeferBodies) then
begin
NewMDecl.Body := CloneBlock(MDecl.Body);
@@ -4123,9 +3327,6 @@ begin
begin
FldName := NewFDecl.Names.Strings[K];
RT.AddField(FldName, FldType);
- RT.FindField(FldName).Visibility := NewFDecl.Visibility;
- RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
- RT.FindField(FldName).DeclaringType := ATypeName;
end;
end;
@@ -4633,7 +3834,7 @@ begin
declarations, transferring the body so AnalyseMethodBodies can process it. }
LinkClassMethodImpls(ABlock);
LinkGenericClassMethodImpls(ABlock);
- RepairEarlyGenericInstances();
+ RepairEarlyGenericInstances;
{ Register standalone proc/func signatures before class method bodies so that
methods can call free functions declared in the same block. }
AnalyseStandaloneDecls(ABlock);
@@ -4723,10 +3924,9 @@ end;
function TSemanticAnalyser.EvalConstIntExpr(AExpr: TASTExpr;
ALine, ACol: Integer): Int64;
var
- Bin: TBinaryExpr;
- IdSym: TSymbol;
- EnumRef: TEnumMemberRef;
- L, R: Int64;
+ Bin: TBinaryExpr;
+ IdSym: TSymbol;
+ L, R: Int64;
begin
Result := 0;
if AExpr = nil then Exit;
@@ -4742,23 +3942,6 @@ begin
IdSym := FTable.Lookup(TIdentExpr(AExpr).Name);
if (IdSym = nil) or (IdSym.Kind <> skConstant) then
begin
- { Bare enum member used in a constant expression (e.g. an array
- bound or set range). No type context here: a member declared by a
- single enum resolves; one shared by several is ambiguous and must be
- qualified (TEnum.Member). }
- EnumRef := ResolveEnumMember(TIdentExpr(AExpr).Name, nil);
- if EnumRef <> nil then
- begin
- if EnumMemberCandidateCount(TIdentExpr(AExpr).Name) > 1 then
- SemanticError(Format(
- 'cannot determine which enum ''%s'' refers to: it is declared by ' +
- '%s, and there is no type context here to choose. Qualify it as ' +
- '.%s',
- [TIdentExpr(AExpr).Name, EnumMemberOwners(TIdentExpr(AExpr).Name),
- TIdentExpr(AExpr).Name]),
- ALine, ACol);
- Exit(EnumRef.Ordinal);
- end;
SemanticError(Format(
'Constant expression references ''%s'', which is not a constant',
[TIdentExpr(AExpr).Name]), ALine, ACol);
@@ -5020,8 +4203,7 @@ function TSemanticAnalyser.ResolveConstArrayElem(const AElem: string;
enum members, and named integer/boolean constants — to their ordinal value.
Numeric and float literals (and already-folded integers) pass through. }
var
- Sym: TSymbol;
- EnumRef: TEnumMemberRef;
+ Sym: TSymbol;
begin
Result := AElem;
if AElem = '' then Exit;
@@ -5044,15 +4226,11 @@ begin
{ Boolean literals. }
if SameText(AElem, 'True') then Exit('1');
if SameText(AElem, 'False') then Exit('0');
- { Named constant carrying its value in ConstValue. }
+ { Named constant or enum member — both are skConstant symbols carrying their
+ ordinal/value in ConstValue. }
Sym := FTable.Lookup(AElem);
if (Sym <> nil) and (Sym.Kind = skConstant) then
Exit(IntToStr(Sym.ConstValue));
- { Bare enum member (no longer a global symbol) — resolve via the reverse
- index, using the array's element type as context when it is an enum. }
- EnumRef := ResolveEnumMember(AElem, AElemType);
- if EnumRef <> nil then
- Exit(IntToStr(EnumRef.Ordinal));
{ Unresolved identifier in a numeric/boolean/enum array — a real error;
leaving it would emit an undefined symbol reference at link time. }
SemanticError(Format(
@@ -5068,32 +4246,28 @@ function TSemanticAnalyser.ResolveSetMemberOrd(const AMember: string;
type then comes from the declared TypeName, e.g. set of Byte). }
var
Sym: TSymbol;
- Ref: TEnumMemberRef;
begin
if IsPlainInt(AMember) then
Exit(Integer(StrToInt(AMember)));
- { A named integer/ordinal constant (enum members are no longer symbols). }
Sym := FTable.Lookup(AMember);
- if (Sym <> nil) and (Sym.Kind = skConstant) then
- Exit(Integer(Sym.ConstValue));
- { Bare enum member via the reverse index. The first enum member seen pins
- the set's base enum; later members resolve against it (so an ambiguous
- name follows the set), and a member outside it is a genuine mix error. }
- Ref := ResolveEnumMember(AMember, AEnumDesc);
- if Ref = nil then
+ if (Sym = nil) or (Sym.Kind <> skConstant) then
begin
SemanticError(Format(
'Set constant ''%s'' member ''%s'' is not a constant value',
[ACD.Name, AMember]), ACD.Line, ACD.Col);
Exit(0);
end;
- if AEnumDesc = nil then
- AEnumDesc := Ref.EnumDesc
- else if Ref.EnumDesc <> AEnumDesc then
- SemanticError(Format(
- 'Set constant ''%s'' mixes members of ''%s'' and ''%s''',
- [ACD.Name, AEnumDesc.Name, Ref.EnumDesc.Name]), ACD.Line, ACD.Col);
- Result := Integer(Ref.Ordinal);
+ { Enum member: pin / check the shared base enum. }
+ if (Sym.TypeDesc <> nil) and (Sym.TypeDesc.Kind = tyEnum) then
+ begin
+ if AEnumDesc = nil then
+ AEnumDesc := TEnumTypeDesc(Sym.TypeDesc)
+ else if Sym.TypeDesc <> AEnumDesc then
+ SemanticError(Format(
+ 'Set constant ''%s'' mixes members of ''%s'' and ''%s''',
+ [ACD.Name, AEnumDesc.Name, Sym.TypeDesc.Name]), ACD.Line, ACD.Col);
+ end;
+ Result := Integer(Sym.ConstValue);
end;
procedure TSemanticAnalyser.AnalyseSetConstDecl(ACD: TConstDecl);
@@ -5238,7 +4412,6 @@ var
CD: TConstDecl;
Sym: TSymbol;
RefSym: TSymbol;
- Prev: TSymbol;
TD: TTypeDesc;
Resolved: string;
IsSameBlockDup: Boolean;
@@ -5315,17 +4488,17 @@ begin
Sym.ConstString := CD.StrVal;
if not FTable.Define(Sym) then
begin
+ Sym.Free();
{ A module-name marker blocking the Define is always a hard error
- (issue #84). }
+ (issue #84) — without this check the const would be silently
+ dropped by the cross-unit shadowing tolerance below. }
RefSym := FTable.CurrentScope.LookupLocal(CD.Name);
if (RefSym <> nil) and (RefSym.Kind = skModule) then
- begin
- Sym.Free();
SemanticError(Format('Duplicate identifier ''%s''', [CD.Name]),
CD.Line, CD.Col);
- end;
- { Same-block duplicate (the unit declares the name twice itself) is a
- hard error. }
+ { Only error for same-block duplicates. Cross-unit const shadowing
+ (e.g. a unit redefining a system.pas constant) is silently accepted,
+ matching FPC behaviour and preserving the existing test coverage. }
IsSameBlockDup := False;
for J := 0 to I - 1 do
if SameText(TConstDecl(ABlock.ConstDecls.Items[J]).Name, CD.Name) then
@@ -5334,107 +4507,11 @@ begin
Break;
end;
if IsSameBlockDup then
- begin
- Sym.Free();
SemanticError(Format('Duplicate identifier ''%s''', [CD.Name]), CD.Line, CD.Col);
- end;
- { Cross-unit collision: last-in-uses wins. Detach the prior unit's
- const and stash it in the per-unit cache so a qualified reference
- (Unit.Const) can still reach the shadowed value; install this unit's
- const as the flat winner. Mirrors RegisterConsts on the prebuilt-
- import path so source-loaded and prebuilt deps behave identically. }
- Prev := FTable.ExtractLocal(CD.Name);
- if (Prev <> nil) and (Prev.OwningUnit <> '') then
- RegisterUnitSymbol(Prev.OwningUnit, Prev);
- FTable.Define(Sym);
end;
- { Register every interface const in the per-unit cache keyed by its owning
- unit, so a qualified reference resolves against the declaring unit's own
- value regardless of which unit won the bare (flat) slot. }
- if Sym.OwningUnit <> '' then
- RegisterUnitSymbol(Sym.OwningUnit, Sym);
end;
end;
-procedure TSemanticAnalyser.DefineGlobalLastWins(ASym: TSymbol;
- ALine, ACol: Integer);
-var
- RefSym: TSymbol;
- Prev: TSymbol;
-begin
- if not FTable.Define(ASym) then
- begin
- RefSym := FTable.CurrentScope.LookupLocal(ASym.Name);
- { A module-name marker (issue #84), a non-unit symbol (builtin /
- program-scope, OwningUnit = ''), or a same-unit redeclaration
- blocking the Define is a hard error — only a genuine cross-unit
- collision (two used units exporting the same name) gets last-wins. }
- if (RefSym = nil) or (RefSym.Kind = skModule) or
- (RefSym.OwningUnit = '') or
- SameText(RefSym.OwningUnit, ASym.OwningUnit) then
- begin
- ASym.Free();
- SemanticError(Format('Duplicate identifier ''%s''', [ASym.Name]),
- ALine, ACol);
- Exit;
- end;
- { Cross-unit collision: last-in-uses wins. Detach the prior unit's
- var and stash it in the per-unit cache so a qualified reference
- (Unit.Var) can still reach the shadowed slot; install this unit's
- var as the flat winner. Mirrors AnalyseConstDecls and RegisterVars. }
- Prev := FTable.ExtractLocal(ASym.Name);
- if (Prev <> nil) and (Prev.OwningUnit <> '') then
- RegisterUnitSymbol(Prev.OwningUnit, Prev);
- FTable.Define(ASym);
- end;
- { Register every interface var in the per-unit cache keyed by its owning
- unit, so a qualified reference resolves against the declaring unit's own
- slot regardless of which unit won the bare (flat) slot. }
- if ASym.OwningUnit <> '' then
- RegisterUnitSymbol(ASym.OwningUnit, ASym);
-end;
-
-procedure TSemanticAnalyser.DefineTypeLastWins(ASym: TSymbol;
- ATypeDecl: TTypeDecl; ALine, ACol: Integer);
-var
- RefSym: TSymbol;
- Prev: TSymbol;
- AName: string;
-begin
- AName := ATypeDecl.Name;
- { Record the descriptor created for THIS decl so codegen can emit this unit's
- own type even after a same-named type from another used unit wins the flat
- slot (extracted below). }
- ATypeDecl.ResolvedDesc := ASym.TypeDesc;
- if not FTable.Define(ASym) then
- begin
- RefSym := FTable.CurrentScope.LookupLocal(AName);
- { Only a genuine cross-unit collision (two used units exporting the same
- type name) gets last-wins; a module marker, a non-unit symbol, or a
- same-unit redeclaration stays a hard error. }
- if (RefSym = nil) or (RefSym.Kind = skModule) or
- (RefSym.OwningUnit = '') or
- SameText(RefSym.OwningUnit, ASym.OwningUnit) then
- begin
- ASym.Free();
- SemanticError(Format('Duplicate type name ''%s''', [AName]), ALine, ACol);
- Exit;
- end;
- { Detach the prior unit's type and stash it in the per-unit cache so a
- qualified reference (Unit.Type) still resolves against it; install this
- unit's type as the flat winner. }
- Prev := FTable.ExtractLocal(AName);
- if (Prev <> nil) and (Prev.OwningUnit <> '') then
- RegisterUnitSymbol(Prev.OwningUnit, Prev);
- FTable.Define(ASym);
- end;
- { Register every type in the per-unit cache keyed by its owning unit, so a
- qualified reference resolves against the declaring unit regardless of which
- unit won the bare (flat) slot. }
- if ASym.OwningUnit <> '' then
- RegisterUnitSymbol(ASym.OwningUnit, ASym);
-end;
-
function TSemanticAnalyser.NewArrayConstLabel(const AName: string): string;
begin
Inc(FArrayConstCounter);
@@ -5625,7 +4702,6 @@ var
MethodList: TObjectList;
Grp: TObjectList;
FDecl: TFieldDecl;
- ClassVarEmit: string;
MDecl: TMethodDecl;
Par: TMethodParam;
ParType: TTypeDesc;
@@ -5655,6 +4731,7 @@ var
Resolved: string;
BaseSym: TSymbol;
MName: string;
+ MSym: TSymbol;
Slot: Integer;
CD: TConstDecl;
AliasDef: TTypeAliasDef;
@@ -5668,16 +4745,7 @@ var
IdxTD: TTypeDesc;
ArrTD: TStaticArrayTypeDesc;
Expected: Integer;
- ForwardDecls: TStringList; { names of bare forward class/interface decls still
- awaiting their completing full declaration }
- FwdIdx: Integer;
begin
- { Forward declarations (`TFoo = class;` / `IFoo = interface;`) register a
- placeholder type in pass 1 and are completed by a later full declaration of
- the same name in this scope. Track the pending ones so a never-completed
- forward is reported as an error. }
- ForwardDecls := TStringList.Create();
- ForwardDecls.CaseSensitive := False;
{ Pass 1 — register all type symbols with empty descriptors.
This allows self-referential field types to resolve in pass 2. }
for I := 0 to ABlock.TypeDecls.Count - 1 do
@@ -5689,37 +4757,7 @@ begin
RT.IsPacked := TRecordTypeDef(TD.Def).IsPacked;
end
else if TD.Def is TClassTypeDef then
- begin
- if TClassTypeDef(TD.Def).IsForward then
- begin
- { Forward class: register a placeholder class type so intervening
- declarations can name it. A name already in the table — including a
- prior forward — is a redeclaration. }
- if FTable.Lookup(TD.Name) <> nil then
- begin
- if ForwardDecls.IndexOf(TD.Name) >= 0 then
- SemanticError(Format('Duplicate forward type declaration ''%s''',
- [TD.Name]), TD.Line, TD.Col)
- else
- SemanticError(Format('Duplicate type name ''%s''', [TD.Name]),
- TD.Line, TD.Col);
- end;
- Sym := TSymbol.Create(TD.Name, skType, FTable.NewClassType(TD.Name));
- FTable.Define(Sym);
- ForwardDecls.AddObject(TD.Name, TD);
- Continue;
- end;
- { Full class declaration completing a pending forward: reuse the
- placeholder descriptor (pass 2 re-derives it by name) — skip the
- re-registration below. }
- FwdIdx := ForwardDecls.IndexOf(TD.Name);
- if FwdIdx >= 0 then
- begin
- ForwardDecls.Delete(FwdIdx);
- Continue;
- end;
- RT := FTable.NewClassType(TD.Name);
- end
+ RT := FTable.NewClassType(TD.Name)
else if TD.Def is TGenericTypeDef then
begin
{ Register as template — no concrete type symbol; instantiated on demand.
@@ -5742,52 +4780,35 @@ begin
end
else if TD.Def is TInterfaceTypeDef then
begin
- if TInterfaceTypeDef(TD.Def).IsForward then
- begin
- { Forward interface: placeholder, completed later in scope. }
- if FTable.Lookup(TD.Name) <> nil then
- begin
- if ForwardDecls.IndexOf(TD.Name) >= 0 then
- SemanticError(Format('Duplicate forward type declaration ''%s''',
- [TD.Name]), TD.Line, TD.Col)
- else
- SemanticError(Format('Duplicate type name ''%s''', [TD.Name]),
- TD.Line, TD.Col);
- end;
- Sym := TSymbol.Create(TD.Name, skType, FTable.NewInterfaceType(TD.Name));
- FTable.Define(Sym);
- ForwardDecls.AddObject(TD.Name, TD);
- Continue;
- end;
- { Full interface completing a pending forward: reuse the placeholder. }
- FwdIdx := ForwardDecls.IndexOf(TD.Name);
- if FwdIdx >= 0 then
- begin
- ForwardDecls.Delete(FwdIdx);
- Continue;
- end;
IntfDesc := FTable.NewInterfaceType(TD.Name);
Sym := TSymbol.Create(TD.Name, skType, IntfDesc);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ 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
- { Enum type: register the type, and record each member in the reverse
- index keyed by name. Members are NOT registered as bare global
- skConstants — a bare member name resolves through ResolveEnumMember
- (by context type, uniqueness, or last-wins), so two enums in scope
- may legitimately share a member name without colliding. }
+ { Enum type: register the type AND each member as a skConstant }
EnumDef := TEnumTypeDef(TD.Def);
EnumDesc := FTable.NewEnumType(TD.Name);
for K := 0 to EnumDef.Members.Count - 1 do
begin
- MName := EnumDef.Members.Strings[K];
+ MName := EnumDef.Members.Strings[K];
EnumDesc.Members.Add(MName);
- RegisterEnumMember(MName, EnumDesc, EnumDef.OrdinalAt(K));
+ MSym := TSymbol.Create(MName, skConstant, EnumDesc);
+ MSym.ConstValue := EnumDef.OrdinalAt(K);
+ if not FTable.Define(MSym) then
+ MSym.Free();
end;
Sym := TSymbol.Create(TD.Name, skType, EnumDesc);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ 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 TSetTypeDef then
@@ -5802,7 +4823,12 @@ begin
SetDesc := FTable.NewOrdinalSetType(TD.Name, SetSubDesc.BaseType,
SetSubDesc.BitCount);
Sym := TSymbol.Create(TD.Name, skType, SetDesc);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ if not FTable.Define(Sym) then
+ begin
+ Sym.Free();
+ SemanticError(Format('Duplicate type name ''%s''', [TD.Name]),
+ TD.Line, TD.Col);
+ end;
Continue;
end;
BaseSym := FTable.Lookup(SetDef.BaseTypeName);
@@ -5832,7 +4858,11 @@ begin
SetDesc := nil;
end;
Sym := TSymbol.Create(TD.Name, skType, SetDesc);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ 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 TProceduralTypeDef then
@@ -5841,7 +4871,11 @@ begin
resolution happens in pass 2. }
Sym := TSymbol.Create(TD.Name, skType,
FTable.NewProceduralType(TD.Name));
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ 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 TTypeAliasDef then
@@ -5877,26 +4911,6 @@ begin
Continue;
end;
end
- else if AliasDef.IsSubrange then
- begin
- { Named integer subrange: type TIdx = lo..hi; AliasName is the
- narrowest fitting standard integer type (e.g. 'Byte'). Create a
- DISTINCT descriptor that copies the underlying int's Kind (so layout,
- QBE type, IsNumeric/IsOrdinal and assignment all treat it as that
- int), but carries IsSubrange + the lo..hi bounds so the array-index
- resolver can fold array[TIdx] -> array[lo..hi]. }
- BaseSym := FTable.Lookup(AliasName);
- if (BaseSym = nil) or (BaseSym.Kind <> skType) or (BaseSym.TypeDesc = nil) then
- begin
- SemanticError(Format('Unknown base type ''%s'' for subrange', [AliasName]),
- TD.Line, TD.Col);
- Continue;
- end;
- AliasDesc := FTable.NewType(BaseSym.TypeDesc.Kind, TD.Name);
- AliasDesc.IsSubrange := True;
- AliasDesc.SubrangeLow := AliasDef.SubrangeLow;
- AliasDesc.SubrangeHigh := AliasDef.SubrangeHigh;
- end
else
begin
{ Simple alias or constructed alias (array[L..H] of T, etc.).
@@ -5918,7 +4932,11 @@ begin
end;
end;
Sym := TSymbol.Create(TD.Name, skType, AliasDesc);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ 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
@@ -5928,7 +4946,11 @@ begin
Continue;
end;
Sym := TSymbol.Create(TD.Name, skType, RT);
- DefineTypeLastWins(Sym, TD, TD.Line, TD.Col);
+ if not FTable.Define(Sym) then
+ begin
+ Sym.Free();
+ SemanticError(Format('Duplicate type name ''%s''', [TD.Name]), TD.Line, TD.Col);
+ end;
end;
{ Pass 2 — resolve parent, fields, and method signatures for each type. }
@@ -5944,11 +4966,6 @@ begin
if TD.Def is TSetTypeDef then Continue;
if TD.Def is TTypeAliasDef then Continue;
- { Forward stub: the completing full declaration (same name, later) carries
- the body and does all pass-2 work. }
- if (TD.Def is TClassTypeDef) and TClassTypeDef(TD.Def).IsForward then Continue;
- if (TD.Def is TInterfaceTypeDef) and TInterfaceTypeDef(TD.Def).IsForward then Continue;
-
{ Procedural types: resolve param + return types now that all
type names are registered. }
if TD.Def is TProceduralTypeDef then
@@ -6113,14 +5130,10 @@ begin
end;
if TClassTypeDef(TD.Def).ParentName <> '' then
begin
- { Resolve through the type machinery (not a literal FTable.Lookup) so
- a unit-qualified ancestor 'Unit.TParent' binds to that unit's type
- and disambiguates a same-named class in another unit.
- FindTypeOrInstantiate handles both bare and dotted names. }
- GenParentDesc := FindTypeOrInstantiate(TClassTypeDef(TD.Def).ParentName);
+ ParentSym := FTable.Lookup(TClassTypeDef(TD.Def).ParentName);
{ If the first name in class(...) is an interface, not a class,
treat it as an implements entry — TObject becomes the implicit parent. }
- if (GenParentDesc <> nil) and (GenParentDesc is TInterfaceTypeDesc) then
+ if (ParentSym <> nil) and (ParentSym.TypeDesc is TInterfaceTypeDesc) then
begin
TClassTypeDef(TD.Def).ImplementsNames.Insert(
0, TClassTypeDef(TD.Def).ParentName);
@@ -6128,12 +5141,12 @@ begin
end
else
begin
- if (GenParentDesc = nil) or not (GenParentDesc is TRecordTypeDesc) then
+ 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(GenParentDesc);
+ ParentRT := TRecordTypeDesc(ParentSym.TypeDesc);
RT.Parent := ParentRT;
RT.CopyVTableFrom(ParentRT);
for K := 0 to ParentRT.Fields.Count - 1 do
@@ -6142,12 +5155,6 @@ begin
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
RT.FindField(FldInfo.Name).IsUnretained := FldInfo.IsUnretained;
RT.FindField(FldInfo.Name).IsWeak := FldInfo.IsWeak;
- { An inherited field keeps the ANCESTOR's visibility + declaring
- origin — protected/strict checks must resolve against where the
- field was actually declared, not the subclass that copied it. }
- RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
- RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
- RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
end;
@@ -6311,63 +5318,14 @@ begin
for K := 0 to FDecl.Names.Count - 1 do
begin
FldName := FDecl.Names.Strings[K];
- if FDecl.IsClassVar then
- begin
- { STATIC (class-level) variable: not an instance field — do NOT call
- AddField (that would advance the instance layout). Register a single
- shared global instead, under a mangled emit label, reachable by both
- the bare name (inside methods) and the qualified 'TFoo.Name' form.
- Class- and interface-typed static vars ARE supported: they are a
- single shared pointer slot, zero-initialised to nil, and assignment
- goes through the normal managed-global store ARC (retain new /
- release old). String and dynamic-array static vars remain deferred
- (their exit-time release story is not yet wired). }
- if (FldType.Kind = tyString) or (FldType.Kind = tyDynArray) then
- SemanticError(Format(
- 'static var ''%s'': string and dynamic-array static fields are ' +
- 'not yet supported (class and interface are)', [FldName]),
- FDecl.Line, FDecl.Col);
- ClassVarEmit := CurrentUnitPrefix() + TD.Name + '_' + FldName;
- { Single source of truth for codegen: stash the mangled label on the
- field decl (used by both backends to emit the data slot, even for a
- read-only static var that no assignment auto-registers). }
- if FDecl.Names.Count = 1 then
- FDecl.ClassVarEmitName := ClassVarEmit;
- { Bare name — usable unqualified inside the class's own methods. }
- Sym := TSymbol.Create(FldName, skVariable, FldType);
- Sym.IsGlobal := True;
- Sym.IsClassVar := True;
- Sym.GlobalEmitName := ClassVarEmit;
- Sym.Visibility := FDecl.Visibility;
- Sym.OwnerTypeName := TD.Name;
- if not FTable.Define(Sym) then Sym.Free();
- { Qualified name — usable as TFoo.Name from anywhere. }
- Sym := TSymbol.Create(TD.Name + '.' + FldName, skVariable, FldType);
- Sym.IsGlobal := True;
- Sym.IsClassVar := True;
- Sym.GlobalEmitName := ClassVarEmit;
- Sym.Visibility := FDecl.Visibility;
- Sym.OwnerTypeName := TD.Name;
- if not FTable.Define(Sym) then Sym.Free();
- end
- else
- begin
- RT.AddField(FldName, FldType);
- { Propagate the weak/unretained flags to the just-added field info so
- codegen and the field cleanup emitter can consult them without
- walking back to the AST. }
- if FDecl.IsWeak then
- RT.FindField(FldName).IsWeak := True;
- if FDecl.IsUnretained then
- RT.FindField(FldName).IsUnretained := True;
- { Carry visibility + declaring origin so member-access checks can be
- applied without re-walking the AST. DeclaringType is this class
- (the one that declares the field); inherited fields copy the
- ancestor's metadata at the copy site above. }
- RT.FindField(FldName).Visibility := FDecl.Visibility;
- RT.FindField(FldName).DeclaringUnit := FCurrentUnitName;
- RT.FindField(FldName).DeclaringType := TD.Name;
- end;
+ RT.AddField(FldName, FldType);
+ { Propagate the weak/unretained flags to the just-added field info so
+ codegen and the field cleanup emitter can consult them without
+ walking back to the AST. }
+ if FDecl.IsWeak then
+ RT.FindField(FldName).IsWeak := True;
+ if FDecl.IsUnretained then
+ RT.FindField(FldName).IsUnretained := True;
end;
end;
@@ -6377,11 +5335,6 @@ begin
begin
MDecl := TMethodDecl(MethodList.Items[J]);
MDecl.OwnerTypeName := TD.Name;
- { Stamp the declaring unit so member-visibility (private/protected) can
- enforce the unit privacy boundary. Only set when empty so a value
- carried from an imported .bif is not overwritten. }
- if MDecl.OwningUnit = '' then
- MDecl.OwningUnit := FCurrentUnitName;
{ Compute mangled key and ResolvedQbeName for overloaded methods.
Non-overloaded methods keep their plain name throughout. }
@@ -6394,20 +5347,11 @@ begin
existing FMethodIndex entries for this (TypeName.Name) — if
any sibling has IsOverload=False or the new MDecl lacks
IsOverload, this is a duplicate-identifier error. }
- if (MDecl.OwningUnit = '') and (FCurrentUnitName <> '') then
- MDecl.OwningUnit := FCurrentUnitName;
Key := TD.Name + '.' + MDecl.Name;
Grp := GroupOf(FMethodGroups, Key);
if Grp <> nil then
for K := 0 to Grp.Count - 1 do
begin
- { A same-named method on a same-named type owned by a DIFFERENT
- used unit is a distinct method (it carries its own unit-prefixed
- ResolvedQbeName), not a missing-overload duplicate — the two
- types coexist under cross-unit last-wins. }
- if not SameText(TMethodDecl(Grp.Items[K]).OwningUnit,
- MDecl.OwningUnit) then
- Continue;
if (not MDecl.IsOverload) or
(not TMethodDecl(Grp.Items[K]).IsOverload) then
SemanticError(
@@ -6476,10 +5420,6 @@ begin
if PropDecl.IndexTypeName <> '' then
PropInfo.IndexTypeDesc := FTable.FindType(PropDecl.IndexTypeName);
PropInfo.IsDefault := PropDecl.IsDefault;
- PropInfo.IsStatic := PropDecl.IsStatic;
- PropInfo.Visibility := PropDecl.Visibility;
- PropInfo.DeclaringUnit := FCurrentUnitName;
- PropInfo.DeclaringType := TD.Name;
RT.AddProperty(PropInfo);
end;
@@ -6619,26 +5559,6 @@ begin
if (Sym <> nil) and (Sym.Kind = skType) then
TPointerTypeDesc(BaseSym.TypeDesc).BaseType := Sym.TypeDesc;
end;
-
- { A forward declaration never completed in this scope is an error. }
- if ForwardDecls.Count > 0 then
- begin
- TD := TTypeDecl(ForwardDecls.Objects[0]);
- SemanticError(Format('Forward type not resolved ''%s''',
- [ForwardDecls.Strings[0]]), TD.Line, TD.Col);
- end;
-
- { Drop the now-redundant forward stubs from the AST so later phases (codegen
- iterates ABlock.TypeDecls) never see two declarations of the same type. }
- for I := ABlock.TypeDecls.Count - 1 downto 0 do
- begin
- TD := TTypeDecl(ABlock.TypeDecls.Items[I]);
- if ((TD.Def is TClassTypeDef) and TClassTypeDef(TD.Def).IsForward) or
- ((TD.Def is TInterfaceTypeDef) and TInterfaceTypeDef(TD.Def).IsForward) then
- ABlock.TypeDecls.Delete(I);
- end;
-
- ForwardDecls.Free();
end;
procedure TSemanticAnalyser.AnalyseMethodBodies(ABlock: TBlock);
@@ -6686,7 +5606,6 @@ var
Par: TMethodParam;
Sym: TSymbol;
SavedClass: TRecordTypeDesc;
- SavedMethodOwner: TRecordTypeDesc;
TKey: string;
begin
{ Generic method (method-level ): its params/body reference the method's
@@ -6703,34 +5622,18 @@ begin
Exit;
end;
SavedClass := FCurrentClass;
- SavedMethodOwner := FCurrentMethodOwner;
- { A STATIC (class-level) method has no instance receiver. Leave FCurrentClass
- at its saved value (do NOT bind it to AClassType) so that an implicit
- instance-member reference inside the body resolves as an undeclared
- identifier rather than silently binding to a non-existent Self. Static
- members of the same type remain reachable through their registered bare
- global symbols. }
- if not AMethod.IsStatic then
- FCurrentClass := AClassType;
- { Visibility context: the declaring type of THIS method body, set for static
- and instance methods alike, so a strict-private member is reachable from its
- own type's methods regardless of static-ness. }
- FCurrentMethodOwner := AClassType;
+ FCurrentClass := AClassType;
FTable.PushScope();
Inc(FScopeDepth);
try
{ Record methods receive the record by pointer (like a var param); class
methods receive the object pointer as a value. Declaring Self as
- skVarParameter for records makes the codegen dereference it correctly.
- A static method receives NO Self. }
- if not AMethod.IsStatic then
- begin
- if AMethod.IsRecordMethod then
- Sym := TSymbol.Create('Self', skVarParameter, AClassType)
- else
- Sym := TSymbol.Create('Self', skVariable, AClassType);
- FTable.Define(Sym);
- end;
+ skVarParameter for records makes the codegen dereference it correctly. }
+ if AMethod.IsRecordMethod then
+ Sym := TSymbol.Create('Self', skVarParameter, AClassType)
+ else
+ Sym := TSymbol.Create('Self', skVariable, AClassType);
+ FTable.Define(Sym);
{ For function methods, define Result as a writable variable }
if AMethod.ResolvedReturnType <> nil then
@@ -6774,7 +5677,6 @@ begin
Dec(FScopeDepth);
FTable.PopScope();
FCurrentClass := SavedClass;
- FCurrentMethodOwner := SavedMethodOwner;
end;
end;
@@ -6782,12 +5684,11 @@ function TSemanticAnalyser.FindMethodDecl(
const ATypeName, AMethodName: string): TMethodDecl;
var
CurrName: string;
- Idx, K: Integer;
+ Idx: Integer;
Key: string;
Sym: TSymbol;
RT: TRecordTypeDesc;
OwnerUnit: string;
- Grp: TObjectList;
begin
CurrName := ATypeName;
while CurrName <> '' do
@@ -6797,29 +5698,13 @@ begin
if Idx >= 0 then
begin
Result := TMethodDecl(FMethodIndex.Objects[Idx]);
- { Visibility is NOT enforced here: FindMethodDecl is also used to resolve
- property getters/setters, Free/Create existence probes, and inherited
- lookups, where the access is legitimate regardless of the member's
- declared visibility. Enforcement happens at the user-written call /
- member-access sites (EnforceMethodVisible / AssertMemberVisibleV). }
- { Cross-unit last-wins: two used units may export a same-named type, so
- the group holds both their methods under one key. FMethodIndex returns
- the first-registered, which may belong to the OTHER unit; bind instead
- to the method on the type that actually resolved (its owning unit). }
+ { Visibility seam: treat the class's owning unit as the member's
+ effective owner. Currently a no-op (returns True); activates
+ without call-site work when class members gain private/protected. }
OwnerUnit := '';
Sym := FTable.Lookup(CurrName);
if Sym <> nil then OwnerUnit := Sym.OwningUnit;
- if (OwnerUnit <> '') and not SameText(Result.OwningUnit, OwnerUnit) then
- begin
- Grp := GroupOf(FMethodGroups, Key);
- if Grp <> nil then
- for K := 0 to Grp.Count - 1 do
- if SameText(TMethodDecl(Grp.Items[K]).OwningUnit, OwnerUnit) then
- begin
- Result := TMethodDecl(Grp.Items[K]);
- Break;
- end;
- end;
+ AssertMemberVisible(OwnerUnit, FCurrentClass, AMethodName, 0, 0);
Exit;
end;
{ Walk to parent }
@@ -6887,7 +5772,6 @@ var
Sym: TSymbol;
RT: TRecordTypeDesc;
Key: string;
- OwnerHint: string;
Cand: TMethodDecl;
Grp: TObjectList;
ArityMatch: TObjectList;
@@ -6906,9 +5790,6 @@ var
SawHiding: Boolean;
begin
Result := nil;
- { Consume the one-shot receiver owner hint set by the caller. }
- OwnerHint := FMethodOwnerHint;
- FMethodOwnerHint := '';
if AArgs <> nil then Arity := AArgs.Count else Arity := -1;
TotalCnt := 0;
ArityMatch := TObjectList.Create(False);
@@ -6922,16 +5803,8 @@ begin
if Grp <> nil then
for K := 0 to Grp.Count - 1 do
begin
- Cand := TMethodDecl(Grp.Items[K]);
- { Cross-unit last-wins: at the receiver's OWN type level the group can
- also hold a same-named method on another used unit's same-named type.
- Bind to the receiver's actual unit (the hint) — a name re-lookup
- would pick the flat-table winner instead. }
- if (OwnerHint <> '') and SameText(CurrName, ATypeName) and
- (Cand.OwningUnit <> '') and
- not SameText(Cand.OwningUnit, OwnerHint) then
- Continue;
Inc(TotalCnt);
+ Cand := TMethodDecl(Grp.Items[K]);
{ A method declared WITHOUT `overload` hides all inherited methods of
the same name — once seen at this (more-derived) level, the parent
chain is not consulted. Methods WITH `overload` merge with the
@@ -7113,14 +5986,11 @@ begin
ADecl.ResolvedQbeName := ADecl.Name;
{ Index for call resolution — overloaded names appear multiple times.
- Nested procs (those inside another routine's body) are resolved via the
+ Nested procs (those inside another proc's body) are resolved via the
scoped symbol table only; adding them to the global FProcIndex would
- make same-named nested procs in different outer routines appear as
- ambiguous overloads of each other. A proc is nested when it sits
- inside a standalone routine (FCurrentEnclosingDecl set) OR inside a
- method body (FCurrentMethodOwner set) — both cases must be excluded
- from the global index. }
- if (FCurrentEnclosingDecl = nil) and (FCurrentMethodOwner = nil) then
+ make same-named nested procs in different outer procs appear as
+ ambiguous overloads of each other. }
+ if FCurrentEnclosingDecl = nil then
RegisterProcDecl(ADecl.Name, ADecl);
{ Register in symbol table }
@@ -7184,7 +6054,7 @@ begin
{ After analysing the body, determine which outer-scope variables are
captured by any nested proc declared inside this one. }
if ADecl.EnclosingDecl <> nil then
- CollectCaptures(ADecl, ADecl.EnclosingDecl);
+ CollectCaptures(ADecl, ADecl.EnclosingDecl.Body);
end;
finally
Dec(FScopeDepth);
@@ -7211,24 +6081,11 @@ begin
end;
end;
-procedure TSemanticAnalyser.MaybeCaptureName(ADecl: TMethodDecl;
- AOuterVars: TStringList; const AName: string);
-begin
- if AName = '' then Exit;
- if AOuterVars.IndexOf(AName) < 0 then Exit;
- if (ADecl.CapturedVars <> nil) and (ADecl.CapturedVars.IndexOf(AName) >= 0) then
- Exit;
- if ADecl.CapturedVars = nil then
- ADecl.CapturedVars := TStringList.Create();
- ADecl.CapturedVars.Add(AName);
-end;
-
-procedure TSemanticAnalyser.CollectCaptures(ADecl: TMethodDecl; AOuterDecl: TMethodDecl);
-{ Walk ADecl's body statements/expressions to find every reference to a variable
- belonging to the enclosing proc AOuterDecl — its locals AND its parameters
- (a `var` record parameter captured by a nested proc is the case that broke
- before). Each such name is "captured": ADecl receives an implicit hidden
- var-by-pointer parameter, and the call site passes the variable's address. }
+procedure TSemanticAnalyser.CollectCaptures(ADecl: TMethodDecl; AOuterBlock: TBlock);
+{ Walk ADecl's body statements/expressions to find all TIdentExpr nodes whose
+ name matches a variable declared in AOuterBlock (the enclosing proc's locals).
+ Each such variable is "captured": ADecl will receive an implicit hidden
+ var-by-pointer parameter, and the call site will pass the variable's address. }
var
OuterVars: TStringList;
I, J: Integer;
@@ -7240,31 +6097,21 @@ var
CurStmt: TASTStmt;
begin
if ADecl.Body = nil then Exit;
- if AOuterDecl = nil then Exit;
OuterVars := TStringList.Create();
TodoExprs := TObjectList.Create(False);
TodoStmts := TObjectList.Create(False);
try
- { Build the set of enclosing names: the outer proc's local var decls ... }
- if AOuterDecl.Body <> nil then
- for I := 0 to AOuterDecl.Body.Decls.Count - 1 do
- begin
- VDecl := TVarDecl(AOuterDecl.Body.Decls.Items[I]);
- for J := 0 to VDecl.Names.Count - 1 do
- begin
- VName := VDecl.Names.Strings[J];
- if OuterVars.IndexOf(VName) < 0 then
- OuterVars.Add(VName);
- end;
- end;
- { ... and the outer proc's PARAMETERS (value, var, out — all capturable;
- a captured var-param carries a pointer, handled by codegen). }
- for I := 0 to AOuterDecl.Params.Count - 1 do
+ { Build set of outer-block local variable names }
+ for I := 0 to AOuterBlock.Decls.Count - 1 do
begin
- VName := TMethodParam(AOuterDecl.Params.Items[I]).ParamName;
- if OuterVars.IndexOf(VName) < 0 then
- OuterVars.Add(VName);
+ VDecl := TVarDecl(AOuterBlock.Decls.Items[I]);
+ for J := 0 to VDecl.Names.Count - 1 do
+ begin
+ VName := VDecl.Names.Strings[J];
+ if OuterVars.IndexOf(VName) < 0 then
+ OuterVars.Add(VName);
+ end;
end;
if OuterVars.Count = 0 then Exit;
@@ -7286,30 +6133,19 @@ begin
begin
{ LHS name — check if it's an outer var (direct assign) }
if TAssignment(CurStmt).ImplicitSelfField = nil then
- MaybeCaptureName(ADecl, OuterVars, TAssignment(CurStmt).Name);
+ begin
+ VName := TAssignment(CurStmt).Name;
+ if (OuterVars.IndexOf(VName) >= 0) and
+ ((ADecl.CapturedVars = nil) or
+ (ADecl.CapturedVars.IndexOf(VName) < 0)) then
+ begin
+ if ADecl.CapturedVars = nil then
+ ADecl.CapturedVars := TStringList.Create();
+ ADecl.CapturedVars.Add(VName);
+ end;
+ end;
TodoExprs.Add(TAssignment(CurStmt).Expr);
end
- else if CurStmt is TFieldAssignment then
- begin
- { 'R.Field := ...' — the receiver R may be an outer var/var-param.
- (Implicit-Self writes have RecordName naming a field of Self, not an
- outer var; those resolve through Self, never captured.) }
- if not TFieldAssignment(CurStmt).IsImplicitSelf then
- MaybeCaptureName(ADecl, OuterVars, TFieldAssignment(CurStmt).RecordName);
- TodoExprs.Add(TFieldAssignment(CurStmt).ObjExpr);
- TodoExprs.Add(TFieldAssignment(CurStmt).PropIndexExpr);
- TodoExprs.Add(TFieldAssignment(CurStmt).Expr);
- end
- else if CurStmt is TStaticSubscriptAssign then
- begin
- { 'A[i] := ...' — the array A may be an outer var/var-param.
- (Implicit-Self array writes resolve through Self.) }
- if not TStaticSubscriptAssign(CurStmt).IsImplicitSelf then
- MaybeCaptureName(ADecl, OuterVars, TStaticSubscriptAssign(CurStmt).ArrayName);
- TodoExprs.Add(TStaticSubscriptAssign(CurStmt).BaseExpr);
- TodoExprs.Add(TStaticSubscriptAssign(CurStmt).IndexExpr);
- TodoExprs.Add(TStaticSubscriptAssign(CurStmt).ValueExpr);
- end
else if CurStmt is TProcCall then
begin
for J := 0 to TProcCall(CurStmt).Args.Count - 1 do
@@ -7358,22 +6194,16 @@ begin
if CurExpr = nil then Continue;
if CurExpr is TIdentExpr then
- MaybeCaptureName(ADecl, OuterVars, TIdentExpr(CurExpr).Name)
- else if CurExpr is TFieldAccessExpr then
begin
- { 'R.Field' read — the base R may be an outer var/var-param. When the
- base is a sub-expression (chain), descend; when it is a bare name,
- capture it. }
- if TFieldAccessExpr(CurExpr).Base <> nil then
- TodoExprs.Add(TFieldAccessExpr(CurExpr).Base)
- else
- MaybeCaptureName(ADecl, OuterVars, TFieldAccessExpr(CurExpr).RecordName);
- TodoExprs.Add(TFieldAccessExpr(CurExpr).PropIndexExpr);
- end
- else if CurExpr is TStringSubscriptExpr then
- begin
- TodoExprs.Add(TStringSubscriptExpr(CurExpr).StrExpr);
- TodoExprs.Add(TStringSubscriptExpr(CurExpr).IndexExpr);
+ VName := TIdentExpr(CurExpr).Name;
+ if (OuterVars.IndexOf(VName) >= 0) and
+ ((ADecl.CapturedVars = nil) or
+ (ADecl.CapturedVars.IndexOf(VName) < 0)) then
+ begin
+ if ADecl.CapturedVars = nil then
+ ADecl.CapturedVars := TStringList.Create();
+ ADecl.CapturedVars.Add(VName);
+ end;
end
else if CurExpr is TBinaryExpr then
begin
@@ -7919,10 +6749,6 @@ var
L: Integer;
DupLocal: Boolean;
begin
- { Inline-assembler block: opaque to the front end — its content is assembly,
- not Pascal, so no statement/type/ARC analysis runs over it. }
- if AStmt is TAsmStmt then
- Exit;
if AStmt is TForStmt then
begin
ForS := TForStmt(AStmt);
@@ -7942,17 +6768,10 @@ begin
Format('Loop variable ''%s'' must be an ordinal type, got ''%s''',
[ForS.VarName, VarSym.TypeDesc.Name]),
ForS.Line, ForS.Col);
- { A bare enum-member bound is steered to the loop variable's enum. }
- if TryResolveBareEnumIdent(ForS.StartExpr, VarSym.TypeDesc) then
- StartType := ForS.StartExpr.ResolvedType
- else
- StartType := AnalyseExpr(ForS.StartExpr);
+ StartType := AnalyseExpr(ForS.StartExpr);
CheckTypesMatch(VarSym.TypeDesc, StartType,
'for-loop start expression', ForS.Line, ForS.Col);
- if TryResolveBareEnumIdent(ForS.EndExpr, VarSym.TypeDesc) then
- EndType := ForS.EndExpr.ResolvedType
- else
- EndType := AnalyseExpr(ForS.EndExpr);
+ EndType := AnalyseExpr(ForS.EndExpr);
CheckTypesMatch(VarSym.TypeDesc, EndType,
'for-loop end expression', ForS.Line, ForS.Col);
Inc(FLoopDepth);
@@ -8503,7 +7322,6 @@ begin
ACall.ResolvedMethod := nil;
Exit;
end;
- HintBareEnumMethodArgs(RT.Name, ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
MDecl := ResolveMethodOverload(RT.Name, ACall.Name, ACall.Args,
@@ -8528,43 +7346,10 @@ begin
AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
ACall.ResolvedClassType := RT;
ACall.ResolvedMethod := MDecl;
- if (MDecl.ResolvedReturnType <> nil) and
- (MDecl.ResolvedReturnType.Kind = tyRecord) then
- ACall.ResolvedReturnTypeDesc := MDecl.ResolvedReturnType;
Exit;
end;
ObjSym := FTable.Lookup(ACall.ObjectName);
- { TypeName.StaticMethod() — a static (class-level) method called through the
- class name in statement position. Resolve the method on the class; it must
- be declared static. Lowered with NO Self. }
- if (ObjSym <> nil) and (ObjSym.Kind = skType) and (ObjSym.TypeDesc <> nil) and
- (ObjSym.TypeDesc.Kind = tyClass) then
- begin
- RT := TRecordTypeDesc(ObjSym.TypeDesc);
- for I := 0 to ACall.Args.Count - 1 do
- AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
- MDecl := ResolveMethodOverload(RT.Name, ACall.Name, ACall.Args,
- ACall.Line, ACall.Col);
- if MDecl = nil then
- SemanticError(
- Format('Class ''%s'' has no method ''%s''', [RT.Name, ACall.Name]),
- ACall.Line, ACall.Col);
- if not MDecl.IsStatic then
- SemanticError(
- Format('''%s.%s'' is not a static method — call it on an instance',
- [RT.Name, ACall.Name]),
- ACall.Line, ACall.Col);
- AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
- EnforceMethodVisible(MDecl, ACall.Line, ACall.Col);
- ACall.ResolvedClassType := RT;
- ACall.ResolvedMethod := MDecl;
- ACall.IsStaticCall := True;
- if (MDecl.ResolvedReturnType <> nil) and
- (MDecl.ResolvedReturnType.Kind = tyRecord) then
- ACall.ResolvedReturnTypeDesc := MDecl.ResolvedReturnType;
- Exit;
- end;
{ Inside a method, class fields shadow same-named globals. Try the
implicit Self.Field path when there is no match (ObjSym=nil) OR when
the only match is a global variable that a class field should shadow. }
@@ -8602,7 +7387,6 @@ begin
ACall.ResolvedMethod := nil;
Exit;
end;
- HintBareEnumMethodArgs(RT.Name, ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
MDecl := ResolveMethodOverload(RT.Name, ACall.Name, ACall.Args,
@@ -8614,9 +7398,6 @@ begin
AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
ACall.ResolvedClassType := RT;
ACall.ResolvedMethod := MDecl;
- if (MDecl.ResolvedReturnType <> nil) and
- (MDecl.ResolvedReturnType.Kind = tyRecord) then
- ACall.ResolvedReturnTypeDesc := MDecl.ResolvedReturnType;
Exit;
end;
end;
@@ -8636,7 +7417,6 @@ begin
(SameText(ACall.Name, 'Create') or (StrPos('Create', ACall.Name) = 0)) then
begin
RT := TRecordTypeDesc(TMetaClassTypeDesc(ObjSym.TypeDesc).BaseClass);
- HintBareEnumMethodArgs(RT.Name, ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
MDecl := ResolveMethodOverload(RT.Name, ACall.Name, ACall.Args,
@@ -8695,7 +7475,6 @@ begin
Exit;
end;
- HintBareEnumMethodArgs(RT.Name, ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
@@ -8727,14 +7506,10 @@ begin
ACall.Line, ACall.Col);
AppendDefaultArgs(ACall.Args, MDecl, ACall.Name, ACall.Line, ACall.Col);
- EnforceMethodVisible(MDecl, ACall.Line, ACall.Col);
ACall.ResolvedClassType := RT;
ACall.ResolvedMethod := MDecl;
ACall.IsGlobal := ObjSym.IsGlobal;
ACall.IsVarParam := (ObjSym.Kind = skVarParameter);
- if (MDecl.ResolvedReturnType <> nil) and
- (MDecl.ResolvedReturnType.Kind = tyRecord) then
- ACall.ResolvedReturnTypeDesc := MDecl.ResolvedReturnType;
end;
{ If AExpr is a diamond constructor call (RecordName ends with '<>'), replace
@@ -8788,11 +7563,7 @@ begin
AAssign.ImplicitSelfField := FldInfo;
AAssign.ResolvedLhsType := FldInfo.TypeDesc;
ResolveDiamond(AAssign.Expr, FldInfo.TypeDesc);
- { Bare enum member on the RHS resolves against the field's type. }
- if TryResolveBareEnumIdent(AAssign.Expr, FldInfo.TypeDesc) then
- ExprType := AAssign.Expr.ResolvedType
- else
- ExprType := AnalyseExpr(AAssign.Expr);
+ ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col);
Exit;
end;
@@ -8809,36 +7580,11 @@ begin
AAssign.Line, AAssign.Col);
AAssign.Name := VarSym.Name; { normalise to declared casing }
- { Static (class-level) var: the assignment target is the single shared global
- emitted under the mangled GlobalEmitName, so the LHS name must be that label
- (matches the read path in AnalyseIdentExpr). Enforce member visibility on
- the bare form too: a strict-private static var is reachable only from its
- declaring type's own methods, so writing it from another type, or from the
- unit initialization/finalization section (FCurrentClass = nil), is rejected. }
- if VarSym.IsClassVar and (VarSym.GlobalEmitName <> '') then
- begin
- AssertStaticVarVisible(VarSym.Visibility, VarSym.OwningUnit,
- VarSym.OwnerTypeName, VarSym.Name,
- AAssign.Line, AAssign.Col);
- AAssign.Name := VarSym.GlobalEmitName;
- end;
AAssign.IsVarParam := (VarSym.Kind = skVarParameter);
AAssign.ResolvedLhsType := VarSym.TypeDesc;
AAssign.IsWeakLhs := VarSym.IsWeak;
AAssign.IsGlobal := VarSym.IsGlobal;
AAssign.IsThreadVar := VarSym.IsThreadVar;
- { Owning unit of a module-scope global target, so the store address is
- mangled with the unit that won resolution — keeps a bare write to a
- cross-unit last-wins var hitting the same slot a bare read sees. A static
- class/record var's name is its already fully-mangled GlobalEmitName, so flag
- it pre-mangled to keep codegen's module-var prefixing from double-applying. }
- if VarSym.IsGlobal and (VarSym.Kind = skVariable) then
- begin
- if VarSym.IsClassVar then
- AAssign.ResolvedOwnerUnit := PreMangledGlobalOwner
- else
- AAssign.ResolvedOwnerUnit := VarSym.OwningUnit;
- end;
ResolveDiamond(AAssign.Expr, VarSym.TypeDesc);
@@ -8858,12 +7604,7 @@ begin
'Empty set literal ''[]'' cannot be assigned to non-set variable ''%s'' of type ''%s''',
[AAssign.Name, VarSym.TypeDesc.Name]), AAssign.Line, AAssign.Col);
- { Bare enum member on the RHS resolves against the variable's type, so a
- member name shared by several enums picks the one the LHS expects. }
- if TryResolveBareEnumIdent(AAssign.Expr, VarSym.TypeDesc) then
- ExprType := AAssign.Expr.ResolvedType
- else
- ExprType := AnalyseExpr(AAssign.Expr);
+ ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(VarSym.TypeDesc, ExprType, 'assignment', AAssign.Line, AAssign.Col);
end;
@@ -9058,14 +7799,6 @@ begin
ElemT := TStaticArrayTypeDesc(AFldInfo.TypeDesc).ElementType
else
begin
- { A class field carrying a default array property: the subscript is a write
- through that default property, Recv.Field[I] := V → (Recv.Field).Default[I]
- := V. Otherwise the subscript is meaningless on this field. }
- if TryLowerDefaultPropertyWrite(AAssign, AFldInfo.TypeDesc) then
- begin
- Result := True;
- Exit;
- end;
SemanticError(
Format('Field ''%s'' is not an array — cannot assign to a subscript',
[AAssign.FieldName]),
@@ -9082,60 +7815,6 @@ begin
Result := True;
end;
-{ Write through a default array property on a member result:
- Recv.Member[idx] := V where Member (a field or property) yields a class that
- carries a writable `default` indexed property — lower to
- (Recv.Member).Default[idx] := V. Reads the member into an inner object
- expression (the new ObjExpr receiver) and re-targets the assignment at the
- default property's setter. Class members only (a record getter result is a
- by-value temp, so a write through it would be discarded). Returns False when
- no lowering applies (no trailing index, not a class, or no writable default
- property), leaving the caller to handle the member as before. }
-function TSemanticAnalyser.TryLowerDefaultPropertyWrite(
- AAssign: TFieldAssignment; AMemberType: TTypeDesc): Boolean;
-var
- DefProp: TPropertyInfo;
- DefRT: TRecordTypeDesc;
- Inner: TFieldAccessExpr;
- IdxType: TTypeDesc;
- ValType: TTypeDesc;
-begin
- Result := False;
- if AAssign.PropIndexExpr = nil then
- Exit;
- if (AMemberType = nil) or (AMemberType.Kind <> tyClass) then
- Exit;
- DefRT := TRecordTypeDesc(AMemberType);
- DefProp := DefRT.FindDefaultProperty();
- if (DefProp = nil) or (DefProp.WriteMethod = '') then
- Exit;
- { Inner = the member read (the getter / field access), the receiver of the
- setter call. Carries the original receiver (RecordName form, or the ObjExpr
- receiver if one was already present). }
- Inner := TFieldAccessExpr.Create();
- Inner.Line := AAssign.Line;
- Inner.Col := AAssign.Col;
- Inner.Base := AAssign.ObjExpr; { transfer (nil for the RecordName form) }
- Inner.RecordName := AAssign.RecordName;
- Inner.FieldName := AAssign.FieldName;
- AnalyseExpr(Inner);
- { Re-target the assignment at the default property setter on that result. }
- AAssign.ObjExpr := Inner;
- AAssign.RecordName := '';
- AAssign.FieldName := DefProp.Name;
- AAssign.PropWriteInfo := DefProp;
- AAssign.PropOwnerType := PropAccessorOwner(DefRT.Name, DefProp.WriteMethod);
- AAssign.PropAccessorVSlot := PropAccessorVSlot(DefRT.Name, DefProp.WriteMethod);
- IdxType := AnalyseExpr(AAssign.PropIndexExpr);
- if DefProp.IndexTypeDesc <> nil then
- CheckTypesMatch(DefProp.IndexTypeDesc, IdxType, 'default property index',
- AAssign.Line, AAssign.Col);
- ValType := AnalyseExpr(AAssign.Expr);
- CheckTypesMatch(DefProp.TypeDesc, ValType, 'default property assignment',
- AAssign.Line, AAssign.Col);
- Result := True;
-end;
-
procedure TSemanticAnalyser.AnalyseFieldAssignment(AAssign: TFieldAssignment);
var
RecSym: TSymbol;
@@ -9147,7 +7826,6 @@ var
ExprType: TTypeDesc;
ObjType: TTypeDesc;
IntfDesc: TInterfaceTypeDesc;
- VarSym: TSymbol;
begin
{ ObjExpr path: receiver is an arbitrary expression (e.g. typecast result) }
if AAssign.ObjExpr <> nil then
@@ -9163,10 +7841,6 @@ begin
if FldInfo = nil then
begin
PropInfo := RT.FindProperty(AAssign.FieldName);
- if PropInfo <> nil then
- AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
- PropInfo.DeclaringType, AAssign.FieldName,
- AAssign.Line, AAssign.Col);
if (PropInfo <> nil) and (PropInfo.WriteField <> '') then
begin
AAssign.FieldName := PropInfo.WriteField;
@@ -9176,11 +7850,7 @@ begin
SemanticError(
Format('Type ''%s'' has no field ''%s''', [ObjType.Name, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
- end
- else
- AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
- FldInfo.DeclaringType, AAssign.FieldName,
- AAssign.Line, AAssign.Col);
+ end;
AAssign.IsClassAccess := ObjType.Kind = tyClass;
AAssign.FieldInfo := FldInfo;
if TryAnalyseFieldElemWrite(AAssign, FldInfo) then
@@ -9262,38 +7932,6 @@ begin
Format('Undeclared variable ''%s''', [AAssign.RecordName]),
AAssign.Line, AAssign.Col);
end;
- { Qualified STATIC (class-level) variable write: 'TFoo.StaticVar := V'.
- RecordName is a class/record TYPE, not a variable; the static var was
- registered under the combined key 'TFoo.StaticVar'. Enforce member
- visibility (a strict/private static var written from another type is
- rejected with a "not accessible" diagnostic), then mark the node so codegen
- lowers it as a plain store to the shared global slot — identical to the bare
- 'StaticVar := V' form a static method writes. }
- if RecSym.Kind = skType then
- begin
- VarSym := FTable.Lookup(AAssign.RecordName + '.' + AAssign.FieldName);
- if (VarSym <> nil) and (VarSym.Kind = skVariable) and VarSym.IsClassVar then
- begin
- AssertStaticVarVisible(VarSym.Visibility, VarSym.OwningUnit,
- VarSym.OwnerTypeName, AAssign.FieldName,
- AAssign.Line, AAssign.Col);
- AAssign.IsClassVarWrite := True;
- AAssign.ClassVarEmitName := VarSym.GlobalEmitName;
- AAssign.ClassVarLhsType := VarSym.TypeDesc;
- AAssign.IsGlobal := True;
- if (VarSym.TypeDesc.Kind = tySet) and (AAssign.Expr is TArrayLiteralExpr) then
- begin
- AnalyseSetLiteralExpr(TArrayLiteralExpr(AAssign.Expr),
- TSetTypeDesc(VarSym.TypeDesc));
- Exit;
- end;
- ResolveDiamond(AAssign.Expr, VarSym.TypeDesc);
- ExprType := AnalyseExpr(AAssign.Expr);
- CheckTypesMatch(VarSym.TypeDesc, ExprType, 'static var assignment',
- AAssign.Line, AAssign.Col);
- Exit;
- end;
- end;
if not (RecSym.Kind in [skVariable, skParameter, skVarParameter]) then
SemanticError(
Format('''%s'' is not a variable', [AAssign.RecordName]),
@@ -9320,10 +7958,7 @@ begin
AAssign.IntfWriteDesc := IntfDesc;
AAssign.IsGlobal := RecSym.IsGlobal;
AAssign.IsVarParam := RecSym.Kind = skVarParameter;
- if TryResolveBareEnumIdent(AAssign.Expr, PropInfo.TypeDesc) then
- ExprType := AAssign.Expr.ResolvedType
- else
- ExprType := AnalyseExpr(AAssign.Expr);
+ ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(PropInfo.TypeDesc, ExprType, 'property assignment',
AAssign.Line, AAssign.Col);
Exit;
@@ -9350,9 +7985,6 @@ begin
PropInfo := RT.FindProperty(AAssign.FieldName);
if PropInfo <> nil then
begin
- AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
- PropInfo.DeclaringType, AAssign.FieldName,
- AAssign.Line, AAssign.Col);
if PropInfo.WriteField <> '' then
begin
{ Field-backed write: redirect to the backing field }
@@ -9381,8 +8013,6 @@ begin
AAssign.Line, AAssign.Col);
Exit;
end
- else if TryLowerDefaultPropertyWrite(AAssign, PropInfo.TypeDesc) then
- Exit
else
SemanticError(
Format('Property ''%s'' is read-only', [AAssign.FieldName]),
@@ -9393,12 +8023,7 @@ begin
Format('Type ''%s'' has no field ''%s''',
[AAssign.RecordName, AAssign.FieldName]),
AAssign.Line, AAssign.Col);
- end
- else
- { Field write via variable.Field — enforce visibility. }
- AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
- FldInfo.DeclaringType, AAssign.FieldName,
- AAssign.Line, AAssign.Col);
+ end;
AAssign.FieldInfo := FldInfo;
if TryAnalyseFieldElemWrite(AAssign, FldInfo) then
@@ -9410,10 +8035,7 @@ begin
TSetTypeDesc(FldInfo.TypeDesc));
Exit;
end;
- if TryResolveBareEnumIdent(AAssign.Expr, FldInfo.TypeDesc) then
- ExprType := AAssign.Expr.ResolvedType
- else
- ExprType := AnalyseExpr(AAssign.Expr);
+ ExprType := AnalyseExpr(AAssign.Expr);
CheckTypesMatch(FldInfo.TypeDesc, ExprType, 'field assignment',
AAssign.Line, AAssign.Col);
end;
@@ -9684,7 +8306,7 @@ function TSemanticAnalyser.SetLiteralBaseEnum(AExpr: TArrayLiteralExpr): TTypeDe
var
I: Integer;
Elem: TASTExpr;
- Ref: TEnumMemberRef;
+ Sym: TSymbol;
begin
Result := nil;
if AExpr.Elements.Count = 0 then Exit;
@@ -9692,15 +8314,18 @@ begin
begin
Elem := TASTExpr(AExpr.Elements.Items[I]);
if not (Elem is TIdentExpr) then
+ begin
Exit(nil);
- { Resolve each element against the enum pinned by the first one, so a
- member name shared by several enums follows the rest of the literal. }
- Ref := ResolveEnumMember(TIdentExpr(Elem).Name, Result);
- if Ref = nil then
+ end;
+ Sym := FTable.Lookup(TIdentExpr(Elem).Name);
+ if (Sym = nil) or (Sym.Kind <> skConstant) or (Sym.TypeDesc = nil) or
+ (Sym.TypeDesc.Kind <> tyEnum) then
+ begin
Exit(nil);
+ end;
if Result = nil then
- Result := Ref.EnumDesc
- else if Ref.EnumDesc <> Result then
+ Result := Sym.TypeDesc
+ else if Sym.TypeDesc <> Result then
begin
Result := nil; { mixed enums — not a clean set constructor }
Exit;
@@ -9848,19 +8473,8 @@ begin
if Grp <> nil then
for I := 0 to Grp.Count - 1 do
begin
- Cand := TMethodDecl(Grp.Items[I]);
- { Impl-only (implementation-section) routines are PRIVATE to their
- unit. When several units each declare a same-named private helper
- (e.g. DiagAbort in both blaise_arc and blaise_exc), only the one
- owned by the unit currently being analysed is a valid candidate —
- the others are not visible here and must not count toward
- ambiguity. Routines exported from an interface (IsImplOnly=False)
- remain globally visible as before. }
- if Cand.IsImplOnly and (Cand.OwningUnit <> '') and
- (FCurrentUnitName <> '') and
- not SameText(Cand.OwningUnit, FCurrentUnitName) then
- Continue;
Inc(TotalCnt);
+ Cand := TMethodDecl(Grp.Items[I]);
if (AArity >= MinArity(Cand)) and (AArity <= Cand.Params.Count) then
ArityMatch.Add(Cand);
end;
@@ -9882,17 +8496,8 @@ begin
begin
Exit(TMethodDecl(ArityMatch.Items[0]));
end;
- { Two units may each privately declare the SAME external C function
- (e.g. a parameterless `external name 'abort'`). Both land in the
- global overload group with identical arity, but they denote ONE
- function — not an ambiguous overload. Collapse the duplicates: if
- every arity match is the same external decl as the first, accept it
- rather than erroring. Mirrors the arg-scoring collapse below. }
- if AllSameExternalDecl(ArityMatch) then
- Exit(TMethodDecl(ArityMatch.Items[0]));
- { zero-arg ambiguity is impossible for non-external decls — same name
- + zero params would have been rejected by the symbol-table chain,
- but be defensive. }
+ { zero-arg ambiguity is impossible — same name + zero params would
+ have been rejected by the symbol-table chain, but be defensive. }
if AArity = 0 then
SemanticError(
Format('Ambiguous overload of ''%s''', [AName]),
@@ -9956,13 +8561,11 @@ begin
end
else if ExactNew = ExactBest then
begin
- { Two candidates may denote the SAME underlying link symbol: two
- units each declaring `external name 'strlen'`, or an
- `external name '_BlaiseGetMem'` binding alongside the real
- _BlaiseGetMem exported by blaise_mem. They score identically but
- are ONE function — not an ambiguous overload. Collapse instead of
- erroring. }
- if not SameLinkSymbol(Cand, Best) then
+ { Two units may each privately declare the SAME external C function
+ (e.g. `external name 'strlen'`). Both land in the global overload
+ group and score identically, but they denote ONE function — not an
+ ambiguous overload. Collapse the duplicate instead of erroring. }
+ if not SameExternalDecl(Cand, Best) then
Inc(BestCount);
end;
end;
@@ -9994,7 +8597,6 @@ var
I: Integer;
PT: TProceduralTypeDesc;
PPar: TProcParamInfo;
- FldInfo: TFieldInfo;
begin
{ Resolution order matches Delphi/FPC:
1. Local variables / parameters / var-parameters — a `var Run:
@@ -10015,7 +8617,6 @@ begin
if MDecl <> nil then
begin
{ Analyse args first so overload resolution can score by type. }
- HintBareEnumMethodArgs(FCurrentClass.Name, ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
{ Use overload resolution so the correct variant is chosen when
@@ -10046,38 +8647,6 @@ begin
ACall.IsImplicitSelfMethod := True;
Exit;
end;
- { No method of that name — an unqualified procedural-typed field of the
- current class (implicit Self.Field) dispatches through its stored
- pointer, mirroring the explicit Self.Field() path. }
- FldInfo := FCurrentClass.FindField(ACall.Name);
- if (FldInfo <> nil) and (FldInfo.TypeDesc <> nil) and
- (FldInfo.TypeDesc.Kind = tyProcedural) then
- begin
- PT := TProceduralTypeDesc(FldInfo.TypeDesc);
- if ACall.Args.Count <> PT.Params.Count then
- SemanticError(Format(
- 'Indirect call ''%s'' expects %d argument(s), got %d',
- [ACall.Name, PT.Params.Count, ACall.Args.Count]),
- ACall.Line, ACall.Col);
- for I := 0 to ACall.Args.Count - 1 do
- begin
- PPar := TProcParamInfo(PT.Params.Items[I]);
- ArgType := AnalyseExprHinted(TASTExpr(ACall.Args.Items[I]), PPar.TypeDesc);
- if PPar.IsVarParam and
- not IsVarArgLValue(TASTExpr(ACall.Args.Items[I])) then
- SemanticError(
- Format('var argument %d of ''%s'' must be a variable',
- [I + 1, ACall.Name]),
- ACall.Line, ACall.Col);
- CheckTypesMatch(PPar.TypeDesc, ArgType,
- Format('argument %d of ''%s''', [I + 1, ACall.Name]),
- ACall.Line, ACall.Col);
- end;
- ACall.IsProcFieldCall := True;
- ACall.ProcFieldInfo := FldInfo;
- ACall.ResolvedProcType := FldInfo.TypeDesc;
- Exit;
- end;
end;
{ Try on-demand instantiation of a generic function }
if StrPos('<', ACall.Name) >= 0 then
@@ -10106,8 +8675,8 @@ begin
ACall.Line, ACall.Col);
for I := 0 to ACall.Args.Count - 1 do
begin
+ ArgType := AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
PPar := TProcParamInfo(PT.Params.Items[I]);
- ArgType := AnalyseExprHinted(TASTExpr(ACall.Args.Items[I]), PPar.TypeDesc);
{ Var-param actual must be an L-value; check before the type match
so the diagnostic matches the regular-call path. }
if PPar.IsVarParam and
@@ -10154,9 +8723,6 @@ begin
Idx := FProcIndex.IndexOf(ACall.Name);
if Idx >= 0 then
begin
- { Steer a bare shared enum member to the enum this proc expects before
- bottom-up analysis pins it by last-wins. }
- HintBareEnumArgs(ACall.Name, ACall.Args);
for I := 0 to ACall.Args.Count - 1 do
AnalyseExpr(TASTExpr(ACall.Args.Items[I]));
@@ -10333,7 +8899,6 @@ var
I: Integer;
PT: TProceduralTypeDesc;
PPar: TProcParamInfo;
- FldInfo: TFieldInfo;
begin
{ HasClassAttribute(AClass, AAttrClass): Boolean — runtime query of the custom
attribute RTTI stored in slot 7 of the class's typeinfo. Both arguments
@@ -10525,7 +9090,6 @@ begin
if MDecl <> nil then
begin
{ Analyse args first so overload resolution can score by type. }
- HintBareEnumMethodArgs(FCurrentClass.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
MDecl := ResolveMethodOverload(FCurrentClass.Name, AExpr.Name,
@@ -10553,40 +9117,6 @@ begin
AExpr.ResolvedType := Result;
Exit;
end;
- { No method of that name — an unqualified procedural-typed field of the
- current class (implicit Self.Field) called as an expression dispatches
- through its stored pointer and yields the signature's return type. }
- FldInfo := FCurrentClass.FindField(AExpr.Name);
- if (FldInfo <> nil) and (FldInfo.TypeDesc <> nil) and
- (FldInfo.TypeDesc.Kind = tyProcedural) then
- begin
- PT := TProceduralTypeDesc(FldInfo.TypeDesc);
- if AExpr.Args.Count <> PT.Params.Count then
- SemanticError(Format(
- 'Indirect call ''%s'' expects %d argument(s), got %d',
- [AExpr.Name, PT.Params.Count, AExpr.Args.Count]),
- AExpr.Line, AExpr.Col);
- for I := 0 to AExpr.Args.Count - 1 do
- begin
- PPar := TProcParamInfo(PT.Params.Items[I]);
- ArgType := AnalyseExprHinted(TASTExpr(AExpr.Args.Items[I]), PPar.TypeDesc);
- if PPar.IsVarParam and
- not IsVarArgLValue(TASTExpr(AExpr.Args.Items[I])) then
- SemanticError(
- Format('var argument %d of ''%s'' must be a variable',
- [I + 1, AExpr.Name]),
- AExpr.Line, AExpr.Col);
- CheckTypesMatch(PPar.TypeDesc, ArgType,
- Format('argument %d of ''%s''', [I + 1, AExpr.Name]),
- AExpr.Line, AExpr.Col);
- end;
- AExpr.IsProcFieldCall := True;
- AExpr.ProcFieldInfo := FldInfo;
- AExpr.ResolvedProcType := FldInfo.TypeDesc;
- Result := PT.ReturnType;
- AExpr.ResolvedType := Result;
- Exit;
- end;
end;
{ Try on-demand instantiation of a generic function }
if StrPos('<', AExpr.Name) >= 0 then
@@ -10630,8 +9160,8 @@ begin
AExpr.Line, AExpr.Col);
for I := 0 to AExpr.Args.Count - 1 do
begin
+ ArgType := AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
PPar := TProcParamInfo(PT.Params.Items[I]);
- ArgType := AnalyseExprHinted(TASTExpr(AExpr.Args.Items[I]), PPar.TypeDesc);
if PPar.IsVarParam and
not IsVarArgLValue(TASTExpr(AExpr.Args.Items[I])) then
SemanticError(
@@ -11262,53 +9792,13 @@ begin
Exit;
end;
- { Scoped nested routine: a function declared inside another routine's body
- is registered in the symbol table only, never in the global FProcIndex /
- FProcGroups (so same-named nested procs in sibling outer routines do not
- collide as ambiguous overloads). When the call name misses the global
- index but the scoped Sym carries its backing decl, resolve directly
- against that single decl rather than the overload group. }
- if (FProcIndex.IndexOf(AExpr.Name) < 0) and (Sym <> nil) and
- (Sym.Decl <> nil) and (Sym.Decl is TMethodDecl) then
- begin
- MDecl := TMethodDecl(Sym.Decl);
- HintBareEnumArgs(AExpr.Name, AExpr.Args);
- for I := 0 to AExpr.Args.Count - 1 do
- AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
- if (AExpr.Args.Count < MinArity(MDecl)) or
- (AExpr.Args.Count > MDecl.Params.Count) then
- SemanticError(
- Format('''%s'' expects %d argument(s), got %d',
- [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.Items[I]);
- if Par.IsVarParam then
- begin
- ArgType := TASTExpr(AExpr.Args.Items[I]).ResolvedType;
- CheckTypesMatch(Par.ResolvedType, ArgType,
- Format('var argument %d of ''%s''', [I + 1, AExpr.Name]),
- AExpr.Line, AExpr.Col);
- end;
- end;
- RetypeSetLiteralArgs(AExpr.Args, MDecl);
- AppendDefaultArgs(AExpr.Args, MDecl, AExpr.Name, AExpr.Line, AExpr.Col);
- AExpr.ResolvedDecl := MDecl;
- Result := MDecl.ResolvedReturnType;
- 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);
- { Phase B: analyse args first, then score overloads by argument type.
- A bare shared enum member is first steered to the enum the target expects
- at its position, so the right ordinal is pinned before bottom-up analysis. }
- HintBareEnumArgs(AExpr.Name, AExpr.Args);
+ { Phase B: analyse args first, then score overloads by argument type. }
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
@@ -11379,7 +9869,6 @@ begin
end;
RT := TRecordTypeDesc(ObjType);
{ Analyse args first so overload resolution can score by type. }
- HintBareEnumMethodArgs(RT.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
{ Built-in TObject.ToString: virtual dispatch via vtable slot 1.
@@ -11395,9 +9884,8 @@ begin
AExpr.ResolvedType := Result;
Exit;
end;
- FMethodOwnerHint := RT.OwningUnit;
- MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
- AExpr.Line, AExpr.Col);
+ MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
+ AExpr.Line, AExpr.Col);
if MDecl = nil then
begin
FldInfo := RT.FindField(AExpr.Name);
@@ -11409,10 +9897,7 @@ begin
AExpr.ResolvedProcType := FldInfo.TypeDesc;
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := nil;
- { Calling a function-pointer field yields the field signature's return
- type — not nil — so the call can be used as an expression. }
- AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
- Result := AExpr.ResolvedType;
+ AExpr.ResolvedType := nil;
Exit;
end;
SemanticError(
@@ -11427,15 +9912,7 @@ begin
Exit;
end;
- { A unit-qualified receiver type 'Unit.Type.Method' resolves against that
- specific unit's exports (directed lookup), so a constructor on a cross-unit
- same-named type binds to the named unit rather than the flat last-wins
- winner. Falls back to the normal lookup on a miss. }
- ObjSym := nil;
- if AExpr.QualifierUnit <> '' then
- ObjSym := ResolveQualified(AExpr.QualifierUnit, AExpr.ObjectName);
- if ObjSym = nil then
- ObjSym := FTable.Lookup(AExpr.ObjectName);
+ ObjSym := FTable.Lookup(AExpr.ObjectName);
{ If the name contains '<' and wasn't found, resolve scope-bound type params
(e.g. 'TListEnumerator' → 'TListEnumerator' when T=Integer is
in scope) and trigger on-demand instantiation. Mirrors the field-access
@@ -11501,12 +9978,10 @@ begin
end;
RT := TRecordTypeDesc(ObjType);
{ Analyse args first so overload resolution can score by type. }
- HintBareEnumMethodArgs(RT.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
- FMethodOwnerHint := RT.OwningUnit;
- MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
- AExpr.Line, AExpr.Col);
+ MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
+ AExpr.Line, AExpr.Col);
if MDecl = nil then
begin
FldInfo := RT.FindField(AExpr.Name);
@@ -11518,9 +9993,7 @@ begin
AExpr.ResolvedProcType := FldInfo.TypeDesc;
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := nil;
- { Function-pointer field call yields the signature's return type. }
- AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
- Result := AExpr.ResolvedType;
+ AExpr.ResolvedType := nil;
Exit;
end;
SemanticError(
@@ -11562,39 +10035,6 @@ begin
if SameText(ObjSym.Name, AExpr.ObjectName) then
AExpr.ObjectName := ObjSym.Name;
- { TypeName.StaticFunction(args) in expression position — a static (class-level)
- method reached through the class name. Must be declared static; lowered with
- NO Self. Checked before the Create-constructor branch so a non-Create static
- method resolves here rather than falling through to "is not a variable". }
- if (ObjSym.Kind = skType) and (ObjSym.TypeDesc <> nil) and
- (ObjSym.TypeDesc.Kind in [tyClass, tyRecord]) and
- not (SameText(AExpr.Name, 'Create') or (StrPos('Create', AExpr.Name) = 0)) then
- begin
- for I := 0 to AExpr.Args.Count - 1 do
- AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
- MDecl := ResolveMethodOverload(ObjSym.Name, AExpr.Name, AExpr.Args,
- AExpr.Line, AExpr.Col);
- if MDecl = nil then
- MDecl := FindMethodDecl(ObjSym.Name, AExpr.Name);
- if MDecl = nil then
- SemanticError(
- Format('Type ''%s'' has no method ''%s''', [ObjSym.Name, AExpr.Name]),
- AExpr.Line, AExpr.Col);
- if not MDecl.IsStatic then
- SemanticError(
- Format('''%s.%s'' is not a static method — call it on an instance',
- [ObjSym.Name, AExpr.Name]),
- AExpr.Line, AExpr.Col);
- AppendDefaultArgs(AExpr.Args, MDecl, AExpr.Name, AExpr.Line, AExpr.Col);
- EnforceMethodVisible(MDecl, AExpr.Line, AExpr.Col);
- AExpr.ResolvedMethod := MDecl;
- AExpr.ResolvedClassType := ObjSym.TypeDesc;
- AExpr.IsStaticCall := True;
- Result := MDecl.ResolvedReturnType;
- AExpr.ResolvedType := Result;
- Exit;
- end;
-
{ 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
@@ -11609,7 +10049,6 @@ begin
SemanticError(
Format('Cannot instantiate abstract class ''%s''', [ObjSym.Name]),
AExpr.Line, AExpr.Col);
- HintBareEnumMethodArgs(ObjSym.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
{ Try to find a user-defined constructor method for type checking.
@@ -11660,7 +10099,6 @@ begin
(SameText(AExpr.Name, 'Create') or (StrPos('Create', AExpr.Name) = 0)) then
begin
RT := TRecordTypeDesc(TMetaClassTypeDesc(ObjSym.TypeDesc).BaseClass);
- HintBareEnumMethodArgs(RT.Name, AExpr.Name, AExpr.Args);
for I := 0 to AExpr.Args.Count - 1 do
AnalyseExpr(TASTExpr(AExpr.Args.Items[I]));
MDecl := ResolveMethodOverload(RT.Name, AExpr.Name,
@@ -11750,9 +10188,8 @@ begin
AExpr.ResolvedType := Result;
Exit;
end;
- FMethodOwnerHint := RT.OwningUnit;
- MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
- AExpr.Line, AExpr.Col);
+ MDecl := ResolveMethodOverload(RT.Name, AExpr.Name, AExpr.Args,
+ AExpr.Line, AExpr.Col);
if MDecl = nil then
MDecl := FindMethodDecl(RT.Name, AExpr.Name);
{ Built-in TObject.ToString: virtual dispatch yielding string.
@@ -11788,9 +10225,7 @@ begin
(ObjSym.Kind = skVarParameter) or
((ObjSym.Kind = skParameter) and (ObjSym.TypeDesc <> nil) and
(ObjSym.TypeDesc.Kind in [tyRecord, tyStaticArray]));
- { Function-pointer field call yields the signature's return type. }
- AExpr.ResolvedType := TProceduralTypeDesc(FldInfo.TypeDesc).ReturnType;
- Result := AExpr.ResolvedType;
+ AExpr.ResolvedType := nil;
Exit;
end;
SemanticError(
@@ -11818,7 +10253,6 @@ begin
AExpr.Line, AExpr.Col);
end;
- EnforceMethodVisible(MDecl, AExpr.Line, AExpr.Col);
AExpr.ResolvedClassType := RT;
AExpr.ResolvedMethod := MDecl;
AExpr.IsGlobal := ObjSym.IsGlobal;
@@ -11834,7 +10268,6 @@ var
Sym: TSymbol;
FldInfo: TFieldInfo;
PropInfo: TPropertyInfo;
- EnumRef: TEnumMemberRef;
begin
if AExpr is TNilLiteral then
Result := FTable.TypeNil
@@ -11852,32 +10285,6 @@ begin
Result := FTable.TypeString
else if AExpr is TIdentExpr then
begin
- { Already resolved to a constant (e.g. a bare enum member pinned in place
- by a context-directed site such as an assignment, case label or 'in'
- operand). Re-returning the type keeps resolution idempotent and avoids
- a spurious second ambiguity warning. }
- if TIdentExpr(AExpr).IsConstant and (AExpr.ResolvedType <> nil) then
- Exit(AExpr.ResolvedType);
- { Unit-qualified reference 'Unit.Symbol' (parser preserved the unit in
- QualifierUnit). Resolve via the directed-lookup primitive against
- that specific unit's exports: a same-named symbol in another used
- unit cannot shadow it, the uses-chain last-wins rule does not apply,
- and an explicit qualifier is never shadowed by a class field. An
- absent member is a hard error at the qualification site. No const/
- var/type special-casing here — it falls through to the shared symbol
- normalisation below, dispatched on Sym.Kind like any other symbol. }
- if TIdentExpr(AExpr).QualifierUnit <> '' then
- begin
- Sym := ResolveQualified(TIdentExpr(AExpr).QualifierUnit,
- TIdentExpr(AExpr).Name);
- if Sym = nil then
- SemanticError(Format(
- 'Identifier ''%s'' not declared in unit ''%s''',
- [TIdentExpr(AExpr).Name, TIdentExpr(AExpr).QualifierUnit]),
- AExpr.Line, AExpr.Col);
- end
- else
- begin
{ Resolution order (matches AnalyseProcCall / AnalyseFuncCall):
local vars/params > implicit Self.member > unit-level. Without
this priority, a bare identifier inside a method binds to the
@@ -11938,53 +10345,13 @@ begin
end;
end;
if Sym = nil then
- begin
- { Not a normal symbol — try a bare enum member. No expected-type
- context flows into the generic expression path, so this resolves a
- member declared by a single enum directly; a member shared by several
- enums is ambiguous here and is rejected — qualify it (TEnum.Member).
- Context-sensitive sites (assignment, case, call args, set elements,
- for bounds) inject a hint before reaching here. }
- EnumRef := ResolveEnumMember(TIdentExpr(AExpr).Name, nil);
- if EnumRef <> nil then
- begin
- if EnumMemberCandidateCount(TIdentExpr(AExpr).Name) > 1 then
- SemanticError(Format(
- 'cannot determine which enum ''%s'' refers to: it is declared by ' +
- '%s, and there is no type context here to choose. Qualify it as ' +
- '.%s',
- [TIdentExpr(AExpr).Name, EnumMemberOwners(TIdentExpr(AExpr).Name),
- TIdentExpr(AExpr).Name]),
- AExpr.Line, AExpr.Col);
- TIdentExpr(AExpr).IsConstant := True;
- TIdentExpr(AExpr).ConstValue := EnumRef.Ordinal;
- Result := EnumRef.EnumDesc;
- AExpr.ResolvedType := Result;
- Exit;
- end;
SemanticError(
Format('Undeclared identifier ''%s''', [TIdentExpr(AExpr).Name]),
AExpr.Line, AExpr.Col);
- end;
- end; { end else: unqualified resolution (qualified set Sym above) }
{ Var-params and value-record/array params are both passed by reference at
the QBE ABI level: the local slot holds a pointer, not the aggregate
bytes. Codegen must dereference the slot before reading fields. }
TIdentExpr(AExpr).Name := Sym.Name; { normalise to declared casing }
- { A static (class-level) variable resolves to a single shared global whose
- emit label is the mangled GlobalEmitName, distinct from the lookup key
- ('FInstance' or 'TFoo.FInstance' both reach the one slot). Rewrite the
- node's emitted name to that label so codegen lowers $TFoo_FInstance.
- Enforce member visibility on the bare form: a strict-private static var is
- reachable only from its declaring type's own methods (FCurrentClass = the
- declaring type), not from another type or the unit init/final section. }
- if Sym.IsClassVar and (Sym.GlobalEmitName <> '') then
- begin
- AssertStaticVarVisible(Sym.Visibility, Sym.OwningUnit,
- Sym.OwnerTypeName, Sym.Name,
- AExpr.Line, AExpr.Col);
- TIdentExpr(AExpr).Name := Sym.GlobalEmitName;
- end;
if Sym.Kind = skVarParameter then
TIdentExpr(AExpr).ParamMode := pmVar
else if (Sym.Kind = skParameter) and (Sym.TypeDesc <> nil) and
@@ -12000,22 +10367,6 @@ begin
TIdentExpr(AExpr).ParamMode := pmNone;
TIdentExpr(AExpr).IsGlobal := Sym.IsGlobal;
TIdentExpr(AExpr).IsThreadVar := Sym.IsThreadVar;
- { Record the owning unit of a module-scope global so codegen mangles
- the storage symbol with the unit that actually won resolution (the
- uses-chain last-wins winner for a bare ref, the named unit for a
- qualified ref). Without this, two used units exporting the same var
- name both resolve to one slot. }
- if Sym.IsGlobal and (Sym.Kind = skVariable) then
- begin
- { A static class/record var's Name was rewritten above to its already
- fully-mangled GlobalEmitName (Unit_Class_Field); flag it so codegen's
- module-var prefixing does not double-apply. Plain module globals carry
- their owning unit for owner-based mangling. }
- if Sym.IsClassVar then
- TIdentExpr(AExpr).ResolvedOwnerUnit := PreMangledGlobalOwner
- else
- TIdentExpr(AExpr).ResolvedOwnerUnit := Sym.OwningUnit;
- end;
if Sym.Kind = skConstant then
begin
TIdentExpr(AExpr).IsConstant := True;
@@ -12106,45 +10457,6 @@ begin
AExpr.ResolvedType := Result;
end;
-{ Default array property on a property-read result. The parser folds the
- trailing '[idx]' of 'Recv.Prop[idx]' into AAccess.PropIndexExpr, so when Prop
- is a (non-indexed) property whose type has a `default` indexed property, the
- read above would resolve Recv.Prop and drop the index. Rewrite it as
- '(Recv.Prop).Default[idx]': move the property read into a fresh inner
- field-access (the getter, no index) and re-point AAccess at the default
- property, then re-analyse — which lands on the chained indexed-property path.
- Returns the resolved element type, or nil when no lowering applies (the
- caller then handles Prop as before). APropInfo is the already-resolved read
- property. }
-function TSemanticAnalyser.TryLowerDefaultPropertyIndex(
- AAccess: TFieldAccessExpr; APropInfo: TPropertyInfo): TTypeDesc;
-var
- Inner: TFieldAccessExpr;
- DefProp: TPropertyInfo;
-begin
- Result := nil;
- if (APropInfo.IndexParamName <> '') or (AAccess.PropIndexExpr = nil) then
- Exit;
- if not (APropInfo.TypeDesc.Kind in [tyRecord, tyClass]) then
- Exit;
- DefProp := TRecordTypeDesc(APropInfo.TypeDesc).FindDefaultProperty();
- if (DefProp = nil) or (DefProp.ReadMethod = '') then
- Exit;
- { Inner = the property getter without the index; carries the receiver. }
- Inner := TFieldAccessExpr.Create();
- Inner.Line := AAccess.Line;
- Inner.Col := AAccess.Col;
- Inner.Base := AAccess.Base; { transfer ownership (may be nil) }
- Inner.RecordName := AAccess.RecordName;
- Inner.FieldName := AAccess.FieldName;
- { Re-point AAccess at the default property on that getter result; the
- PropIndexExpr ('[idx]') is left in place as its index. }
- AAccess.Base := Inner;
- AAccess.RecordName := '';
- AAccess.FieldName := DefProp.Name;
- Result := AnalyseFieldAccess(AAccess);
-end;
-
function TSemanticAnalyser.AnalyseFieldAccess(AAccess: TFieldAccessExpr): TTypeDesc;
var
RecSym: TSymbol;
@@ -12154,8 +10466,6 @@ var
PropInfo: TPropertyInfo;
BaseType: TTypeDesc;
IntfDesc: TInterfaceTypeDesc;
- MDecl: TMethodDecl;
- EnumOrd: Integer;
begin
{ Chained access: A.B.C — base is another expression whose type must be
a record or class. Leaf lookup uses Base.ResolvedType; RecordName path
@@ -12163,53 +10473,6 @@ begin
if AAccess.Base <> nil then
begin
BaseType := AnalyseExpr(AAccess.Base);
- { Metaclass base: 'TypeName.StaticVar' or 'TypeName.StaticProp' arriving as
- a chained access (Base is the bare class-name ident resolving to
- 'class of TypeName') rather than the simple RecordName form. This is how
- the parser shapes a qualified static-var/property used as the BASE of a
- further chain on an l-value, e.g. 'TFoo.GObj.V := x' or 'TFoo.GObj.M()'.
- Resolve it exactly like the RecordName static-var/static-prop read below,
- so the result type feeds the outer chain. }
- if BaseType.Kind = tyMetaClass then
- begin
- RT := TRecordTypeDesc(TMetaClassTypeDesc(BaseType).BaseClass);
- Sym := FTable.Lookup(RT.Name + '.' + AAccess.FieldName);
- if (Sym <> nil) and (Sym.Kind = skVariable) and Sym.IsClassVar then
- begin
- AssertStaticVarVisible(Sym.Visibility, Sym.OwningUnit,
- Sym.OwnerTypeName, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
- AAccess.IsClassVarRead := True;
- AAccess.IsGlobal := True;
- AAccess.ClassVarEmitName := Sym.GlobalEmitName;
- AAccess.ResolvedType := Sym.TypeDesc;
- Exit(Sym.TypeDesc);
- end;
- PropInfo := RT.FindProperty(AAccess.FieldName);
- if (PropInfo <> nil) and PropInfo.IsStatic then
- begin
- if PropInfo.ReadMethod = '' then
- SemanticError(
- Format('Static property ''%s.%s'' has no readable static getter',
- [RT.Name, AAccess.FieldName]),
- AAccess.Line, AAccess.Col);
- MDecl := FindMethodDecl(RT.Name, PropInfo.ReadMethod);
- if (MDecl = nil) or not MDecl.IsStatic then
- SemanticError(
- Format('Static property ''%s.%s'' getter ''%s'' is not a static method',
- [RT.Name, AAccess.FieldName, PropInfo.ReadMethod]),
- AAccess.Line, AAccess.Col);
- AAccess.IsStaticPropGet := True;
- AAccess.ResolvedMethod := MDecl;
- AAccess.ResolvedClassType := BaseType;
- AAccess.ResolvedType := MDecl.ResolvedReturnType;
- Exit(MDecl.ResolvedReturnType);
- end;
- SemanticError(
- Format('Unknown static member ''%s'' on type ''%s''',
- [AAccess.FieldName, RT.Name]),
- AAccess.Line, AAccess.Col);
- end;
if not (BaseType.Kind in [tyRecord, tyClass]) then
SemanticError(
Format('Field access ''.%s'' requires a record or class base, got ''%s''',
@@ -12234,27 +10497,16 @@ begin
if FldInfo = nil then
begin
PropInfo := RT.FindProperty(AAccess.FieldName);
- if PropInfo <> nil then
- AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
- PropInfo.DeclaringType, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
if (PropInfo <> nil) and (PropInfo.ReadField <> '') then
begin
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
- AAccess.BackingFieldRedirect := True;
Exit(PropInfo.TypeDesc);
end;
{ Method-backed property (including indexed: the parser attaches the
'[idx]' to AAccess.PropIndexExpr when it parses 'Base.Prop[idx]'). }
if (PropInfo <> nil) and (PropInfo.ReadMethod <> '') then
begin
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
if PropInfo.IndexParamName <> '' then
begin
if AAccess.PropIndexExpr = nil then
@@ -12306,12 +10558,6 @@ begin
[BaseType.Name, AAccess.FieldName]),
AAccess.Line, AAccess.Col);
end;
- { Field found via qualified access (Base.Field) — enforce visibility unless
- this node is a property→backing-field redirect already checked. }
- if not AAccess.BackingFieldRedirect then
- AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
- FldInfo.DeclaringType, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;
if AAccess.PropIndexExpr <> nil then
@@ -12365,15 +10611,7 @@ begin
Exit;
end;
- { A unit-qualified base type 'Unit.TEnum.Member' / 'Unit.TFoo.StaticVar'
- resolves the base against that specific unit's exports (directed lookup), so
- it binds to the named unit rather than the flat cross-unit last-wins winner.
- Falls back to the normal lookup on a miss. }
- RecSym := nil;
- if AAccess.QualifierUnit <> '' then
- RecSym := ResolveQualified(AAccess.QualifierUnit, AAccess.RecordName);
- if RecSym = nil then
- RecSym := FTable.Lookup(AAccess.RecordName);
+ RecSym := FTable.Lookup(AAccess.RecordName);
{ If the name contains '<' and wasn't found, resolve scope-bound type params
(e.g. 'TGenEnum' → 'TGenEnum' when T=Integer is in scope)
and update AAccess.RecordName so codegen sees the concrete instantiation. }
@@ -12405,9 +10643,6 @@ begin
begin
if PropInfo.ReadField <> '' then
begin
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
Result := PropInfo.TypeDesc;
@@ -12417,9 +10652,6 @@ begin
else if PropInfo.ReadMethod <> '' then
begin
{ Method-backed read (includes indexed properties) }
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
if PropInfo.IndexParamName <> '' then
begin
if AAccess.PropIndexExpr = nil then
@@ -12509,26 +10741,6 @@ begin
AAccess.RecordName := RecSym.Name; { normalise to declared casing }
- { Type-qualified enum member: TMyEnum.meValue. Resolve the member straight
- from the named enum's own member list, so the reference is unambiguous even
- when another enum in scope declares a member of the same name (the bare name
- resolves to whichever enum claimed the global slot; the qualified form
- always names this one). }
- if (RecSym.Kind = skType) and (RecSym.TypeDesc <> nil) and
- (RecSym.TypeDesc.Kind = tyEnum) then
- begin
- EnumOrd := TEnumTypeDesc(RecSym.TypeDesc).OrdinalOf(AAccess.FieldName);
- if EnumOrd < 0 then
- SemanticError(
- Format('Enum ''%s'' has no member ''%s''',
- [AAccess.RecordName, AAccess.FieldName]),
- AAccess.Line, AAccess.Col);
- AAccess.IsConstant := True;
- AAccess.ConstValue := EnumOrd;
- AAccess.ResolvedType := RecSym.TypeDesc;
- Exit(RecSym.TypeDesc);
- end;
-
{ Constructor call: TypeName.Create }
if RecSym.Kind = skType then
begin
@@ -12560,46 +10772,6 @@ begin
AAccess.ResolvedType := Sym.TypeDesc;
Exit(Sym.TypeDesc);
end;
- { Static (class-level) variable read: TypeName.StaticVar. The qualified
- symbol carries the mangled GlobalEmitName; rewrite the access to a plain
- global read of that label (codegen lowers it like a global ident).
- Enforce member visibility — a strict/private static var read through the
- qualified form from a context that may not see it is rejected. }
- if (Sym <> nil) and (Sym.Kind = skVariable) and Sym.IsClassVar then
- begin
- AssertStaticVarVisible(Sym.Visibility, Sym.OwningUnit,
- Sym.OwnerTypeName, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
- AAccess.IsClassVarRead := True;
- AAccess.IsGlobal := True;
- AAccess.ClassVarEmitName := Sym.GlobalEmitName;
- AAccess.ResolvedType := Sym.TypeDesc;
- Exit(Sym.TypeDesc);
- end;
- { Static property read: TypeName.StaticProp. Resolve to its (static)
- getter and lower as a static getter call. Only method-backed static
- getters are supported (a field-backed static property would resolve to
- the static var directly). }
- PropInfo := TRecordTypeDesc(RecSym.TypeDesc).FindProperty(AAccess.FieldName);
- if (PropInfo <> nil) and PropInfo.IsStatic then
- begin
- if PropInfo.ReadMethod = '' then
- SemanticError(
- Format('Static property ''%s.%s'' has no readable static getter',
- [AAccess.RecordName, AAccess.FieldName]),
- AAccess.Line, AAccess.Col);
- MDecl := FindMethodDecl(TRecordTypeDesc(RecSym.TypeDesc).Name, PropInfo.ReadMethod);
- if (MDecl = nil) or not MDecl.IsStatic then
- SemanticError(
- Format('Static property ''%s.%s'' getter ''%s'' is not a static method',
- [AAccess.RecordName, AAccess.FieldName, PropInfo.ReadMethod]),
- AAccess.Line, AAccess.Col);
- AAccess.IsStaticPropGet := True;
- AAccess.ResolvedMethod := MDecl;
- AAccess.ResolvedClassType := RecSym.TypeDesc;
- AAccess.ResolvedType := MDecl.ResolvedReturnType;
- Exit(MDecl.ResolvedReturnType);
- end;
SemanticError(
Format('Unknown class method ''%s'' on type ''%s''',
[AAccess.FieldName, AAccess.RecordName]),
@@ -12653,27 +10825,6 @@ begin
Exit;
end;
- { Metaclass variable: a bare 'C.Create' / 'C.Method' (no parens) reaching
- field-access analysis is a constructor/method call written without the
- mandatory parentheses — the parenthesised form is a TMethodCallExpr and
- never lands here. Emit the parens diagnostic rather than the misleading
- 'is not a record or class' error. }
- if RecSym.TypeDesc.Kind = tyMetaClass then
- begin
- RT := TRecordTypeDesc(TMetaClassTypeDesc(RecSym.TypeDesc).BaseClass);
- if (RT <> nil) and
- (SameText(AAccess.FieldName, 'Create') or
- (FindMethodDecl(RT.Name, AAccess.FieldName) <> nil)) then
- SemanticError(
- Format('Bare reference to ''%s'' requires () for a call',
- [AAccess.FieldName]),
- AAccess.Line, AAccess.Col);
- SemanticError(
- Format('Metaclass ''%s'' has no method ''%s''',
- [RecSym.TypeDesc.Name, AAccess.FieldName]),
- AAccess.Line, AAccess.Col);
- end;
-
if not (RecSym.TypeDesc.Kind in [tyRecord, tyClass]) then
SemanticError(
Format('''%s'' is not a record or class', [AAccess.RecordName]),
@@ -12724,18 +10875,11 @@ begin
PropInfo := RT.FindProperty(AAccess.FieldName);
if PropInfo <> nil then
begin
- AssertMemberVisibleV(PropInfo.Visibility, PropInfo.DeclaringUnit,
- PropInfo.DeclaringType, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
if PropInfo.ReadField <> '' then
begin
{ Field-backed read: redirect to the backing field }
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
AAccess.FieldName := PropInfo.ReadField;
AAccess.FieldInfo := RT.FindField(PropInfo.ReadField);
- AAccess.BackingFieldRedirect := True;
Result := PropInfo.TypeDesc;
AAccess.ResolvedType := Result;
Exit;
@@ -12743,9 +10887,6 @@ begin
else if PropInfo.ReadMethod <> '' then
begin
{ Method-backed read (includes indexed properties) }
- Result := TryLowerDefaultPropertyIndex(AAccess, PropInfo);
- if Result <> nil then
- Exit;
if PropInfo.IndexParamName <> '' then
begin
if AAccess.PropIndexExpr = nil then
@@ -12792,12 +10933,6 @@ begin
AAccess.Line, AAccess.Col);
end;
- { Field found via variable.Field qualified access — enforce visibility unless
- this node is a property→backing-field redirect already checked. }
- if not AAccess.BackingFieldRedirect then
- AssertMemberVisibleV(FldInfo.Visibility, FldInfo.DeclaringUnit,
- FldInfo.DeclaringType, AAccess.FieldName,
- AAccess.Line, AAccess.Col);
AAccess.FieldInfo := FldInfo;
Result := FldInfo.TypeDesc;
if AAccess.PropIndexExpr <> nil then
@@ -12853,25 +10988,8 @@ var
LType, RType: TTypeDesc;
TmpSet: TSetTypeDesc;
begin
- { Set membership with a bare enum-member left operand and a real set (not a
- literal) on the right: the set's element type disambiguates the member, so
- resolve the right first and pin the left against it. Done before the eager
- analysis below, which would otherwise pick a context-free last-wins
- candidate (and warn) for a shared member name. }
- if (ABin.Op = boIn) and (ABin.Left is TIdentExpr) and
- not TIdentExpr(ABin.Left).IsConstant and
- not (ABin.Right is TArrayLiteralExpr) then
- begin
- RType := AnalyseExpr(ABin.Right);
- if (RType <> nil) and (RType.Kind = tySet) then
- TryResolveBareEnumIdent(ABin.Left, TSetTypeDesc(RType).BaseType);
- LType := AnalyseExpr(ABin.Left);
- end
- else
- begin
- LType := AnalyseExpr(ABin.Left);
- RType := AnalyseExpr(ABin.Right);
- end;
+ LType := AnalyseExpr(ABin.Left);
+ RType := AnalyseExpr(ABin.Right);
{ Set membership: elem in SetVar — left is base enum, right is set type }
if ABin.Op = boIn then
@@ -13406,15 +11524,6 @@ var
DefProp: TPropertyInfo;
DefFA: TFieldAccessExpr;
begin
- { Idempotency guard: this node rewrites itself in place on the default-property
- and indexed-property paths (StrExpr is swapped for a synthesised field-access,
- IndexExpr is cleared). A second analysis of an already-resolved node would
- re-walk the mutated children and recurse without bound — which happens when a
- typecast operand is itself a default-property subscript, e.g.
- TStringList(OL[0])[1] (the outer subscript re-analyses its typecast base,
- which re-analyses the inner OL[0]). Once resolved, return the cached type. }
- if AExpr.ResolvedType <> nil then
- Exit(AExpr.ResolvedType);
StrType := AnalyseExpr(AExpr.StrExpr);
{ Indexed property read: Obj.Prop[I] where Prop is a method-backed indexed property }
if AExpr.StrExpr is TFieldAccessExpr then
@@ -13514,7 +11623,6 @@ begin
Format('String subscript index must be numeric, got ''%s''', [IdxType.Name]),
AExpr.Line, AExpr.Col);
Result := FTable.TypeInteger;
- AExpr.ResolvedType := Result;
end;
function TSemanticAnalyser.AnalyseIndirectFuncCallExpr(AExpr: TIndirectFuncCallExpr): TTypeDesc;
@@ -13580,24 +11688,14 @@ begin
if AStmt.IsStringCase then
SemanticError('case range labels are not allowed for a string selector',
AStmt.Line, AStmt.Col);
- if not TryResolveBareEnumIdent(TSetRangeExpr(Branch.Values.Items[J]).LowExpr, SelType) then
- ValType := AnalyseExpr(TSetRangeExpr(Branch.Values.Items[J]).LowExpr)
- else
- ValType := TSetRangeExpr(Branch.Values.Items[J]).LowExpr.ResolvedType;
+ ValType := AnalyseExpr(TSetRangeExpr(Branch.Values.Items[J]).LowExpr);
CheckTypesMatch(SelType, ValType, 'case range low', AStmt.Line, AStmt.Col);
- if not TryResolveBareEnumIdent(TSetRangeExpr(Branch.Values.Items[J]).HighExpr, SelType) then
- ValType := AnalyseExpr(TSetRangeExpr(Branch.Values.Items[J]).HighExpr)
- else
- ValType := TSetRangeExpr(Branch.Values.Items[J]).HighExpr.ResolvedType;
+ ValType := AnalyseExpr(TSetRangeExpr(Branch.Values.Items[J]).HighExpr);
CheckTypesMatch(SelType, ValType, 'case range high', AStmt.Line, AStmt.Col);
end
else
begin
- { A bare enum member label resolves against the selector's type. }
- if TryResolveBareEnumIdent(TASTExpr(Branch.Values.Items[J]), SelType) then
- ValType := TASTExpr(Branch.Values.Items[J]).ResolvedType
- else
- ValType := AnalyseExpr(TASTExpr(Branch.Values.Items[J]));
+ ValType := AnalyseExpr(TASTExpr(Branch.Values.Items[J]));
CheckTypesMatch(SelType, ValType, 'case value', AStmt.Line, AStmt.Col);
end;
end;
@@ -13622,7 +11720,7 @@ begin
'Cannot write through untyped ''Pointer'' — use a typed pointer (e.g. ^Integer)',
AStmt.Line, AStmt.Col);
AStmt.BaseTy := TPointerTypeDesc(PtrType).BaseType;
- ValType := AnalyseExprHinted(AStmt.ValExpr, AStmt.BaseTy);
+ ValType := AnalyseExpr(AStmt.ValExpr);
CheckTypesMatch(AStmt.BaseTy, ValType, 'pointer write', AStmt.Line, AStmt.Col);
end;
@@ -13655,7 +11753,7 @@ begin
IdxType := AnalyseExpr(AStmt.IndexExpr);
if not IdxType.IsNumeric() then
SemanticError('Array index must be numeric', AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr, ElemT);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(ElemT, ValType,
Format('''%s'' element', [AStmt.ArrayName]), AStmt.Line, AStmt.Col);
Exit;
@@ -13682,36 +11780,11 @@ begin
IdxType := AnalyseExpr(AStmt.IndexExpr);
if not IdxType.IsNumeric() then
SemanticError('Array index must be numeric', AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr, ElemT);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(ElemT, ValType,
Format('''%s'' element', [AStmt.ArrayName]), AStmt.Line, AStmt.Col);
Exit;
end;
- { Implicit Self.Field[I] := V where Field is a class with a writable
- default array property — lower to its setter on the field's object. }
- if (BaseInfo <> nil) and (BaseInfo.TypeDesc <> nil) and
- (BaseInfo.TypeDesc.Kind = tyClass) then
- begin
- DefProp := TRecordTypeDesc(BaseInfo.TypeDesc).FindDefaultProperty();
- if (DefProp <> nil) and (DefProp.WriteMethod <> '') then
- begin
- AStmt.IsImplicitSelf := True;
- AStmt.ImplicitFieldInfo := BaseInfo;
- AStmt.PropWriteInfo := DefProp;
- AStmt.PropOwnerType := PropAccessorOwner(
- TRecordTypeDesc(BaseInfo.TypeDesc).Name, DefProp.WriteMethod);
- AStmt.PropAccessorVSlot := PropAccessorVSlot(
- TRecordTypeDesc(BaseInfo.TypeDesc).Name, DefProp.WriteMethod);
- IdxType := AnalyseExpr(AStmt.IndexExpr);
- if DefProp.IndexTypeDesc <> nil then
- CheckTypesMatch(DefProp.IndexTypeDesc, IdxType, 'default property index',
- AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr, DefProp.TypeDesc);
- CheckTypesMatch(DefProp.TypeDesc, ValType, 'default property assignment',
- AStmt.Line, AStmt.Col);
- Exit;
- end;
- end;
end;
SemanticError(
Format('Undeclared variable ''%s''', [AStmt.ArrayName]),
@@ -13736,7 +11809,7 @@ begin
if (DefProp.IndexTypeDesc <> nil) then
CheckTypesMatch(DefProp.IndexTypeDesc, IdxType, 'default property index',
AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr, DefProp.TypeDesc);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(DefProp.TypeDesc, ValType, 'default property assignment',
AStmt.Line, AStmt.Col);
Exit;
@@ -13790,8 +11863,7 @@ begin
IdxType := AnalyseExpr(AStmt.IndexExpr);
if not IdxType.IsNumeric() then
SemanticError('Dynamic array index must be numeric', AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr,
- TDynArrayTypeDesc(Sym.TypeDesc).ElementType);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(TDynArrayTypeDesc(Sym.TypeDesc).ElementType, ValType,
Format('''%s'' element', [AStmt.ArrayName]), AStmt.Line, AStmt.Col);
Exit;
@@ -13813,8 +11885,7 @@ begin
IdxType := AnalyseExpr(AStmt.IndexExpr);
if not IdxType.IsNumeric() then
SemanticError('Open array index must be numeric', AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr,
- TOpenArrayTypeDesc(Sym.TypeDesc).ElementType);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(TOpenArrayTypeDesc(Sym.TypeDesc).ElementType, ValType,
Format('''%s'' element', [AStmt.ArrayName]), AStmt.Line, AStmt.Col);
Exit;
@@ -13830,7 +11901,7 @@ begin
IdxType := AnalyseExpr(AStmt.IndexExpr);
if not IdxType.IsNumeric() then
SemanticError('Array index must be numeric', AStmt.Line, AStmt.Col);
- ValType := AnalyseExprHinted(AStmt.ValueExpr, ArrType.ElementType);
+ ValType := AnalyseExpr(AStmt.ValueExpr);
CheckTypesMatch(ArrType.ElementType, ValType,
Format('''%s'' element', [AStmt.ArrayName]), AStmt.Line, AStmt.Col);
end;
@@ -13906,24 +11977,25 @@ function TSemanticAnalyser.SetRangeBoundOrdinal(ABound: TASTExpr;
base enum. Rejects non-constant and wrong-type bounds. Issue #105. }
var
BType: TTypeDesc;
+ Sym: TSymbol;
begin
- { Resolve a bare enum-member bound against the base enum so a member name
- shared by several enums binds to this set's enum, not last-wins. }
- if TryResolveBareEnumIdent(ABound, ABaseEnum) then
- BType := ABound.ResolvedType
- else
- BType := AnalyseExpr(ABound);
+ BType := AnalyseExpr(ABound);
if BType <> ABaseEnum then
SemanticError(
Format('Set range %s bound has type ''%s''; expected ''%s''',
[AWhich, BType.Name, ABaseEnum.Name]),
ABound.Line, ABound.Col);
if not ((ABound is TIdentExpr) and TIdentExpr(ABound).IsConstant) then
+ SemanticError(
+ Format('Set range %s bound must be a constant', [AWhich]),
+ ABound.Line, ABound.Col);
+ Sym := FTable.Lookup(TIdentExpr(ABound).Name);
+ if (Sym = nil) or (Sym.Kind <> skConstant) then
SemanticError(
Format('Set range %s bound ''%s'' is not a constant',
[AWhich, TIdentExpr(ABound).Name]),
ABound.Line, ABound.Col);
- Result := TIdentExpr(ABound).ConstValue;
+ Result := Sym.ConstValue;
end;
procedure TSemanticAnalyser.ExpandSetRanges(AExpr: TArrayLiteralExpr;
@@ -14086,12 +12158,7 @@ begin
ExpandSetRanges(AExpr, nil);
for I := 0 to AExpr.Elements.Count - 1 do
begin
- { A bare enum member element resolves against the set's element type, so a
- member name shared by several enums picks this set's enum. }
- if TryResolveBareEnumIdent(TASTExpr(AExpr.Elements.Items[I]), ASetType.BaseType) then
- ElemType := TASTExpr(AExpr.Elements.Items[I]).ResolvedType
- else
- ElemType := AnalyseExpr(TASTExpr(AExpr.Elements.Items[I]));
+ ElemType := AnalyseExpr(TASTExpr(AExpr.Elements.Items[I]));
if IsOrdBase then
begin
if (not ElemType.IsNumeric()) and (ElemType <> ASetType.BaseType) then
diff --git a/compiler/src/main/pascal/uSemanticExport.pas b/compiler/src/main/pascal/uSemanticExport.pas
index a02d366..8ecf642 100644
--- a/compiler/src/main/pascal/uSemanticExport.pas
+++ b/compiler/src/main/pascal/uSemanticExport.pas
@@ -230,16 +230,6 @@ begin
Result.ResolvedQbeName := ASrc.ResolvedQbeName;
Result.IsVirtual := ASrc.IsVirtual;
Result.IsOverride := ASrc.IsOverride;
- { Carry static-ness so a cross-unit TypeName.StaticMethod() call resolves —
- VTableSlot alone cannot distinguish a static method from a final
- non-virtual instance method (both are -1). }
- Result.IsStatic := ASrc.IsStatic;
- { Carry the `overload` directive so a cross-unit overload set whose members
- are split across an imported class and its ancestor is not truncated by
- ResolveMethodOverload's hiding walk (which stops at a non-overload). }
- Result.IsOverload := ASrc.IsOverload;
- { Carry visibility so cross-unit member access enforces private/protected. }
- Result.Visibility := ASrc.Visibility;
Result.ReturnType := ResolveTypeRef(ASrc.ReturnTypeName, AIface, ADeps);
for I := 0 to ASrc.Params.Count - 1 do
@@ -481,13 +471,6 @@ begin
if AUnit.ImplUsedUnits <> nil then
for I := 0 to AUnit.ImplUsedUnits.Count - 1 do
AIface.ImplUsedUnits.Add(AUnit.ImplUsedUnits.Strings[I]);
- { Link libraries — hoisted from every 'external ''lib''' decl (interface or
- implementation), deduped. Carries the unit's link dependencies into the
- .bif even when the importing routine is implementation-private. }
- if AUnit.LinkLibs <> nil then
- for I := 0 to AUnit.LinkLibs.Count - 1 do
- if AIface.LinkLibs.IndexOf(TLinkLibDecl(AUnit.LinkLibs.Items[I]).LibName) < 0 then
- AIface.LinkLibs.Add(TLinkLibDecl(AUnit.LinkLibs.Items[I]).LibName);
AIface.HasInitialization :=
(AUnit.InitStmts <> nil) and (AUnit.InitStmts.Count > 0);
end;
diff --git a/compiler/src/main/pascal/uSemanticImport.pas b/compiler/src/main/pascal/uSemanticImport.pas
index 32069fb..216fd2f 100644
--- a/compiler/src/main/pascal/uSemanticImport.pas
+++ b/compiler/src/main/pascal/uSemanticImport.pas
@@ -260,90 +260,17 @@ begin
ART.SetVTableSlotAt(ASig.VTableSlot, ASig.Name, ImplName);
end;
-{ Register the shared globals for a `static var` (class variable) imported
- from a .bif. Mirrors uSemantic.AnalyseTypeDecls (the IsClassVar branch):
- a static var is NOT an instance field, so it must not advance the type
- layout — instead it becomes one shared global reachable both bare (inside
- the type's own methods) and qualified ('TFoo.Name' from anywhere).
-
- CRITICAL: ClassVarEmitName is the mangled label computed at the DEFINING
- unit's export time and serialised verbatim. The importer must use the
- DECODED value, never recompute it — the importing unit's own prefix
- differs, so re-deriving would produce a label that does not match the data
- slot the exporting unit emitted. }
-procedure RegisterImportedClassVar(const ATypeName, AFieldName,
- AEmitName: string;
- AFieldType: TTypeDesc;
- ATable: TSymbolTable);
-var
- Sym: TSymbol;
-begin
- { Bare name — usable unqualified inside the type's own methods. }
- Sym := TSymbol.Create(AFieldName, skVariable, AFieldType);
- Sym.IsGlobal := True;
- Sym.IsClassVar := True;
- Sym.GlobalEmitName := AEmitName;
- if not ATable.Define(Sym) then Sym.Free();
- { Qualified name — usable as TFoo.Name from anywhere. }
- Sym := TSymbol.Create(ATypeName + '.' + AFieldName, skVariable, AFieldType);
- Sym.IsGlobal := True;
- Sym.IsClassVar := True;
- Sym.GlobalEmitName := AEmitName;
- if not ATable.Define(Sym) then Sym.Free();
-end;
-
-{ Register class/record-level `static const` declarations imported from a
- .bif. Mirrors the within-unit registration in uSemantic.AnalyseTypeDecls:
- each const is reachable both bare and qualified ('TFoo.Tag'). Array consts
- are out of scope here (the within-unit path supports them, but no cached
- consumer needs them yet); only scalar int/string consts are imported. }
-procedure RegisterImportedTypeConsts(const ATypeName: string;
- AConstDecls: TObjectList;
- ATable: TSymbolTable);
-var
- J: Integer;
- CD: TConstDecl;
- Par: TTypeDesc;
- Sym: TSymbol;
-begin
- if AConstDecls = nil then Exit;
- for J := 0 to AConstDecls.Count - 1 do
- begin
- CD := TConstDecl(AConstDecls.Items[J]);
- if CD.IsArrayConst then Continue; { array static consts not yet imported }
- if CD.IsString then
- Par := ATable.FindType('string')
- else
- Par := ATable.FindType('Integer');
- { Unqualified name — usable inside the type's own methods without prefix. }
- Sym := TSymbol.Create(CD.Name, skConstant, Par);
- Sym.ConstValue := CD.IntVal;
- Sym.ConstString := CD.StrVal;
- if not ATable.Define(Sym) then Sym.Free();
- { Qualified name — usable as TFoo.Tag from anywhere. }
- Sym := TSymbol.Create(ATypeName + '.' + CD.Name, skConstant, Par);
- Sym.ConstValue := CD.IntVal;
- Sym.ConstString := CD.StrVal;
- if not ATable.Define(Sym) then Sym.Free();
- end;
-end;
-
function ResolveParentClassByName(const AParentName: string;
ATable: TSymbolTable): TRecordTypeDesc;
var
- TD: TTypeDesc;
+ Sym: TSymbol;
begin
Result := nil;
if AParentName = '' then Exit;
- { Use FindType, not a bare Lookup: a cross-unit parent is serialised in the
- .bif with its unit qualifier (e.g. `testing.TTestCase`), and FindType
- strips the qualifier and resolves the tail through the uses chain. A bare
- Lookup of the qualified name returns nil, leaving the parent unlinked — the
- warm-cache "Undeclared procedure 'Ignore'" bug (inherited method on a
- grandparent in another cached unit could not be reached). }
- TD := ATable.FindType(AParentName);
- if TD is TRecordTypeDesc then
- Result := TRecordTypeDesc(TD);
+ Sym := ATable.Lookup(AParentName);
+ if (Sym = nil) or (Sym.Kind <> skType) then Exit;
+ if Sym.TypeDesc is TRecordTypeDesc then
+ Result := TRecordTypeDesc(Sym.TypeDesc);
end;
{ Build the comma-separated '1'/'0' var-flag string AddMethod expects.
@@ -529,10 +456,6 @@ begin
begin
FldInfo := TFieldInfo(ParentRT.Fields.Items[I]);
RT.AddField(FldInfo.Name, FldInfo.TypeDesc);
- { Inherited field keeps the ancestor's visibility + declaring origin. }
- RT.FindField(FldInfo.Name).Visibility := FldInfo.Visibility;
- RT.FindField(FldInfo.Name).DeclaringUnit := FldInfo.DeclaringUnit;
- RT.FindField(FldInfo.Name).DeclaringType := FldInfo.DeclaringType;
end;
end;
@@ -545,25 +468,8 @@ begin
raise EImportError.CreateFmt(
'Class %s field type %s unresolved',
[AEntry.Name, FldDecl.TypeName]);
- if FldDecl.IsClassVar then
- { `static var`: a shared global, NOT an instance field — do not AddField
- (that would advance the layout). Register the global under the
- DECODED emit label. Multi-name static-var decls are not produced by
- the parser (ClassVarEmitName is only set for single-name decls), so
- the single decoded label applies to FldDecl.Names[0]. }
- RegisterImportedClassVar(AEntry.Name, FldDecl.Names.Strings[0],
- FldDecl.ClassVarEmitName, FldType, ATable)
- else
- for J := 0 to FldDecl.Names.Count - 1 do
- begin
- RT.AddField(FldDecl.Names.Strings[J], FldType);
- { An imported field's privacy boundary is its own declaring unit, not
- the importing unit — carry both so cross-unit private/protected is
- enforced exactly as in the declaring unit. }
- RT.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
- RT.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
- RT.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
- end;
+ for J := 0 to FldDecl.Names.Count - 1 do
+ RT.AddField(FldDecl.Names.Strings[J], FldType);
end;
{ Methods: walk TRoutineSig list; for virtual/override, register
@@ -639,19 +545,9 @@ begin
if (FldSym <> nil) and (FldSym.Kind = skType) then
PropInfo.IndexTypeDesc := FldSym.TypeDesc;
end;
- { Static-property facts — TypeName.Prop reads/writes dispatch with no
- implicit Self. Mirrors the within-unit pass (PropInfo.IsStatic). }
- PropInfo.IsDefault := PropDecl.IsDefault;
- PropInfo.IsStatic := PropDecl.IsStatic;
- PropInfo.Visibility := PropDecl.Visibility;
- PropInfo.DeclaringUnit := AUnitName;
- PropInfo.DeclaringType := AEntry.Name;
RT.AddProperty(PropInfo);
end;
- { Class-level `static const` declarations — reachable bare and qualified. }
- RegisterImportedTypeConsts(AEntry.Name, ClassDef.ConstDecls, ATable);
-
{ Class attributes. uSemanticExport currently copies the raw
attribute names ('Threaded', not 'ThreadedAttribute') — but
AddClassAttribute downstream wants the resolved-name form.
@@ -708,22 +604,9 @@ begin
raise EImportError.CreateFmt(
'Record %s field type %s unresolved',
[AEntry.Name, FldDecl.TypeName]);
- if FldDecl.IsClassVar then
- { record-level `static var`: shared global, not an instance field. }
- RegisterImportedClassVar(AEntry.Name, FldDecl.Names.Strings[0],
- FldDecl.ClassVarEmitName, FldType, ATable)
- else
- for J := 0 to FldDecl.Names.Count - 1 do
- begin
- RecDesc.AddField(FldDecl.Names.Strings[J], FldType);
- RecDesc.FindField(FldDecl.Names.Strings[J]).Visibility := FldDecl.Visibility;
- RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringUnit := AUnitName;
- RecDesc.FindField(FldDecl.Names.Strings[J]).DeclaringType := AEntry.Name;
- end;
+ for J := 0 to FldDecl.Names.Count - 1 do
+ RecDesc.AddField(FldDecl.Names.Strings[J], FldType);
end;
-
- { record-level `static const` declarations — reachable bare and qualified. }
- RegisterImportedTypeConsts(AEntry.Name, RecDef.ConstDecls, ATable);
end;
procedure RegisterProcType(AEntry: TTypeEntry; ATable: TSymbolTable;
@@ -896,13 +779,7 @@ begin
Sym.ConstString := Entry.Decl.StrVal;
Sym.OwningUnit := AIface.Name;
if not ATable.Define(Sym) then
- begin
- { EXPERIMENT (last-wins): on a duplicate name, detach the slot the
- table already holds (kept alive via the per-unit cache for
- qualified access) and store this later unit's symbol instead. }
- ATable.ExtractLocal(Entry.Decl.Name);
- ATable.Define(Sym);
- end;
+ Sym.Free(); { duplicate — silently skip }
end;
end;
@@ -928,14 +805,7 @@ begin
Sym.IsThreadVar := Entry.IsThreadVar;
Sym.OwningUnit := AIface.Name;
if not ATable.Define(Sym) then
- begin
- { Cross-unit collision (last-wins): detach the slot the table already
- holds — kept alive via the per-unit cache (RegisterUnitIface) for
- qualified access — and store this later unit's symbol instead.
- Mirrors RegisterConsts and the source-path DefineGlobalLastWins. }
- ATable.ExtractLocal(Entry.Name);
- ATable.Define(Sym);
- end;
+ Sym.Free();
end;
end;
@@ -991,15 +861,6 @@ begin
Result.VTableSlot := ASig.VTableSlot;
Result.IsVirtual := ASig.IsVirtual;
Result.IsOverride := ASig.IsOverride;
- { Carry static-ness so the semantic pass's TypeName.StaticMethod() resolution
- (which checks MDecl.IsStatic) succeeds for a method imported from a .bif. }
- Result.IsStatic := ASig.IsStatic;
- { Carry the `overload` directive so ResolveMethodOverload's hiding walk treats
- an imported overload as overloadable — otherwise an overload set split
- across an imported class and its ancestor is truncated to the derived level. }
- Result.IsOverload := ASig.IsOverload;
- { Carry visibility so cross-unit private/protected method access is enforced. }
- Result.Visibility := ASig.Visibility;
for J := 0 to ASig.Params.Count - 1 do
begin
Param := TMethodParam(ASig.Params.Items[J]);
diff --git a/compiler/src/main/pascal/uSymbolTable.pas b/compiler/src/main/pascal/uSymbolTable.pas
index ea654e1..e70caa5 100644
--- a/compiler/src/main/pascal/uSymbolTable.pas
+++ b/compiler/src/main/pascal/uSymbolTable.pas
@@ -14,28 +14,6 @@ uses
Classes, SysUtils, contnrs;
type
- { Member visibility — class/record field, method, and property access scope.
- Default (a member declared before any visibility keyword) is mvPublic, to
- match Blaise's previous behaviour where visibility was parsed but never
- enforced (everything was effectively public).
- mvPublic / mvPublished — visible everywhere the type is.
- mvPrivate — visible only within the declaring UNIT
- (classic Pascal unit-scoped privacy).
- mvProtected — as mvPrivate plus descendant types' methods,
- regardless of unit.
- mvStrictPrivate — visible only from the declaring TYPE's methods.
- mvStrictProtected — declaring type plus its descendants' methods.
- Declared here (not in uAST) so the symbol-table descriptors can carry it;
- uAST uses uSymbolTable, so the type flows up to the AST member decls. }
- TMemberVisibility = (
- mvPublic,
- mvPrivate,
- mvProtected,
- mvPublished,
- mvStrictPrivate,
- mvStrictProtected
- );
-
{ ------------------------------------------------------------------ }
{ Type descriptors }
{ ------------------------------------------------------------------ }
@@ -73,21 +51,6 @@ type
public
Kind: TTypeKind;
Name: string;
- { Name of the unit that declared this named type (empty for builtins and
- program-scope types). Set by TSymbolTable.Define when the type symbol is
- registered. Codegen mangles the type's storage symbols (typeinfo,
- vtable, _FieldCleanup, itab) with this owner so two used units exporting a
- same-named type emit distinct, non-colliding symbols. }
- OwningUnit: string;
- { True when this descriptor was created for a NAMED integer subrange
- (type TIdx = lo..hi;). Layout/Kind/RawSize remain those of the narrowest
- fitting standard integer type — the value behaves as an ordinary unchecked
- int — but the lo..hi bounds are retained as compile-time metadata so the
- array-index resolver can fold array[TIdx] -> array[lo..hi]. No other path
- (codegen, IsNumeric/IsOrdinal, assignment compatibility) consults these. }
- IsSubrange: Boolean;
- SubrangeLow: Int64;
- SubrangeHigh: Int64;
function IsNumeric: Boolean;
function IsFloat: Boolean;
function IsString: Boolean;
@@ -150,9 +113,8 @@ type
end;
{ Enum type descriptor. Members are ordered; ordinal values are 0..N-1.
- Stored as QBE 'w' (same as Integer). Members are NOT registered as bare
- global skConstants; a bare member name resolves through the semantic
- analyser's type-keyed reverse index (see ResolveEnumMember). }
+ Stored as QBE 'w' (same as Integer). Each member is also registered in
+ the symbol table as a skConstant with this type descriptor. }
TEnumTypeDesc = class(TTypeDesc)
public
Members: TStringList; { owned — ordered member names }
@@ -234,13 +196,6 @@ type
with neither addref nor release, and field cleanup
does nothing. Use only when the referent is
guaranteed to outlive this field. }
- Visibility: TMemberVisibility; { access scope; default mvPublic }
- DeclaringUnit: string; { name of the unit that declares the owning type — the
- privacy boundary for mvPrivate/mvProtected }
- DeclaringType: string; { name of the class/record that DECLARED this field; for
- an inherited field this is the ancestor, not the
- subclass that copied it — protected/strict checks walk
- the descendant chain up to this type }
end;
{ One entry in a class vtable — tracks slot index and implementing method. }
@@ -264,10 +219,6 @@ type
IndexParamName: string; { '' = non-indexed property }
[Unretained] IndexTypeDesc: TTypeDesc; { not owned; non-nil when IndexParamName <> '' }
IsDefault: Boolean; { declared with the `default` directive (Obj[I] sugar) }
- IsStatic: Boolean; { declared `static property` — accessors are static (no Self) }
- Visibility: TMemberVisibility; { access scope; default mvPublic }
- DeclaringUnit: string; { unit that declares the owning type — privacy boundary }
- DeclaringType: string; { class/record that DECLARED this property (ancestor for inherited) }
end;
{ Type descriptor for zero-GUID interface types (Phase 3). }
@@ -417,16 +368,6 @@ type
of the strong addref/release pattern. }
IsGlobal: Boolean; { true for program-level variables; codegen uses
QBE data-section storage instead of stack alloc }
- IsClassVar: Boolean; { true for a STATIC (class-level) variable. Stored
- as a single shared global (IsGlobal is also True),
- under the mangled GlobalEmitName, not as a
- per-instance field. }
- GlobalEmitName: string; { when non-empty, the mangled data-label this symbol
- emits/loads/stores under (e.g. 'TFoo_FInstance').
- Lets a bare lookup key ('FInstance') and a
- qualified one ('TFoo.FInstance') resolve to ONE
- storage slot. Mirrors ConstArrayQbe for consts.
- Empty = emit under Name. }
IsThreadVar: Boolean; { true for threadvar declarations; codegen emits
TLS storage instead of plain global data }
IsOverload: Boolean; { true when declared with the 'overload' directive;
@@ -442,22 +383,6 @@ type
symbols owned by the unit being analysed. Read
by per-unit visibility and by unit-prefix
mangling on cross-unit references. }
- IsImplPrivate: Boolean; { true for a symbol declared in the IMPLEMENTATION
- section of its owning unit. Such a symbol is
- visible only inside that unit — never to a used
- unit (it is not in the unit's interface) — so
- Lookup suppresses it whenever the viewing unit is
- not the owner. Prevents an impl-section class/
- type from leaking into an unrelated unit through
- the flat global scope. }
- Visibility: TMemberVisibility; { for a STATIC (class-level) variable: the
- declared member visibility (private/protected/
- strict/public). Default mvPublic. Read by the
- qualified-access visibility checks. }
- OwnerTypeName: string; { for a STATIC (class-level) variable: the class/
- record that declared it. Empty for non-members.
- Lets strict/protected checks resolve the owning
- type the same way TFieldInfo.DeclaringType does. }
constructor Create(const AName: string; AKind: TSymbolKind; AType: TTypeDesc);
destructor Destroy; override;
end;
@@ -485,13 +410,6 @@ type
references through every Register* helper. }
function SymbolCount: Integer;
function SymbolAt(AIdx: Integer): TSymbol;
- { Detach a directly-defined symbol from this scope WITHOUT freeing
- it (FSymbols owns, so Extract not Remove). Returns the detached
- symbol, or nil if not present. Caller takes responsibility for
- the object's lifetime — used so a duplicate import can hand the
- flat-scope slot to a later unit while a per-unit cache keeps the
- original alive. }
- function ExtractLocal(const AName: string): TSymbol;
end;
{ ------------------------------------------------------------------ }
@@ -570,34 +488,12 @@ type
retrieve the canonical TSymbol — without this flag we'd loop. }
FBypassUsesChain: Boolean;
- FInCodegen: Boolean; { True while a backend is emitting code.
- Disables the Layer-6 impl-private
- suppression in Lookup: that guard exists
- only to stop an implementation-section
- symbol of unit A leaking into a different
- unit B DURING ANALYSIS. At codegen time a
- backend legitimately resolves a unit's own
- impl-section classes (to emit their
- typeinfo/vtable/_FieldCleanup and the
- references to them), but FDefineOwningUnit
- can have drifted to a dependency unit
- mid-emit, which made the suppression wrongly
- fire and silently drop the class's typeinfo
- — a dangling symbol the linker binds to
- garbage. Set by the QBE and native
- backends around Generate/GenerateUnit. }
-
FDefineOwningUnit: string; { auto-applied to Sym.OwningUnit on Define
when the symbol has no explicit value;
set by AnalyseUnit/AnalyseUnitForExport
so semantic-side Define sites don't
each need to thread the unit name. }
- FDefineImplPrivate: Boolean; { when True, Define()/DefineGlobal() mark the
- symbol IsImplPrivate. Set by the analyser
- around impl-section type/const registration
- so those symbols stay unit-private. }
-
function GetCurrentScope: TScope;
function GetScopeDepth: Integer;
function NewType(AKind: TTypeKind; const AName: string): TTypeDesc;
@@ -617,9 +513,6 @@ type
function Define(ASymbol: TSymbol): Boolean;
{ Define in global (outermost) scope regardless of current push depth. }
function DefineGlobal(ASymbol: TSymbol): Boolean;
- { Detach a symbol from the current scope without freeing it (see
- TScope.ExtractLocal). Returns the detached symbol or nil. }
- function ExtractLocal(const AName: string): TSymbol;
function Lookup(const AName: string): TSymbol;
{ Auto-OwningUnit context. When set, Define()/DefineGlobal() will
@@ -628,12 +521,6 @@ type
property DefineOwningUnit: string read FDefineOwningUnit
write FDefineOwningUnit;
- { Impl-private context. When True, Define()/DefineGlobal() mark the symbol
- IsImplPrivate so it stays visible only to its owning unit. Set by the
- analyser around implementation-section type/const registration. }
- property DefineImplPrivate: Boolean read FDefineImplPrivate
- write FDefineImplPrivate;
-
{ Hook into the analyser's uses-chain lookup. When non-nil,
Lookup() consults the chain after pushed scopes and before the
global scope. Wired by TSemanticAnalyser. Task #44 step 7. }
@@ -647,9 +534,6 @@ type
property BypassUsesChain: Boolean read FBypassUsesChain
write FBypassUsesChain;
- { Set by a backend for the duration of code emission; see FInCodegen. }
- property InCodegen: Boolean read FInCodegen write FInCodegen;
-
{ Type lookup — case-insensitive, returns nil if not found }
function FindType(const AName: string): TTypeDesc;
@@ -726,14 +610,6 @@ function IsUnmangledUnit(const AUnitName: string): Boolean;
agree on the QBE global name. }
function MangleUnitPrefix(const AUnitName: string): string;
-const
- { Sentinel owning-unit value meaning "this global's emit name is ALREADY a
- fully-mangled symbol — codegen must add no further unit prefix". Used for
- static class/record vars, whose label (Unit_Class_Field) is class-qualified
- and complete; the module-var prefixing must not double-apply. The leading
- control byte can never collide with a real unit name. }
- PreMangledGlobalOwner = #1'premangled';
-
implementation
uses
@@ -1385,17 +1261,6 @@ begin
Result := True;
end;
-function TScope.ExtractLocal(const AName: string): TSymbol;
-var
- Idx: Integer;
-begin
- Result := nil;
- if not FKeys.Find(AName, Idx) then Exit;
- Result := TSymbol(FKeys.Objects[Idx]);
- FKeys.Delete(Idx); { free the name }
- FSymbols.Extract(Result); { detach without freeing }
-end;
-
function TScope.LookupLocal(const AName: string): TSymbol;
var
Idx: Integer;
@@ -1984,8 +1849,6 @@ function TSymbolTable.DefineGlobal(ASymbol: TSymbol): Boolean;
begin
if (ASymbol.OwningUnit = '') and (FDefineOwningUnit <> '') then
ASymbol.OwningUnit := FDefineOwningUnit;
- if FDefineImplPrivate then
- ASymbol.IsImplPrivate := True;
Result := TScope(FScopeStack.Items[0]).Define(ASymbol);
end;
@@ -2025,22 +1888,9 @@ begin
if (ASymbol.OwningUnit = '') and (FDefineOwningUnit <> '')
and (FScopeStack.Count = 1) then
ASymbol.OwningUnit := FDefineOwningUnit;
- if FDefineImplPrivate and (FScopeStack.Count = 1) then
- ASymbol.IsImplPrivate := True;
- { Propagate the owning unit onto the type descriptor so codegen can mangle a
- type's storage symbols by the declaring unit even after a same-named type
- from another used unit wins the flat slot (cross-unit type last-wins). }
- if (ASymbol.Kind = skType) and (ASymbol.TypeDesc <> nil)
- and (ASymbol.TypeDesc.OwningUnit = '') and (ASymbol.OwningUnit <> '') then
- ASymbol.TypeDesc.OwningUnit := ASymbol.OwningUnit;
Result := CurrentScope.Define(ASymbol);
end;
-function TSymbolTable.ExtractLocal(const AName: string): TSymbol;
-begin
- Result := CurrentScope.ExtractLocal(AName);
-end;
-
function TSymbolTable.Lookup(const AName: string): TSymbol;
var
I: Integer;
@@ -2107,33 +1957,7 @@ begin
end;
{ Layer 6 — whatever the global walk produced earlier (builtins, or
- flat-merged residue not yet caught above).
-
- Suppress one specific leak: an IMPLEMENTATION-section symbol of unit A is
- private to A and must never resolve while a DIFFERENT unit B is being
- analysed. Without this, a class declared in A's implementation section
- leaks into an unrelated B through the flat global scope (the root blocker
- for "classes in unit implementation section"). Interface symbols are left
- untouched here so existing transitive-visibility behaviour is unchanged.
-
- The check only runs while a unit/program is being analysed
- (FDefineOwningUnit <> '') and the chain walker is not mid-callback; outside
- analysis (some codegen-side lookups clear FDefineOwningUnit) the residue is
- returned unchanged so unit-prefix mangling still resolves owned symbols.
-
- It is also disabled during code emission (FInCodegen): the leak it guards is
- purely an analysis-time concern, whereas a backend legitimately resolves a
- unit's own implementation-section classes to emit their typeinfo/vtable/
- _FieldCleanup. FDefineOwningUnit can have drifted to a dependency unit
- mid-emit, which would otherwise make this suppression wrongly fire and drop
- the class's typeinfo, leaving a dangling symbol the linker binds to garbage. }
- if (Sym <> nil) and Sym.IsImplPrivate and (FDefineOwningUnit <> '')
- and not FBypassUsesChain and not FInCodegen
- and not SameText(Sym.OwningUnit, FDefineOwningUnit) then
- begin
- Result := nil;
- Exit;
- end;
+ flat-merged residue not yet caught above). }
Result := Sym;
end;
@@ -2188,18 +2012,11 @@ end;
function IsUnmangledUnit(const AUnitName: string): Boolean;
begin
- { RTL units export their runtime symbols (_SetArgs, _BlaiseGetMem, _start, …)
- UNMANGLED — the compiler emits bare calls to them — so their unit prefix is
- empty. The RTL units are: System, the rtl.* platform units, and the
- runtime.* units (dotted-flat names after the RTL-unification move; the
- legacy blaise_* names are still accepted for any not-yet-renamed source). }
Result := True;
if AUnitName = '' then Exit;
if SameText(AUnitName, 'System') then Exit;
if (Length(AUnitName) >= 4)
and SameText(Copy(AUnitName, 0, 4), 'rtl.') then Exit;
- if (Length(AUnitName) >= 8)
- and SameText(Copy(AUnitName, 0, 8), 'runtime.') then Exit;
if (Length(AUnitName) >= 7)
and SameText(Copy(AUnitName, 0, 7), 'blaise_') then Exit;
Result := False;
diff --git a/compiler/src/main/pascal/uToolchain.pas b/compiler/src/main/pascal/uToolchain.pas
index 08da064..86e5183 100644
--- a/compiler/src/main/pascal/uToolchain.pas
+++ b/compiler/src/main/pascal/uToolchain.pas
@@ -36,13 +36,7 @@ type
{ Variant of a tool, determining the CLI syntax callers emit. }
TToolKind = (
tkUnknown, { resolver couldn't classify }
- tkGnuAs, { as -o OUT IN.s — GNU assembler. Named tkGnuAs (not the
- bare tkAs) so it does not collide with uLexer's
- TTokenKind.tkAs: a bare `tkAs` here is ambiguous and
- bare-member resolution is cross-unit order-fragile,
- which could bind it to TTokenKind.tkAs (ordinal 40) —
- out of range for this 4-member enum, sending downstream
- Kind-indexing off the end into a layout-sensitive crash. }
+ tkAs, { as -o OUT IN.s — GNU assembler }
tkCCDriver, { cc / gcc / clang-as-driver — GNU link line }
tkQBE { qbe -o OUT IN.ssa }
);
@@ -56,6 +50,7 @@ type
QBE: TTool; { QBE backend only }
Assembler: TTool; { native backend: assemble .s -> .o (reserved) }
Linker: TTool; { both backends: link final binary }
+ RTLPath: string; { '' if not found }
end;
{ One external tool a backend declares it needs (TBackendDriver.DescribeTools).
@@ -92,14 +87,13 @@ function ResolveToolchain(const ATarget: TTargetDesc): TToolchain;
function ResolveQBE: TTool;
function ResolveAssembler: TTool;
function ResolveLinker(const ATarget: TTargetDesc): TTool;
+function FindRTLArchive(const ATarget: TTargetDesc): string;
-{ Directory containing the running compiler binary (ParamStr(0)). }
-function CompilerBinDir: string;
-
-{ RTL source directory (compiler/src/main/pascal), relative to the binary.
- The driver builds the RTL objects from here when linking; overridable via
- $BLAISE_RTL_SRC. }
-function RTLSourceDir: string;
+{ Locate the system CRT startup objects needed for dynamic (PIE) linking.
+ Returns True when all five objects are found; on False the paths are empty
+ and the caller should fall back to the external linker. }
+function FindCrtObjects(out ACrt1, ACrti, ACrtn,
+ ACrtBeginS, ACrtEndS: string): Boolean;
{ Walks $PATH for the first file named ABaseName that exists. Returns the
absolute path on hit, '' on miss. On Windows hosts also tries '.exe'. }
@@ -313,7 +307,7 @@ end;
function ResolveAssembler: TTool;
begin
Result.Path := ResolveToolPath('BLAISE_AS', 'as', '');
- Result.Kind := tkGnuAs;
+ Result.Kind := tkAs;
end;
function ResolveLinker(const ATarget: TTargetDesc): TTool;
@@ -331,40 +325,72 @@ begin
Result := ExtractFilePath(ParamStr(0));
end;
-function RTLDirHasUnits(const ADir: string): Boolean;
+function FindRTLArchive(const ATarget: TTargetDesc): string;
+var
+ BinDir: string;
begin
- Result := (ADir <> '') and
- FileExists(IncludeTrailingPathDelimiter(ADir) + 'runtime.arc.pas');
+ Result := GetEnvironmentVariable('BLAISE_RTL');
+ if (Result <> '') and FileExists(Result) then Exit;
+ BinDir := CompilerBinDir();
+ Result := IncludeTrailingPathDelimiter(BinDir) + 'blaise_rtl.a';
+ if FileExists(Result) then Exit;
+ Result := '';
end;
-function RTLSourceDir: string;
+{ ------------------------------------------------------------------ }
+{ CRT object discovery }
+{ ------------------------------------------------------------------ }
+
+function FindCrtObjects(out ACrt1, ACrti, ACrtn,
+ ACrtBeginS, ACrtEndS: string): Boolean;
+const
+ CrtDirs: array[0..2] of string = (
+ '/usr/lib/x86_64-linux-gnu',
+ '/usr/lib64',
+ '/usr/lib'
+ );
+ GccVers: array[0..3] of string = ('14', '13', '12', '11');
+ GccBases: array[0..1] of string = (
+ '/usr/lib/gcc/x86_64-linux-gnu',
+ '/usr/lib/gcc/x86_64-redhat-linux'
+ );
var
- Cand: string;
+ CrtDir, GccDir: string;
+ I, J: Integer;
begin
- { The RTL units (runtime.*, rtl.platform.*) live in the compiler's own source
- tree. Resolve the directory robustly across the ways the compiler is run:
+ ACrt1 := '';
+ ACrti := '';
+ ACrtn := '';
+ ACrtBeginS := '';
+ ACrtEndS := '';
+ Result := False;
- 1. binary-relative: /../src/main/pascal — the in-tree
- compiler/target/blaise.
- 2. CWD-relative: compiler/src/main/pascal then src/main/pascal — the
- binary may be copied elsewhere (e.g. /tmp during a fixpoint) but
- invoked from the project root by the build.
+ for I := 0 to High(CrtDirs) do
+ begin
+ CrtDir := CrtDirs[I];
+ if FileExists(CrtDir + '/Scrt1.o') then
+ begin
+ ACrt1 := CrtDir + '/Scrt1.o';
+ ACrti := CrtDir + '/crti.o';
+ ACrtn := CrtDir + '/crtn.o';
+ Break;
+ end;
+ end;
+ if ACrt1 = '' then Exit;
- The driver consults $BLAISE_RTL_SRC before calling this, for a fully
- relocated binary (release) that ships its RTL source elsewhere. }
- Cand := IncludeTrailingPathDelimiter(CompilerBinDir()) + '../src/main/pascal';
- if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
-
- Cand := 'compiler/src/main/pascal';
- if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
-
- Cand := 'src/main/pascal';
- if RTLDirHasUnits(ExpandFileName(Cand)) then Exit(ExpandFileName(Cand));
-
- { Fall back to the binary-relative path so callers get a meaningful "not
- found" message naming a concrete location. }
- Result := ExpandFileName(IncludeTrailingPathDelimiter(CompilerBinDir())
- + '../src/main/pascal');
+ for I := 0 to High(GccBases) do
+ for J := 0 to High(GccVers) do
+ begin
+ GccDir := GccBases[I] + '/' + GccVers[J];
+ if FileExists(GccDir + '/crtbeginS.o') then
+ begin
+ ACrtBeginS := GccDir + '/crtbeginS.o';
+ ACrtEndS := GccDir + '/crtendS.o';
+ Result := FileExists(ACrti) and FileExists(ACrtn)
+ and FileExists(ACrtEndS);
+ Exit;
+ end;
+ end;
end;
{ ------------------------------------------------------------------ }
@@ -376,6 +402,7 @@ begin
Result.QBE := ResolveQBE();
Result.Assembler := ResolveAssembler();
Result.Linker := ResolveLinker(ATarget);
+ Result.RTLPath := FindRTLArchive(ATarget);
end;
end.
diff --git a/compiler/src/main/pascal/uUnitInterface.pas b/compiler/src/main/pascal/uUnitInterface.pas
index d7004d4..754bce9 100644
--- a/compiler/src/main/pascal/uUnitInterface.pas
+++ b/compiler/src/main/pascal/uUnitInterface.pas
@@ -89,18 +89,6 @@ type
IsVirtual: Boolean; { virtual method that allocates a new
vtable slot }
IsOverride: Boolean; { override that replaces a parent slot }
- IsStatic: Boolean; { static (class-level) method — takes no
- implicit Self. VTableSlot is -1 for both
- static and final non-virtual instance
- methods, so this is a distinct flag rather
- than being inferred from the slot. }
- IsOverload: Boolean; { declared with the `overload` directive.
- ResolveMethodOverload's hiding walk stops at
- the first non-overload candidate, so this must
- survive the .bif or an overload set split
- across an imported class and its ancestor is
- truncated to the more-derived level. }
- Visibility: TMemberVisibility; { member access scope; default mvPublic }
constructor Create;
destructor Destroy; override;
end;
@@ -204,14 +192,6 @@ type
that loads this unit from its cached .bif
still pulls in (and links) impl-only
dependencies. }
- LinkLibs: TStringList; { owned — bare library names this unit must be
- linked against (deduped), hoisted from every
- 'external ''lib''' decl, interface OR
- implementation. An implementation-private
- import keeps its symbol out of the .bif but
- its library still propagates here, so a
- downstream program links it (-l /
- .dll). }
HasInitialization: Boolean; { unit has a non-empty initialization
section. An incremental rebuild loads this
unit from its cached .bif and must still
@@ -410,7 +390,6 @@ begin
Name := AName;
UsedUnits := TStringList.Create();
ImplUsedUnits := TStringList.Create();
- LinkLibs := TStringList.Create();
Types := TObjectList.Create(True);
Consts := TObjectList.Create(True);
@@ -441,7 +420,6 @@ begin
Consts.Free();
Types.Free();
- LinkLibs.Free();
ImplUsedUnits.Free();
UsedUnits.Free();
inherited Destroy();
diff --git a/compiler/src/main/pascal/uUnitInterfaceIO.pas b/compiler/src/main/pascal/uUnitInterfaceIO.pas
index 540d32e..9b43b1a 100644
--- a/compiler/src/main/pascal/uUnitInterfaceIO.pas
+++ b/compiler/src/main/pascal/uUnitInterfaceIO.pas
@@ -49,55 +49,11 @@ unit uUnitInterfaceIO;
interface
uses
- Classes, SysUtils, streams, strutils, uAST, uUnitInterface, uStrCompat;
+ Classes, SysUtils, streams, strutils, uAST, uUnitInterface;
const
IFACE_MAGIC = 'BLAISE-IFACE';
- IFACE_VERSION = 8; { v8 (this cycle): named integer subranges now round-trip.
- A `type TIdx = lo..hi;` alias carries IsSubrange + the
- lo..hi bounds so `array[TIdx] of T` folds to
- `array[lo..hi] of T` across separate compilation. The
- 'alias' TYPE entry grew three trailing fields
- (IsSubrange bool + SubrangeLow + SubrangeHigh, each an
- lpstr) after TypeName, so v7 readers must reject these
- .bif and recompile.
- v7: external-library link dependencies now
- round-trip. TUnitInterface.LinkLibs is serialised in
- the META block (one EncodeStringList after
- ImplUsedUnits, before HasInitialization) so a unit's
- `external 'lib' name '...'` declarations propagate the
- libraries to link. The META layout grew, so v6 readers
- must reject these .bif and recompile.
- v6: the `overload` directive now round-trips.
- TRoutineSig.IsOverload added to EncodeMethodSig/
- ReadMethodSig (one extra byte after IsStatic) and
- TMethodDecl.IsOverload added to EncodeMethodDecl/
- ReadMethodDecl (after IsOverride; this is the
- interface- and generic-template-method path). Without
- it a cross-unit overload set split across an imported
- class and its ancestor is truncated by the importer's
- hiding walk. Both method layouts grew, so v5 readers
- must reject these .bif and recompile.
- v5: member Visibility (private/protected/
- strict) now serialised — field, method, and property
- payloads each carry one extra byte for the visibility
- ordinal, so v4 readers must reject these .bif and
- recompile.
- v4: TRoutineSig.IsStatic added to
- EncodeMethodSig/ReadMethodSig so a cross-unit
- TypeName.StaticMethod() call resolves through the
- cached .bif (VTableSlot alone cannot distinguish a
- static method from a final non-virtual instance
- method — both are -1). The method-sig layout grew,
- so v3 readers must reject these .bif and recompile.
- v3: `static` (class-level) member facts now
- serialised — TFieldDecl.IsClassVar + ClassVarEmitName in
- EncodeFieldList/ReadFieldList, TPropertyDecl.IsStatic in
- EncodePropertyList/ReadPropertyList, and record/class
- static-const declarations (ConstDecls) in the record/class
- payloads. The layout grew, so v2 readers must reject these
- .bif and recompile.
- v1: shipped through release v0.11.x (last public commit
+ IFACE_VERSION = 2; { v1: shipped through release v0.11.x (last public commit
d56bdbf).
v2 (release v0.12.0): a batch of META/record additions
made this cycle, all gated by this single bump since
@@ -310,41 +266,7 @@ begin
Result := Result +
EncodeLpstr(F.Names.Strings[J]) +
EncodeLpstr(F.TypeName) +
- EncodeBool(F.IsWeak) +
- { `static var` (class variable) facts: IsClassVar marks the field
- as a shared global rather than an instance slot; ClassVarEmitName
- is the defining unit's mangled global label (set by uSemantic).
- An importer cannot re-derive that label — its own unit prefix
- differs — so the label is carried verbatim. Both default to
- False/'' for ordinary instance fields. }
- EncodeBool(F.IsClassVar) +
- EncodeLpstr(F.ClassVarEmitName) +
- { member visibility ordinal (private/protected/strict) }
- EncodeLpstr(IntToStr(Ord(F.Visibility)));
- end;
-end;
-
-{ Record/class-level `static const` declarations. These are scalar
- constants folded by the semantic pass; we serialise the same five-
- field scalar shape the unit-level CONST block uses (Name, TypeName,
- IntVal, StrVal, IsString/IsFloat flags). Non-scalar const forms
- (array consts, unfolded expression tokens) are not carried here —
- static const members are scalar in the current language surface. }
-function EncodeConstDeclList(AConsts: TObjectList): string;
-var
- I: Integer;
- C: TConstDecl;
-begin
- Result := EncodeCount(AConsts.Count);
- for I := 0 to AConsts.Count - 1 do
- begin
- C := TConstDecl(AConsts.Items[I]);
- Result := Result +
- EncodeLpstr(C.Name) +
- EncodeLpstr(C.TypeName) +
- EncodeInt64(C.IntVal) +
- EncodeLpstr(C.StrVal) +
- EncodeFlags(C.IsString, C.IsFloat);
+ EncodeBool(F.IsWeak);
end;
end;
@@ -364,14 +286,6 @@ begin
EncodeBool (AR.IsOverride) +
EncodeLpstr(AR.ResolvedQbeName) +
EncodeLpstr(IntToStr(AR.VTableSlot)) +
- { static-method flag — distinct from VTableSlot (both static and final
- non-virtual instance methods carry slot -1). }
- EncodeBool (AR.IsStatic) +
- { `overload` directive — must round-trip so a split overload set is not
- truncated by the importer's hiding walk. }
- EncodeBool (AR.IsOverload) +
- { member visibility ordinal }
- EncodeLpstr(IntToStr(Ord(AR.Visibility))) +
EncodeCount(AR.Params.Count);
for J := 0 to AR.Params.Count - 1 do
begin
@@ -399,9 +313,7 @@ var
begin
Def := TRecordTypeDef(AEntry.Def);
Result := EncodeBool(Def.IsPacked) +
- EncodeFieldList(Def.Fields) +
- { record-level `static const` declarations. }
- EncodeConstDeclList(Def.ConstDecls);
+ EncodeFieldList(Def.Fields);
end;
function EncodePropertyList(AList: TObjectList): string;
@@ -420,12 +332,7 @@ begin
EncodeLpstr(P.WriteName) +
EncodeLpstr(P.IndexParamName) +
EncodeLpstr(P.IndexTypeName) +
- EncodeBool(P.IsDefault) +
- { `static property` — accessors take no implicit Self. An importer
- needs this to dispatch reads/writes without a receiver. }
- EncodeBool(P.IsStatic) +
- { member visibility ordinal }
- EncodeLpstr(IntToStr(Ord(P.Visibility)));
+ EncodeBool(P.IsDefault);
end;
end;
@@ -441,9 +348,7 @@ begin
EncodeStringList(AEntry.Implements) +
EncodeFieldList(Def.Fields) +
EncodeMethodList(AEntry.Methods) +
- EncodePropertyList(Def.Properties) +
- { class-level `static const` declarations. }
- EncodeConstDeclList(Def.ConstDecls);
+ EncodePropertyList(Def.Properties);
end;
{ Encode a TMethodDecl (AST) using the same per-method payload shape
@@ -465,9 +370,6 @@ begin
resolved cross-unit refs }
EncodeBool (AM.IsVirtual) +
EncodeBool (AM.IsOverride) +
- EncodeBool (AM.IsOverload) + { `overload` directive — generic-template
- and interface methods share this path
- and may be overloaded }
EncodeCount(AM.Params.Count);
for J := 0 to AM.Params.Count - 1 do
begin
@@ -640,10 +542,7 @@ begin
else if Kind = 'alias' then
SB.AppendLine(EncodeLpstr('alias') +
EncodeLpstr(E.Name) +
- EncodeLpstr(TTypeAliasDef(E.Def).TypeName) +
- EncodeBool(TTypeAliasDef(E.Def).IsSubrange) +
- EncodeLpstr(IntToStr(TTypeAliasDef(E.Def).SubrangeLow)) +
- EncodeLpstr(IntToStr(TTypeAliasDef(E.Def).SubrangeHigh)))
+ EncodeLpstr(TTypeAliasDef(E.Def).TypeName))
else if Kind = 'record' then
SB.AppendLine(EncodeLpstr('record') +
EncodeLpstr(E.Name) +
@@ -753,7 +652,6 @@ begin
EncodeInt64(AIface.SourceModTime) +
EncodeStringList(AIface.UsedUnits) +
EncodeStringList(AIface.ImplUsedUnits) +
- EncodeStringList(AIface.LinkLibs) +
EncodeBool(AIface.HasInitialization));
SB.AppendLine('END');
Result := SB.ToString();
@@ -813,8 +711,7 @@ begin
Result := EncodeLpstr('nillit')
else if AE is TIdentExpr then
Result := EncodeLpstr('id') +
- EncodeLpstr(TIdentExpr(AE).Name) +
- EncodeLpstr(TIdentExpr(AE).QualifierUnit)
+ EncodeLpstr(TIdentExpr(AE).Name)
else if AE is TBinaryExpr then
Result := EncodeLpstr('bin') +
EncodeLpstr(IntToStr(Ord(TBinaryExpr(AE).Op))) +
@@ -831,7 +728,6 @@ begin
Result := EncodeLpstr('mcall') +
EncodeLpstr(TMethodCallExpr(AE).ObjectName) +
EncodeLpstr(TMethodCallExpr(AE).Name) +
- EncodeLpstr(TMethodCallExpr(AE).QualifierUnit) +
EncodeExpr(TMethodCallExpr(AE).ObjExpr) +
EncodeExprList(TMethodCallExpr(AE).Args)
else if AE is TIndirectFuncCallExpr then
@@ -842,7 +738,6 @@ begin
Result := EncodeLpstr('field') +
EncodeLpstr(TFieldAccessExpr(AE).RecordName) +
EncodeLpstr(TFieldAccessExpr(AE).FieldName) +
- EncodeLpstr(TFieldAccessExpr(AE).QualifierUnit) +
EncodeExpr(TFieldAccessExpr(AE).Base) +
EncodeExpr(TFieldAccessExpr(AE).PropIndexExpr)
else if AE is TDerefExpr then
@@ -1008,9 +903,6 @@ begin
Result := EncodeLpstr('inh') +
EncodeLpstr(TInheritedCallStmt(AStmt).Name) +
EncodeExprList(TInheritedCallStmt(AStmt).Args)
- else if AStmt is TAsmStmt then
- Result := EncodeLpstr('asm') +
- EncodeLpstr(TAsmStmt(AStmt).Code)
else
raise EIfaceFormatError.Create(
'EncodeStmt: unhandled statement node ' + AStmt.ClassName);
@@ -1212,28 +1104,19 @@ end;
uSemanticImport.ResolveRef. }
procedure DecodeQualRef(const ASrc: string; var AUnit, AType: string);
var
- I, LastDot: Integer;
+ Dot: Integer;
begin
- { Blaise Pos and Copy are 0-based. Split at the LAST '.', not the first:
- the unit qualifier may itself be dotted (e.g. 'blaise.testing'), while a
- type name never contains a dot. Splitting at the first dot mangled a
- qualified type from a dotted unit — 'blaise.testing.TTestCase' decoded to
- unit='blaise', type='testing.TTestCase', so the bare type name was lost
- and a cached parent class could not be relinked (warm --unit-cache
- inherited-method resolution failure). }
- LastDot := -1;
- for I := 0 to Length(ASrc) - 1 do
- if StrAt(ASrc, I) = Ord('.') then
- LastDot := I;
- if LastDot < 0 then
+ { Blaise Pos and Copy are 0-based. }
+ Dot := Pos('.', ASrc);
+ if Dot < 0 then
begin
AUnit := '';
AType := ASrc;
end
else
begin
- AUnit := Copy(ASrc, 0, LastDot);
- AType := Copy(ASrc, LastDot + 1, Length(ASrc) - LastDot - 1);
+ AUnit := Copy(ASrc, 0, Dot);
+ AType := Copy(ASrc, Dot + 1, Length(ASrc) - Dot - 1);
end;
end;
@@ -1508,7 +1391,6 @@ begin
begin
IE := TIdentExpr.Create();
IE.Name := ReadLpstrAt(AText, APos);
- IE.QualifierUnit := ReadLpstrAt(AText, APos);
Result := IE;
end
else if Kind = 'bin' then
@@ -1535,10 +1417,9 @@ begin
else if Kind = 'mcall' then
begin
MCE := TMethodCallExpr.Create();
- MCE.ObjectName := ReadLpstrAt(AText, APos);
- MCE.Name := ReadLpstrAt(AText, APos);
- MCE.QualifierUnit := ReadLpstrAt(AText, APos);
- MCE.ObjExpr := ReadExpr(AText, APos);
+ MCE.ObjectName := ReadLpstrAt(AText, APos);
+ MCE.Name := ReadLpstrAt(AText, APos);
+ MCE.ObjExpr := ReadExpr(AText, APos);
ReadExprList(AText, APos, MCE.Args);
Result := MCE;
end
@@ -1554,7 +1435,6 @@ begin
FA := TFieldAccessExpr.Create();
FA.RecordName := ReadLpstrAt(AText, APos);
FA.FieldName := ReadLpstrAt(AText, APos);
- FA.QualifierUnit := ReadLpstrAt(AText, APos);
FA.Base := ReadExpr(AText, APos);
FA.PropIndexExpr := ReadExpr(AText, APos);
Result := FA;
@@ -1646,7 +1526,6 @@ var
PCn: TProcCall;
MCSn: TMethodCallStmt;
ICSn: TInheritedCallStmt;
- ASMn: TAsmStmt;
C, I: Integer;
Body: TASTStmt;
begin
@@ -1814,12 +1693,6 @@ begin
ReadExprList(AText, APos, ICSn.Args);
Result := ICSn;
end
- else if Kind = 'asm' then
- begin
- ASMn := TAsmStmt.Create();
- ASMn.Code := ReadLpstrAt(AText, APos);
- Result := ASMn;
- end
else
raise EIfaceFormatError.Create(
'ReadStmt: unknown statement kind ''' + Kind + '''');
@@ -1877,14 +1750,11 @@ end;
procedure ReadFieldList(const AText: string; var APos: Integer;
ATarget: TObjectList);
var
- C, I: Integer;
- FldName: string;
- FldType: string;
- IsWeak: Boolean;
- IsClassVar: Boolean;
- ClassVarEmit: string;
- Vis: Integer;
- F: TFieldDecl;
+ C, I: Integer;
+ FldName: string;
+ FldType: string;
+ IsWeak: Boolean;
+ F: TFieldDecl;
begin
C := DecodeCount(AText, APos);
for I := 1 to C do
@@ -1892,47 +1762,14 @@ begin
FldName := ReadLpstrAt(AText, APos);
FldType := ReadLpstrAt(AText, APos);
IsWeak := DecodeBool(AText, APos);
- { Order must mirror EncodeFieldList: IsClassVar then ClassVarEmitName
- then the visibility ordinal. }
- IsClassVar := DecodeBool(AText, APos);
- ClassVarEmit := ReadLpstrAt(AText, APos);
- Vis := StrToInt(ReadLpstrAt(AText, APos));
F := TFieldDecl.Create();
F.Names.Add(FldName);
F.TypeName := FldType;
F.IsWeak := IsWeak;
- F.IsClassVar := IsClassVar;
- F.ClassVarEmitName := ClassVarEmit;
- F.Visibility := TMemberVisibility(Vis);
ATarget.Add(F);
end;
end;
-{ Inverse of EncodeConstDeclList — rebuild record/class `static const`
- decls. Mirrors the writer's five-field scalar shape exactly. }
-procedure ReadConstDeclList(const AText: string; var APos: Integer;
- ATarget: TObjectList);
-var
- C, I: Integer;
- CD: TConstDecl;
- IsString: Boolean;
- IsFloat: Boolean;
-begin
- C := DecodeCount(AText, APos);
- for I := 1 to C do
- begin
- CD := TConstDecl.Create();
- CD.Name := ReadLpstrAt(AText, APos);
- CD.TypeName := ReadLpstrAt(AText, APos);
- CD.IntVal := ReadInt64At(AText, APos);
- CD.StrVal := ReadLpstrAt(AText, APos);
- ReadFlagsAt(AText, APos, IsString, IsFloat);
- CD.IsString := IsString;
- CD.IsFloat := IsFloat;
- ATarget.Add(CD);
- end;
-end;
-
{ Inverse of EncodeMethodSig — builds a TRoutineSig from the
per-method payload. }
function ReadMethodSig(const AText: string; var APos: Integer): TRoutineSig;
@@ -1954,11 +1791,6 @@ begin
Result.IsOverride := DecodeBool(AText, APos);
Result.ResolvedQbeName := ReadLpstrAt(AText, APos);
Result.VTableSlot := StrToInt(ReadLpstrAt(AText, APos));
- { Order must mirror EncodeMethodSig: IsStatic follows VTableSlot, then
- IsOverload, then the visibility ordinal. }
- Result.IsStatic := DecodeBool(AText, APos);
- Result.IsOverload := DecodeBool(AText, APos);
- Result.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
Pc := DecodeCount(AText, APos);
for J := 1 to Pc do
begin
@@ -1989,7 +1821,6 @@ begin
Def := TRecordTypeDef.Create();
Def.IsPacked := DecodeBool(AText, APos);
ReadFieldList(AText, APos, Def.Fields);
- ReadConstDeclList(AText, APos, Def.ConstDecls);
AEntry.Def := Def;
end;
@@ -2012,7 +1843,6 @@ begin
ReadFieldList(AText, APos, Def.Fields);
ReadMethodList(AText, APos, AEntry.Methods);
ReadPropertyList(AText, APos, Def.Properties);
- ReadConstDeclList(AText, APos, Def.ConstDecls);
AEntry.IsClass := True;
AEntry.Def := Def;
end;
@@ -2031,7 +1861,6 @@ begin
if not HasReturn then Result.ReturnTypeName := '';
Result.IsVirtual := DecodeBool(AText, APos);
Result.IsOverride := DecodeBool(AText, APos);
- Result.IsOverload := DecodeBool(AText, APos);
Pc := DecodeCount(AText, APos);
for J := 1 to Pc do
begin
@@ -2071,10 +1900,6 @@ begin
P.IndexParamName := ReadLpstrAt(AText, APos);
P.IndexTypeName := ReadLpstrAt(AText, APos);
P.IsDefault := DecodeBool(AText, APos);
- { Order must mirror EncodePropertyList: IsStatic follows IsDefault, then
- the visibility ordinal. }
- P.IsStatic := DecodeBool(AText, APos);
- P.Visibility := TMemberVisibility(StrToInt(ReadLpstrAt(AText, APos)));
ATarget.Add(P);
end;
end;
@@ -2145,9 +1970,6 @@ begin
C := DecodeCount(AText, APos);
for I := 1 to C do
AIface.ImplUsedUnits.Add(ReadLpstrAt(AText, APos));
- C := DecodeCount(AText, APos);
- for I := 1 to C do
- AIface.LinkLibs.Add(ReadLpstrAt(AText, APos));
AIface.HasInitialization := ReadLpstrAt(AText, APos) = '1';
if ReadTag(AText, APos) <> 'END' then
raise EIfaceFormatError.Create('META block: missing END marker');
@@ -2329,9 +2151,6 @@ begin
Payload := ReadLpstrAt(AText, APos);
AliasDef := TTypeAliasDef.Create();
AliasDef.TypeName := Payload;
- AliasDef.IsSubrange := ReadLpstrAt(AText, APos) = '1';
- AliasDef.SubrangeLow := ReadInt64At(AText, APos);
- AliasDef.SubrangeHigh := ReadInt64At(AText, APos);
Entry.Def := AliasDef;
end
else if Kind = 'record' then
diff --git a/compiler/src/main/pascal/uUnitLoader.pas b/compiler/src/main/pascal/uUnitLoader.pas
index 4cb3ae2..56b51da 100644
--- a/compiler/src/main/pascal/uUnitLoader.pas
+++ b/compiler/src/main/pascal/uUnitLoader.pas
@@ -60,8 +60,7 @@ type
private
FSearchPaths: TStringList; { not owned }
FDefines: TStringList; { not owned — conditional symbols for each unit's lexer }
- FLoading: TStringList; { units currently on the load stack (any edge) — guards re-entry / infinite recursion }
- FIfaceChain: TStringList; { units reached along an unbroken chain of interface-section uses — a back-edge into this set is a true circular dependency. Implementation-section uses do NOT extend this chain (Pascal allows them to point back), so following one starts a fresh chain. }
+ FLoading: TStringList; { units currently on the load stack — cycle detection }
FLoadedNames: TStringList; { units already fully loaded }
FSourceLoadedNames: TStringList; { units taken via the SOURCE-recompile
path (stale cache or no cache). A
@@ -103,15 +102,6 @@ type
implementation
-{ True if ASym is one of the OS conditional-compilation symbols (the target's
- OS define, injected by the driver, replaces the lexer's host-seeded ones). }
-function DefineIsOS(const ASym: string): Boolean;
-begin
- Result := SameText(ASym, 'LINUX') or SameText(ASym, 'FREEBSD') or
- SameText(ASym, 'WINDOWS') or SameText(ASym, 'DARWIN') or
- SameText(ASym, 'UNIX');
-end;
-
function TUnitLoader.IsBuiltin(const AName: string): Boolean;
begin
Result :=
@@ -249,27 +239,16 @@ var
L: TLexer;
P: TParser;
DI: Integer;
- HasOS: Boolean;
begin
SL := TStringList.Create();
try
SL.LoadFromFile(APath);
L := TLexer.Create(SL.Text, APath);
{ Apply the same -d/--define symbols the main program got, so IFDEF
- directives resolve consistently across the program and all its units.
- If the set carries an OS symbol (the target's, injected by the driver),
- drop the lexer's host-seeded OS symbols first so the target wins here too
- — mirrors AddDefinesTo in Blaise.pas. }
+ directives resolve consistently across the program and all its units. }
if FDefines <> nil then
- begin
- HasOS := False;
- for DI := 0 to FDefines.Count - 1 do
- if DefineIsOS(FDefines.Strings[DI]) then HasOS := True;
- if HasOS then
- L.ClearOSDefines();
for DI := 0 to FDefines.Count - 1 do
L.AddDefine(FDefines.Strings[DI]);
- end;
try
P := TParser.Create(L);
try
@@ -330,29 +309,18 @@ end;
procedure TUnitLoader.LoadTransitive(const AName: string);
var
- Path: string;
- ObjPath: string;
- Iface: TUnitInterface;
- U: TUnit;
- I: Integer;
- SavedChain: TStringList;
+ Path: string;
+ ObjPath: string;
+ Iface: TUnitInterface;
+ U: TUnit;
+ I: Integer;
begin
if IsBuiltin(AName) then Exit;
if FLoadedNames.IndexOf(AName) >= 0 then Exit; { already in result list }
if FLoading.IndexOf(AName) >= 0 then
- begin
- { Already on the load stack. This is a true circular dependency only when
- the back-edge closes a chain of interface-section uses (those cannot be
- satisfied — each unit's interface needs the other's first). A back-edge
- reached through an implementation-section use is legal in Pascal, so it
- is simply skipped: the unit is already being loaded higher up the stack
- and its interface will be available by the time bodies are compiled. }
- if FIfaceChain.IndexOf(AName) >= 0 then
- raise ECircularDependency.Create(Format(
- 'Circular unit dependency: ''%s''', [AName]));
- Exit;
- end;
+ raise ECircularDependency.Create(Format(
+ 'Circular unit dependency: ''%s''', [AName]));
{ Auto-discovery: prefer a pre-built '.o' on the search path
when it carries an embedded iface section. The .o + embedded
@@ -380,10 +348,7 @@ begin
if Iface <> nil then
begin
FLoading.Add(AName);
- FIfaceChain.Add(AName);
try
- { A prebuilt .bif carries only interface-section uses, so these all
- extend the interface chain. }
for I := 0 to Iface.UsedUnits.Count - 1 do
LoadTransitive(Iface.UsedUnits.Strings[I]);
{ Staleness propagation: if any interface-use dependency was taken via
@@ -420,7 +385,6 @@ begin
end;
finally
FLoading.Delete(FLoading.IndexOf(AName));
- FIfaceChain.Delete(FIfaceChain.IndexOf(AName));
end;
if Iface <> nil then
Exit; { cached path taken — done. Otherwise fall through to source. }
@@ -433,33 +397,17 @@ begin
'Unit ''%s'' not found in search paths', [AName]));
FLoading.Add(AName);
- FIfaceChain.Add(AName);
U := nil;
try
U := LoadOne(Path);
- { Post-order DFS: process dependencies before this unit. Both interface-
- and implementation-section uses are loaded — the parser splits them into
- separate lists.
-
- Interface-section uses extend the interface chain, so a loop among them
- is reported as a circular dependency. Implementation-section uses are
- traversed with a FRESH interface chain: Pascal permits a unit's
- implementation to use a unit whose interface (transitively) uses it
- back, and that is not a real cycle (interfaces compile first, bodies
- after). A back-edge into a unit still on the load stack is then
- tolerated by the guard at the top of this routine. }
+ { Post-order DFS: process dependencies before this unit.
+ Both interface- and implementation-section uses are loaded —
+ they are stored on separate lists since the parser was
+ taught to split them, but the loader still needs both. }
for I := 0 to U.UsedUnits.Count - 1 do
LoadTransitive(U.UsedUnits.Strings[I]);
- SavedChain := FIfaceChain;
- FIfaceChain := TStringList.Create();
- FIfaceChain.CaseSensitive := False;
- try
- for I := 0 to U.ImplUsedUnits.Count - 1 do
- LoadTransitive(U.ImplUsedUnits.Strings[I]);
- finally
- FIfaceChain.Free();
- FIfaceChain := SavedChain;
- end;
+ for I := 0 to U.ImplUsedUnits.Count - 1 do
+ LoadTransitive(U.ImplUsedUnits.Strings[I]);
{ Append this unit after all its dependencies }
FResult.Add(U);
FLoadedNames.Add(AName);
@@ -472,7 +420,6 @@ begin
finally
U.Free(); { no-op if U = nil (success path) or on error }
FLoading.Delete(FLoading.IndexOf(AName));
- FIfaceChain.Delete(FIfaceChain.IndexOf(AName));
end;
end;
@@ -484,8 +431,6 @@ begin
FDefines := ADefines;
FLoading := TStringList.Create();
FLoading.CaseSensitive := False;
- FIfaceChain := TStringList.Create();
- FIfaceChain.CaseSensitive := False;
FLoadedNames := TStringList.Create();
FLoadedNames.CaseSensitive := False;
FSourceLoadedNames := TStringList.Create();
@@ -507,7 +452,6 @@ begin
FPrebuiltIfaces.Free();
FSourceLoadedNames.Free();
FLoadedNames.Free();
- FIfaceChain.Free();
FLoading.Free();
inherited Destroy();
end;
diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas
index fa14786..2899a63 100644
--- a/compiler/src/test/pascal/TestRunner.pas
+++ b/compiler/src/test/pascal/TestRunner.pas
@@ -122,9 +122,6 @@ uses
cp.test.proctypes,
cp.test.overload,
cp.test.classof,
- cp.test.staticmembers,
- cp.test.e2e.staticmembers,
- cp.test.visibility,
cp.test.publishedrtti,
cp.test.attributes,
cp.test.proctypes_ofobject,
@@ -133,8 +130,6 @@ uses
cp.test.strutils,
cp.test.e2e.strutils,
cp.test.toolchain,
- cp.test.targettoolkit,
- cp.test.platformlayout.freebsd,
cp.test.dynarray,
cp.test.math,
cp.test.e2e.math,
diff --git a/compiler/src/test/pascal/cp.test.arc.pas b/compiler/src/test/pascal/cp.test.arc.pas
index 7d862eb..0d4e175 100644
--- a/compiler/src/test/pascal/cp.test.arc.pas
+++ b/compiler/src/test/pascal/cp.test.arc.pas
@@ -687,7 +687,7 @@ begin
f := TFoo.Create()
end;
begin
- DoIt()
+ DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@@ -725,7 +725,7 @@ begin
f := TFoo.Create()
end;
begin
- DoIt()
+ DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@@ -759,7 +759,7 @@ begin
f := TFoo.Create()
end;
begin
- DoIt()
+ DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@@ -800,7 +800,7 @@ begin
F := TFoo(P)
end;
begin
- DoIt()
+ DoIt
end.
''');
FnPos := Pos('function $DoIt', IR);
@@ -832,7 +832,7 @@ const
r := Make()
end;
begin
- Run()
+ Run
end.
''';
@@ -848,7 +848,7 @@ const
b := a
end;
begin
- Run()
+ Run
end.
''';
@@ -868,7 +868,7 @@ const
r := Make()
end;
begin
- Run()
+ Run
end.
''';
@@ -883,7 +883,7 @@ const
b := a
end;
begin
- Run()
+ Run
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.assembler.pas b/compiler/src/test/pascal/cp.test.assembler.pas
index a3dd02c..01f597b 100644
--- a/compiler/src/test/pascal/cp.test.assembler.pas
+++ b/compiler/src/test/pascal/cp.test.assembler.pas
@@ -36,18 +36,6 @@ type
procedure TestErrorMessage_HasLineNumber;
procedure TestMovqXmmToReg_SseEncoding;
procedure TestMovqRegToXmm_SseEncoding;
- procedure TestNegl_F7Slash3;
- procedure TestLockXaddl_AtomicEncoding;
- procedure TestUnsuffixedMov_InfersSize;
- procedure TestJmpIndirectMem_FFSlash4;
- procedure TestEndbr64AndHlt;
- procedure TestSyscall_0F05;
- procedure TestCallPltStripsSuffix;
- procedure TestSse2_PxorAndPabsb;
- procedure TestVex_Vpxor2byte;
- procedure TestVex_Vpabsb3byte;
- procedure TestVex_VextractI128;
- procedure TestSibWhitespaceTolerated;
end;
{ ---- ELF writer unit tests ---- }
@@ -83,6 +71,7 @@ type
FCompiler: string;
FRTLPath: string;
FStdlibPath: string;
+ FRTL: string;
FScratch: string;
FCounter: Integer;
function ProjectRoot: string;
@@ -92,9 +81,6 @@ type
function RunProcNoArgs(const AExe: string; out AStdout: string): Integer;
function CompileAndRun(const ASrc: string;
out AStdout: string; out AExitCode: Integer): Boolean;
- function CompileAndRunArgs(const ASrc: string;
- const AArgs: array of string;
- out AStdout: string; out AExitCode: Integer): Boolean;
protected
procedure SetUp; override;
published
@@ -111,23 +97,6 @@ type
procedure TestClassVirtualCall;
procedure TestFloatArithmetic;
procedure TestFormatFloatArg;
- { Self-contained program entry (issue #142): the runtime supplies its own
- _start (blaise_start_x86_64.s) so the internal linker needs no system
- Scrt1.o / crtbegin / crtend. These assert the two things _start owns —
- argc/argv forwarding and exit-code propagation through __libc_start_main. }
- procedure TestEntry_ExitCodePropagates;
- procedure TestEntry_ArgsForwarded;
- { Inline assembler blocks (asm ... end): a nostackframe asm-body function is
- assembled verbatim by the internal assembler and called from Pascal. }
- procedure TestInlineAsm_ReturnsValue;
- procedure TestInlineAsm_AddsTwoArgs;
- { --debug-opdf appends the OPDF section to the SAME assembly text the
- internal assembler consumes. A string constant whose value contains a
- double-quote or newline used to break the recConstant `.ascii ""`
- line (the raw value closed the literal early), aborting the assemble.
- Escaping the value fixes it; this compiles+runs such a program under
- --debug-opdf --assembler internal. }
- procedure TestDebugOPDF_StringConstSpecialChars_AssemblesAndRuns;
end;
implementation
@@ -138,14 +107,6 @@ implementation
var
GInternalAsmSkipNoted: Boolean = False;
-{ Validity-probe cache for the fallback compiler — see the matching note in
- cp.test.cli.pas. The /tmp/fp_blaise2 fallback is a transient fixpoint
- artifact that is often stale; a stale binary turns these e2e tests into a
- cascade of cryptic failures. Probe once and skip (not fail) on a bad probe.
- 0 = not probed, 1 = good, 2 = bad. }
-var
- GInternalAsmProbeState: Integer = 0;
-
{ ---- TAsmEncodingTests ---- }
function TAsmEncodingTests.ContainsBytes(const ABuf, APat: string): Boolean;
@@ -174,147 +135,6 @@ begin
ContainsBytes(Obj, Chr($48) + Chr($8B) + Chr($07)));
end;
-procedure TAsmEncodingTests.TestNegl_F7Slash3;
-var
- Obj: string;
-begin
- { negl %esi -> f7 de (F7 /3, reg=esi=6). Verified vs `cc`. }
- Obj := AssembleToBytes('negl %esi' + LineEnding);
- AssertTrue('f7 de missing',
- ContainsBytes(Obj, Chr($F7) + Chr($DE)));
-end;
-
-procedure TAsmEncodingTests.TestLockXaddl_AtomicEncoding;
-var
- Obj: string;
-begin
- { lock xaddl %eax, (%rdi) -> f0 0f c1 07. The atomic RTL primitive
- (_AtomicAddInt32). f0 = lock prefix, 0f c1 = xadd, 07 = ModRM
- (reg=eax=0, r/m=[rdi]). Verified vs `cc`. }
- Obj := AssembleToBytes('lock xaddl %eax, (%rdi)' + LineEnding);
- AssertTrue('f0 0f c1 07 missing',
- ContainsBytes(Obj, Chr($F0) + Chr($0F) + Chr($C1) + Chr($07)));
-end;
-
-procedure TAsmEncodingTests.TestUnsuffixedMov_InfersSize;
-var
- Obj: string;
-begin
- { Unsuffixed AT&T mnemonics infer size from the register operand.
- mov %rbx, (%rdi) is 64-bit -> 48 89 1f (same as movq). Verified vs cc. }
- Obj := AssembleToBytes('mov %rbx, (%rdi)' + LineEnding);
- AssertTrue('48 89 1f missing (mov inferred q)',
- ContainsBytes(Obj, Chr($48) + Chr($89) + Chr($1F)));
- { xor %eax, %eax is 32-bit -> 31 c0 (no REX.W). }
- Obj := AssembleToBytes('xor %eax, %eax' + LineEnding);
- AssertTrue('31 c0 missing (xor inferred l)',
- ContainsBytes(Obj, Chr($31) + Chr($C0)));
-end;
-
-procedure TAsmEncodingTests.TestJmpIndirectMem_FFSlash4;
-var
- Obj: string;
-begin
- { jmp *56(%rdi) -> ff 67 38 (FF /4, memory-indirect). The longjmp tail. }
- Obj := AssembleToBytes('jmp *56(%rdi)' + LineEnding);
- AssertTrue('ff 67 38 missing',
- ContainsBytes(Obj, Chr($FF) + Chr($67) + Chr($38)));
-end;
-
-procedure TAsmEncodingTests.TestEndbr64AndHlt;
-var
- Obj: string;
-begin
- { endbr64 -> f3 0f 1e fa ; hlt -> f4 }
- Obj := AssembleToBytes('endbr64' + LineEnding);
- AssertTrue('f3 0f 1e fa missing',
- ContainsBytes(Obj, Chr($F3) + Chr($0F) + Chr($1E) + Chr($FA)));
- Obj := AssembleToBytes('hlt' + LineEnding);
- AssertTrue('f4 missing', ContainsBytes(Obj, Chr($F4)));
-end;
-
-procedure TAsmEncodingTests.TestSyscall_0F05;
-var
- Obj: string;
-begin
- { syscall -> 0f 05 (needed for the FreeBSD direct-syscall stubs). }
- Obj := AssembleToBytes('syscall' + LineEnding);
- AssertTrue('0f 05 missing', ContainsBytes(Obj, Chr($0F) + Chr($05)));
-end;
-
-procedure TAsmEncodingTests.TestCallPltStripsSuffix;
-var
- Obj: string;
-begin
- { call foo@PLT must reference symbol 'foo' (with a PLT32 reloc), NOT a bogus
- symbol literally named 'foo@PLT' that no loader resolves. The @PLT suffix
- is a relocation qualifier, not part of the name. Regression for the
- _start migration (call __libc_start_main@PLT). }
- Obj := AssembleToBytes('call foo@PLT' + LineEnding);
- AssertTrue('symbol foo missing', ContainsBytes(Obj, 'foo'));
- AssertTrue('bogus foo@PLT symbol present',
- not ContainsBytes(Obj, 'foo@PLT'));
-end;
-
-procedure TAsmEncodingTests.TestSse2_PxorAndPabsb;
-var
- Obj: string;
-begin
- { pxor %xmm3,%xmm3 -> 66 0f ef db ; pabsb is a 3-byte 0F38 op:
- pabsb %xmm2,%xmm2 -> 66 0f 38 1c d2. Verified vs cc. }
- Obj := AssembleToBytes('pxor %xmm3, %xmm3' + LineEnding);
- AssertTrue('66 0f ef db missing',
- ContainsBytes(Obj, Chr($66) + Chr($0F) + Chr($EF) + Chr($DB)));
- Obj := AssembleToBytes('pabsb %xmm2, %xmm2' + LineEnding);
- AssertTrue('66 0f 38 1c d2 missing',
- ContainsBytes(Obj, Chr($66) + Chr($0F) + Chr($38) + Chr($1C) + Chr($D2)));
-end;
-
-procedure TAsmEncodingTests.TestVex_Vpxor2byte;
-var
- Obj: string;
-begin
- { vpxor %ymm3,%ymm3,%ymm3 -> c5 e5 ef db (2-byte VEX). Verified vs cc. }
- Obj := AssembleToBytes('vpxor %ymm3, %ymm3, %ymm3' + LineEnding);
- AssertTrue('c5 e5 ef db missing',
- ContainsBytes(Obj, Chr($C5) + Chr($E5) + Chr($EF) + Chr($DB)));
-end;
-
-procedure TAsmEncodingTests.TestVex_Vpabsb3byte;
-var
- Obj: string;
-begin
- { vpabsb %ymm2,%ymm2 -> c4 e2 7d 1c d2 (3-byte VEX, 0F38 map). Verified vs cc. }
- Obj := AssembleToBytes('vpabsb %ymm2, %ymm2' + LineEnding);
- AssertTrue('c4 e2 7d 1c d2 missing',
- ContainsBytes(Obj, Chr($C4) + Chr($E2) + Chr($7D) + Chr($1C) + Chr($D2)));
-end;
-
-procedure TAsmEncodingTests.TestVex_VextractI128;
-var
- Obj: string;
-begin
- { vextracti128 $1,%ymm3,%xmm4 -> c4 e3 7d 39 dc 01 (L=1 despite xmm dst).
- Verified vs cc. }
- Obj := AssembleToBytes('vextracti128 $1, %ymm3, %xmm4' + LineEnding);
- AssertTrue('c4 e3 7d 39 dc 01 missing',
- ContainsBytes(Obj, Chr($C4) + Chr($E3) + Chr($7D) + Chr($39) + Chr($DC) + Chr($01)));
-end;
-
-procedure TAsmEncodingTests.TestSibWhitespaceTolerated;
-var
- A, B: string;
-begin
- { GNU as allows whitespace after the SIB comma: `(%rdi, %rdx)` must encode
- identically to `(%rdi,%rdx)` (movdqu -> f3 0f 6f 04 17). }
- A := AssembleToBytes('movdqu (%rdi,%rdx), %xmm0' + LineEnding);
- B := AssembleToBytes('movdqu (%rdi, %rdx), %xmm0' + LineEnding);
- AssertTrue('f3 0f 6f 04 17 missing (no space)',
- ContainsBytes(A, Chr($F3) + Chr($0F) + Chr($6F) + Chr($04) + Chr($17)));
- AssertTrue('f3 0f 6f 04 17 missing (with space)',
- ContainsBytes(B, Chr($F3) + Chr($0F) + Chr($6F) + Chr($04) + Chr($17)));
-end;
-
procedure TAsmEncodingTests.TestQuadSymbol_EmitsReloc;
var
Obj: string;
@@ -756,56 +576,24 @@ begin
FCompiler := '/tmp/fp_blaise2';
if not FileExists(FCompiler) then
FCompiler := '/tmp/fp_blaise3';
- FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
+ FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
+ FRTL := ProjectRoot() + 'compiler/target/blaise_rtl.a';
FScratch := ProjectRoot() + 'compiler/target/asm_scratch/';
ForceDirectories(FScratch);
FCounter := 0;
end;
function TInternalAsmE2ETests.CompilerAvailable: Boolean;
-var
- SrcFile, OutFile, CompOut, RunOut: string;
- Rc: Integer;
begin
- { The compiler binary source-builds the RTL itself (no blaise_rtl.a); only
- the binary and the RTL source need to be present. }
- Result := FileExists(FCompiler)
- and FileExists(FRTLPath + '/runtime.arc.pas');
+ Result := FileExists(FCompiler) and FileExists(FRTL);
if (not Result) and (not GInternalAsmSkipNoted) then
begin
GInternalAsmSkipNoted := True;
WriteLn(StdErr, 'note: TInternalAsmE2ETests skipped — compiler binary "',
- FCompiler, '" or RTL source not found ',
+ FCompiler, '" or RTL "', FRTL, '" not found ',
'(set BLAISE_QBE_COMPILER to a QBE-backend blaise binary to run them)');
- Exit;
end;
- if not Result then Exit;
-
- { Validity probe: compile+run a trivial program with --assembler internal.
- A stale fallback binary compiles fine but produces a SIGILL/wrong-output
- executable; detect that here and skip rather than emit a cryptic cascade. }
- if GInternalAsmProbeState = 0 then
- begin
- SrcFile := FScratch + 'probe.pas';
- OutFile := FScratch + 'probe';
- WriteFile(SrcFile, 'program p; begin WriteLn(42); end.');
- Rc := Self.RunProc(FCompiler, [
- '--source', SrcFile, '--unit-path', FRTLPath, '--unit-path', FStdlibPath,
- '--output', OutFile, '--backend', 'native', '--assembler', 'internal'
- ], CompOut);
- if (Rc = 0) and (Self.RunProcNoArgs(OutFile, RunOut) = 0)
- and (Pos('42', RunOut) >= 0) then
- GInternalAsmProbeState := 1
- else
- begin
- GInternalAsmProbeState := 2;
- WriteLn(StdErr, 'note: TInternalAsmE2ETests skipped — compiler binary "',
- FCompiler, '" is stale/broken (probe program did not run); ',
- 'rebuild it or set BLAISE_QBE_COMPILER to a current binary.');
- end;
- end;
- Result := GInternalAsmProbeState = 1;
end;
function TInternalAsmE2ETests.RunProc(const AExe: string;
@@ -887,39 +675,6 @@ begin
Result := True;
end;
-{ Like CompileAndRun but runs the produced binary WITH command-line arguments,
- so argc/argv forwarding through the runtime's own _start is exercised. }
-function TInternalAsmE2ETests.CompileAndRunArgs(const ASrc: string;
- const AArgs: array of string;
- out AStdout: string; out AExitCode: Integer): Boolean;
-var
- SrcFile, OutFile, CompOut: string;
- Rc: Integer;
-begin
- Result := False;
- if not Self.CompilerAvailable() then Exit;
-
- FCounter := FCounter + 1;
- SrcFile := FScratch + 'test_asm_' + IntToStr(FCounter) + '.pas';
- OutFile := FScratch + 'test_asm_' + IntToStr(FCounter);
-
- WriteFile(SrcFile, ASrc);
-
- Rc := Self.RunProc(FCompiler, [
- '--source', SrcFile,
- '--unit-path', FRTLPath,
- '--unit-path', FStdlibPath,
- '--output', OutFile,
- '--backend', 'native',
- '--assembler', 'internal'
- ], CompOut);
- if Rc <> 0 then
- Fail('compile failed (rc=' + IntToStr(Rc) + '): ' + CompOut);
-
- AExitCode := Self.RunProc(OutFile, AArgs, AStdout);
- Result := True;
-end;
-
{ ---- Test methods ---- }
procedure TInternalAsmE2ETests.TestSimpleAdd;
@@ -971,7 +726,7 @@ begin
'begin' + LineEnding +
' for I := 1 to 5 do' + LineEnding +
' Write(I);' + LineEnding +
- ' WriteLn()' + LineEnding +
+ ' WriteLn' + LineEnding +
'end.',
Out_, EC) then
begin
@@ -1044,7 +799,7 @@ begin
' Write(N);' + LineEnding +
' N := N + 1' + LineEnding +
' end;' + LineEnding +
- ' WriteLn()' + LineEnding +
+ ' WriteLn' + LineEnding +
'end.',
Out_, EC) then
begin
@@ -1170,7 +925,7 @@ begin
'begin' + LineEnding +
' G := TGreeter.Create;' + LineEnding +
' WriteLn(G.Greet());' + LineEnding +
- ' G.Free()' + LineEnding +
+ ' G.Free' + LineEnding +
'end.',
Out_, EC) then
begin
@@ -1234,156 +989,6 @@ begin
AssertEquals('1.2500' + LineEnding, Out_);
end;
-procedure TInternalAsmE2ETests.TestEntry_ExitCodePropagates;
-var
- Out_: string;
- EC: Integer;
-begin
- { Halt(N): the runtime's own _start calls __libc_start_main(main, ...) and
- glibc exits with main's return value. A broken entry sequence would crash
- at startup or return the wrong code. No system Scrt1.o is involved. }
- if not CompileAndRun(
- 'program test_exit;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(''before'');' + LineEnding +
- ' Halt(7)' + LineEnding +
- 'end.',
- Out_, EC) then
- begin
- Ignore('');
- Exit;
- end;
- AssertEquals(7, EC);
- AssertEquals('before' + LineEnding, Out_);
-end;
-
-procedure TInternalAsmE2ETests.TestEntry_ArgsForwarded;
-var
- Out_: string;
- EC: Integer;
-begin
- { argc/argv reach the program through _start -> __libc_start_main -> main ->
- _SetArgs. ParamStr(0) is the program path; the passed args follow. }
- if not CompileAndRunArgs(
- 'program test_args;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(ParamCount());' + LineEnding +
- ' WriteLn(ParamStr(1));' + LineEnding +
- ' WriteLn(ParamStr(2))' + LineEnding +
- 'end.',
- ['alpha', 'beta'], Out_, EC) then
- begin
- Ignore('');
- Exit;
- end;
- AssertEquals(0, EC);
- AssertEquals('2' + LineEnding + 'alpha' + LineEnding + 'beta' + LineEnding, Out_);
-end;
-
-procedure TInternalAsmE2ETests.TestInlineAsm_ReturnsValue;
-var
- Out_: string;
- EC: Integer;
-begin
- { A nostackframe asm-body function returns 42 in %eax; the internal assembler
- assembles the verbatim block, and Pascal calls it normally. }
- if not CompileAndRun(
- 'program test_asmret;' + LineEnding +
- 'function GetFortyTwo: Integer; assembler; nostackframe;' + LineEnding +
- 'asm' + LineEnding +
- ' movl $42, %eax' + LineEnding +
- ' ret' + LineEnding +
- 'end;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(GetFortyTwo())' + LineEnding +
- 'end.',
- Out_, EC) then
- begin
- Ignore('');
- Exit;
- end;
- AssertEquals(0, EC);
- AssertEquals('42' + LineEnding, Out_);
-end;
-
-procedure TInternalAsmE2ETests.TestInlineAsm_AddsTwoArgs;
-var
- Out_: string;
- EC: Integer;
-begin
- { Two integer args arrive in %edi/%esi (SysV); the asm body sums them. Proves
- a nostackframe asm function reads its parameters from the arg registers. }
- if not CompileAndRun(
- 'program test_asmadd;' + LineEnding +
- 'function AddTwo(A, B: Integer): Integer; assembler; nostackframe;' + LineEnding +
- 'asm' + LineEnding +
- ' movl %edi, %eax' + LineEnding +
- ' addl %esi, %eax' + LineEnding +
- ' ret' + LineEnding +
- 'end;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(AddTwo(40, 2))' + LineEnding +
- 'end.',
- Out_, EC) then
- begin
- Ignore('');
- Exit;
- end;
- AssertEquals(0, EC);
- AssertEquals('42' + LineEnding, Out_);
-end;
-
-procedure TInternalAsmE2ETests.TestDebugOPDF_StringConstSpecialChars_AssemblesAndRuns;
-var
- SrcFile, OutFile, CompOut, RunOut: string;
- Rc, EC: Integer;
- Src: string;
-begin
- if not Self.CompilerAvailable() then
- begin
- Ignore('');
- Exit;
- end;
-
- { A double-quote, a newline and a backslash in string-constant VALUES — each
- would break the recConstant `.ascii` line if emitted unescaped. }
- Src :=
- 'program test_opdf_qc;' + LineEnding +
- 'const' + LineEnding +
- ' Q = ' + '''' + '"' + '''' + ';' + LineEnding +
- ' NL = ' + '''' + 'a' + '''' + '#10' + '''' + 'b' + '''' + ';' + LineEnding +
- ' BS = ' + '''' + 'a\b' + '''' + ';' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(Q);' + LineEnding +
- ' WriteLn(NL);' + LineEnding +
- ' WriteLn(BS)' + LineEnding +
- 'end.';
-
- FCounter := FCounter + 1;
- SrcFile := FScratch + 'test_opdf_' + IntToStr(FCounter) + '.pas';
- OutFile := FScratch + 'test_opdf_' + IntToStr(FCounter);
- WriteFile(SrcFile, Src);
-
- Rc := Self.RunProc(FCompiler, [
- '--source', SrcFile,
- '--unit-path', FRTLPath,
- '--unit-path', FStdlibPath,
- '--output', OutFile,
- '--backend', 'native',
- '--assembler', 'internal',
- '--debug-opdf'
- ], CompOut);
- { The bug manifested as an "Internal assembler error: ... unhandled mnemonic"
- from the mangled .ascii line — a non-zero compile with that text. }
- if Rc <> 0 then
- Fail('compile under --debug-opdf failed (rc=' + IntToStr(Rc) + '): ' + CompOut);
-
- EC := Self.RunProcNoArgs(OutFile, RunOut);
- AssertEquals(0, EC);
- AssertEquals('"' + LineEnding + 'a' + LineEnding + 'b' + LineEnding +
- 'a\b' + LineEnding, RunOut);
-end;
-
{ ---- Registration ---- }
initialization
diff --git a/compiler/src/test/pascal/cp.test.attributes.pas b/compiler/src/test/pascal/cp.test.attributes.pas
index 9d2a8e1..016832d 100644
--- a/compiler/src/test/pascal/cp.test.attributes.pas
+++ b/compiler/src/test/pascal/cp.test.attributes.pas
@@ -20,8 +20,7 @@ interface
uses
Classes, SysUtils, Process, blaise.testing,
- uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe,
- cp.test.rtllink;
+ uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe;
function ProjectRootAttr: string;
function RunCmdAttr(const AExe: string; const AArgs: array of string): Integer;
@@ -155,7 +154,7 @@ function TCustomAttributeTests.CompileAndRun(const ASrc: string): string;
var
IR: string;
Root: string;
- QBE, Scratch: string;
+ QBE, RTL, Scratch: string;
IRFile, AsmFile, BinFile: string;
Lst: TStringList;
Proc: TProcess;
@@ -164,7 +163,8 @@ begin
Result := '';
Root := ProjectRootAttr();
QBE := Root + 'vendor/qbe/qbe';
- if not RTLLinkToolchainAvailable(Root) then
+ RTL := Root + 'compiler/target/blaise_rtl.a';
+ if not (FileExists(QBE) and FileExists(RTL)) then
begin
Result := '';
Exit;
@@ -190,7 +190,7 @@ begin
Exit;
end;
- if LinkProgramWithRTL(Root, AsmFile, BinFile) <> 0 then
+ if RunCmdAttr('cc', ['-o', BinFile, AsmFile, RTL]) <> 0 then
begin
Result := '';
Exit;
diff --git a/compiler/src/test/pascal/cp.test.bif_coverage.pas b/compiler/src/test/pascal/cp.test.bif_coverage.pas
index 6d8333e..5cbc5d0 100644
--- a/compiler/src/test/pascal/cp.test.bif_coverage.pas
+++ b/compiler/src/test/pascal/cp.test.bif_coverage.pas
@@ -102,7 +102,7 @@ begin
Proc.WaitOnExit();
Code := Proc.ExitCode
finally
- Proc.Free()
+ Proc.Free
end;
if Code <> 0 then
diff --git a/compiler/src/test/pascal/cp.test.caseenum.pas b/compiler/src/test/pascal/cp.test.caseenum.pas
index 25d041a..9ba4267 100644
--- a/compiler/src/test/pascal/cp.test.caseenum.pas
+++ b/compiler/src/test/pascal/cp.test.caseenum.pas
@@ -23,8 +23,6 @@ type
function GenIR(const ASrc: string): string;
procedure SemanticOK(const ASrc: string);
procedure ParseOK(const ASrc: string);
- { Analyse ASrc; return the raised semantic-error message, or '' if none. }
- function SemanticErrText(const ASrc: string): string;
published
{ ------------------------------------------------------------------ }
{ case — parse }
@@ -63,21 +61,6 @@ type
{ ------------------------------------------------------------------ }
procedure TestCodegen_Enum_MemberEmitsIntegerCopy;
procedure TestCodegen_Enum_AssignEmitsStore;
- procedure TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal;
- procedure TestSemantic_ScopedEnum_UnknownMemberRejected;
- procedure TestSemantic_ScopedEnum_SharedMemberCompiles;
- procedure TestSemantic_ScopedEnum_AssignmentDisambiguates;
- procedure TestSemantic_ScopedEnum_CaseDisambiguates;
- procedure TestSemantic_ScopedEnum_SetElementDisambiguates;
- procedure TestSemantic_ScopedEnum_AmbiguousBareRejected;
- procedure TestSemantic_ScopedEnum_UniqueBareResolves;
- procedure TestSemantic_ScopedEnum_CallArgDisambiguates;
- procedure TestSemantic_ScopedEnum_CallArgResolvesCleanly;
- procedure TestSemantic_ScopedEnum_FieldAssignDisambiguates;
- procedure TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
- procedure TestSemantic_ScopedEnum_MethodArgDisambiguates;
- procedure TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
- procedure TestSemantic_ScopedEnum_ForBoundsDisambiguate;
{ ------------------------------------------------------------------ }
{ enum + case integration }
@@ -262,31 +245,6 @@ begin
end;
end;
-function TCaseEnumTests.SemanticErrText(const ASrc: string): string;
-var
- Lex: TLexer;
- Par: TParser;
- SA: TSemanticAnalyser;
- Prog: TProgram;
-begin
- Result := '';
- Lex := TLexer.Create(ASrc);
- Par := TParser.Create(Lex);
- Prog := Par.Parse();
- Par.Free(); Lex.Free();
- SA := TSemanticAnalyser.Create();
- try
- try
- SA.Analyse(Prog);
- except
- on E: Exception do Result := E.Message;
- end;
- finally
- SA.Free();
- Prog.Free();
- end;
-end;
-
{ ------------------------------------------------------------------ }
{ case — parse }
{ ------------------------------------------------------------------ }
@@ -618,339 +576,6 @@ begin
Pos('_StringEquals', IR) < 0);
end;
-procedure TCaseEnumTests.TestCodegen_ScopedEnum_QualifiedMemberEmitsOrdinal;
-const
- Src =
- '''
- program P;
- type TDir = (dN, dE, dS, dW);
- var x: Integer;
- begin
- x := Ord(TDir.dS)
- end.
- ''';
-var
- IR: string;
-begin
- IR := GenIR(Src);
- { TDir.dS is the third member (ordinal 2); the type-qualified reference must
- resolve to that member and emit copy 2, exactly as the bare dS would. }
- AssertTrue('TDir.dS emits copy 2', Pos('copy 2', IR) > 0);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_UnknownMemberRejected;
-const
- Src =
- '''
- program P;
- type TDir = (dN, dE, dS, dW);
- var x: Integer;
- begin
- x := Ord(TDir.dNope)
- end.
- ''';
-var
- Raised: Boolean;
-begin
- Raised := False;
- try
- SemanticOK(Src);
- except
- on E: Exception do Raised := True;
- end;
- AssertTrue('unknown enum member via TEnum.Member rejected', Raised);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_SharedMemberCompiles;
-const
- { Two enums in one unit both declare 'Red'. Members are no longer bare
- global symbols, so this is NOT a collision — each is reachable through its
- own type, and the program compiles cleanly. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- begin
- WriteLn(Ord(TColorA.Red));
- WriteLn(Ord(TColorB.Red))
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_AssignmentDisambiguates;
-const
- { 'Red' belongs to both enums; the assignment target type selects which one,
- so BOTH assignments type-check (a fallback-only resolver would mis-type one). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- var
- a: TColorA;
- b: TColorB;
- begin
- a := Red;
- b := Red;
- WriteLn(Ord(a) + Ord(b))
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_CaseDisambiguates;
-const
- { The case selector's type picks the enum for a bare, shared member label. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- var
- b: TColorB;
- begin
- b := Blue;
- case b of
- Red: WriteLn(1);
- Blue: WriteLn(2)
- end
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_SetElementDisambiguates;
-const
- { The set's element type picks the enum for a bare, shared member element. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- var
- s: set of TColorA;
- begin
- s := [Red, Green];
- if Red in s then WriteLn(1)
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_AmbiguousBareRejected;
-const
- { A bare, context-free reference to a member shared by two enums cannot be
- resolved: it is rejected with an error that names the member and lists the
- enums that declare it. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- begin
- WriteLn(Ord(Red))
- end.
- ''';
-var
- E: string;
-begin
- E := SemanticErrText(Src);
- AssertTrue('the ambiguous bare member is rejected', E <> '');
- AssertTrue('error names the ambiguous member', Pos('''Red''', E) >= 0);
- AssertTrue('error names the first declaring enum', Pos('TColorA', E) >= 0);
- AssertTrue('error names the second declaring enum', Pos('TColorB', E) >= 0);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_UniqueBareResolves;
-const
- { A bare member unique across all enums needs no context and resolves
- cleanly with no error. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Cyan, Blue);
- begin
- WriteLn(Ord(Green))
- end.
- ''';
-begin
- AssertEquals('unique bare member resolves with no error', '',
- SemanticErrText(Src));
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgDisambiguates;
-const
- { 'Red' is shared; a bare member passed as a call argument is steered to the
- enum the routine expects at that position, so both calls type-check. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- procedure TakeA(c: TColorA);
- begin WriteLn(Ord(c)) end;
- procedure TakeB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- begin
- TakeA(Red);
- TakeB(Red)
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_CallArgResolvesCleanly;
-const
- { A shared member resolved by the call target's parameter type is NOT
- ambiguous — the hint pins it before bottom-up analysis, so no error. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- procedure TakeA(c: TColorA);
- begin WriteLn(Ord(c)) end;
- begin
- TakeA(Red)
- end.
- ''';
-begin
- AssertEquals('call-arg hint resolves with no error', '',
- SemanticErrText(Src));
-end;
-
-procedure TCaseEnumTests.TestCodegen_ScopedEnum_CallArgEmitsCorrectOrdinal;
-const
- { Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the call target's
- parameter type must select TColorB.Red so the argument lowers to copy 1. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red);
- procedure TakeB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- begin
- TakeB(Red)
- end.
- ''';
-var
- IR: string;
-begin
- IR := GenIR(Src);
- AssertTrue('TakeB(Red) selects TColorB.Red and emits copy 1',
- Pos('copy 1', IR) > 0);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_FieldAssignDisambiguates;
-const
- { Assigning a bare shared member to a record field is disambiguated by the
- field's declared enum type — the same context that lets the compiler's own
- 'Result.Kind := tkAs' resolve when tkAs is shared by two enums. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- TRec = record c: TColorB; end;
- var r: TRec;
- begin
- r.c := Red;
- WriteLn(Ord(r.c))
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestCodegen_ScopedEnum_FieldAssignEmitsCorrectOrdinal;
-const
- { Red is ordinal 0 in TColorA but ordinal 1 in TColorB; the field's type
- selects TColorB.Red, so the assignment lowers to copy 1. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red);
- TRec = record c: TColorB; end;
- var r: TRec;
- begin
- r.c := Red
- end.
- ''';
-var
- IR: string;
-begin
- IR := GenIR(Src);
- AssertTrue('r.c := Red selects TColorB.Red and emits copy 1',
- Pos('copy 1', IR) > 0);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_MethodArgDisambiguates;
-const
- { A bare shared member passed to a method argument is steered to the enum of
- the method's parameter, resolved by walking the receiver's class. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- TFoo = class
- procedure TakeB(c: TColorB);
- end;
- procedure TFoo.TakeB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- var f: TFoo;
- begin
- f := TFoo.Create();
- f.TakeB(Red);
- f.Free()
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
-procedure TCaseEnumTests.TestSemantic_ScopedEnum_ForBoundsDisambiguate;
-const
- { The loop variable's type picks the enum for bare, shared start/end bounds. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- var
- b: TColorB;
- begin
- for b := Red to Blue do
- WriteLn(Ord(b))
- end.
- ''';
-begin
- SemanticOK(Src);
-end;
-
initialization
RegisterTest(TCaseEnumTests);
diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas
index 37557b6..9f247fa 100644
--- a/compiler/src/test/pascal/cp.test.classes.pas
+++ b/compiler/src/test/pascal/cp.test.classes.pas
@@ -71,15 +71,6 @@ type
procedure TestCodegen_MethodCall_CaseInsensitive;
procedure TestCodegen_MethodBody_ReadsProgramGlobal;
- { ------------------------------------------------------------------ }
- { Forward class declarations (TFoo = class;) }
- { ------------------------------------------------------------------ }
- procedure TestSemantic_ForwardClass_CompletedByFullDecl;
- procedure TestSemantic_ForwardClass_MutualReference;
- procedure TestSemantic_ForwardClass_Unresolved_RaisesError;
- procedure TestSemantic_ForwardClass_DoubleForward_RaisesError;
- procedure TestCodegen_ForwardClass_SingleVTable;
-
{ ------------------------------------------------------------------ }
{ Free built-in }
{ ------------------------------------------------------------------ }
@@ -1189,121 +1180,6 @@ begin
end;
end;
-{ ------------------------------------------------------------------ }
-{ Forward class declarations }
-{ ------------------------------------------------------------------ }
-
-procedure TClassTests.TestSemantic_ForwardClass_CompletedByFullDecl;
-var
- Prog: TProgram;
-begin
- { A bare `TFoo = class;` forward stub, completed by the full declaration
- later in the same type section, must not be a duplicate-type error. }
- Prog := AnalyseSrc(
- '''
- program P;
- type
- TFoo = class;
- TFoo = class
- X: Integer;
- end;
- begin
- end.
- ''');
- try
- AssertTrue('forward class completed by full decl analyses OK', Prog <> nil);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TClassTests.TestSemantic_ForwardClass_MutualReference;
-var
- Prog: TProgram;
-begin
- { The point of a forward decl: a class declared between the forward and the
- full declaration can name the forward-declared type. }
- Prog := AnalyseSrc(
- '''
- program P;
- type
- TFoo = class;
- TBar = class
- Foo: TFoo;
- end;
- TFoo = class
- Bar: TBar;
- end;
- begin
- end.
- ''');
- try
- AssertTrue('mutual class reference via forward decl analyses OK',
- Prog <> nil);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TClassTests.TestSemantic_ForwardClass_Unresolved_RaisesError;
-begin
- { A forward never completed in the scope is an error. }
- AnalyseExpectError(
- '''
- program P;
- type
- TFoo = class;
- begin
- end.
- ''');
-end;
-
-procedure TClassTests.TestSemantic_ForwardClass_DoubleForward_RaisesError;
-begin
- { The same type may be forward-declared only once. }
- AnalyseExpectError(
- '''
- program P;
- type
- TFoo = class;
- TFoo = class;
- TFoo = class
- X: Integer;
- end;
- begin
- end.
- ''');
-end;
-
-procedure TClassTests.TestCodegen_ForwardClass_SingleVTable;
-var
- IR: string;
- Count: Integer;
- P: Integer;
-begin
- { The forward stub is dropped after semantic analysis, so codegen must emit
- the class's vtable exactly once — a second emission would be a duplicate
- data symbol and fail to link. }
- IR := GenIR(
- '''
- program P;
- type
- TFoo = class;
- TFoo = class
- X: Integer;
- end;
- begin
- end.
- ''');
- Count := 0;
- P := 0;
- repeat
- P := PosEx('data $vtable_TFoo', IR, P);
- if P >= 0 then begin Inc(Count); Inc(P) end;
- until P < 0;
- AssertEquals('vtable_TFoo emitted exactly once', 1, Count);
-end;
-
initialization
RegisterTest(TClassTests);
diff --git a/compiler/src/test/pascal/cp.test.classof.pas b/compiler/src/test/pascal/cp.test.classof.pas
index c539ec0..cfbfc39 100644
--- a/compiler/src/test/pascal/cp.test.classof.pas
+++ b/compiler/src/test/pascal/cp.test.classof.pas
@@ -23,7 +23,6 @@ type
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
- procedure AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
published
{ Parser }
procedure TestParse_ClassOf_AsAlias;
@@ -57,11 +56,6 @@ type
procedure TestSemantic_MetaclassVar_Create_Accepted;
procedure TestCodegen_MetaclassVar_Create_IndirectCtor;
procedure TestCodegen_MetaclassVar_Create_NoCtor_NoIndirectCall;
-
- { Bare 'C.Create' (no parens) on a metaclass variable must give the
- mandatory-parentheses diagnostic, not the misleading
- 'is not a record or class' error. }
- procedure TestSemantic_MetaclassVar_BareCreate_RequiresParens;
end;
implementation
@@ -119,20 +113,6 @@ begin
end;
end;
-procedure TClassOfTests.AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
-var Prog: TProgram;
-begin
- try
- Prog := AnalyseSrc(ASrc);
- Prog.Free();
- Fail('Expected ESemanticError');
- except
- on E: ESemanticError do
- AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
- E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
- end;
-end;
-
{ ------------------------------------------------------------------ }
{ Parser }
{ ------------------------------------------------------------------ }
@@ -568,24 +548,6 @@ begin
Pos('TFoo_Create', IR) < 0);
end;
-procedure TClassOfTests.TestSemantic_MetaclassVar_BareCreate_RequiresParens;
-const Src = '''
- program P;
- type
- TFoo = class(TObject)
- constructor Create;
- end;
- constructor TFoo.Create; begin end;
- var C: class of TFoo; F: TFoo;
- begin
- C := TFoo;
- F := C.Create
- end.
- ''';
-begin
- AnalyseExpectErrorMsg(Src, 'requires () for a call');
-end;
-
initialization
RegisterTest(TClassOfTests);
end.
diff --git a/compiler/src/test/pascal/cp.test.cli.pas b/compiler/src/test/pascal/cp.test.cli.pas
index 5f66447..7c0a1ae 100644
--- a/compiler/src/test/pascal/cp.test.cli.pas
+++ b/compiler/src/test/pascal/cp.test.cli.pas
@@ -35,6 +35,7 @@ type
FCompiler: string;
FRTLPath: string;
FStdlibPath: string;
+ FRTL: string;
FScratch: string;
FCounter: Integer;
function ProjectRoot: string;
@@ -75,22 +76,11 @@ type
procedure TestEmitAsm_WithExplicitQbeBackend_Rejected;
procedure TestEmitIr_WithoutBackend_StillWorks;
procedure TestEmitIr_WithExplicitQbeBackend_StillWorks;
- { ---- external 'lib' propagates a -l to the real link command ---- }
- { A program declaring `external 'lib'` for a NON-EXISTENT library must fail
- the link with the linker's "cannot find -l" — which only happens if
- the driver actually emitted -l. The e2e harness can't test this (it
- links with a hardcoded `cc ... -lm -lpthread` and never calls
- LinkViaToolchain), so this drives the real compiler binary end to end. }
- procedure TestExternalLib_MissingLib_FailsLink_QBE;
- procedure TestExternalLib_MissingLib_FailsLink_Native;
{ ---- div/mod by zero raises a catchable EDivByZero (needs stdlib) ---- }
procedure TestDivByZeroCaught_QBE;
procedure TestDivByZeroCaught_Native;
procedure TestModByZeroCaught_QBE;
procedure TestModByZeroCaught_Native;
- { ---- a bare --output (no directory part) must not anchor per-unit
- .o/.bif artefacts at the filesystem root ---- }
- procedure TestBareOutput_UnitArtefacts_NotWrittenToRoot;
end;
implementation
@@ -101,17 +91,6 @@ implementation
var
GCLISkipNoted: Boolean = False;
-{ Validity-probe cache for the fallback compiler. The fallback path
- (/tmp/fp_blaise2) is a transient fixpoint artifact that is frequently STALE —
- built by an earlier, possibly-broken compiler. Running the contract tests
- against a stale binary produces a cascade of cryptic failures (e.g. SIGILL
- from a since-fixed mis-encoding) that look like regressions but are not.
- We probe the binary once (compile+run a trivial program) and, if it does not
- behave, skip the suite with an actionable message instead of failing.
- 0 = not probed, 1 = good, 2 = bad. }
-var
- GCLIProbeState: Integer = 0;
-
{ ---- helpers ---- }
function TCLIContractTests.ProjectRoot: string;
@@ -149,49 +128,24 @@ begin
FCompiler := '/tmp/fp_blaise3';
if not FileExists(FCompiler) then
FCompiler := '/tmp/fp_blaise2';
- FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
+ FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
+ FRTL := ProjectRoot() + 'compiler/target/blaise_rtl.a';
FScratch := ProjectRoot() + 'compiler/target/cli_scratch/';
ForceDirectories(FScratch);
FCounter := 0;
end;
function TCLIContractTests.CompilerAvailable: Boolean;
-var
- Out_: string;
- EC: Integer;
begin
- { The compiler binary source-builds the RTL itself (no blaise_rtl.a); only
- the binary and the RTL source need to be present. }
- Result := FileExists(FCompiler)
- and FileExists(FRTLPath + '/runtime.arc.pas');
+ Result := FileExists(FCompiler) and FileExists(FRTL);
if (not Result) and (not GCLISkipNoted) then
begin
GCLISkipNoted := True;
WriteLn(StdErr, 'note: TCLIContractTests skipped — compiler binary "',
- FCompiler, '" or RTL source not found ',
+ FCompiler, '" or RTL "', FRTL, '" not found ',
'(set BLAISE_QBE_COMPILER to a QBE-backend blaise binary to run them)');
- Exit;
end;
- if not Result then Exit;
-
- { Validity probe: a stale fallback binary would otherwise turn into a cascade
- of cryptic failures. Probe once; on a bad probe, treat as unavailable. }
- if GCLIProbeState = 0 then
- begin
- if CompileRunFull('program p; begin WriteLn(42); end.', 'native', Out_, EC)
- and (EC = 0) and (Pos('42', Out_) >= 0) then
- GCLIProbeState := 1
- else
- begin
- GCLIProbeState := 2;
- WriteLn(StdErr, 'note: TCLIContractTests skipped — compiler binary "',
- FCompiler, '" is stale/broken (probe program did not run); ',
- 'rebuild it or set BLAISE_QBE_COMPILER to a current QBE-backend ',
- 'blaise binary.');
- end;
- end;
- Result := GCLIProbeState = 1;
end;
function TCLIContractTests.RunCompiler(const AArgs: array of string;
@@ -565,52 +519,6 @@ const
' end' + LineEnding +
'end.';
-const
- { Declares an external from a library that does not exist. The function is
- never called, but the parser collects the library into Prog.LinkLibs at
- parse time, so the driver must still emit -lnosuchlib_blaise_xyz on the link
- line — which the system linker then rejects. If the -l propagation
- were broken (no flag emitted), the link would SUCCEED. }
- SrcMissingExternalLib =
- 'program P;' + LineEnding +
- 'function f(X: Integer): Integer;' +
- ' external ''nosuchlib_blaise_xyz'' name ''nope'';' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(''unreached'')' + LineEnding +
- 'end.';
-
-procedure TCLIContractTests.TestExternalLib_MissingLib_FailsLink_QBE;
-var SrcPath, BinPath, Out_: string; EC: Integer;
-begin
- if not CompilerAvailable() then begin Ignore(''); Exit; end;
- SrcPath := WriteScratchSource(SrcMissingExternalLib);
- BinPath := FScratch + 'cli_misslib_qbe_' + IntToStr(FCounter);
- EC := RunCompiler(['--source', SrcPath, '--backend', 'qbe',
- '--unit-path', FRTLPath, '--unit-path', FStdlibPath,
- '--output', BinPath], Out_);
- AssertTrue('link must fail (missing library)', EC <> 0);
- AssertTrue('linker reports the -l it could not find',
- Pos('nosuchlib_blaise_xyz', Out_) >= 0);
-end;
-
-procedure TCLIContractTests.TestExternalLib_MissingLib_FailsLink_Native;
-var SrcPath, BinPath, Out_: string; EC: Integer;
-begin
- if not CompilerAvailable() then begin Ignore(''); Exit; end;
- SrcPath := WriteScratchSource(SrcMissingExternalLib);
- BinPath := FScratch + 'cli_misslib_nat_' + IntToStr(FCounter);
- { --linker external: the internal linker cannot resolve -l system
- libraries (it errors out separately); the toolchain linker is what emits
- and consumes -l. }
- EC := RunCompiler(['--source', SrcPath, '--backend', 'native',
- '--linker', 'external',
- '--unit-path', FRTLPath, '--unit-path', FStdlibPath,
- '--output', BinPath], Out_);
- AssertTrue('link must fail (missing library)', EC <> 0);
- AssertTrue('linker reports the -l it could not find',
- Pos('nosuchlib_blaise_xyz', Out_) >= 0);
-end;
-
procedure TCLIContractTests.TestDivByZeroCaught_QBE;
var Out_: string; EC: Integer;
begin
@@ -651,58 +559,6 @@ begin
AssertTrue('mod by zero caught', Pos('mod caught', Out_) >= 0);
end;
-procedure TCLIContractTests.TestBareOutput_UnitArtefacts_NotWrittenToRoot;
-var
- UnitPath, ProgPath, Out_: string;
- EC: Integer;
-begin
- if not CompilerAvailable() then begin Ignore(''); Exit; end;
- { Regression: incremental compilation (default) compiles each used unit to
- its own .o/.bif via a worker. The worker's output directory was derived
- from --output via IncludeTrailingPathDelimiter(ExtractFilePath(OutputFile)).
- For a bare --output filename (no directory part) ExtractFilePath returns ''
- and IncludeTrailingPathDelimiter('') yields '/', so the worker tried to
- write '/.o.bif.tmp' at the filesystem root and failed with
- 'Cannot open file for writing: /.o.bif.tmp'. The artefacts must land
- in the current directory instead. }
- UnitPath := FScratch + 'clidemo_unit.pas';
- WriteFile(UnitPath,
- 'unit clidemo_unit;' + LineEnding +
- 'interface' + LineEnding +
- 'function Answer: Integer;' + LineEnding +
- 'implementation' + LineEnding +
- 'function Answer: Integer;' + LineEnding +
- 'begin' + LineEnding +
- ' Result := 42' + LineEnding +
- 'end;' + LineEnding +
- 'end.');
- ProgPath := WriteScratchSource(
- 'program cli_bareout;' + LineEnding +
- 'uses clidemo_unit;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(Answer())' + LineEnding +
- 'end.');
- { Bare --output name (no '/') is the trigger; the unit is found via the
- scratch --unit-path. }
- EC := RunCompiler([
- '--source', ProgPath,
- '--unit-path', FScratch,
- '--unit-path', FRTLPath,
- '--unit-path', FStdlibPath,
- '--output', 'cli_bareout_bin'
- ], Out_);
- { The bare output name resolves relative to the compiler's CWD (the test
- runner's working directory): the program binary and the per-unit .o land
- there. Remove them so the working tree stays clean. }
- if FileExists('cli_bareout_bin') then DeleteFile('cli_bareout_bin');
- if FileExists('clidemo_unit.o') then DeleteFile('clidemo_unit.o');
- AssertTrue('no root-path worker failure: ' + Out_,
- Pos('Cannot open file for writing: /', Out_) < 0);
- AssertTrue('no worker exception: ' + Out_,
- Pos('Worker exception', Out_) < 0);
- AssertEquals('bare --output compile exits 0: ' + Out_, 0, EC);
-end;
-
{ ---- Registration ---- }
initialization
diff --git a/compiler/src/test/pascal/cp.test.codegen.pas b/compiler/src/test/pascal/cp.test.codegen.pas
index ef91b6f..7ce0d85 100644
--- a/compiler/src/test/pascal/cp.test.codegen.pas
+++ b/compiler/src/test/pascal/cp.test.codegen.pas
@@ -81,13 +81,6 @@ type
procedure TestInt64AssignDouble_EmitsSltof;
procedure TestIntAssignSingle_EmitsSwtof;
- { Integer→float conversion on a CLASS-FIELD store target (not just a
- simple variable). Regression: the field-store path emitted a bare
- integer store into the float slot. }
- procedure TestInt64AssignDoubleField_EmitsSltof;
- procedure TestIntAssignSingleField_EmitsSwtof;
- procedure TestInt64AssignDoubleFieldBare_EmitsSltof;
-
{ Mixed Single×Double arithmetic }
procedure TestSingleMulDouble_PromotesSingleToDouble;
procedure TestSingleAddSingle_EmitsSTypedOp;
@@ -674,65 +667,6 @@ begin
IRContains(IR, 'swtof'));
end;
-procedure TCodeGenTests.TestInt64AssignDoubleField_EmitsSltof;
-var IR: string;
-begin
- IR := GenerateIR('''
- program P;
- type TFoo = class
- FD: Double;
- procedure SetIt(AValue: Int64);
- begin Self.FD := AValue end;
- end;
- var F: TFoo;
- begin
- F := TFoo.Create()
- end.
- ''');
- AssertTrue('Int64→Double field store should emit sltof',
- IRContains(IR, 'sltof'));
- AssertFalse('Int64→Double field store must not bare-store the integer',
- IRContains(IR, 'storel %_t2, %_t1'));
-end;
-
-procedure TCodeGenTests.TestIntAssignSingleField_EmitsSwtof;
-var IR: string;
-begin
- IR := GenerateIR('''
- program P;
- type TFoo = class
- FS: Single;
- procedure SetIt(AValue: Integer);
- begin Self.FS := AValue end;
- end;
- var F: TFoo;
- begin
- F := TFoo.Create()
- end.
- ''');
- AssertTrue('Integer→Single field store should emit swtof',
- IRContains(IR, 'swtof'));
-end;
-
-procedure TCodeGenTests.TestInt64AssignDoubleFieldBare_EmitsSltof;
-var IR: string;
-begin
- IR := GenerateIR('''
- program P;
- type TFoo = class
- FD: Double;
- procedure SetIt(AValue: Int64);
- begin FD := AValue end;
- end;
- var F: TFoo;
- begin
- F := TFoo.Create()
- end.
- ''');
- AssertTrue('Int64→Double bare implicit-Self field store should emit sltof',
- IRContains(IR, 'sltof'));
-end;
-
procedure TCodeGenTests.TestSingleMulDouble_PromotesSingleToDouble;
var IR: string;
begin
diff --git a/compiler/src/test/pascal/cp.test.config.pas b/compiler/src/test/pascal/cp.test.config.pas
index f8f52cc..a76ce43 100644
--- a/compiler/src/test/pascal/cp.test.config.pas
+++ b/compiler/src/test/pascal/cp.test.config.pas
@@ -28,11 +28,6 @@ type
procedure TestParseRelativePath_ResolvedAgainstBaseDir;
procedure TestParseAbsolutePath_NotModified;
procedure TestParseUnknownKey_IgnoredSilently;
- procedure TestParseRtlSrc_Absolute_SetsValue;
- procedure TestParseRtlSrc_Relative_ResolvedAgainstBaseDir;
- procedure TestParseRtlSrc_Absent_LeavesSeedUnchanged;
- procedure TestParseTildePath_ExpandsToHome;
- procedure TestParseRtlSrcTilde_ExpandsToHome;
procedure TestFindConfigFile_NextToBinary;
end;
@@ -186,11 +181,11 @@ begin
Lines := TStringList.Create();
Paths := TStringList.Create();
try
- Lines.Add('unit-path=../../compiler/src/main/pascal');
+ Lines.Add('unit-path=../../runtime/src/main/pascal');
ParseConfigLines(Lines, '/data/devel/new-pascal-compiler/compiler/target/', Paths);
AssertEquals('one path', 1, Paths.Count);
AssertEquals('resolved',
- '/data/devel/new-pascal-compiler/compiler/target/../../compiler/src/main/pascal',
+ '/data/devel/new-pascal-compiler/compiler/target/../../runtime/src/main/pascal',
Paths.Strings[0]);
finally
Lines.Free();
@@ -232,110 +227,6 @@ begin
end;
end;
-procedure TConfigTests.TestParseRtlSrc_Absolute_SetsValue;
-var
- Lines, Paths: TStringList;
- Rtl: string;
-begin
- Lines := TStringList.Create();
- Paths := TStringList.Create();
- try
- Rtl := '';
- Lines.Add('rtl-src=/opt/blaise/rtl');
- ParseConfigLines(Lines, '/base', Paths, Rtl);
- AssertEquals('rtl-src set', '/opt/blaise/rtl', Rtl);
- AssertEquals('rtl-src is not a unit-path', 0, Paths.Count);
- finally
- Lines.Free();
- Paths.Free();
- end;
-end;
-
-procedure TConfigTests.TestParseRtlSrc_Relative_ResolvedAgainstBaseDir;
-var
- Lines, Paths: TStringList;
- Rtl: string;
-begin
- Lines := TStringList.Create();
- Paths := TStringList.Create();
- try
- Rtl := '';
- Lines.Add('rtl-src=src/main/pascal');
- ParseConfigLines(Lines, '/base/', Paths, Rtl);
- AssertEquals('relative rtl-src resolved against base dir',
- '/base/src/main/pascal', Rtl);
- finally
- Lines.Free();
- Paths.Free();
- end;
-end;
-
-procedure TConfigTests.TestParseRtlSrc_Absent_LeavesSeedUnchanged;
-var
- Lines, Paths: TStringList;
- Rtl: string;
-begin
- Lines := TStringList.Create();
- Paths := TStringList.Create();
- try
- { Seed a value (as the driver does with a CLI --rtl-src); a config with no
- rtl-src line must leave it untouched. }
- Rtl := '/cli/override';
- Lines.Add('unit-path=/opt/blaise/runtime');
- ParseConfigLines(Lines, '/base', Paths, Rtl);
- AssertEquals('seed unchanged when config has no rtl-src',
- '/cli/override', Rtl);
- finally
- Lines.Free();
- Paths.Free();
- end;
-end;
-
-procedure TConfigTests.TestParseTildePath_ExpandsToHome;
-var
- Lines, Paths: TStringList;
- Home: string;
-begin
- Home := GetEnvironmentVariable('HOME');
- if Home = '' then begin Ignore('no $HOME'); Exit end;
- Lines := TStringList.Create();
- Paths := TStringList.Create();
- try
- { A '~/...' unit-path expands to $HOME/..., NOT resolved against the base. }
- Lines.Add('unit-path=~/devel/blaise/runtime');
- ParseConfigLines(Lines, '/some/base', Paths);
- AssertEquals('one path', 1, Paths.Count);
- AssertEquals('~ expanded to $HOME',
- IncludeTrailingPathDelimiter(Home) + 'devel/blaise/runtime',
- Paths.Strings[0]);
- finally
- Lines.Free();
- Paths.Free();
- end;
-end;
-
-procedure TConfigTests.TestParseRtlSrcTilde_ExpandsToHome;
-var
- Lines, Paths: TStringList;
- Rtl, Home: string;
-begin
- Home := GetEnvironmentVariable('HOME');
- if Home = '' then begin Ignore('no $HOME'); Exit end;
- Lines := TStringList.Create();
- Paths := TStringList.Create();
- try
- Rtl := '';
- Lines.Add('rtl-src=~/devel/blaise/compiler/src/main/pascal');
- ParseConfigLines(Lines, '/some/base', Paths, Rtl);
- AssertEquals('~ in rtl-src expanded to $HOME',
- IncludeTrailingPathDelimiter(Home) + 'devel/blaise/compiler/src/main/pascal',
- Rtl);
- finally
- Lines.Free();
- Paths.Free();
- end;
-end;
-
procedure TConfigTests.TestFindConfigFile_NextToBinary;
var
CfgPath: string;
diff --git a/compiler/src/test/pascal/cp.test.constants.pas b/compiler/src/test/pascal/cp.test.constants.pas
index 6f152b2..04d9c91 100644
--- a/compiler/src/test/pascal/cp.test.constants.pas
+++ b/compiler/src/test/pascal/cp.test.constants.pas
@@ -480,7 +480,7 @@ begin
x := Threshold
end;
begin
- DoWork()
+ DoWork
end.
'''
);
diff --git a/compiler/src/test/pascal/cp.test.driver.pas b/compiler/src/test/pascal/cp.test.driver.pas
index a84fee7..3bfe0bb 100644
--- a/compiler/src/test/pascal/cp.test.driver.pas
+++ b/compiler/src/test/pascal/cp.test.driver.pas
@@ -22,24 +22,12 @@ interface
uses
SysUtils, Classes, blaise.testing,
blaise.codegen.driver,
- blaise.codegen.target, { TTargetOS: osLinux / osFreeBSD }
blaise.codegen.qbe.driver, { registers the QBE driver }
blaise.codegen.native.driver; { registers the native driver }
type
TBackendDriverContractTests = class(TTestCase)
- private
- function ListContains(AList: TStringList; const AName: string): Boolean;
published
- { Per-target RTL unit-list selection (FreeBSD Step 5). BuildRTLUnitList is
- the pure selection helper EnsureRTLObjects drives off AOpts.Static +
- AOpts.Target.OS; these assert Linux vs FreeBSD swaps without invoking the
- whole compile+link pipeline. }
- procedure TestRTLUnits_LinuxDynamic_UsesLinuxLayout;
- procedure TestRTLUnits_LinuxStatic_SwapsLinuxLeaf;
- procedure TestRTLUnits_FreeBSDStatic_SwapsFreeBSDLeaf;
- procedure TestRTLUnits_FreeBSDStatic_NoLinuxLeaf;
-
{ ClaimsEmitIR selection policy. }
procedure TestQBE_ClaimsEmitIR_True;
procedure TestNative_ClaimsEmitIR_False;
@@ -66,107 +54,6 @@ type
implementation
-function TBackendDriverContractTests.ListContains(AList: TStringList;
- const AName: string): Boolean;
-var
- I: Integer;
-begin
- Result := False;
- for I := 0 to AList.Count - 1 do
- if SameText(AList.Strings[I], AName) then
- Exit(True);
-end;
-
-procedure TBackendDriverContractTests.TestRTLUnits_LinuxDynamic_UsesLinuxLayout;
-var
- U: TStringList;
-begin
- { A dynamic (libc) Linux link keeps the plain RTL list: the Linux layout
- adapter is present and no freestanding kernel leaf is pulled in. }
- U := BuildRTLUnitList(False, osLinux);
- try
- AssertTrue('linux layout present',
- ListContains(U, 'rtl.platform.layout.linux'));
- AssertFalse('no static start in dynamic mode',
- ListContains(U, 'runtime.start.static.linux'));
- AssertFalse('no syscall leaf in dynamic mode',
- ListContains(U, 'runtime.syscall.linux'));
- finally
- U.Free();
- end;
-end;
-
-procedure TBackendDriverContractTests.TestRTLUnits_LinuxStatic_SwapsLinuxLeaf;
-var
- U: TStringList;
-begin
- { A --static Linux link swaps runtime.start for the freestanding
- runtime.start.static.linux and adds the Linux syscall/cstub/libc leaf. }
- U := BuildRTLUnitList(True, osLinux);
- try
- AssertTrue('freestanding start present',
- ListContains(U, 'runtime.start.static.linux'));
- AssertFalse('libc start dropped',
- ListContains(U, 'runtime.start'));
- AssertTrue('linux syscall leaf present',
- ListContains(U, 'runtime.syscall.linux'));
- AssertTrue('linux libc2 present',
- ListContains(U, 'runtime.libc2.linux'));
- AssertTrue('linux static thread leaf present',
- ListContains(U, 'runtime.thread.static.linux'));
- AssertTrue('linux layout present',
- ListContains(U, 'rtl.platform.layout.linux'));
- finally
- U.Free();
- end;
-end;
-
-procedure TBackendDriverContractTests.TestRTLUnits_FreeBSDStatic_SwapsFreeBSDLeaf;
-var
- U: TStringList;
-begin
- { A --static FreeBSD link selects the FreeBSD adapter set: the FreeBSD
- layout, freestanding start, syscall leaf, libc2 and static thread leaf. }
- U := BuildRTLUnitList(True, osFreeBSD);
- try
- AssertTrue('freebsd layout present',
- ListContains(U, 'rtl.platform.layout.freebsd'));
- AssertTrue('freebsd freestanding start present',
- ListContains(U, 'runtime.start.static.freebsd'));
- AssertTrue('freebsd syscall leaf present',
- ListContains(U, 'runtime.syscall.freebsd'));
- AssertTrue('freebsd libc2 present',
- ListContains(U, 'runtime.libc2.freebsd'));
- AssertTrue('freebsd static thread leaf present',
- ListContains(U, 'runtime.thread.static.freebsd'));
- finally
- U.Free();
- end;
-end;
-
-procedure TBackendDriverContractTests.TestRTLUnits_FreeBSDStatic_NoLinuxLeaf;
-var
- U: TStringList;
-begin
- { The FreeBSD list must contain NO Linux-specific RTL unit — the whole point
- of the per-target swap. }
- U := BuildRTLUnitList(True, osFreeBSD);
- try
- AssertFalse('no linux layout',
- ListContains(U, 'rtl.platform.layout.linux'));
- AssertFalse('no linux start',
- ListContains(U, 'runtime.start.static.linux'));
- AssertFalse('no linux syscall leaf',
- ListContains(U, 'runtime.syscall.linux'));
- AssertFalse('no linux libc2',
- ListContains(U, 'runtime.libc2.linux'));
- AssertFalse('no linux static thread leaf',
- ListContains(U, 'runtime.thread.static.linux'));
- finally
- U.Free();
- end;
-end;
-
procedure TBackendDriverContractTests.TestQBE_ClaimsEmitIR_True;
begin
AssertTrue('QBE must claim --emit-ir',
diff --git a/compiler/src/test/pascal/cp.test.e2e.arc.pas b/compiler/src/test/pascal/cp.test.e2e.arc.pas
index f474ff3..3bf5c89 100644
--- a/compiler/src/test/pascal/cp.test.e2e.arc.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.arc.pas
@@ -47,14 +47,6 @@ type
LHS (class) slot type. }
procedure TestRun_PtrRvalueToClassLocal_PreservesLifetime;
procedure TestRun_ClassVarAssignNil_Destroys;
- { A method call whose receiver is a deep field chain rooted in a
- transient function result — MakeIt().A.B.Method() — must keep the
- transient alive until the call completes. The native backend released
- the transient after the FIRST field hop, and _ClassRelease at refcount 0
- runs _FieldCleanup, freeing the intermediate objects (A, then B) the rest
- of the chain still dereferences — a use-after-free that crashed when the
- chain had two or more hops before the call. Guards both backends. }
- procedure TestRun_TransientDeepChainMethodCall_NoUseAfterFree;
end;
implementation
@@ -517,7 +509,7 @@ const
Freed := 0;
L := TObjectList.Create(True);
L.Add(TThing.Create());
- Borrow();
+ Borrow;
WriteLn(Freed);
L.Free();
WriteLn(Freed)
@@ -544,7 +536,7 @@ const
destructor TThing.Destroy;
begin
WriteLn('destroyed');
- inherited Destroy()
+ inherited Destroy
end;
var O: TThing;
begin
@@ -564,70 +556,6 @@ begin
'destroyed' + LE + 'done' + LE, Output);
end;
-const
- SrcTransientDeepChain = '''
- program P;
- type
- TInner = class
- Val: Integer;
- function GetVal: Integer;
- end;
- TBlk = class
- Inner: TInner;
- constructor Create;
- end;
- TProg = class
- Blk: TBlk;
- constructor Create;
- end;
- function TInner.GetVal: Integer;
- begin
- Result := Self.Val
- end;
- constructor TBlk.Create;
- begin
- Self.Inner := TInner.Create();
- Self.Inner.Val := 7
- end;
- constructor TProg.Create;
- begin
- Self.Blk := TBlk.Create()
- end;
- function MakeProg: TProg;
- begin
- Result := TProg.Create()
- end;
- var
- V, I: Integer;
- begin
- { Two field hops (.Blk.Inner) before the method call, on a transient
- function result that is never explicitly freed. The loop forces the
- freed-then-reused arena to surface a use-after-free deterministically. }
- V := 0;
- for I := 0 to 50 do
- V := V + MakeProg().Blk.Inner.GetVal();
- WriteLn(V)
- end.
- ''';
-
-procedure TE2EArcTests.TestRun_TransientDeepChainMethodCall_NoUseAfterFree;
-var Log: string;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { 51 iterations * 7 = 357. Both backends must agree on the value. }
- AssertRunsOnAll(SrcTransientDeepChain, '357' + LE, 0);
- { The use-after-free is non-deterministic at the stdout level (a freed-then-
- not-yet-reused read returns the old value), so the value check above can
- pass even when the bug is present. valgrind on the NATIVE binary detects
- the invalid read deterministically — this is the real regression guard. }
- if not ValgrindAvailable() then begin Ignore('valgrind not installed'); Exit; end;
- if not RunUnderValgrindNative(SrcTransientDeepChain, Log) then
- begin
- if Log = '' then Log := '(valgrind produced no output)';
- Fail('native valgrind reported an invalid access (use-after-free):' + LE + Log);
- end;
-end;
-
initialization
RegisterTest(TE2EArcTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.base.pas b/compiler/src/test/pascal/cp.test.e2e.base.pas
index 964ac11..556490e 100644
--- a/compiler/src/test/pascal/cp.test.e2e.base.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.base.pas
@@ -34,6 +34,7 @@ type
TE2ETestCase = class(TTestCase)
private
FQBE: string;
+ FRTL: string;
FRTLUnitPath: string;
FStdlibUnitPath: string;
FScratch: string;
@@ -42,13 +43,6 @@ type
function RunProc(const AExe: string; const AArgs: array of string;
out AStdout: string): Integer;
function RunProcNoArgs(const AExe: string; out AStdout: string): Integer;
- { Link an assembled program (AAsmFile) into ABinFile against the RTL. The
- RTL is built from source by scripts/build-rtl-objects.sh (no blaise_rtl.a
- archive); --exclude-defined-by drops the RTL objects the whole-program
- assembly already inlines, so the loose objects do not double-define.
- Returns the cc exit code; AStdout carries any tool output. }
- function LinkWithRTL(const AAsmFile, ABinFile: string;
- out AStdout: string): Integer;
protected
function ToolchainAvailable(): Boolean;
function ValgrindAvailable(): Boolean;
@@ -107,10 +101,6 @@ type
procedure AssertRunsOnOne(ABackend: TBackend; const AName, ASrc,
AExpectedOut: string; AExpectedCode: Integer);
function RunUnderValgrind(const ASrc: string; out ALog: string): Boolean;
- { Native-backend twin of RunUnderValgrind: compile ASrc with the NATIVE
- codegen, link, and run under valgrind. Needed to detect native-only
- use-after-free/leak bugs that the QBE-only RunUnderValgrind cannot see. }
- function RunUnderValgrindNative(const ASrc: string; out ALog: string): Boolean;
function CompileAndRunWithRTL(const ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean; overload;
@@ -146,15 +136,6 @@ type
function CompileAndRunWithUnitNative(const AUnitName, AUnitSrc, ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
- { Two-written-units compile+run (QBE). Writes both units to the scratch
- dir (filename derived from each `unit ;` header) so the program's
- `uses` clause resolves them, then lowers + links + runs. Needed for
- cross-unit tests (two units exporting the same name: last-wins shadowing,
- unit-qualified disambiguation). Kept at 5 params (Self+5 = 6 register
- slots) so the stage-1 native ABI does not overflow. }
- function CompileAndRunWithUnits(const AUnit1Src, AUnit2Src, ASrc: string;
- out AStdout: string;
- out AExitCode: Integer): Boolean;
end;
implementation
@@ -188,11 +169,7 @@ end;
function TE2ETestCase.ToolchainAvailable(): Boolean;
begin
- { Need the QBE assembler, the compiler binary (build-rtl-objects.sh drives it
- to source-build the RTL), and the RTL source. No blaise_rtl.a archive. }
- Result := FileExists(FQBE)
- and FileExists(ProjectRoot() + 'compiler/target/blaise')
- and FileExists(ProjectRoot() + 'compiler/src/main/pascal/runtime.arc.pas')
+ Result := FileExists(FQBE) and FileExists(FRTL)
end;
function TE2ETestCase.ValgrindAvailable(): Boolean;
@@ -209,9 +186,10 @@ begin
FQBE := GetEnvironmentVariable('BLAISE_QBE');
if FQBE = '' then
FQBE := ProjectRoot() + 'vendor/qbe/qbe';
- { RTL units (runtime.*, rtl.platform.*) now live in the compiler's own source
- tree after the RTL-unification move; the old runtime/src/main/pascal is empty. }
- FRTLUnitPath := ProjectRoot() + 'compiler/src/main/pascal';
+ FRTL := GetEnvironmentVariable('BLAISE_RTL');
+ if FRTL = '' then
+ FRTL := ProjectRoot() + 'runtime/target/blaise_rtl.a';
+ FRTLUnitPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibUnitPath := ProjectRoot() + 'stdlib/src/main/pascal'
end;
@@ -248,62 +226,6 @@ begin
end
end;
-function TE2ETestCase.LinkWithRTL(const AAsmFile, ABinFile: string;
- out AStdout: string): Integer;
-var
- ProgObj, ObjDir, Compiler, ScriptOut: string;
- Objs: TStringList;
- Proc: TProcess;
- I: Integer;
-begin
- { 1. Assemble the program to an object so build-rtl-objects.sh can see which
- RTL symbols it already defines (it inlines the RTL units it uses). }
- ProgObj := AAsmFile + '.o';
- Result := RunProc('cc', ['-c', '-o', ProgObj, AAsmFile], AStdout);
- if Result <> 0 then Exit;
-
- { 2. Build the RTL objects from source, excluding the units the program
- already inlined. Compiler binary is the freshly-built compiler/target. }
- Compiler := ProjectRoot() + 'compiler/target/blaise';
- ObjDir := IncludeTrailingPathDelimiter(FScratch) + 'rtlobj';
- Result := RunProc(ProjectRoot() + 'scripts/build-rtl-objects.sh',
- [Compiler, ObjDir, '--exclude-defined-by', ProgObj],
- ScriptOut);
- if Result <> 0 then
- begin
- AStdout := 'build-rtl-objects failed: ' + ScriptOut;
- Exit;
- end;
-
- { 3. Link: cc -o Bin ProgObj -lm -lpthread. Build the TProcess
- directly so the object list (variable length) can be appended. }
- Objs := TStringList.Create();
- Proc := TProcess.Create(nil);
- try
- Objs.Text := ScriptOut;
- Proc.Executable := 'cc';
- Proc.Parameters.Add('-o');
- Proc.Parameters.Add(ABinFile);
- Proc.Parameters.Add(ProgObj);
- for I := 0 to Objs.Count - 1 do
- if Trim(Objs.Strings[I]) <> '' then
- Proc.Parameters.Add(Trim(Objs.Strings[I]));
- Proc.Parameters.Add('-lm');
- Proc.Parameters.Add('-lpthread');
- Proc.Execute();
- AStdout := '';
- repeat
- ScriptOut := Proc.ReadOutput();
- AStdout := AStdout + ScriptOut
- until (ScriptOut = '') and not Proc.Running;
- Proc.WaitOnExit();
- Result := Proc.ExitCode;
- finally
- Proc.Free();
- Objs.Free();
- end;
-end;
-
function TE2ETestCase.RunProcNoArgs(const AExe: string;
out AStdout: string): Integer;
var
@@ -392,7 +314,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
+ Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
@@ -504,7 +426,7 @@ begin
WriteFile(IRFile, IR);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
+ Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProc(BinFile, AExtraArgs, AStdout);
Result := True
@@ -548,7 +470,7 @@ begin
WriteFile(IRFile, IR);
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then Exit;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
+ Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then Exit;
Rc := RunProc('valgrind',
@@ -556,53 +478,6 @@ begin
Result := Rc = 0
end;
-function TE2ETestCase.RunUnderValgrindNative(const ASrc: string; out ALog: string): Boolean;
-var
- Lexer: TLexer;
- Parser: TParser;
- Prog: TProgram;
- Semantic: TSemanticAnalyser;
- NCG: TCodeGenNative;
- CG: ICodeGen;
- Asm_: string;
- AsmFile: string;
- BinFile: string;
- ToolOut: string;
- Rc: Integer;
-begin
- Result := False;
- ALog := '';
- Inc(FCounter);
- AsmFile := FScratch + '/vgn' + IntToStr(FCounter) + '.s';
- BinFile := FScratch + '/vgn' + IntToStr(FCounter);
-
- Lexer := nil; Parser := nil; Prog := nil; Semantic := nil; CG := nil;
- try
- Lexer := TLexer.Create(ASrc);
- Parser := TParser.Create(Lexer);
- Prog := Parser.Parse();
- Semantic := TSemanticAnalyser.Create();
- Semantic.Analyse(Prog);
- NCG := TCodeGenNative.Create();
- NCG.SetTarget(HostTarget());
- CG := NCG; { ARC-managed; released at scope exit }
- CG.Generate(Prog);
- Asm_ := CG.GetOutput()
- finally
- Semantic.Free(); Prog.Free(); Parser.Free(); Lexer.Free()
- end;
-
- WriteFile(AsmFile, Asm_);
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
- if Rc <> 0 then begin ALog := 'cc failed: ' + ToolOut; Exit end;
-
- { --error-exitcode=99: any invalid read/write (the use-after-free) makes
- valgrind exit non-zero even when the program does not itself crash. }
- Rc := RunProc('valgrind',
- ['--error-exitcode=99', '--leak-check=no', '--quiet', BinFile], ALog);
- Result := Rc = 0
-end;
-
function TE2ETestCase.CompileAndRunWithRTL(const ASrc: string;
out AStdout: string;
out AExitCode: Integer): Boolean;
@@ -787,7 +662,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
+ Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
@@ -887,94 +762,7 @@ begin
Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end
end;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
- if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
- AExitCode := RunProcNoArgs(BinFile, AStdout);
- Result := True
-end;
-
-{ Extract the unit name from a 'unit ;' header so the source can be
- written to the matching .pas the unit loader expects. Strings are
- byte-indexed (S[i] returns a Byte); Pos is 0-based and returns -1 when the
- substring is absent. }
-function UnitNameOf(const ASrc: string): string;
-var
- P, Q: Integer;
-begin
- P := Pos('unit ', ASrc);
- if P < 0 then begin Result := ''; Exit; end;
- P := P + 5; { skip past 'unit ' }
- Q := P;
- while (Q < Length(ASrc)) and (ASrc[Q] <> Ord(';')) and (ASrc[Q] <> Ord(' '))
- and (ASrc[Q] <> 10) and (ASrc[Q] <> 13) do
- Q := Q + 1;
- Result := Copy(ASrc, P, Q - P);
-end;
-
-function TE2ETestCase.CompileAndRunWithUnits(const AUnit1Src, AUnit2Src,
- ASrc: string;
- out AStdout: string;
- out AExitCode: Integer): Boolean;
-var
- Lexer: TLexer;
- Parser: TParser;
- Prog: TProgram;
- Semantic: TSemanticAnalyser;
- QCG: TCodeGenQBE;
- CG: ICodeGen;
- Loader: TUnitLoader;
- Units: TObjectList;
- SearchPaths: TStringList;
- Emitted: string;
- IRFile, AsmFile, BinFile, ToolOut: string;
- Rc, I: Integer;
-begin
- Result := False;
- Inc(FCounter);
- IRFile := FScratch + '/t' + IntToStr(FCounter) + '.ssa';
- AsmFile := FScratch + '/t' + IntToStr(FCounter) + '.s';
- BinFile := FScratch + '/t' + IntToStr(FCounter);
-
- { Write both user units to the scratch dir so the loader resolves them.
- Filenames are derived from each unit's own `unit ;` header. }
- WriteFile(FScratch + '/' + UnitNameOf(AUnit1Src) + '.pas', AUnit1Src);
- WriteFile(FScratch + '/' + UnitNameOf(AUnit2Src) + '.pas', AUnit2Src);
-
- Lexer := nil; Parser := nil; Prog := nil; Semantic := nil;
- QCG := nil; CG := nil;
- Loader := nil; Units := nil; SearchPaths := nil;
- try
- Lexer := TLexer.Create(ASrc);
- Parser := TParser.Create(Lexer);
- Prog := Parser.Parse();
- Semantic := TSemanticAnalyser.Create();
- SearchPaths := TStringList.Create();
- SearchPaths.Add(FScratch);
- SearchPaths.Add(FRTLUnitPath);
- SearchPaths.Add(FStdlibUnitPath);
- Loader := TUnitLoader.Create(SearchPaths);
- Units := Loader.LoadAll(Prog.UsedUnits);
- for I := 0 to Units.Count - 1 do
- Semantic.AnalyseUnitForExport(TUnit(Units.Items[I]));
- Semantic.Analyse(Prog);
- QCG := TCodeGenQBE.Create();
- CG := QCG;
- CG.SetSymbolTable(Prog.SymbolTable);
- for I := 0 to Units.Count - 1 do
- CG.AppendUnit(TUnit(Units.Items[I]));
- CG.AppendProgram(Prog);
- Emitted := CG.GetOutput()
- finally
- QCG.Free();
- Semantic.Free();
- Units.Free(); Loader.Free(); SearchPaths.Free();
- Prog.Free(); Parser.Free(); Lexer.Free()
- end;
-
- WriteFile(IRFile, Emitted);
- Rc := RunProc(FQBE, ['-o', AsmFile, IRFile], ToolOut);
- if Rc <> 0 then begin AStdout := 'qbe failed: ' + ToolOut; AExitCode := Rc; Exit end;
- Rc := LinkWithRTL(AsmFile, BinFile, ToolOut);
+ Rc := RunProc('cc', ['-o', BinFile, AsmFile, FRTL, '-lm', '-lpthread'], ToolOut);
if Rc <> 0 then begin AStdout := 'cc failed: ' + ToolOut; AExitCode := Rc; Exit end;
AExitCode := RunProcNoArgs(BinFile, AStdout);
Result := True
diff --git a/compiler/src/test/pascal/cp.test.e2e.caseenum.pas b/compiler/src/test/pascal/cp.test.e2e.caseenum.pas
index c92466e..bb30dd5 100644
--- a/compiler/src/test/pascal/cp.test.e2e.caseenum.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.caseenum.pas
@@ -28,17 +28,6 @@ type
procedure TestRun_Enum_ExplicitOrdinals;
procedure TestRun_Enum_AutoContinueAfterExplicit;
procedure TestRun_Enum_ExplicitInCase;
- procedure TestRun_Enum_ScopedAccess;
- procedure TestRun_Enum_SharedMemberByContext;
- procedure TestRun_Enum_AmbiguousBareRejected;
- procedure TestRun_Enum_CallArgByContext;
- procedure TestRun_Enum_ForBoundsByContext;
- procedure TestRun_Enum_FieldAssignByContext;
- procedure TestRun_Enum_MethodArgByContext;
- procedure TestRun_Enum_ArrayElemByContext;
- procedure TestRun_Enum_PointerWriteByContext;
- procedure TestRun_Enum_ProcTypeArgByContext;
- procedure TestRun_Enum_ReturnByContext;
end;
implementation
@@ -236,362 +225,6 @@ begin
AssertEquals('NotFound=404 matches case 404', 'not found', Trim(Output));
end;
-procedure TE2ECaseEnumTests.TestRun_Enum_ScopedAccess;
-const
- { Two enums in one unit share the member name 'Red'. Members are not bare
- global symbols, so each enum's members are reachable through the
- type-qualified form regardless of the shared name. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- begin
- WriteLn(Ord(TColorA.Red));
- WriteLn(Ord(TColorA.Green));
- WriteLn(Ord(TColorB.Red));
- WriteLn(Ord(TColorB.Blue))
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('TColorA.Red', '0', Lines.Strings[0]);
- AssertEquals('TColorA.Green','1', Lines.Strings[1]);
- AssertEquals('TColorB.Red', '0', Lines.Strings[2]);
- AssertEquals('TColorB.Blue', '1', Lines.Strings[3]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_SharedMemberByContext;
-const
- { 'Red' is shared by both enums. Each bare use is disambiguated by its
- context — assignment target, case selector, set element — so the program
- reaches the correct member of each enum at runtime. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Red, Blue);
- var
- a: TColorA;
- b: TColorB;
- s: set of TColorA;
- begin
- a := Red; WriteLn(Ord(a));
- b := Blue; WriteLn(Ord(b));
- s := [Red, Green];
- if Red in s then WriteLn(10);
- case b of
- Red: WriteLn(20);
- Blue: WriteLn(21)
- end
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('a := Red (TColorA.Red)', '0', Lines.Strings[0]);
- AssertEquals('b := Blue (TColorB.Blue)','1', Lines.Strings[1]);
- AssertEquals('Red in s (TColorA.Red)', '10', Lines.Strings[2]);
- AssertEquals('case b = Blue', '21', Lines.Strings[3]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_AmbiguousBareRejected;
-const
- { A bare, context-free reference to a member shared by two enums cannot be
- resolved and must fail to compile — there is no last-wins fallback. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red);
- begin
- WriteLn(Ord(Red))
- end.
- ''';
-var Output: string; RCode: Integer; Rejected: Boolean;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- Rejected := False;
- try
- if not CompileAndRun(Src, Output, RCode) then
- Rejected := True;
- except
- on E: Exception do Rejected := True;
- end;
- AssertTrue('ambiguous bare member must not compile', Rejected);
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_CallArgByContext;
-const
- { 'Red' is shared (ordinal 0 in TColorA, ordinal 1 in TColorB). Each bare
- member passed as a call argument is steered to the enum of the callee's
- parameter, so the right ordinal reaches the routine at runtime. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- procedure TakeA(c: TColorA);
- begin WriteLn(Ord(c)) end;
- procedure TakeB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- begin
- TakeA(Red);
- TakeB(Red);
- TakeB(Blue)
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('TakeA(Red) -> TColorA.Red', '0', Lines.Strings[0]);
- AssertEquals('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[1]);
- AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[2]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_ForBoundsByContext;
-const
- { The loop variable's type disambiguates the bare shared start bound 'Red'
- (TColorB here), so the loop walks TColorB.Red(1)..TColorB.Blue(2). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- var b: TColorB;
- begin
- for b := Red to Blue do
- WriteLn(Ord(b))
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('first iter b=Red(1)', '1', Lines.Strings[0]);
- AssertEquals('second iter b=Blue(2)','2', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_FieldAssignByContext;
-const
- { A bare shared member assigned to a record field is disambiguated by the
- field's enum type (TColorB), so r.c receives TColorB.Red (ordinal 1). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- TRec = record c: TColorB; end;
- var r: TRec;
- begin
- r.c := Red;
- WriteLn(Ord(r.c))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- AssertEquals('r.c := Red -> TColorB.Red (ordinal 1)', '1', Trim(Output));
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_MethodArgByContext;
-const
- { A bare shared member passed to a method is steered to the enum of the
- method's parameter (TColorB), so TColorB.Red (ordinal 1) reaches it. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- TFoo = class
- procedure TakeB(c: TColorB);
- end;
- procedure TFoo.TakeB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- var f: TFoo;
- begin
- f := TFoo.Create();
- f.TakeB(Red);
- f.TakeB(Blue);
- f.Free()
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('TakeB(Red) -> TColorB.Red', '1', Lines.Strings[0]);
- AssertEquals('TakeB(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_ArrayElemByContext;
-const
- { Writing a bare shared member into an array element is disambiguated by the
- array's element type (TColorB), so arr[0] receives TColorB.Red (ordinal 1). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- var arr: array[0..1] of TColorB;
- begin
- arr[0] := Red;
- arr[1] := Blue;
- WriteLn(Ord(arr[0]));
- WriteLn(Ord(arr[1]))
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('arr[0] := Red -> TColorB.Red', '1', Lines.Strings[0]);
- AssertEquals('arr[1] := Blue -> TColorB.Blue','2', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_PointerWriteByContext;
-const
- { Writing a bare shared member through a typed pointer is disambiguated by
- the pointer's base enum type (TColorB), so the target receives ordinal 2. }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- PColorB = ^TColorB;
- var
- b: TColorB;
- q: PColorB;
- begin
- q := @b;
- q^ := Blue;
- WriteLn(Ord(b))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- AssertEquals('q^ := Blue -> TColorB.Blue (ordinal 2)', '2', Trim(Output));
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_ProcTypeArgByContext;
-const
- { Calling through a procedural-type variable steers a bare shared member to
- the enum of the procedural type's parameter (TColorB). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- TProcB = procedure(c: TColorB);
- procedure ShowB(c: TColorB);
- begin WriteLn(Ord(c)) end;
- var cb: TProcB;
- begin
- cb := @ShowB;
- cb(Red);
- cb(Blue)
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('cb(Red) -> TColorB.Red', '1', Lines.Strings[0]);
- AssertEquals('cb(Blue) -> TColorB.Blue','2', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
-procedure TE2ECaseEnumTests.TestRun_Enum_ReturnByContext;
-const
- { A bare shared member returned from a function is disambiguated by the
- function's return enum, via both Result := and Exit(). }
- Src =
- '''
- program P;
- type
- TColorA = (Red, Green);
- TColorB = (Amber, Red, Blue);
- function ViaResult: TColorB;
- begin Result := Red end;
- function ViaExit: TColorB;
- begin Exit(Blue) end;
- begin
- WriteLn(Ord(ViaResult()));
- WriteLn(Ord(ViaExit()))
- end.
- ''';
-var Output: string; RCode: Integer; Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('Result := Red -> TColorB.Red', '1', Lines.Strings[0]);
- AssertEquals('Exit(Blue) -> TColorB.Blue', '2', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
initialization
RegisterTest(TE2ECaseEnumTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.classes2.pas b/compiler/src/test/pascal/cp.test.e2e.classes2.pas
index ed82666..3ced1bb 100644
--- a/compiler/src/test/pascal/cp.test.e2e.classes2.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.classes2.pas
@@ -159,17 +159,6 @@ type
{ ClassCreate builtin still works (backwards compat) and now dispatches
the ctor body via vtable too. }
procedure TestRun_ClassCreate_StillWorks;
- { Forward class declaration with a managed (string) field: the forward
- stub must complete into the same type so the full class — including its
- ARC field — compiles and runs correctly. }
- procedure TestRun_ForwardClass_MutualRefRuns;
-
- { Implicit Int64/Integer→float conversion when the assignment target is a
- class FIELD (both Self.Field and bare implicit-Self forms), for Double
- and Single fields. Regression: QBE deposited the raw integer bits into
- the float slot; native stored a Double into a Single slot (movss of a
- double) without narrowing. }
- procedure TestRun_IntToFloatField_Converts;
procedure TestRun_SelfIndexedRecordFieldAssign;
end;
@@ -212,35 +201,6 @@ const
end.
''';
- { Forward-declared TNode referenced by TEdge before its full definition,
- then completed with a managed (string) field and a back-reference. }
- SrcForwardClass =
- '''
- program Prg;
- type
- TNode = class;
- TEdge = class
- Target: TNode;
- end;
- TNode = class
- Name: string;
- Link: TEdge;
- end;
- var
- N: TNode;
- E: TEdge;
- begin
- N := TNode.Create();
- N.Name := 'hello';
- E := TEdge.Create();
- E.Target := N;
- N.Link := E;
- WriteLn(E.Target.Name);
- N.Free();
- E.Free()
- end.
- ''';
-
SrcToStringDefault = '''
program Prg;
type
@@ -2326,57 +2286,6 @@ begin
AssertRunsOnAll(Src, '1' + LE, 0);
end;
-procedure TE2EClasses2Tests.TestRun_ForwardClass_MutualRefRuns;
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(SrcForwardClass, Output, RCode));
- AssertEquals('forward-declared TNode field read back', 'hello', Trim(Output));
-end;
-
-const
- SrcIntToFloatField =
- '''
- program Prg;
- type
- TFoo = class
- FD: Double;
- FS: Single;
- procedure SetD(AValue: Int64);
- begin Self.FD := AValue end; { Int64 -> Double, Self.Field }
- procedure SetDBare(AValue: Int64);
- begin FD := AValue end; { Int64 -> Double, implicit Self }
- procedure SetS(AValue: Integer);
- begin Self.FS := AValue end; { Integer -> Single, Self.Field }
- procedure SetSBare(AValue: Integer);
- begin FS := AValue end; { Integer -> Single, implicit Self }
- end;
- var F: TFoo;
- begin
- F := TFoo.Create();
- F.SetD(7);
- WriteLn(Format('%g', [F.FD]));
- F.SetDBare(42);
- WriteLn(Format('%g', [F.FD]));
- F.SetS(5);
- WriteLn(Format('%g', [F.FS]));
- F.SetSBare(9);
- WriteLn(Format('%g', [F.FS]))
- end.
- ''';
-
-procedure TE2EClasses2Tests.TestRun_IntToFloatField_Converts;
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { All four forms convert the integer to the field's float width — including
- Integer->Single, where the native backend had stored a Double into the
- 4-byte Single slot. }
- AssertTrue('compile+run', CompileAndRun(SrcIntToFloatField, Output, RCode));
- AssertEquals('Int64/Integer→float field stores convert',
- '7' + LE + '42' + LE + '5' + LE + '9', Trim(Output));
-end;
-
initialization
RegisterTest(TE2EClasses2Tests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.collections2.pas b/compiler/src/test/pascal/cp.test.e2e.collections2.pas
index 0938b3f..df84348 100644
--- a/compiler/src/test/pascal/cp.test.e2e.collections2.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.collections2.pas
@@ -26,7 +26,6 @@ type
procedure TestRun_Collections_Valgrind;
procedure TestRun_TwoDictInstancesInUnit_BothLink;
procedure TestRun_IntfFreeFunc_GenericReturn_Compiles;
- procedure TestRun_DefaultProp_StringList_And_ObjectList;
end;
implementation
@@ -365,45 +364,6 @@ begin
AssertEquals('list count', '2' + #10, Output);
end;
-{ Regression (GitHub #138): the real classes.TStringList and contnrs.TObjectList
- must both carry a `default` indexed property so SL[i] / OL[i] work as sugar
- for SL.Strings[i] / OL.Items[i]. TStringList already had it; TObjectList did
- not. The chained form TStringList(OL[0])[1] — a typecast whose operand is
- itself a default-property subscript, indexed again by a default property —
- crashed the compiler (unbounded re-analysis of the rewritten subscript node);
- AnalyseStringSubscriptExpr now guards against re-analysis via ResolvedType. }
-procedure TE2ECollections2Tests.TestRun_DefaultProp_StringList_And_ObjectList;
-const
- Src = '''
- program P;
- uses classes, contnrs;
- var SL: TStringList; OL: TObjectList; i: Integer;
- begin
- SL := TStringList.Create;
- SL.Add('alpha');
- SL.Add('beta');
- for i := 0 to SL.Count - 1 do
- WriteLn(SL[i]); // default property read
- SL[0] := 'ALPHA'; // default property write
- WriteLn(SL[0]);
- OL := TObjectList.Create(False);
- OL.Add(SL);
- WriteLn(TStringList(OL[0])[1]); // chained: cast(OL default) then default
- SL.Free();
- OL.Free()
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { CompileAndRunWithRTL runs on BOTH backends and asserts parity, and puts the
- RTL + stdlib (classes, contnrs) on the unit search path. }
- AssertTrue('compile+run', CompileAndRunWithRTL(Src, Output, RCode));
- AssertEquals('exit code 0', 0, RCode);
- AssertEquals('default-property output',
- 'alpha' + #10 + 'beta' + #10 + 'ALPHA' + #10 + 'beta' + #10, Output);
-end;
-
initialization
RegisterTest(TE2ECollections2Tests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.controlflow.pas b/compiler/src/test/pascal/cp.test.e2e.controlflow.pas
index a265f72..448c0ae 100644
--- a/compiler/src/test/pascal/cp.test.e2e.controlflow.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.controlflow.pas
@@ -24,8 +24,6 @@ type
procedure TestRun_For_Upward_PrintsRange;
procedure TestRun_For_Downto_PrintsRange;
procedure TestRun_While_PrintsRange;
- procedure TestRun_For_EmptyBody_NoCrash;
- procedure TestRun_While_EmptyBody_NoCrash;
procedure TestRun_Repeat_PrintsRange;
procedure TestRun_For_BreakExitsEarly;
procedure TestRun_For_ContinueSkipsIteration;
@@ -107,29 +105,6 @@ const
end.
''';
- { Empty loop body — `for ... do;` / `while ... do;` parse to a nil body.
- Regression for issue #150: the native backend segfaulted (nil.ClassName in
- the unsupported-statement fallback) and the QBE backend rejected it; both
- must now treat the empty body as a valid no-op. }
- SrcForEmptyBody = '''
- program P;
- var I: Integer;
- begin
- for I := 0 to 9 do;
- WriteLn('done')
- end.
- ''';
-
- SrcWhileEmptyBody = '''
- program P;
- var I: Integer;
- begin
- I := 0;
- while I < 0 do;
- WriteLn('done')
- end.
- ''';
-
SrcRepeat = '''
program P;
var I: Integer;
@@ -192,11 +167,11 @@ const
end;
begin
Counter := 0;
- Inner();
+ Inner;
WriteLn(Counter);
end;
begin
- Outer();
+ Outer;
end.
''';
@@ -227,20 +202,6 @@ begin
AssertEquals('1 2 3', '1' + LE + '2' + LE + '3' + LE, Output);
end;
-procedure TE2EControlFlowTests.TestRun_For_EmptyBody_NoCrash;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Issue #150: an empty `for` body must compile + run as a no-op on both
- backends (native previously segfaulted the compiler). }
- AssertRunsOnAll(SrcForEmptyBody, 'done' + LE, 0);
-end;
-
-procedure TE2EControlFlowTests.TestRun_While_EmptyBody_NoCrash;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcWhileEmptyBody, 'done' + LE, 0);
-end;
-
procedure TE2EControlFlowTests.TestRun_Repeat_PrintsRange;
var Output: string; RCode: Integer;
begin
@@ -311,7 +272,7 @@ const
end;
Write(r); Write(' ');
end;
- WriteLn()
+ WriteLn
end.
''';
@@ -326,7 +287,7 @@ const
5, 7..9: Write('b');
else Write('.');
end;
- WriteLn()
+ WriteLn
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.e2e.crypto.pas b/compiler/src/test/pascal/cp.test.e2e.crypto.pas
deleted file mode 100644
index 7ea7ba7..0000000
--- a/compiler/src/test/pascal/cp.test.e2e.crypto.pas
+++ /dev/null
@@ -1,55 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.e2e.crypto;
-
-{ E2E smoke test for the Security.Crypto stdlib unit.
- Guards against native-backend miscompilation of the hash
- implementations (the Ord(S[I]) precedent). }
-
-interface
-
-uses
- blaise.testing, cp.test.e2e.base;
-
-type
- [Threaded]
- TE2ECryptoTests = class(TE2ETestCase)
- protected
- procedure SetUp; override;
- published
- procedure TestRun_Sha256Hex_Empty;
- end;
-
-implementation
-
-procedure TE2ECryptoTests.SetUp;
-begin
- inherited SetUp();
- SetUpScratch('compiler/target/test-e2e-crypto');
-end;
-
-procedure TE2ECryptoTests.TestRun_Sha256Hex_Empty;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRTLRunsOnAll(
- '''
- program P;
- uses Security.Crypto;
- begin
- WriteLn(Sha256Hex(''));
- end.
- ''',
- 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855' + LineEnding,
- 0);
-end;
-
-initialization
- RegisterTest(TE2ECryptoTests);
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.e2e.dynarray.pas b/compiler/src/test/pascal/cp.test.e2e.dynarray.pas
index 0c150d2..533654c 100644
--- a/compiler/src/test/pascal/cp.test.e2e.dynarray.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.dynarray.pas
@@ -85,7 +85,7 @@ const
program Prg;
var a: array of string; i: Integer;
begin SetLength(a, 3); a[0] := 'x'; a[1] := 'y'; a[2] := 'z';
- for i := 0 to 2 do Write(a[i]); WriteLn() end.
+ for i := 0 to 2 do Write(a[i]); WriteLn end.
''';
SrcRefSem = '''
@@ -125,7 +125,7 @@ const
SetLength(m, 2); SetLength(m[0], 2); SetLength(m[1], 2);
m[0][0] := 1; m[0][1] := 2; m[1][0] := 3; m[1][1] := 4;
for i := 0 to 1 do for j := 0 to 1 do Write(m[i][j]);
- WriteLn()
+ WriteLn
end.
''';
@@ -137,7 +137,7 @@ const
m[0][0] := 'a'; m[0][1] := 'b'; m[1][0] := 'c'; m[1][1] := 'd';
m[0][1] := 'B';
for i := 0 to 1 do for j := 0 to 1 do Write(m[i][j]);
- WriteLn()
+ WriteLn
end.
''';
@@ -154,7 +154,7 @@ const
c[i][j][k] := i*4 + j*2 + k;
for i := 0 to 1 do for j := 0 to 1 do for k := 0 to 1 do
Write(c[i][j][k]);
- WriteLn()
+ WriteLn
end.
''';
@@ -212,7 +212,7 @@ const
SetLength(G, Length(H));
for I := 0 to High(G) do G[I] := 9;
for I := 0 to High(G) do Write(G[I]);
- WriteLn()
+ WriteLn
end.
''';
@@ -226,7 +226,7 @@ const
SetLength(A, Length(B));
for I := 0 to High(A) do A[I] := 8;
for I := 0 to High(A) do Write(A[I]);
- WriteLn()
+ WriteLn
end.
''';
@@ -241,7 +241,7 @@ const
SetLength(A, Pick());
for I := 0 to High(A) do A[I] := 6;
for I := 0 to High(A) do Write(A[I]);
- WriteLn()
+ WriteLn
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.e2e.external.pas b/compiler/src/test/pascal/cp.test.e2e.external.pas
index 81b3ea9..6e6c9ff 100644
--- a/compiler/src/test/pascal/cp.test.e2e.external.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.external.pas
@@ -26,11 +26,6 @@ type
{ Basic external call — strlen via external name }
procedure TestRun_ExternalName_Strlen;
- { Library-qualified external — external 'c' name 'strlen': the bare library
- name is parsed and recorded (propagated via the unit's LinkLibs) while the
- symbol resolves as usual. }
- procedure TestRun_ExternalLibName_Strlen;
-
{ Narrow-int return masking: strlen returns size_t (64-bit) but declared
as Byte/Word/SmallInt — upper bits must be masked/sign-extended. }
procedure TestRun_ExternalByteReturn_MaskedCorrectly;
@@ -75,18 +70,6 @@ begin
AssertRunsOnAll(Src, '5' + Chr(10), 0);
end;
-procedure TE2EExternalTests.TestRun_ExternalLibName_Strlen;
-const Src = '''
- program T;
- function c_strlen(S: PChar): Integer; external 'c' name 'strlen';
- begin
- WriteLn(c_strlen(PChar('hello')))
- end.
- ''';
-begin
- AssertRunsOnAll(Src, '5' + Chr(10), 0);
-end;
-
procedure TE2EExternalTests.TestRun_ExternalByteReturn_MaskedCorrectly;
const Src = '''
program T;
diff --git a/compiler/src/test/pascal/cp.test.e2e.interfaces.pas b/compiler/src/test/pascal/cp.test.e2e.interfaces.pas
index 1709aaa..ce29fb2 100644
--- a/compiler/src/test/pascal/cp.test.e2e.interfaces.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.interfaces.pas
@@ -48,15 +48,6 @@ type
(issue #130 bug3). }
procedure TestRun_InheritedInterface_DescendantToVar;
procedure TestRun_InheritedInterface_OverrideAndInheritedMethod;
- procedure TestRun_InheritedInterface_NonVirtualMethod;
- { An itab-dispatched method returning a RECORD. Two ABI shapes:
- a memory-class record (has a managed field -> sret) and a register-class
- record (all-scalar, returned in registers). Both must work when the
- result is ASSIGNED and when DISCARDED in statement position — the
- discarded statement and the assignment used to mis-handle the
- record-return ABI and corrupt memory (bug #5). }
- procedure TestRun_InterfaceMethod_ReturnsSretRecord;
- procedure TestRun_InterfaceMethod_ReturnsRegisterRecord;
end;
implementation
@@ -372,9 +363,9 @@ const
begin WriteLn(g.Greet(), ' / ', g.Who()) end;
var per: TPerson; lou: TLoud; vl: TVeryLoud;
begin
- per := TPerson.Create; Use(per); per.Free();
- lou := TLoud.Create; Use(lou); lou.Free();
- vl := TVeryLoud.Create; Use(vl); vl.Free()
+ per := TPerson.Create; Use(per); per.Free;
+ lou := TLoud.Create; Use(lou); lou.Free;
+ vl := TVeryLoud.Create; Use(vl); vl.Free
end.
''';
begin
@@ -383,108 +374,6 @@ begin
'hi / person' + LE + 'HI / person' + LE + 'HI!!! / person' + LE, 0);
end;
-procedure TE2EInterfaceTests.TestRun_InheritedInterface_NonVirtualMethod;
-const
- { Regression (issue #130 bug3): a NON-virtual interface method inherited by a
- descendant. A non-virtual method gets no vtable slot, so the itab method ref
- cannot be resolved via the vtable; the descendant's itab used to name
- $TDerived_Hello (which does not exist) instead of the declaring ancestor's
- $TBase_Hello, causing an "undefined symbol"/link error. The earlier
- inherited-interface tests only exercised VIRTUAL methods, which DO have
- vtable slots, so this path went uncovered. Both backends must now link+run. }
- Src = '''
- program P;
- type
- IBase = interface procedure Hello; end;
- TBase = class(IBase) procedure Hello; end;
- TDerived = class(TBase) end;
- procedure TBase.Hello; begin WriteLn('hello') end;
- procedure Use(g: IBase); begin g.Hello() end;
- var d: TDerived; i: IBase;
- begin
- d := TDerived.Create;
- i := d; // assignment to interface
- i.Hello();
- Use(d); // parameter passing
- d.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, 'hello' + LE + 'hello' + LE, 0);
-end;
-
-procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsSretRecord;
-const
- { TRect has a managed (string) field, so ClassifyRecordReturn => sret. }
- Src = '''
- program P;
- type
- TRect = record Name: string; N: Integer; end;
- IShape = interface
- function MakeRect(AN: Integer): TRect;
- end;
- TShape = class(IShape)
- function MakeRect(AN: Integer): TRect;
- end;
- function TShape.MakeRect(AN: Integer): TRect;
- begin
- Result.Name := 'r';
- Result.N := AN;
- WriteLn('callee ', AN)
- end;
- var
- M: IShape;
- R: TRect;
- begin
- M := TShape.Create();
- R := M.MakeRect(5); { assigned sret record return }
- WriteLn('assigned ', R.N);
- M.MakeRect(7) { discarded sret record return }
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src,
- 'callee 5' + LE + 'assigned 5' + LE + 'callee 7' + LE, 0);
-end;
-
-procedure TE2EInterfaceTests.TestRun_InterfaceMethod_ReturnsRegisterRecord;
-const
- { TPt is all-scalar, so ClassifyRecordReturn => a register-class return
- (no sret buffer); the itab dispatch must capture the register result. }
- Src = '''
- program P;
- type
- TPt = record X, Y: Integer; end;
- IShape = interface
- function MakePt(AN: Integer): TPt;
- end;
- TShape = class(IShape)
- function MakePt(AN: Integer): TPt;
- end;
- function TShape.MakePt(AN: Integer): TPt;
- begin
- Result.X := AN;
- Result.Y := AN * 2;
- WriteLn('callee ', AN)
- end;
- var
- M: IShape;
- R: TPt;
- begin
- M := TShape.Create();
- R := M.MakePt(5); { assigned register-class record return }
- WriteLn('assigned ', R.X, ' ', R.Y);
- M.MakePt(9) { discarded register-class record return }
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src,
- 'callee 5' + LE + 'assigned 5 10' + LE + 'callee 9' + LE, 0);
-end;
-
initialization
RegisterTest(TE2EInterfaceTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.jumboset.pas b/compiler/src/test/pascal/cp.test.e2e.jumboset.pas
index 685070e..4864054 100644
--- a/compiler/src/test/pascal/cp.test.e2e.jumboset.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.jumboset.pas
@@ -123,7 +123,7 @@ begin
' for e in s do n := n + 1;' + LE +
' WriteLn(n);' + LE + { 4 }
' for e in s do Write(Ord(e), '' '');' + LE +
- ' WriteLn()' + LE +
+ ' WriteLn' + LE +
'end.';
AssertRunsOnAll(Src, '4' + LE + '5 40 70 79 ' + LE, 0);
end;
diff --git a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas
index 84a92eb..27d2df0 100644
--- a/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.leakcheck.pas
@@ -38,10 +38,6 @@ type
{ obj.Field := MakeClass() consumes the call's +1 — no leak per store. }
procedure TestDebug_ClassFieldFromCall_NoLeak;
-
- { local := MakeClass() consumes the call's +1 — no leak per assignment.
- Pins the native class-assignment AddRef elision against the QBE backend. }
- procedure TestDebug_FuncReturnAssign_NoLeak;
{ Multiple same-named typed handlers share one slot — no over-release. }
procedure TestDebug_MultiHandlerVar_NoOverRelease;
{ for-in over a TList: GetEnumerator's +1 result must be transferred
@@ -59,20 +55,6 @@ type
release it after the call or one instance leaks. }
procedure TestDebug_IntfCallResultArg_NoLeak;
procedure TestDebug_IntfCallResultArg_NoLeak_Native;
- { A call/getter result used as a field-access receiver must be released
- after the field load. L[I].HitPoints — the TList.Get getter returns
- +1, the field is read, then the transient base must be released. }
- procedure TestDebug_ReceiverFieldAccess_NoLeak;
- { A static array of interfaces (array[0..N] of IFoo): the elements are
- ARC-managed but the scope-exit cleanup previously skipped tyStaticArray
- locals entirely, so every stored element leaked on BOTH backends. The
- fix releases each element at scope exit. }
- procedure TestDebug_StaticArrayOfInterface_NoLeak;
- { A string-returning call/getter used DIRECTLY as a Write/WriteLn argument
- (WriteLn(GetBar)) returns a fresh +1 string that _SysWriteStr only borrows.
- EmitWrite previously never released it, leaking one string per call. The
- fix releases the owned string transient after the write (both backends). }
- procedure TestDebug_WriteLnCallArg_NoLeak;
end;
implementation
@@ -89,7 +71,7 @@ const
{ A clean program: object is created and properly released by ARC at scope exit. }
SrcNoLeak = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
TBox = class
Value: Integer;
@@ -110,7 +92,7 @@ const
use-after-free. With the fix it is freed exactly once: no leak, no crash. }
SrcExceptionHandlerVar = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
Exception = class
FMessage: string;
@@ -126,7 +108,7 @@ const
end
end;
begin
- DoIt();
+ DoIt;
WriteLn('done')
end.
''';
@@ -134,7 +116,7 @@ const
{ Constructor with args — must not double-AddRef; object must be clean after scope. }
SrcConstructorWithArgs = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
TBox = class
Value: Integer;
@@ -155,7 +137,7 @@ const
{ Deliberately leaked: object assigned to a raw Pointer, bypassing ARC release. }
SrcOneLeak = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
TBox = class
Value: Integer;
@@ -175,7 +157,7 @@ const
{ Two distinct classes leaked to verify count and class-name reporting. }
SrcTwoLeaks = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
TAlpha = class
X: Integer;
@@ -200,7 +182,7 @@ const
{ Reference cycle: each object holds the other — both leak. }
SrcCycleLeak = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
type
TNode = class
Other: TNode;
@@ -222,7 +204,7 @@ const
line number where the leaking TBox.Create() call was made. }
SrcLeakWithSite = '''
program LeakSite;
- uses runtime.arc;
+ uses blaise_arc;
type
TBox = class
Value: Integer;
@@ -240,7 +222,7 @@ const
Extra AddRef prevents scope-exit release from freeing it. }
SrcStringLeak = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
var
S: string;
begin
@@ -253,7 +235,7 @@ const
{ Clean string usage: no leak expected — scope-exit ARC releases properly. }
SrcStringClean = '''
program P;
- uses runtime.arc;
+ uses blaise_arc;
var
S: string;
begin
@@ -315,7 +297,7 @@ const
allocation site as 'generics.collections:', not ':'. }
SrcGenericAllocSite = '''
program LeakGen;
- uses runtime.arc, generics.collections;
+ uses blaise_arc, generics.collections;
var
L: TList;
E: TListEnumerator;
@@ -530,35 +512,6 @@ const
end.
''';
- { A function returning a class leaves Result at +1 (the callee's `Result := x`
- AddRef'd and the epilogue did not release it). Assigning that call result to
- a local consumes the transferred reference — the assignment site must NOT
- AddRef again, or one object leaks per call. The native backend used to
- AddRef class assignments unconditionally; this pins the elision. }
- SrcFuncReturnAssign = '''
- program P;
- type
- TThing = class N: Integer; end;
- function MakeThing(): TThing;
- begin
- Result := TThing.Create();
- Result.N := 9;
- end;
- var
- T: TThing;
- I, Sum: Integer;
- begin
- Sum := 0;
- for I := 1 to 100 do
- begin
- T := MakeThing();
- Sum := Sum + T.N;
- T := nil;
- end;
- WriteLn(Sum);
- end.
- ''';
-
SrcMultiHandlerVar = '''
program P;
type
@@ -597,24 +550,6 @@ begin
AssertTrue('no leak report (native)', Pos('leak', Output) < 0);
end;
-procedure TE2ELeakCheckTests.TestDebug_FuncReturnAssign_NoLeak;
-var
- Output: string;
- ExitCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run (qbe)',
- CompileAndRunWithRTLDebugOn(beQBE, SrcFuncReturnAssign, Output, ExitCode, True));
- AssertEquals('exit 0 (qbe)', 0, ExitCode);
- AssertEquals('stdout (qbe)', '900' + LE, Output);
- AssertTrue('no leak report (qbe)', Pos('leak', Output) < 0);
- AssertTrue('compile+run (native)',
- CompileAndRunWithRTLDebugOn(beNative, SrcFuncReturnAssign, Output, ExitCode, True));
- AssertEquals('exit 0 (native)', 0, ExitCode);
- AssertEquals('stdout (native)', '900' + LE, Output);
- AssertTrue('no leak report (native)', Pos('leak', Output) < 0);
-end;
-
procedure TE2ELeakCheckTests.TestDebug_MultiHandlerVar_NoOverRelease;
var
Output: string;
@@ -692,153 +627,6 @@ begin
AssertTrue('no leak report, got: ' + Output, Pos('leak', Output) < 0);
end;
-const
- { Call result used as a field-access receiver — the getter's +1 must be
- released after the field read, otherwise one object leaks per access.
- Uses TList[I].HitPoints which is the most common trigger. }
- SrcReceiverFieldAccess = '''
- program P;
- type
- TCreature = class
- HitPoints: Integer;
- end;
- function MakeCreature(): TCreature;
- begin
- Result := TCreature.Create();
- Result.HitPoints := 42;
- end;
- var
- X: Integer;
- begin
- X := MakeCreature().HitPoints;
- WriteLn(X);
- end.
- ''';
-
- { Static array of interfaces: three IGreet elements stored into a local
- array[0..2]. Scope-exit cleanup must release each element. Prints the
- three greetings, then exits with no leak report. }
- SrcStaticArrayOfInterface = '''
- program P;
- type
- IGreet = interface
- function Name(): string;
- end;
- TGreet = class(IGreet)
- FName: string;
- function Name(): string;
- end;
- function TGreet.Name(): string;
- begin
- Result := Self.FName;
- end;
- procedure MakeInto(var G: IGreet; const N: string);
- var
- T: TGreet;
- begin
- T := TGreet.Create();
- T.FName := N;
- G := T;
- end;
- procedure Run();
- var
- Arr: array[0..2] of IGreet;
- I: Integer;
- begin
- MakeInto(Arr[0], 'a');
- MakeInto(Arr[1], 'b');
- MakeInto(Arr[2], 'c');
- for I := 0 to 2 do
- Write(Arr[I].Name());
- WriteLn('');
- end;
- begin
- Run();
- end.
- ''';
-
- { A string-returning getter used directly as a WriteLn argument. The getter
- returns a fresh +1 string (Copy result); WriteLn only borrows it, so the
- caller must release it after the write. Three calls => three leaks before
- the fix. }
- SrcWriteLnCallArg = '''
- program P;
- type
- TFoo = class
- private
- function GetBar: String;
- public
- property Bar: String read GetBar;
- end;
- function TFoo.GetBar: String;
- begin
- Result := Copy('abcd', 1, 3);
- end;
- var
- X: TFoo;
- begin
- X := TFoo.Create;
- WriteLn(X.Bar);
- WriteLn(X.Bar);
- WriteLn(X.Bar);
- X := nil;
- end.
- ''';
-
-procedure TE2ELeakCheckTests.TestDebug_ReceiverFieldAccess_NoLeak;
-var
- Output: string;
- ExitCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run (qbe)',
- CompileAndRunWithRTLDebugOn(beQBE, SrcReceiverFieldAccess, Output, ExitCode, True));
- AssertEquals('exit 0 (qbe)', 0, ExitCode);
- AssertEquals('stdout (qbe)', '42' + LE, Output);
- AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
- AssertTrue('compile+run (native)',
- CompileAndRunWithRTLDebugOn(beNative, SrcReceiverFieldAccess, Output, ExitCode, True));
- AssertEquals('exit 0 (native)', 0, ExitCode);
- AssertEquals('stdout (native)', '42' + LE, Output);
- AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
-end;
-
-procedure TE2ELeakCheckTests.TestDebug_StaticArrayOfInterface_NoLeak;
-var
- Output: string;
- ExitCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run (qbe)',
- CompileAndRunWithRTLDebugOn(beQBE, SrcStaticArrayOfInterface, Output, ExitCode, True));
- AssertEquals('exit 0 (qbe)', 0, ExitCode);
- AssertEquals('stdout (qbe)', 'abc' + LE, Output);
- AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
- AssertTrue('compile+run (native)',
- CompileAndRunWithRTLDebugOn(beNative, SrcStaticArrayOfInterface, Output, ExitCode, True));
- AssertEquals('exit 0 (native)', 0, ExitCode);
- AssertEquals('stdout (native)', 'abc' + LE, Output);
- AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
-end;
-
-procedure TE2ELeakCheckTests.TestDebug_WriteLnCallArg_NoLeak;
-var
- Output: string;
- ExitCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run (qbe)',
- CompileAndRunWithRTLDebugOn(beQBE, SrcWriteLnCallArg, Output, ExitCode, True));
- AssertEquals('exit 0 (qbe)', 0, ExitCode);
- AssertEquals('stdout (qbe)', 'bcd' + LE + 'bcd' + LE + 'bcd' + LE, Output);
- AssertTrue('no leak report (qbe), got: ' + Output, Pos('leak', Output) < 0);
- AssertTrue('compile+run (native)',
- CompileAndRunWithRTLDebugOn(beNative, SrcWriteLnCallArg, Output, ExitCode, True));
- AssertEquals('exit 0 (native)', 0, ExitCode);
- AssertEquals('stdout (native)', 'bcd' + LE + 'bcd' + LE + 'bcd' + LE, Output);
- AssertTrue('no leak report (native), got: ' + Output, Pos('leak', Output) < 0);
-end;
-
initialization
RegisterTest(TE2ELeakCheckTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.misc.pas b/compiler/src/test/pascal/cp.test.e2e.misc.pas
index e0b29d3..d16980f 100644
--- a/compiler/src/test/pascal/cp.test.e2e.misc.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.misc.pas
@@ -42,25 +42,6 @@ type
{ Procedural types }
procedure TestRun_ProcType_CallViaVariable;
procedure TestRun_ProcType_OfObject_Dispatch;
- { Procedural-typed class field called through a receiver (Self.FFn(...)). }
- procedure TestRun_ProcFieldCall_ReturnValue;
- procedure TestRun_ProcFieldCall_Statement;
- procedure TestRun_ProcFieldCall_OutParam;
- procedure TestRun_ProcFieldCall_MultiArg;
- { Method-pointer (of object) field: assign @Obj.Method into a field, then
- dispatch through it — exercises the 16-byte (Code, Data) field store. }
- procedure TestRun_MethodPtrField_AssignAndCall;
- { Capturing @Obj.VirtualMethod must bind the receiver's dynamic override,
- not the statically-resolved declared-type method. }
- procedure TestRun_MethodPtrVirtualCapture_Var;
- procedure TestRun_MethodPtrVirtualCapture_Field;
- procedure TestRun_MethodPtrReturn;
- procedure TestRun_MethodPtrReturn_ReadsSelf;
- procedure TestRun_MethodPtrImplicitSelfFieldAssign;
- { Unqualified call to a procedural-typed field via implicit Self (FFn(...)
- with no 'Self.' prefix), as an expression and as a statement. }
- procedure TestRun_ImplicitSelfProcField_Expr;
- procedure TestRun_ImplicitSelfProcField_Stmt;
{ Default parameters }
procedure TestRun_DefaultParam_OmitLast;
@@ -88,26 +69,6 @@ type
{ Nested procedures }
procedure TestRun_NestedProc_MutatesCapturedVar;
- { Nested proc captures an outer VAR RECORD PARAMETER (read + write through
- the var-param fields). Previously the nested proc emitted the parameter
- as a global symbol reference and the program failed to link / ran wrong. }
- procedure TestRun_NestedProc_CapturesVarRecordParam;
- { Nested proc captures an outer plain LOCAL record (field read + write). }
- procedure TestRun_NestedProc_CapturesLocalRecord;
- { Nested proc captures an outer VAR ARRAY PARAMETER (element read + write).
- The captured var-param array slot is reached through the _cap_ pointer
- with one extra dereference; without it the element address resolved to a
- global symbol and the writes/reads hit the wrong storage. }
- procedure TestRun_NestedProc_CapturesVarArrayParam;
- { Two sibling outer routines each declare a same-named nested function.
- Each call must resolve to the nested function of its own enclosing
- routine. Previously the call fell through to the global overload index
- (which does not list nested procs) and errored with "Cannot find
- declaration". }
- procedure TestRun_NestedProc_SiblingSameName_ResolvesPerScope;
- { As above but the enclosing routines are METHODS. Nested-in-method
- functions must be scoped to their method body, not registered globally. }
- procedure TestRun_NestedFunc_InSiblingMethods_ResolvesPerScope;
{ Diamond operator: TFoo<> infers type args from LHS }
procedure TestRun_Diamond_SingleArg_WorksAtRuntime;
@@ -363,337 +324,11 @@ const
Obj := TFoo.Create();
Obj.FVal := 55;
M := @Obj.Print;
- M();
+ M;
Obj.Free()
end.
''';
- { Function-pointer class field called through a receiver, as an expression. }
- SrcProcFieldReturn = '''
- program Prg;
- type
- TFn = function(const S: string): Integer;
- TBox = class
- FFn: TFn;
- function Run(const S: string): Integer;
- end;
- function Len2(const S: string): Integer;
- begin Result := Length(S) end;
- function TBox.Run(const S: string): Integer;
- begin Result := Self.FFn(S) end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Len2;
- WriteLn(IntToStr(B.Run('hello')));
- B.Free()
- end.
- ''';
-
- { Function-pointer class field called as a statement. }
- SrcProcFieldStmt = '''
- program Prg;
- type
- TFn = procedure(const S: string);
- TBox = class
- FFn: TFn;
- procedure Run;
- end;
- procedure Hi(const S: string);
- begin WriteLn(S) end;
- procedure TBox.Run;
- begin Self.FFn('hi') end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Hi;
- B.Run();
- B.Free()
- end.
- ''';
-
- { Function-pointer class field with an out parameter — the argument must be
- passed by reference so the callee writes back into the caller's variable. }
- SrcProcFieldOut = '''
- program Prg;
- type
- TFn = function(const S: string; out V: string): Boolean;
- TBox = class
- FFn: TFn;
- function Run(const S: string): string;
- end;
- function Echo(const S: string; out V: string): Boolean;
- begin V := S; Result := True end;
- function TBox.Run(const S: string): string;
- var V: string;
- begin
- if Self.FFn(S, V) then Result := V else Result := '?'
- end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Echo;
- WriteLn(B.Run('hi'));
- B.Free()
- end.
- ''';
-
- { Function-pointer class field with several value arguments. }
- SrcProcFieldMultiArg = '''
- program Prg;
- type
- TFn = function(A, B, C: Integer): Integer;
- TBox = class
- FFn: TFn;
- function Run(X: Integer): Integer;
- end;
- function Sum3(A, B, C: Integer): Integer;
- begin Result := A + B + C end;
- function TBox.Run(X: Integer): Integer;
- begin Result := Self.FFn(X, X + 1, X + 2) end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Sum3;
- WriteLn(IntToStr(B.Run(10)));
- B.Free()
- end.
- ''';
-
- { Method-pointer (of object) class field: capture @Obj.Method into a field
- and call through it. The capture stores a 16-byte (Code, Data) pair. }
- SrcMethodPtrField = '''
- program Prg;
- type
- TEvt = procedure(const S: string) of object;
- TSrc = class
- Tag: string;
- procedure Handle(const S: string);
- end;
- TBox = class
- FEvt: TEvt;
- procedure Fire(const S: string);
- end;
- procedure TSrc.Handle(const S: string);
- begin WriteLn(Self.Tag, ':', S) end;
- procedure TBox.Fire(const S: string);
- begin Self.FEvt(S) end;
- var B: TBox; S: TSrc;
- begin
- S := TSrc.Create(); S.Tag := 'T';
- B := TBox.Create();
- B.FEvt := @S.Handle;
- B.Fire('hello');
- B.Free();
- S.Free()
- end.
- ''';
-
- { Method-pointer capture of a VIRTUAL method through a base-typed variable:
- A is declared TAnimal but holds a TDog, so @A.Speak must capture TDog's
- override (print 'dog'), resolving the Code half through A's vtable rather
- than freezing the declared type's TAnimal.Speak. }
- SrcMethodPtrVirtualCaptureVar = '''
- program Prg;
- type
- TSpeak = procedure of object;
- TAnimal = class
- procedure Speak; virtual;
- end;
- TDog = class(TAnimal)
- procedure Speak; override;
- end;
- procedure TAnimal.Speak;
- begin WriteLn('animal') end;
- procedure TDog.Speak;
- begin WriteLn('dog') end;
- var A: TAnimal; M: TSpeak;
- begin
- A := TDog.Create();
- M := @A.Speak;
- M();
- A.Free()
- end.
- ''';
-
- { Same dynamic-dispatch capture, but stored into a class FIELD rather than a
- local variable — exercises the field-destination assignment path. }
- SrcMethodPtrVirtualCaptureField = '''
- program Prg;
- type
- TSpeak = procedure of object;
- TAnimal = class
- procedure Speak; virtual;
- end;
- TDog = class(TAnimal)
- procedure Speak; override;
- end;
- TBox = class
- M: TSpeak;
- end;
- procedure TAnimal.Speak;
- begin WriteLn('animal') end;
- procedure TDog.Speak;
- begin WriteLn('dog') end;
- var A: TAnimal; B: TBox;
- begin
- A := TDog.Create();
- B := TBox.Create();
- B.M := @A.Speak;
- B.M();
- B.Free();
- A.Free()
- end.
- ''';
-
- { A method returning a 'function ... of object' value. The return is a
- 16-byte (Code, Data) aggregate; it must travel back by the two-register/
- sret record-return ABI rather than a scalar that drops the Data half.
- Op(3, 4) invokes the captured method pointer and must print 7. }
- SrcMethodPtrReturn = '''
- program Prg;
- type TBinOp = function(X, Y: Integer): Integer of object;
- type
- TCalc = class
- function Add(X, Y: Integer): Integer;
- function GetOp: TBinOp;
- end;
- function TCalc.Add(X, Y: Integer): Integer;
- begin Result := X + Y end;
- function TCalc.GetOp: TBinOp;
- begin Result := @Self.Add end;
- var C: TCalc; Op: TBinOp;
- begin
- C := TCalc.Create();
- Op := C.GetOp();
- WriteLn(Op(3, 4));
- C.Free()
- end.
- ''';
-
- { Method pointer whose RETURNED method READS an instance field (Self.Base).
- A method ptr is a 16-byte [Code; Data] aggregate; if a backend returns only
- the Code half the Data (Self) pointer is lost and the invoked method
- dereferences garbage — which it only observes when it actually uses Self.
- SrcMethodPtrReturn's Add(X,Y)=X+Y never touches Self, so it cannot catch
- that defect; this one does, on every backend. Also exercises a field
- destination (Self.FStored), a free-function method-ptr return, and an
- immediate invoke of the returned pointer (C.GetFn()(9)). }
- SrcMethodPtrReturnSelf = '''
- program Prg;
- type TFn = function(X: Integer): Integer of object;
- type
- TCalc = class
- Base: Integer;
- FStored: TFn;
- function AddBase(X: Integer): Integer;
- function GetFn: TFn;
- procedure StoreFn;
- function CallStored(X: Integer): Integer;
- end;
- function TCalc.AddBase(X: Integer): Integer;
- begin Result := Self.Base + X end;
- function TCalc.GetFn: TFn;
- begin Result := @Self.AddBase end;
- procedure TCalc.StoreFn;
- begin Self.FStored := Self.GetFn() end;
- function TCalc.CallStored(X: Integer): Integer;
- begin Result := Self.FStored(X) end;
- var GC: TCalc;
- function GetGlobalFn: TFn;
- begin Result := @GC.AddBase end;
- var C: TCalc; F: TFn;
- begin
- C := TCalc.Create();
- C.Base := 100;
- F := C.GetFn();
- WriteLn(F(7));
- C.StoreFn();
- WriteLn(C.CallStored(5));
- GC := C;
- F := GetGlobalFn();
- WriteLn(F(3));
- WriteLn(C.GetFn()(9));
- C.Free()
- end.
- ''';
-
- { Assigning @Self.Method to a bare (implicit-Self) method-pointer field:
- FFn := @Self.DoIt inside a method, with no 'Self.' on the LHS. DoIt reads
- another field through Self, so a wrong Data half (the bug) would crash or
- print garbage rather than 'T:x'. }
- SrcMethodPtrImplicitSelfFieldAssign = '''
- program Prg;
- type
- TProc = procedure(const S: string) of object;
- TA = class
- FName: string;
- FFn: TProc;
- procedure DoIt(const S: string);
- procedure Fire;
- end;
- procedure TA.DoIt(const S: string);
- begin WriteLn(FName + ':' + S) end;
- procedure TA.Fire;
- begin
- FFn := @Self.DoIt;
- FFn('x')
- end;
- var A: TA;
- begin
- A := TA.Create();
- A.FName := 'T';
- A.Fire();
- A.Free()
- end.
- ''';
-
- { Unqualified (implicit-Self) call to a procedural-typed field, as an
- expression — FFn(...) with no 'Self.' prefix. }
- SrcImplicitProcFieldExpr = '''
- program Prg;
- type
- TFn = function(A, B, C: Integer): Integer;
- TBox = class
- FFn: TFn;
- function Run(X: Integer): Integer;
- end;
- function Sum3(A, B, C: Integer): Integer;
- begin Result := A + B + C end;
- function TBox.Run(X: Integer): Integer;
- begin Result := FFn(X, X + 1, X + 2) end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Sum3;
- WriteLn(IntToStr(B.Run(10)));
- B.Free()
- end.
- ''';
-
- { Unqualified (implicit-Self) call to a procedural-typed field, as a
- statement. }
- SrcImplicitProcFieldStmt = '''
- program Prg;
- type
- TFn = procedure(const S: string);
- TBox = class
- FFn: TFn;
- procedure Run;
- end;
- procedure Hi(const S: string);
- begin WriteLn(S) end;
- procedure TBox.Run;
- begin FFn('hi') end;
- var B: TBox;
- begin
- B := TBox.Create();
- B.FFn := @Hi;
- B.Run();
- B.Free()
- end.
- ''';
-
SrcDefaultParam = '''
program Prg;
function Add(A: Integer; B: Integer = 10): Integer;
@@ -1011,81 +646,6 @@ begin
AssertEquals('55', '55' + LE, Output);
end;
-procedure TE2EMiscTests.TestRun_ProcFieldCall_ReturnValue;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcProcFieldReturn, '5' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_ProcFieldCall_Statement;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcProcFieldStmt, 'hi' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_ProcFieldCall_OutParam;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcProcFieldOut, 'hi' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_ProcFieldCall_MultiArg;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcProcFieldMultiArg, '33' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrField_AssignAndCall;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcMethodPtrField, 'T:hello' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Var;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcMethodPtrVirtualCaptureVar, 'dog' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrVirtualCapture_Field;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcMethodPtrVirtualCaptureField, 'dog' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrReturn;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcMethodPtrReturn, '7' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrReturn_ReadsSelf;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { 107, 105, 103, 109 — each line proves the Data (Self) half of the returned
- 16-byte method pointer survived: AddBase reads Self.Base (100). }
- AssertRunsOnAll(SrcMethodPtrReturnSelf,
- '107' + LE + '105' + LE + '103' + LE + '109' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_MethodPtrImplicitSelfFieldAssign;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcMethodPtrImplicitSelfFieldAssign, 'T:x' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Expr;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcImplicitProcFieldExpr, '33' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_ImplicitSelfProcField_Stmt;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcImplicitProcFieldStmt, 'hi' + LE, 0);
-end;
-
procedure TE2EMiscTests.TestRun_DefaultParam_OmitLast;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
@@ -1199,11 +759,11 @@ const
begin
x := 5;
WriteLn(IntToStr(x));
- Inner();
+ Inner;
WriteLn(IntToStr(x))
end;
begin
- Outer()
+ Outer
end.
''';
var Output: string; RCode: Integer;
@@ -1215,162 +775,6 @@ begin
'5' + LE + '15' + LE + '15' + LE, Output);
end;
-procedure TE2EMiscTests.TestRun_NestedProc_SiblingSameName_ResolvesPerScope;
-const
- Src =
- '''
- program Prg;
- procedure First;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 1
- end;
- begin
- WriteLn(IntToStr(Helper(10)))
- end;
- procedure Second;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 2
- end;
- begin
- WriteLn(IntToStr(Helper(20)))
- end;
- begin
- First();
- Second()
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- AssertEquals('exit code 0', 0, RCode);
- AssertEquals('First.Helper(10)=11, Second.Helper(20)=22',
- '11' + LE + '22' + LE, Output);
-end;
-
-procedure TE2EMiscTests.TestRun_NestedFunc_InSiblingMethods_ResolvesPerScope;
-const
- Src =
- '''
- program Prg;
- type
- TFoo = class
- procedure MethodA;
- procedure MethodB;
- end;
- procedure TFoo.MethodA;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 1
- end;
- begin
- WriteLn(IntToStr(Helper(10)))
- end;
- procedure TFoo.MethodB;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 2
- end;
- begin
- WriteLn(IntToStr(Helper(20)))
- end;
- var F: TFoo;
- begin
- F := TFoo.Create;
- F.MethodA();
- F.MethodB()
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRun(Src, Output, RCode));
- AssertEquals('exit code 0', 0, RCode);
- AssertEquals('MethodA.Helper(10)=11, MethodB.Helper(20)=22',
- '11' + LE + '22' + LE, Output);
-end;
-
-procedure TE2EMiscTests.TestRun_NestedProc_CapturesVarRecordParam;
-const
- Src =
- '''
- program Prg;
- type TRec = record A, B: Integer; end;
- procedure Outer(var R: TRec);
- procedure Inner;
- var Sum: Integer;
- begin
- Sum := R.A + R.B;
- R.A := Sum;
- R.B := Sum * 2
- end;
- begin
- Inner()
- end;
- var Rec: TRec;
- begin
- Rec.A := 3; Rec.B := 4;
- Outer(Rec);
- WriteLn(IntToStr(Rec.A), ' ', IntToStr(Rec.B))
- end.
- ''';
-begin
- AssertRunsOnAll(Src, '7 14' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_NestedProc_CapturesLocalRecord;
-const
- Src =
- '''
- program Prg;
- type TRec = record A, B: Integer; end;
- procedure Outer;
- var R: TRec;
- procedure Inner;
- begin
- R.A := R.A + 10;
- R.B := R.B + 20
- end;
- begin
- R.A := 1; R.B := 2;
- Inner();
- WriteLn(IntToStr(R.A), ' ', IntToStr(R.B))
- end;
- begin
- Outer()
- end.
- ''';
-begin
- AssertRunsOnAll(Src, '11 22' + LE, 0);
-end;
-
-procedure TE2EMiscTests.TestRun_NestedProc_CapturesVarArrayParam;
-const
- Src =
- '''
- program Prg;
- type TArr = array[0..2] of Integer;
- procedure Outer(var A: TArr);
- procedure Inner;
- begin
- A[0] := 10; A[1] := 20; A[2] := A[0] + A[1]
- end;
- begin
- Inner()
- end;
- var Ar: TArr;
- begin
- Ar[0] := 0; Ar[1] := 0; Ar[2] := 0;
- Outer(Ar);
- WriteLn(IntToStr(Ar[0]), ' ', IntToStr(Ar[1]), ' ', IntToStr(Ar[2]))
- end.
- ''';
-begin
- AssertRunsOnAll(Src, '10 20 30' + LE, 0);
-end;
-
procedure TE2EMiscTests.TestRun_Diamond_SingleArg_WorksAtRuntime;
const
Src = '''
diff --git a/compiler/src/test/pascal/cp.test.e2e.native.pas b/compiler/src/test/pascal/cp.test.e2e.native.pas
index c67728b..f4a8297 100644
--- a/compiler/src/test/pascal/cp.test.e2e.native.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.native.pas
@@ -386,10 +386,6 @@ type
{ Record value assigned into a record-typed field of the sret Result
must be a full ARC-aware copy, not an 8-byte pointer store. }
procedure TestRun_Native_SretResult_NestedRecordFieldAssign;
- { Regression: implicit-Self method calls whose Self+args exceed six integer
- registers must spill the overflow to the stack (the expression path used
- to abort codegen with 'arg register index 6 out of range'). }
- procedure TestRun_Native_ImplicitSelfCall_RegisterOverflow;
{ Subscripting a string-typed FIELD (Rec.S[I] / Obj.Data[I]) must be
0-based like every other Blaise subscript (regression: QBE
subtracted 1, native read garbage through the unhandled path). }
@@ -1226,7 +1222,7 @@ const
WriteLn(D)
end;
begin
- ShowDouble()
+ ShowDouble
end.
''';
@@ -1421,43 +1417,6 @@ const
end.
''';
- { Implicit-Self method calls whose register slots (Self + args) exceed the
- six System V integer registers must spill the overflow to the stack — the
- implicit-Self expression path previously aborted codegen. Covers a
- non-virtual call (Self + 8 args = 9 slots, 3 spilled) and a virtual/vtable
- call (Self + 7 args = 8 slots, 2 spilled); the values verify that every
- arg, including the spilled ones, arrives intact. }
- SrcImplicitSelfArgOverflow = '''
- program Prg;
- type
- TWorker = class
- function Sum8(a, b, c, d, e, f, g, h: Integer): Integer;
- function VSum7(a, b, c, d, e, f, g: Integer): Integer; virtual;
- function Drive(): string;
- end;
- function TWorker.Sum8(a, b, c, d, e, f, g, h: Integer): Integer;
- begin
- Result := a + b + c + d + e + f + g + h;
- end;
- function TWorker.VSum7(a, b, c, d, e, f, g: Integer): Integer;
- begin
- Result := a * 1 + b * 2 + c * 3 + d * 4 + e * 5 + f * 6 + g * 7;
- end;
- function TWorker.Drive(): string;
- begin
- WriteLn(Sum8(1, 2, 3, 4, 5, 6, 7, 8));
- WriteLn(VSum7(1, 1, 1, 1, 1, 1, 1));
- Result := 'ok';
- end;
- var
- W: TWorker;
- begin
- W := TWorker.Create();
- WriteLn(W.Drive());
- W.Free();
- end.
- ''';
-
const
SrcStringFieldCharRead = '''
program Prg;
@@ -1487,7 +1446,7 @@ const
WriteLn(B.Data[4]);
WriteLn(B.Data[I + 2]);
WriteLn(B.At(1));
- B.Free();
+ B.Free;
end.
''';
@@ -1513,13 +1472,6 @@ begin
'1' + LE + '5' + LE + '7' + LE + '70' + LE + 'x' + LE + '9' + LE, 0);
end;
-procedure TE2ENativeTests.TestRun_Native_ImplicitSelfCall_RegisterOverflow;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcImplicitSelfArgOverflow,
- '36' + LE + '28' + LE + 'ok' + LE, 0);
-end;
-
procedure TE2ENativeTests.TestRun_Native_EmptyProgram_ExitsZero;
begin
if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
@@ -2843,13 +2795,13 @@ const
end;
procedure Tmi.use;
begin
- im.print();
+ im.print;
end;
var
im: Tmi;
begin
im := Tmi.Create(Toutput.Create());
- im.use();
+ im.use;
end.
''';
@@ -3157,7 +3109,7 @@ const
destructor TThing.Destroy;
begin
WriteLn('destroyed');
- inherited Destroy()
+ inherited Destroy
end;
var O: TThing;
begin
@@ -3486,7 +3438,7 @@ const
destructor TVal.Destroy;
begin
WriteLn('destroyed');
- inherited Destroy()
+ inherited Destroy
end;
var
S: IVal;
@@ -3624,7 +3576,7 @@ const
destructor TGreeter.Destroy;
begin
WriteLn('greeter-gone');
- inherited Destroy()
+ inherited Destroy
end;
var
H: THolder;
@@ -3659,7 +3611,7 @@ const
destructor TInner.Destroy;
begin
WriteLn('inner-gone');
- inherited Destroy()
+ inherited Destroy
end;
var H: THolder;
begin
@@ -4966,7 +4918,7 @@ begin
begin
B := TBox.Create(99);
WriteLn(B.Val);
- B.Free()
+ B.Free
end.
''',
'99' + LE, 0);
@@ -4992,7 +4944,7 @@ begin
A := TArr.Create;
WriteLn(A.Items[0]);
WriteLn(A.Items[1]);
- A.Free()
+ A.Free
end.
''',
'10' + LE + '30' + LE, 0);
@@ -5018,7 +4970,7 @@ begin
B := TBox.Create;
B.Val := 42;
WriteLn(B.Val);
- B.Free()
+ B.Free
end.
''',
'42' + LE, 0);
@@ -5046,7 +4998,7 @@ begin
A.Items[1] := 30;
WriteLn(A.Items[0]);
WriteLn(A.Items[1]);
- A.Free()
+ A.Free
end.
''',
'10' + LE + '30' + LE, 0);
@@ -5062,7 +5014,7 @@ begin
begin
F := TFoo.Create;
WriteLn(F.ClassName);
- F.Free()
+ F.Free
end.
''',
'TFoo' + LE, 0);
@@ -5084,7 +5036,7 @@ begin
begin
Obj := TCalc.Create;
WriteLn(Obj.Sum6(1, 2, 3, 4, 5, 6));
- Obj.Free()
+ Obj.Free
end.
''',
'21' + LE, 0);
@@ -5109,8 +5061,8 @@ begin
O := TOuter.Create;
O.FInner := I;
WriteLn(O.GetVal());
- O.Free();
- I.Free()
+ O.Free;
+ I.Free
end.
''',
'42' + LE, 0);
@@ -5137,8 +5089,8 @@ begin
begin
O := TMyObj.Create;
O.FVal := 99;
- O.Show();
- O.Free()
+ O.Show;
+ O.Free
end.
''',
'99' + LE, 0);
@@ -5176,7 +5128,7 @@ begin
begin
B := TChild.Create;
WriteLn(B.GetVal());
- B.Free()
+ B.Free
end.
''',
'42' + LE, 0);
@@ -5322,7 +5274,7 @@ begin
procedure TCalc.Run;
begin
FVal := 5;
- Step();
+ Step;
WriteLn(FVal);
WriteLn(Double())
end;
@@ -5360,8 +5312,8 @@ begin
var P: TParser;
begin
P := TParser.Create();
- P.Setup();
- P.Advance();
+ P.Setup;
+ P.Advance;
WriteLn(P.FA.Kind, ':', P.FA.Value, ':', P.FA.Line, ':', P.FA.Col);
WriteLn(P.FB.Kind, ':', P.FB.Value, ':', P.FB.Line, ':', P.FB.Col);
P.Free()
diff --git a/compiler/src/test/pascal/cp.test.e2e.properties.pas b/compiler/src/test/pascal/cp.test.e2e.properties.pas
index b38b564..1c579e9 100644
--- a/compiler/src/test/pascal/cp.test.e2e.properties.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.properties.pas
@@ -35,17 +35,6 @@ type
procedure TestRun_DefaultProperty_ReadWrite;
procedure TestRun_DefaultProperty_StringElement;
procedure TestRun_DefaultProperty_Inherited;
- { Default array property read through a property-read result:
- Obj.Prop[I] where Prop returns a class carrying a default property. }
- procedure TestRun_DefaultProperty_ViaFieldBackedProperty;
- procedure TestRun_DefaultProperty_ViaMethodBackedProperty;
- { Write through a default array property on a member result:
- Obj.Field[I] := V and Obj.Prop[I] := V. }
- procedure TestRun_DefaultProperty_WriteThroughField;
- procedure TestRun_DefaultProperty_WriteThroughProperty;
- { Implicit-Self write/read: Field[I] := V / Field[I] inside a method, where
- Field is a class with a default array property. }
- procedure TestRun_DefaultProperty_WriteThroughImplicitSelf;
{ Static-array field accessed from inside a method (implicit Self). }
procedure TestRun_StaticArrayField_ReadInMethod;
procedure TestRun_StaticArrayField_WriteInMethod;
@@ -305,178 +294,6 @@ begin
AssertRunsOnAll(SrcDefaultInherited, '12' + LE, 0);
end;
-const
- { Obj.Prop[I] where Prop is a field-backed property returning a class with a
- default array property — reads through the property result. }
- SrcDefaultViaFieldProp = '''
- program P;
- type
- TVec = class
- FData: array[0..4] of Integer;
- function Get(i: Integer): Integer; begin Result := FData[i] end;
- procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
- property Items[i: Integer]: Integer read Get write Put; default;
- end;
- TOwner = class
- FVec: TVec;
- constructor Create;
- property Vec: TVec read FVec;
- end;
- constructor TOwner.Create;
- begin
- inherited Create();
- FVec := TVec.Create;
- FVec.Put(0, 3); FVec.Put(1, 4);
- end;
- var o: TOwner;
- begin
- o := TOwner.Create;
- WriteLn(o.Vec[0] + o.Vec[1]);
- o := nil
- end.
- ''';
-
- { Same, but Prop is a method-backed (getter) property. }
- SrcDefaultViaMethodProp = '''
- program P;
- type
- TVec = class
- FData: array[0..4] of Integer;
- function Get(i: Integer): Integer; begin Result := FData[i] end;
- procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
- property Items[i: Integer]: Integer read Get write Put; default;
- end;
- TOwner = class
- FVec: TVec;
- constructor Create;
- function GetVec: TVec; begin Result := FVec end;
- property Vec: TVec read GetVec;
- end;
- constructor TOwner.Create;
- begin
- inherited Create();
- FVec := TVec.Create;
- FVec.Put(0, 5); FVec.Put(1, 4);
- end;
- var o: TOwner;
- begin
- o := TOwner.Create;
- WriteLn(o.Vec[0] + o.Vec[1]);
- o := nil
- end.
- ''';
-
-procedure TE2EPropertyTests.TestRun_DefaultProperty_ViaFieldBackedProperty;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcDefaultViaFieldProp, '7' + LE, 0);
-end;
-
-procedure TE2EPropertyTests.TestRun_DefaultProperty_ViaMethodBackedProperty;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcDefaultViaMethodProp, '9' + LE, 0);
-end;
-
-const
- { Write through a class field's default property: Obj.Field[I] := V. }
- SrcDefaultWriteField = '''
- program P;
- type
- TVec = class
- FData: array[0..4] of Integer;
- function Get(i: Integer): Integer; begin Result := FData[i] end;
- procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
- property Items[i: Integer]: Integer read Get write Put; default;
- end;
- TOwner = class
- FVec: TVec;
- constructor Create;
- property Vec: TVec read FVec;
- end;
- constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
- var o: TOwner;
- begin
- o := TOwner.Create;
- o.FVec[0] := 3; o.FVec[1] := 4;
- WriteLn(o.Vec[0] + o.Vec[1]);
- o := nil
- end.
- ''';
-
- { Write through a read-only property's result default property:
- Obj.Prop[I] := V. }
- SrcDefaultWriteProp = '''
- program P;
- type
- TVec = class
- FData: array[0..4] of Integer;
- function Get(i: Integer): Integer; begin Result := FData[i] end;
- procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
- property Items[i: Integer]: Integer read Get write Put; default;
- end;
- TOwner = class
- FVec: TVec;
- constructor Create;
- property Vec: TVec read FVec;
- end;
- constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
- var o: TOwner;
- begin
- o := TOwner.Create;
- o.Vec[0] := 5; o.Vec[1] := 4;
- WriteLn(o.Vec[0] + o.Vec[1]);
- o := nil
- end.
- ''';
-
-procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughField;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcDefaultWriteField, '7' + LE, 0);
-end;
-
-procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughProperty;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcDefaultWriteProp, '9' + LE, 0);
-end;
-
-const
- { Implicit Self.Field[I] := V and Field[I] read, inside methods. }
- SrcDefaultWriteImplicitSelf = '''
- program P;
- type
- TVec = class
- FData: array[0..4] of Integer;
- function Get(i: Integer): Integer; begin Result := FData[i] end;
- procedure Put(i: Integer; v: Integer); begin FData[i] := v end;
- property Items[i: Integer]: Integer read Get write Put; default;
- end;
- TOwner = class
- FVec: TVec;
- constructor Create;
- procedure Fill;
- function Sum: Integer;
- end;
- constructor TOwner.Create; begin inherited Create(); FVec := TVec.Create end;
- procedure TOwner.Fill; begin FVec[0] := 3; FVec[1] := 4; end;
- function TOwner.Sum: Integer; begin Result := FVec[0] + FVec[1]; end;
- var o: TOwner;
- begin
- o := TOwner.Create;
- o.Fill();
- WriteLn(o.Sum());
- o := nil
- end.
- ''';
-
-procedure TE2EPropertyTests.TestRun_DefaultProperty_WriteThroughImplicitSelf;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcDefaultWriteImplicitSelf, '7' + LE, 0);
-end;
-
initialization
RegisterTest(TE2EPropertyTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.recordret.pas b/compiler/src/test/pascal/cp.test.e2e.recordret.pas
index cec4b12..45480f9 100644
--- a/compiler/src/test/pascal/cp.test.e2e.recordret.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.recordret.pas
@@ -97,14 +97,6 @@ type
procedure TestRun_ChainedRecvManyArgs;
procedure TestRun_ChainedRecvDoubleChain;
procedure TestRun_ChainedRecvManagedRecord_TDecimalLike;
- { Regression: a record-returning method assigned back into the SAME variable
- that is its receiver (M := M.Method(...)). The sret destination buffer
- would alias Self, so the callee wrote Result (== Self) while still reading
- Self — clobbering it mid-flight. Fix routes the call through a fresh temp
- and moves the result into the destination only after the call returns.
- Both backends; managed (string) and scalar fields both checked. }
- procedure TestRun_SelfAssignRecordMethod_ManagedField;
- procedure TestRun_SelfAssignRecordMethod_ScalarFields;
{ Regression: a record-returning method that takes an INTERFACE parameter.
An interface is a fat pointer (obj + itab) occupying TWO integer-register
slots, but the native sret/record call paths popped one register per
@@ -124,36 +116,6 @@ type
already fixed; this covers the free-function path. Both backends. }
procedure TestRun_InterfaceArg_FreeFunc_SretReturn;
procedure TestRun_InterfaceArg_FreeFunc_IntThenInterface;
- { Regression: an override that returns a record with a managed (string)
- field by value, sourced from `inherited`. The inherited call path
- dropped the hidden sret pointer and passed Self into the sret slot, so
- the base wrote its managed field over the Self object and _StringRelease
- ran on garbage → heap corruption / segfault. Both backends. Covers the
- assignment form (Result := inherited M()) and the implicit-Result
- statement form (inherited M;). }
- procedure TestRun_InheritedRecordReturn_ManagedField;
- procedure TestRun_InheritedRecordReturn_StatementForm;
- { Regression: reading the OFFSET-0 field of an sret function's own Result
- mid-body (read-modify) after assigning Result from a record-returning
- call. The native offset-0 field-read shortcut loaded the Result slot
- directly — but for an sret function that slot holds a POINTER to the
- record, so the buffer pointer was read as the field value (garbage).
- Offset>0 fields were fine (they always deref). Both backends. (The fix
- lives in the inline-asm commit; this test, from Andrew's parallel fix,
- locks it in.) }
- procedure TestRun_SretResult_ReadModifyOffsetZeroField;
- { Regression: calling a record-returning METHOD as a statement (result
- discarded) with no assignment target. The SysV sret ABI puts the sret
- pointer in %rdi and Self in %rsi, but without a buffer the callee wrote
- the record through Self, corrupting the object. Both backends. }
- procedure TestRun_DiscardedRecordReturn_ManagedField;
- { Same for a small record with only scalar fields (register-returned,
- not sret) — the return value goes to %rax and is harmlessly discarded,
- but we must verify codegen doesn't crash. }
- procedure TestRun_DiscardedRecordReturn_ScalarOnly;
- { Discarded record-returning call via an expression receiver
- (Obj.RecordMethod();). Tests the ObjExpr path. }
- procedure TestRun_DiscardedRecordReturn_ObjExprReceiver;
end;
implementation
@@ -671,7 +633,7 @@ const
K := TMaker.Create;
R := K.Make(0.25);
WriteLn(R.X);
- K.Free()
+ K.Free
end.
''';
begin
@@ -817,60 +779,6 @@ begin
AssertRunsOnAll(Src, '15' + LE + '25' + LE, 0);
end;
-procedure TE2ERecordReturnTests.TestRun_SelfAssignRecordMethod_ManagedField;
-const
- { Managed (string) field record method assigned back into its own receiver.
- The non-aliasing case (C := A.Up(B)) and the receiver staying intact after
- the self-assign are both checked as regression guards. }
- Src = '''
- program P;
- type
- TR = record
- S: string;
- function Up(const X: TR): TR;
- end;
- function TR.Up(const X: TR): TR;
- begin Result.S := Self.S + X.S end;
- var A, B, C: TR;
- begin
- A.S := 'a'; B.S := 'b';
- A := A.Up(B);
- WriteLn(A.S);
- C := A.Up(B);
- WriteLn(C.S);
- WriteLn(A.S)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, 'ab' + LE + 'abb' + LE + 'ab' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_SelfAssignRecordMethod_ScalarFields;
-const
- { Two-integer record (register-return class) self-assigned through its own
- receiver. }
- Src = '''
- program P;
- type
- TR = record
- A, B: Integer;
- function Add(const X: TR): TR;
- end;
- function TR.Add(const X: TR): TR;
- begin Result.A := Self.A + X.A; Result.B := Self.B + X.B end;
- var R, Q: TR;
- begin
- R.A := 1; R.B := 10; Q.A := 2; Q.B := 20;
- R := R.Add(Q);
- WriteLn(R.A, ' ', R.B)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, '3 30' + LE, 0);
-end;
-
{ ------------------------------------------------------------------ }
{ Record-returning method with an interface (fat-pointer) parameter }
{ ------------------------------------------------------------------ }
@@ -1013,212 +921,6 @@ begin
AssertRunsOnAll(Src, '12' + LE, 0);
end;
-procedure TE2ERecordReturnTests.TestRun_InheritedRecordReturn_ManagedField;
-const
- Src = '''
- program P;
- type
- TTok = record Kind: Integer; Value: string; Line: Integer; end;
- TBase = class
- function Next(N: Integer): TTok; virtual;
- end;
- TDeriv = class(TBase)
- function Next(N: Integer): TTok; override;
- end;
- function TBase.Next(N: Integer): TTok;
- begin
- Result.Kind := N;
- Result.Value := 'hello-world';
- Result.Line := 99
- end;
- function TDeriv.Next(N: Integer): TTok;
- begin
- Result := inherited Next(N)
- end;
- var D: TDeriv; T: TTok;
- begin
- D := TDeriv.Create();
- T := D.Next(7);
- WriteLn(T.Kind);
- WriteLn(T.Value);
- WriteLn(T.Line);
- D.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, '7' + LE + 'hello-world' + LE + '99' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_InheritedRecordReturn_StatementForm;
-const
- Src = '''
- program P;
- type
- TTok = record Kind: Integer; Value: string; end;
- TBase = class
- function Make(N: Integer): TTok; virtual;
- end;
- TDeriv = class(TBase)
- function Make(N: Integer): TTok; override;
- end;
- function TBase.Make(N: Integer): TTok;
- begin
- Result.Kind := N + 100;
- Result.Value := 'base'
- end;
- function TDeriv.Make(N: Integer): TTok;
- begin
- inherited Make(N)
- end;
- var D: TDeriv; T: TTok;
- begin
- D := TDeriv.Create();
- T := D.Make(5);
- WriteLn(T.Kind);
- WriteLn(T.Value);
- D.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { `inherited Make(N);` with no explicit assignment sets the override's
- Result through the sret pointer. }
- AssertRunsOnAll(Src, '105' + LE + 'base' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_SretResult_ReadModifyOffsetZeroField;
-const
- Src = '''
- program P;
- type TR = record A: Integer; S: string; B: Integer; end;
- function Raw(N: Integer): TR;
- begin
- Result.A := N;
- Result.S := 'hi';
- Result.B := 20
- end;
- function Make(N: Integer): TR;
- begin
- Result := Raw(N);
- Result.A := Result.A + 1
- end;
- var R: TR;
- begin
- R := Make(10);
- WriteLn(R.A, ' ', R.S, ' ', R.B)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { The string field forces a genuine sret return (24 bytes); reading
- Result.A (offset 0) mid-body must deref the Result pointer. }
- AssertRunsOnAll(Src, '11 hi 20' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ManagedField;
-const
- Src = '''
- program P;
- type
- TToken = record
- Kind: Integer;
- Value: string;
- end;
- TLexer = class
- FName: string;
- function Next(): TToken;
- function GetName(): string;
- end;
- function TLexer.Next(): TToken;
- begin
- Result.Kind := 42;
- Result.Value := 'hello'
- end;
- function TLexer.GetName(): string;
- begin
- Result := FName
- end;
- var L: TLexer;
- begin
- L := TLexer.Create();
- L.FName := 'mylex';
- L.Next();
- WriteLn(L.GetName());
- L.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, 'mylex' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ScalarOnly;
-const
- Src = '''
- program P;
- type
- TPoint = record X, Y: Integer; end;
- TObj = class
- function Pos(): TPoint;
- end;
- function TObj.Pos(): TPoint;
- begin
- Result.X := 10;
- Result.Y := 20
- end;
- var O: TObj;
- begin
- O := TObj.Create();
- O.Pos();
- WriteLn('ok');
- O.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, 'ok' + LE, 0);
-end;
-
-procedure TE2ERecordReturnTests.TestRun_DiscardedRecordReturn_ObjExprReceiver;
-const
- Src = '''
- program P;
- type
- TRec = record N: Integer; S: string; end;
- TFactory = class
- FTag: string;
- function Make(): TRec;
- function GetTag(): string;
- end;
- THolder = class
- F: TFactory;
- end;
- function TFactory.Make(): TRec;
- begin
- Result.N := 7;
- Result.S := 'test'
- end;
- function TFactory.GetTag(): string;
- begin
- Result := FTag
- end;
- var H: THolder;
- begin
- H := THolder.Create();
- H.F := TFactory.Create();
- H.F.FTag := 'mytag';
- H.F.Make();
- WriteLn(H.F.GetTag());
- H.F.Free();
- H.Free()
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(Src, 'mytag' + LE, 0);
-end;
-
initialization
RegisterTest(TE2ERecordReturnTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.records.pas b/compiler/src/test/pascal/cp.test.e2e.records.pas
index 2946982..43efd7b 100644
--- a/compiler/src/test/pascal/cp.test.e2e.records.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.records.pas
@@ -27,7 +27,6 @@ type
procedure TestRun_Record_PassByVar;
procedure TestRun_Record_AssignToVarParam;
procedure TestRun_Record_StringField_ARC;
- procedure TestRun_Record_VarToVarCopy_StringField_ARC;
procedure TestRun_Record_NestedRecord;
procedure TestRun_Record_FourByteFields_PackedAndRoundTrip;
procedure TestRun_Record_ByteThenInteger_RoundTrip;
@@ -645,42 +644,6 @@ begin
AssertEquals('Ada Lovelace', 'Ada Lovelace' + LE, Output);
end;
-const
- { Copying a record with a managed (string) field var-to-var (B := A) must
- field-copy with ARC: AddRef the source's string so the copy owns its own
- reference, and Release the destination's prior string. A bare memcpy left
- both records sharing one buffer at refcount 1 — mutating/churning the source
- then dropped it to 0 and freed it, so the copy held a dangling pointer
- (use-after-free → '_StringRelease double-free' abort). This is the same
- record-copy path TList.Get uses (Result := Src^), so it also fixes the
- generic-container crash. }
- SrcRecordVarToVarCopy = '''
- program Prg;
- type
- TPerson = record Name: string; Age: Integer; end;
- var
- A, B: TPerson;
- I: Integer;
- begin
- A.Name := 'Alice-' + IntToStr(42);
- A.Age := 30;
- B := A;
- A.Name := 'Bob';
- for I := 0 to 200 do
- A.Name := 'churn-' + IntToStr(I);
- WriteLn(B.Name, ' ', B.Age)
- end.
- ''';
-
-procedure TE2ERecordsTests.TestRun_Record_VarToVarCopy_StringField_ARC;
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRunWithRTL(SrcRecordVarToVarCopy, Output, RCode));
- AssertEquals('exit code 0', 0, RCode);
- AssertEquals('copy retained own string', 'Alice-42 30' + LE, Output);
-end;
-
procedure TE2ERecordsTests.TestRun_Record_NestedRecord;
var Output: string; RCode: Integer;
begin
@@ -967,7 +930,7 @@ const
var c: TC;
begin
c := TC.Create();
- c.Fill();
+ c.Fill;
writeln(c.A[0]);
writeln(c.A[1]);
writeln(c.A[2]);
diff --git a/compiler/src/test/pascal/cp.test.e2e.sepcompile.pas b/compiler/src/test/pascal/cp.test.e2e.sepcompile.pas
index ea82bec..4343fb4 100644
--- a/compiler/src/test/pascal/cp.test.e2e.sepcompile.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.sepcompile.pas
@@ -49,27 +49,6 @@ type
procedure TestDuplicateExternalAcrossUnits_Compiles;
procedure TestNativeIncremental_MultiUnitClass_Compiles;
procedure TestNativeNoIncremental_MultiUnitClass_Compiles;
- { Regression: a class declared in a unit's IMPLEMENTATION section (not its
- interface) was rejected at compile and never had its method bodies /
- typeinfo / vtable / _FieldCleanup emitted — both backends' unit-emission
- loops only walked IntfBlock.TypeDecls. The fix registers impl-section
- types unit-private, analyses their method bodies, and emits them
- alongside IntfBlock ones. }
- procedure TestNativeImplSectionClass_Compiles;
- procedure TestQBEImplSectionClass_Compiles;
- { Regression: an IMPLEMENTATION-section class referenced as a METACLASS value
- (class-of / `TFoo` used as a value) in the unit's OWN initialization block.
- Per-unit codegen left DefineOwningUnit pointing at a dependency unit by the
- time the init block was emitted, so the impl-section class symbol was
- suppressed by Lookup's cross-unit-leak guard and the metaclass ref mangled
- to a bare, undefined typeinfo symbol -> link-time garbage -> SIGSEGV.
- Both backends. }
- procedure TestNativeImplSectionMetaclassInInit_Runs;
- procedure TestQBEImplSectionMetaclassInInit_Runs;
- { Regression: a class declared in unit A's IMPLEMENTATION section must NOT
- be visible to an unrelated unit B that never `uses` A — it previously
- leaked through the flat global scope. }
- procedure TestImplSectionClass_DoesNotLeakCrossUnit;
{ Regression: compiling a UNIT (unit-mode, top source is a `unit`) that
USES another unit, with the default incremental path, segfaulted — the
incremental worker setup read Prog.SymbolTable, but in unit-mode Prog is
@@ -106,29 +85,7 @@ type
object's fields stayed nil. This crashed the stdlib JSON test suite
when its TTestCase base came from target/units. }
procedure TestIncrementalRebuild_VirtualCtorVtableSlot;
- { Regression (bugs.txt warm --unit-cache): a leaf class inherits a method
- from a GRANDPARENT class that lives in a different cached unit. On a
- warm rebuild the leaf unit recompiles from source while its ancestors
- load from cached .bif ifaces. A cross-unit parent is serialised in the
- .bif with its unit qualifier (e.g. `base.TBase`); the importer resolved
- the parent with a bare Lookup that missed the qualified name, leaving the
- intermediate class's Parent pointer nil — so the leaf's inherited-method
- walk dead-ended and reported "Undeclared procedure". }
- procedure TestIncrementalRebuild_QualifiedGrandparentMethod;
procedure TestDebugOpdf_PerUnitSection_InDependencyObject;
- { Regression (F1-followup cross-unit static members): a class with `static`
- members — a static var, a static method, and a static const — declared in
- one unit and used through the COMPILED .bif boundary from another unit.
- The wire format already encoded the static facts, but the export clone
- dropped TFieldDecl.IsClassVar/ClassVarEmitName, TMethodDecl.IsStatic and
- TPropertyDecl.IsStatic before encoding; the importer ignored them and the
- decoded ConstDecls; and TRoutineSig carried no IsStatic field at all. So
- a cross-unit TReg.Next() failed with "is not a static method", a static
- var did not register as a shared global, and TReg.Tag did not resolve.
- Driving through --unit-cache exercises the real .bif write+read path on
- both backends. }
- procedure TestStaticMembers_CrossUnit_QBE;
- procedure TestStaticMembers_CrossUnit_Native;
end;
implementation
@@ -659,375 +616,6 @@ begin
AssertEquals('use_shapes_ni stdout', 'shape:box' + #10, Captured)
end;
-procedure TSepCompileTests.TestNativeImplSectionClass_Compiles;
-{ A class declared entirely in a unit's IMPLEMENTATION section, used by an
- interface-exported routine of that unit. The unit object must emit the
- class's method bodies, typeinfo, vtable and _FieldCleanup so the call site
- links. Native default (incremental) path. }
-const
- UnitSrc =
- '''
- unit ImplCls;
- interface
- function MakeAndGet: Integer;
- implementation
- type
- TFoo = class
- FX: Integer;
- constructor Create(AX: Integer);
- function GetX: Integer;
- end;
- constructor TFoo.Create(AX: Integer);
- begin FX := AX end;
- function TFoo.GetX: Integer;
- begin Result := FX end;
- function MakeAndGet: Integer;
- var F: TFoo;
- begin
- F := TFoo.Create(7);
- Result := F.GetX();
- F.Free()
- end;
- end.
- ''';
- ProgSrc =
- '''
- program UseImplCls;
- uses ImplCls;
- begin
- WriteLn(MakeAndGet())
- end.
- ''';
-var
- UnitPas, ProgPas, ProgBin: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/ImplCls.pas';
- ProgPas := FScratch + '/use_implcls.pas';
- ProgBin := FScratch + '/use_implcls';
-
- WriteFile(UnitPas, UnitSrc);
- WriteFile(ProgPas, ProgSrc);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'native',
- '--unit-path', FScratch], Captured);
- AssertEquals('blaise(use_implcls) exit code (out: ' + Captured + ')', 0, Rc);
- AssertTrue('use_implcls exists', FileExists(ProgBin));
-
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('use_implcls exit code', 0, Rc);
- AssertEquals('use_implcls stdout', '7' + #10, Captured)
-end;
-
-procedure TSepCompileTests.TestQBEImplSectionClass_Compiles;
-{ Same as TestNativeImplSectionClass_Compiles but forces the QBE backend —
- the QBE unit-emission loop (AppendUnit) must also walk ImplBlock classes. }
-const
- UnitSrc =
- '''
- unit ImplClsQ;
- interface
- function MakeAndGet: Integer;
- implementation
- type
- TFoo = class
- FX: Integer;
- constructor Create(AX: Integer);
- function GetX: Integer;
- end;
- constructor TFoo.Create(AX: Integer);
- begin FX := AX end;
- function TFoo.GetX: Integer;
- begin Result := FX end;
- function MakeAndGet: Integer;
- var F: TFoo;
- begin
- F := TFoo.Create(7);
- Result := F.GetX();
- F.Free()
- end;
- end.
- ''';
- ProgSrc =
- '''
- program UseImplClsQ;
- uses ImplClsQ;
- begin
- WriteLn(MakeAndGet())
- end.
- ''';
-var
- UnitPas, ProgPas, ProgBin: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/ImplClsQ.pas';
- ProgPas := FScratch + '/use_implclsq.pas';
- ProgBin := FScratch + '/use_implclsq';
-
- WriteFile(UnitPas, UnitSrc);
- WriteFile(ProgPas, ProgSrc);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'qbe',
- '--unit-path', FScratch], Captured);
- AssertEquals('blaise(use_implclsq) exit code (out: ' + Captured + ')', 0, Rc);
- AssertTrue('use_implclsq exists', FileExists(ProgBin));
-
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('use_implclsq exit code', 0, Rc);
- AssertEquals('use_implclsq stdout', '7' + #10, Captured)
-end;
-
-procedure TSepCompileTests.TestNativeImplSectionMetaclassInInit_Runs;
-{ The unit's INITIALIZATION block references an impl-section class as a metaclass
- value (assigns the class to a `class of` global). Before the
- DefineOwningUnit re-assertion fix, per-unit codegen emitted that metaclass ref
- under a bare, undefined `typeinfo_` symbol, linking to garbage and
- crashing at runtime. Native (default) path. }
-const
- UnitSrc =
- '''
- unit ImplMetaN;
- interface
- function MakeViaMeta: Integer;
- implementation
- type
- TFoo = class
- FX: Integer;
- constructor Create;
- function GetX: Integer;
- end;
- TFooClass = class of TFoo;
- var
- GCls: TFooClass;
- constructor TFoo.Create;
- begin FX := 42 end;
- function TFoo.GetX: Integer;
- begin Result := FX end;
- function MakeViaMeta: Integer;
- var F: TFoo;
- begin
- F := GCls.Create();
- Result := F.GetX();
- F.Free()
- end;
- initialization
- GCls := TFoo;
- end.
- ''';
- ProgSrc =
- '''
- program UseImplMetaN;
- uses ImplMetaN;
- begin
- WriteLn(MakeViaMeta())
- end.
- ''';
-var
- UnitPas, ProgPas, ProgBin: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/ImplMetaN.pas';
- ProgPas := FScratch + '/use_implmetan.pas';
- ProgBin := FScratch + '/use_implmetan';
-
- WriteFile(UnitPas, UnitSrc);
- WriteFile(ProgPas, ProgSrc);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'native',
- '--unit-path', FScratch], Captured);
- AssertEquals('blaise(use_implmetan) exit code (out: ' + Captured + ')', 0, Rc);
- AssertTrue('use_implmetan exists', FileExists(ProgBin));
-
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('use_implmetan exit code', 0, Rc);
- AssertEquals('use_implmetan stdout', '42' + #10, Captured)
-end;
-
-procedure TSepCompileTests.TestQBEImplSectionMetaclassInInit_Runs;
-{ Same as TestNativeImplSectionMetaclassInInit_Runs but forces the QBE backend. }
-const
- UnitSrc =
- '''
- unit ImplMetaQ;
- interface
- function MakeViaMeta: Integer;
- implementation
- type
- TFoo = class
- FX: Integer;
- constructor Create;
- function GetX: Integer;
- end;
- TFooClass = class of TFoo;
- var
- GCls: TFooClass;
- constructor TFoo.Create;
- begin FX := 42 end;
- function TFoo.GetX: Integer;
- begin Result := FX end;
- function MakeViaMeta: Integer;
- var F: TFoo;
- begin
- F := GCls.Create();
- Result := F.GetX();
- F.Free()
- end;
- initialization
- GCls := TFoo;
- end.
- ''';
- ProgSrc =
- '''
- program UseImplMetaQ;
- uses ImplMetaQ;
- begin
- WriteLn(MakeViaMeta())
- end.
- ''';
-var
- UnitPas, ProgPas, ProgBin: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/ImplMetaQ.pas';
- ProgPas := FScratch + '/use_implmetaq.pas';
- ProgBin := FScratch + '/use_implmetaq';
-
- WriteFile(UnitPas, UnitSrc);
- WriteFile(ProgPas, ProgSrc);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'qbe',
- '--unit-path', FScratch], Captured);
- AssertEquals('blaise(use_implmetaq) exit code (out: ' + Captured + ')', 0, Rc);
- AssertTrue('use_implmetaq exists', FileExists(ProgBin));
-
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('use_implmetaq exit code', 0, Rc);
- AssertEquals('use_implmetaq stdout', '42' + #10, Captured)
-end;
-
-procedure TSepCompileTests.TestImplSectionClass_DoesNotLeakCrossUnit;
-{ A class declared in unit A's IMPLEMENTATION section is private to A. A second
- unit B that never `uses` A must NOT see it — referencing it must be a compile
- error, not a silent success via the flat global scope. (Both A and B sit on
- the same unit path, so before the fix B resolved A's impl class by leak.) }
-const
- UnitASrc =
- '''
- unit LeakA;
- interface
- procedure Noop;
- implementation
- type
- TPrivate = class
- V: Integer;
- end;
- procedure Noop; begin end;
- end.
- ''';
- UnitBSrc =
- '''
- unit LeakB;
- interface
- function Use: Integer;
- implementation
- function Use: Integer;
- var X: TPrivate; // LeakB does NOT use LeakA — must be unknown
- begin
- X := TPrivate.Create();
- Result := X.V;
- X.Free()
- end;
- end.
- ''';
- ProgSrc =
- '''
- program UseLeak;
- uses LeakA, LeakB;
- begin
- WriteLn(Use())
- end.
- ''';
-var
- UnitAPas, UnitBPas, ProgPas, ProgBin: string;
- Captured: string;
- Rc: Integer;
-begin
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitAPas := FScratch + '/LeakA.pas';
- UnitBPas := FScratch + '/LeakB.pas';
- ProgPas := FScratch + '/use_leak.pas';
- ProgBin := FScratch + '/use_leak';
-
- WriteFile(UnitAPas, UnitASrc);
- WriteFile(UnitBPas, UnitBSrc);
- WriteFile(ProgPas, ProgSrc);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'native',
- '--unit-path', FScratch], Captured);
- AssertTrue('compile must FAIL (impl-section class is unit-private), out: '
- + Captured, Rc <> 0);
- AssertTrue('error names the unknown type TPrivate, out: ' + Captured,
- Pos('TPrivate', Captured) >= 0)
-end;
-
procedure TSepCompileTests.TestNativeIncremental_UnitUsesUnit_Compiles;
{ Compile a UNIT that uses another unit, in unit-mode (--source .pas
--output .o), via the default incremental path. This is the runtime
@@ -1264,144 +852,6 @@ begin
AssertEquals('build2 stdout', '43' + #10, Captured)
end;
-procedure TSepCompileTests.TestIncrementalRebuild_QualifiedGrandparentMethod;
-const
- { Three-level chain mirroring TAssert->TTestCase->TE2ETestCase. Greet is
- defined on the grandparent TBase. CRITICAL: the grandparent unit has a
- DOTTED name (chain.base) — the trigger for this bug. A cross-unit parent
- is serialised in the .bif as `Unit.Type`; when the unit is dotted
- (chain.base.TBase) the decoder must split at the LAST dot. Splitting at
- the first dot yielded type='base.TBase', so the cached parent could not be
- relinked and the leaf's inherited-method walk dead-ended. }
- BaseSrc =
- '''
- unit chain.base;
- interface
- type
- TBase = class
- function Greet: Integer;
- end;
- implementation
- function TBase.Greet: Integer;
- begin Result := 7 end;
- end.
- ''';
- { TMid's parent TBase lives in the dotted unit chain.base, so chain.mid's
- .bif serialises the parent qualified as `chain.base.TBase`. }
- MidSrc =
- '''
- unit chain.mid;
- interface
- uses chain.base;
- type
- TMid = class(TBase)
- function MidOnly: Integer;
- end;
- implementation
- function TMid.MidOnly: Integer;
- begin Result := 1 end;
- end.
- ''';
- { Leaf unit: TLeaf inherits Greet from TBase via TMid (two cached units up).
- The marker comment is edited between builds to force a recompile-from-
- source of THIS unit while chain.base/chain.mid stay cached. }
- LeafSrc =
- '''
- unit chain.leaf;
- interface
- uses chain.mid;
- type
- TLeaf = class(TMid)
- function Run: Integer;
- end;
- implementation
- { rev 1 }
- function TLeaf.Run: Integer;
- begin Result := Greet() + MidOnly() end;
- end.
- ''';
- LeafSrc2 =
- '''
- unit chain.leaf;
- interface
- uses chain.mid;
- type
- TLeaf = class(TMid)
- function Run: Integer;
- end;
- implementation
- { rev 2 — edited to force recompile from source }
- function TLeaf.Run: Integer;
- begin Result := Greet() + MidOnly() end;
- end.
- ''';
- ProgSrc =
- '''
- program UseLeaf;
- uses chain.leaf;
- var L: TLeaf;
- begin
- L := TLeaf.Create();
- WriteLn(L.Run());
- L.Free()
- end.
- ''';
-var
- BasePas, MidPas, LeafPas, ProgPas, ProgBin, CacheDir: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- BasePas := FScratch + '/chain.base.pas';
- MidPas := FScratch + '/chain.mid.pas';
- LeafPas := FScratch + '/chain.leaf.pas';
- ProgPas := FScratch + '/use_leaf.pas';
- ProgBin := FScratch + '/use_leaf';
- CacheDir := FScratch + '/units-qgp';
-
- WriteFile(BasePas, BaseSrc);
- WriteFile(MidPas, MidSrc);
- WriteFile(LeafPas, LeafSrc);
- WriteFile(ProgPas, ProgSrc);
- ForceDirectories(CacheDir);
-
- { Build 1 (clean cache): all units from source; populates the cache. }
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('build1 exit code (out: ' + Captured + ')', 0, Rc);
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('build1 run exit code', 0, Rc);
- AssertEquals('build1 stdout', '8' + #10, Captured);
-
- { Edit the LEAF unit's content so build 2 recompiles it FROM SOURCE while
- BaseU and MidU load from their cached .bif/.o. The inherited Greet (on
- the cached grandparent TBase) must still resolve through MidU's
- qualified parent link. }
- WriteFile(LeafPas, LeafSrc2);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('build2 exit code — grandparent method must resolve (out: '
- + Captured + ')', 0, Rc);
- AssertTrue('use_leaf exists after rebuild', FileExists(ProgBin));
-
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('build2 run exit code', 0, Rc);
- AssertEquals('build2 stdout', '8' + #10, Captured)
-end;
-
{ Regression for the cached-unit virtual-constructor vtable-slot bug.
BaseU declares a class with a non-virtual constructor Create (which still
@@ -1598,140 +1048,6 @@ begin
Captured)
end;
-{ Shared source for the two cross-unit static-member tests below. RegModU
- declares a class with all three static member forms; the consuming program
- reaches them across the compiled .bif boundary. }
-const
- StaticRegModSrc =
- '''
- unit RegModU;
- interface
- type
- TReg = class
- private static var
- FCount: Integer;
- public
- static function Next: Integer;
- { Static property whose getter is a static method: exercises
- TPropertyDecl.IsStatic surviving the .bif round-trip (a non-static
- import would dispatch with a bogus Self). }
- static property Counter: Integer read Next;
- public static const
- Tag = 7;
- end;
- implementation
- static function TReg.Next: Integer;
- begin
- FCount := FCount + 1;
- Result := FCount;
- end;
- end.
- ''';
- StaticRegProgSrc =
- '''
- program UseReg;
- uses RegModU;
- begin
- WriteLn(TReg.Next());
- WriteLn(TReg.Next());
- WriteLn(TReg.Counter);
- WriteLn(TReg.Tag)
- end.
- ''';
-
-procedure TSepCompileTests.TestStaticMembers_CrossUnit_QBE;
-var
- UnitPas, ProgPas, ProgBin, CacheDir: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/RegModU.pas';
- ProgPas := FScratch + '/use_reg_qbe.pas';
- ProgBin := FScratch + '/use_reg_qbe';
- CacheDir := FScratch + '/units-static-qbe';
-
- WriteFile(UnitPas, StaticRegModSrc);
- WriteFile(ProgPas, StaticRegProgSrc);
- ForceDirectories(CacheDir);
-
- { Build 1 (clean cache): RegModU compiled from source, .o/.bif cached. }
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'qbe',
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('qbe build1 exit (out: ' + Captured + ')', 0, Rc);
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('qbe build1 run exit', 0, Rc);
- AssertEquals('qbe build1 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured);
-
- { Build 2 (warm cache): RegModU loaded purely from its cached .bif — the
- static facts must survive the .bif round-trip. }
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'qbe',
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('qbe build2 exit (out: ' + Captured + ')', 0, Rc);
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('qbe build2 run exit', 0, Rc);
- AssertEquals('qbe build2 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured)
-end;
-
-procedure TSepCompileTests.TestStaticMembers_CrossUnit_Native;
-var
- UnitPas, ProgPas, ProgBin, CacheDir: string;
- Captured: string;
- Rc: Integer;
-begin
- if not ToolchainAvailable() then
- begin
- Fail('toolchain missing — qbe or RTL not found');
- Exit
- end;
- if not FileExists(BlaisePath()) then
- begin
- Fail('blaise binary missing at ' + BlaisePath());
- Exit
- end;
-
- UnitPas := FScratch + '/RegModU.pas';
- ProgPas := FScratch + '/use_reg_native.pas';
- ProgBin := FScratch + '/use_reg_native';
- CacheDir := FScratch + '/units-static-native';
-
- WriteFile(UnitPas, StaticRegModSrc);
- WriteFile(ProgPas, StaticRegProgSrc);
- ForceDirectories(CacheDir);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'native',
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('native build1 exit (out: ' + Captured + ')', 0, Rc);
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('native build1 run exit', 0, Rc);
- AssertEquals('native build1 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured);
-
- Rc := RunBlaise(['--source', ProgPas, '--output', ProgBin,
- '--backend', 'native',
- '--unit-cache', CacheDir,
- '--unit-path', FScratch], Captured);
- AssertEquals('native build2 exit (out: ' + Captured + ')', 0, Rc);
- Rc := RunBinary(ProgBin, Captured);
- AssertEquals('native build2 run exit', 0, Rc);
- AssertEquals('native build2 stdout', '1' + #10 + '2' + #10 + '3' + #10 + '7' + #10, Captured)
-end;
-
initialization
RegisterTest(TSepCompileTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.staticarray.pas b/compiler/src/test/pascal/cp.test.e2e.staticarray.pas
index 405acb6..97fc049 100644
--- a/compiler/src/test/pascal/cp.test.e2e.staticarray.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.staticarray.pas
@@ -35,10 +35,6 @@ type
procedure TestRun_TypeAlias_AsParam_Length;
procedure TestRun_TypeAlias_MultipleVarsShareType;
procedure TestRun_TypeAlias_GlobalAndLocal;
- { A named integer subrange (TIdx = 0..2) used as an array index type:
- array[TIdx] of T resolves to array[0..2] of T (ordinal-indexed). }
- procedure TestRun_NamedSubrange_AsArrayIndex;
- procedure TestRun_NamedSubrange_NonZeroBase_AsArrayIndex;
{ Range-indexed const array: const X: array[L..H] of T = (...) }
procedure TestRun_ConstArray_RangeIndexed_Strings;
@@ -202,48 +198,12 @@ const
G[2] := L[2]
end;
begin
- Fill();
+ Fill;
WriteLn(G[0]);
WriteLn(G[2])
end.
''';
- { A named integer subrange used as an array index type. array[TIdx] of T,
- where TIdx = 0..2, must resolve to array[0..2] of T (ordinal-indexed,
- like array[TEnum]). FPC compiles this; Blaise must too. }
- SrcSubrangeIndex =
- '''
- program P;
- type
- TIdx = 0..2;
- TBuf = array[TIdx] of Integer;
- var A: TBuf;
- begin
- A[0] := 11; A[1] := 22; A[2] := 33;
- WriteLn(A[0]);
- WriteLn(A[1]);
- WriteLn(A[2]);
- WriteLn(Length(A))
- end.
- ''';
-
- { Non-zero-based named subrange index: array[2..4] via a named subrange. }
- SrcSubrangeIndexNonZero =
- '''
- program P;
- type
- TIdx = 2..4;
- TBuf = array[TIdx] of Integer;
- var A: TBuf;
- begin
- A[2] := 100; A[3] := 200; A[4] := 300;
- WriteLn(A[2]);
- WriteLn(A[4]);
- WriteLn(Low(A));
- WriteLn(High(A))
- end.
- ''';
-
{ ------------------------------------------------------------------ }
{ Setup }
{ ------------------------------------------------------------------ }
@@ -379,40 +339,6 @@ begin
finally Lines.Free() end
end;
-procedure TE2EStaticArrayTests.TestRun_NamedSubrange_AsArrayIndex;
-var Output: string; RCode: Integer;
- Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Fail(''); Exit end;
- AssertTrue('compile+run', CompileAndRun(SrcSubrangeIndex, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('A[0]=11', '11', Lines.Strings[0]);
- AssertEquals('A[1]=22', '22', Lines.Strings[1]);
- AssertEquals('A[2]=33', '33', Lines.Strings[2]);
- AssertEquals('Length(A)=3', '3', Lines.Strings[3]);
- finally Lines.Free() end
-end;
-
-procedure TE2EStaticArrayTests.TestRun_NamedSubrange_NonZeroBase_AsArrayIndex;
-var Output: string; RCode: Integer;
- Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Fail(''); Exit end;
- AssertTrue('compile+run', CompileAndRun(SrcSubrangeIndexNonZero, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('A[2]=100', '100', Lines.Strings[0]);
- AssertEquals('A[4]=300', '300', Lines.Strings[1]);
- AssertEquals('Low(A)=2', '2', Lines.Strings[2]);
- AssertEquals('High(A)=4', '4', Lines.Strings[3]);
- finally Lines.Free() end
-end;
-
procedure TE2EStaticArrayTests.TestRun_ConstArray_RangeIndexed_Strings;
const
Src =
diff --git a/compiler/src/test/pascal/cp.test.e2e.staticmembers.pas b/compiler/src/test/pascal/cp.test.e2e.staticmembers.pas
deleted file mode 100644
index da086f7..0000000
--- a/compiler/src/test/pascal/cp.test.e2e.staticmembers.pas
+++ /dev/null
@@ -1,370 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.e2e.staticmembers;
-
-{ E2E tests for `static` class/record members: static var, static method,
- static property, and the lazy-singleton pattern. Each program is compiled
- and run on every backend (QBE + native). Parser/semantic/IR tests live in
- cp.test.staticmembers.pas; these guard the codegen -> QBE -> run boundary
- the IR harness cannot see (data-slot emission, no-Self call ABI, qualified
- static reads). }
-
-interface
-
-uses
- classes, blaise.testing, cp.test.e2e.base;
-
-type
- [Threaded]
- TE2EStaticMembersTests = class(TE2ETestCase)
- protected
- procedure SetUp; override;
- published
- procedure TestRun_StaticMethod_NoSelf;
- procedure TestRun_StaticVar_SharedAcrossCalls;
- procedure TestRun_StaticVar_QualifiedRead;
- procedure TestRun_StaticVar_QualifiedWrite_Scalar;
- procedure TestRun_StaticVar_QualifiedWrite_ClassARC;
- procedure TestRun_StaticVar_InterfaceStore;
- procedure TestRun_StaticVar_ChainedLValueBase;
- procedure TestRun_StaticProperty_QualifiedRead;
- procedure TestRun_Singleton_LazyGetInstance;
- procedure TestRun_StaticConst_OnClass;
- procedure TestRun_RecordStaticFactory;
- end;
-
-implementation
-
-procedure TE2EStaticMembersTests.SetUp;
-begin
- inherited SetUp();
- SetUpScratch('compiler/target/test-e2e-staticmembers')
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticMethod_NoSelf;
-const Src =
- '''
- program P;
- type
- TMath = class
- public
- static function Square(X: Integer): Integer;
- end;
- static function TMath.Square(X: Integer): Integer;
- begin
- Result := X * X;
- end;
- begin
- WriteLn(TMath.Square(7))
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '49' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_SharedAcrossCalls;
-const Src =
- '''
- program P;
- type
- TCounter = class
- private static var
- FN: Integer;
- public
- static function Next: Integer;
- end;
- static function TCounter.Next: Integer;
- begin
- FN := FN + 1;
- Result := FN;
- end;
- begin
- WriteLn(TCounter.Next());
- WriteLn(TCounter.Next());
- WriteLn(TCounter.Next())
- end.
- ''';
-var LE: string;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- LE := LineEnding;
- AssertRunsOnAll(Src, '1' + LE + '2' + LE + '3' + LE, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedRead;
-const Src =
- '''
- program P;
- type
- TCounter = class
- public static var
- Total: Integer;
- static procedure Bump;
- end;
- static procedure TCounter.Bump;
- begin
- Total := Total + 10;
- end;
- begin
- TCounter.Bump();
- TCounter.Bump();
- WriteLn(TCounter.Total)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '20' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedWrite_Scalar;
-const Src =
- '''
- program P;
- type
- TFoo = class
- public static var
- GCount: Integer;
- end;
- begin
- TFoo.GCount := 5;
- TFoo.GCount := TFoo.GCount + 37;
- WriteLn(TFoo.GCount)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '42' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_QualifiedWrite_ClassARC;
-const Src =
- '''
- program P;
- type
- TObj = class
- public
- V: Integer;
- end;
- THolder = class
- public static var
- GObj: TObj;
- end;
- var local: TObj;
- begin
- THolder.GObj := TObj.Create();
- local := THolder.GObj;
- local.V := 99;
- WriteLn(local.V);
- THolder.GObj := nil;
- if THolder.GObj = nil then WriteLn('released')
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '99' + LineEnding + 'released' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_InterfaceStore;
-{ Interface-typed static var: the bare store inside a static method
- (FCache := X) must write BOTH slots of the 2-slot fat pointer (obj + itab)
- with correct ARC, and the bare read (Result := FCache) must reconstruct it.
- Regression for the static-call interface-arg leading-comma bug that made
- THolder.SetIt(T) emit an invalid QBE call and segfault native. }
-const Src =
- '''
- program P;
- type
- IThing = interface
- procedure Speak;
- end;
- TThing = class(IThing)
- public
- Tag: Integer;
- procedure Speak;
- end;
- THolder = class
- public static var
- FCache: IThing;
- static procedure SetIt(X: IThing);
- static function GetIt: IThing;
- end;
- procedure TThing.Speak;
- begin
- WriteLn('thing ', Tag);
- end;
- static procedure THolder.SetIt(X: IThing);
- begin
- FCache := X;
- end;
- static function THolder.GetIt: IThing;
- begin
- Result := FCache;
- end;
- var
- T: TThing;
- Got: IThing;
- begin
- T := TThing.Create();
- T.Tag := 7;
- THolder.SetIt(T);
- Got := THolder.GetIt();
- Got.Speak();
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, 'thing 7' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticVar_ChainedLValueBase;
-{ A qualified static var of class type used as the BASE of a further l-value
- chain: 'TFoo.GObj.Field := V' (field write through the chained base) and
- 'TFoo.GObj.Method()' (method call on the chained base). The read form
- (TFoo.GObj.Field as an expression) already worked; the write/call receiver
- path through the chained base was unresolved ("Field access requires a record
- or class base, got 'class of TFoo'"). }
-const Src =
- '''
- program P;
- type
- TObj = class
- public
- V: Integer;
- procedure Bump;
- end;
- THolder = class
- public static var
- GObj: TObj;
- end;
- procedure TObj.Bump;
- begin
- V := V + 1;
- end;
- begin
- THolder.GObj := TObj.Create();
- WriteLn(THolder.GObj.V);
- THolder.GObj.V := 5;
- WriteLn(THolder.GObj.V);
- THolder.GObj.Bump();
- WriteLn(THolder.GObj.V);
- THolder.GObj := nil
- end.
- ''';
-var LE: string;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- LE := LineEnding;
- AssertRunsOnAll(Src, '0' + LE + '5' + LE + '6' + LE, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticProperty_QualifiedRead;
-const Src =
- '''
- program P;
- type
- TRegistry = class
- private static var
- FCounter: Integer;
- public
- static function NextId: Integer;
- static property Counter: Integer read NextId;
- end;
- static function TRegistry.NextId: Integer;
- begin
- FCounter := FCounter + 1;
- Result := FCounter;
- end;
- begin
- WriteLn(TRegistry.Counter);
- WriteLn(TRegistry.Counter)
- end.
- ''';
-var LE: string;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- LE := LineEnding;
- AssertRunsOnAll(Src, '1' + LE + '2' + LE, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_Singleton_LazyGetInstance;
-const Src =
- '''
- program P;
- type
- TConfig = class
- private static var
- FInstance: TConfig;
- public
- FValue: Integer;
- static function Instance: TConfig;
- end;
- static function TConfig.Instance: TConfig;
- begin
- if FInstance = nil then
- FInstance := TConfig.Create();
- Result := FInstance;
- end;
- begin
- TConfig.Instance().FValue := 42;
- WriteLn(TConfig.Instance().FValue)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '42' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_StaticConst_OnClass;
-const Src =
- '''
- program P;
- type
- TLimits = class
- public static const
- MaxItems = 128;
- end;
- begin
- WriteLn(TLimits.MaxItems)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '128' + LineEnding, 0);
-end;
-
-procedure TE2EStaticMembersTests.TestRun_RecordStaticFactory;
-const Src =
- '''
- program P;
- type
- TPoint = record
- X, Y: Integer;
- static function Make(AX, AY: Integer): TPoint;
- end;
- static function TPoint.Make(AX, AY: Integer): TPoint;
- begin
- Result.X := AX;
- Result.Y := AY;
- end;
- var Pt: TPoint;
- begin
- Pt := TPoint.Make(3, 4);
- WriteLn(Pt.X + Pt.Y)
- end.
- ''';
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertRunsOnAll(Src, '7' + LineEnding, 0);
-end;
-
-initialization
- RegisterTest(TE2EStaticMembersTests);
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.e2e.sysutils.pas b/compiler/src/test/pascal/cp.test.e2e.sysutils.pas
index b24ce54..0f19515 100644
--- a/compiler/src/test/pascal/cp.test.e2e.sysutils.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.sysutils.pas
@@ -45,7 +45,6 @@ type
procedure TestRun_SetCurrentDir_ChangesDir;
procedure TestRun_ExtractFileExt_ReturnsExt;
procedure TestRun_BoolToStr_TrueAndFalse;
- procedure TestRun_SameFileName_ExactMatch;
procedure TestRun_PlatformConstants;
procedure TestRun_GetCurrentDir_ReturnsNonEmpty;
procedure TestRun_FileAge_ReturnsTimestamp;
@@ -535,16 +534,6 @@ const
end.
''';
- SrcSameFileName =
- '''
- program P;
- uses SysUtils;
- begin
- WriteLn(SameFileName('a/b.pas', 'a/b.pas'));
- WriteLn(SameFileName('a/b.pas', 'a/c.pas'))
- end.
- ''';
-
SrcPlatformConstants =
'''
program P;
@@ -670,25 +659,6 @@ begin
end;
end;
-procedure TE2ESysUtilsTests.TestRun_SameFileName_ExactMatch;
-var
- Output: string;
- RCode: Integer;
- Lines: TStringList;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+run', CompileAndRunWithRTL(SrcSameFileName, Output, RCode));
- AssertEquals('exit code 0', 0, RCode);
- Lines := TStringList.Create();
- try
- Lines.Text := Trim(Output);
- AssertEquals('identical names match', 'True', Lines.Strings[0]);
- AssertEquals('different names differ', 'False', Lines.Strings[1]);
- finally
- Lines.Free();
- end;
-end;
-
procedure TE2ESysUtilsTests.TestRun_PlatformConstants;
var
Output: string;
diff --git a/compiler/src/test/pascal/cp.test.e2e.threading.pas b/compiler/src/test/pascal/cp.test.e2e.threading.pas
index 4e75889..8afb019 100644
--- a/compiler/src/test/pascal/cp.test.e2e.threading.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.threading.pas
@@ -32,8 +32,6 @@ type
procedure TestRun_Thread_InheritedDestroy_CleanExit;
procedure TestRun_ThreadVar_MainThread_ReadWrite;
procedure TestRun_ThreadVar_MixedWithGlobalVar;
- procedure TestRun_ThreadVar_RecordField_PerThreadIsolation;
- procedure TestRun_ThreadVar_RecordMethod_PerThreadIsolation;
procedure TestRun_PerThreadAllocator_IndependentAllocs;
procedure TestRun_AtomicARC_SharedObject_NoCorruption;
end;
@@ -110,20 +108,18 @@ const
var I: Integer;
begin
{ Spin until terminated. The loop must exit *only* via the terminate
- flag so Terminated is guaranteed True when read — an early-break
+ flag so FTerminated is guaranteed True when read — an early-break
escape would let the worker finish before the main thread's Terminate
landed, making the printed flag race between 0 and 1. The large cap is
- only a safety net so a missed Terminate cannot hang the test forever.
- Read the public Terminated property — the backing FTerminated field is
- private to TThread and not visible to subclasses. }
+ only a safety net so a missed Terminate cannot hang the test forever. }
I := 0;
- while not Self.Terminated do
+ while not Self.FTerminated do
begin
I := I + 1;
if I > 2000000000 then
break
end;
- WriteLn(Self.Terminated)
+ WriteLn(Self.FTerminated)
end;
var T: TLoopThread;
begin
@@ -149,13 +145,11 @@ const
end;
var T: TQuickThread;
begin
- { Read the public Finished property — the backing FFinished field is
- private to TThread and not visible outside the class. }
T := TQuickThread.Create(True);
- WriteLn(T.Finished);
+ WriteLn(T.FFinished);
T.Start();
T.WaitFor();
- WriteLn(T.Finished)
+ WriteLn(T.FFinished)
end.
''';
@@ -373,154 +367,6 @@ begin
AssertEquals('stdout', '30' + LE, Output)
end;
-const
- { A RECORD-typed threadvar mutated and read back per-thread. Each thread
- stamps its own id into the record-field threadvar, then spins re-reading it
- and asserting it never changes. If the record threadvar is addressed
- statically (leaq Name(%rip)) instead of via TLS (%fs:0 + @tpoff), all
- threads share one slot and clobber each other -> 'CORRUPT'. Scalar
- threadvars already use TLS; the bug was that record/aggregate threadvar
- field access bypassed it. }
- SrcThreadVarRecordIsolation =
- '''
- program P;
- uses Classes;
- type
- TRec = record
- Tag: Integer;
- end;
- TStampThread = class(TThread)
- MyId: Integer;
- protected
- procedure Execute; override;
- end;
- threadvar
- TVR: TRec;
- var
- Corrupt: Integer;
- procedure TStampThread.Execute;
- var I: Integer;
- begin
- TVR.Tag := Self.MyId;
- for I := 0 to 200000 do
- if TVR.Tag <> Self.MyId then
- begin
- Corrupt := 1;
- Exit
- end
- end;
- var
- A, B, C: TStampThread;
- begin
- Corrupt := 0;
- A := TStampThread.Create(True);
- B := TStampThread.Create(True);
- C := TStampThread.Create(True);
- A.MyId := 11;
- B.MyId := 22;
- C.MyId := 33;
- A.Start();
- B.Start();
- C.Start();
- A.WaitFor();
- B.WaitFor();
- C.WaitFor();
- if Corrupt = 0 then
- WriteLn('ok')
- else
- WriteLn('CORRUPT')
- end.
- ''';
-
-procedure TE2EThreadingTests.TestRun_ThreadVar_RecordField_PerThreadIsolation;
-var
- Output: string;
- RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run', CompileAndRunWithRTL(SrcThreadVarRecordIsolation, Output, RCode));
- AssertEquals('exit code', 0, RCode);
- AssertEquals('stdout', 'ok' + LE, Output)
-end;
-
-const
- { Same per-thread isolation guarantee, but the record threadvar is accessed
- through METHOD CALLS (GR.Put / GR.Get) rather than direct field access. The
- method-call receiver ladder loads the record base too, and used the same
- static `leaq Name(%rip)` for a global receiver — so this exercises the
- receiver-load path specifically. }
- SrcThreadVarRecordMethod =
- '''
- program P;
- uses Classes;
- type
- TRec = record
- N: Integer;
- procedure Put(V: Integer);
- function Get: Integer;
- end;
- TStampThread = class(TThread)
- MyId: Integer;
- protected
- procedure Execute; override;
- end;
- procedure TRec.Put(V: Integer);
- begin
- N := V
- end;
- function TRec.Get: Integer;
- begin
- Result := N
- end;
- threadvar
- GR: TRec;
- var
- Corrupt: Integer;
- procedure TStampThread.Execute;
- var I: Integer;
- begin
- GR.Put(Self.MyId);
- for I := 0 to 200000 do
- if GR.Get() <> Self.MyId then
- begin
- Corrupt := 1;
- Exit
- end
- end;
- var
- A, B, C: TStampThread;
- begin
- Corrupt := 0;
- A := TStampThread.Create(True);
- B := TStampThread.Create(True);
- C := TStampThread.Create(True);
- A.MyId := 11;
- B.MyId := 22;
- C.MyId := 33;
- A.Start();
- B.Start();
- C.Start();
- A.WaitFor();
- B.WaitFor();
- C.WaitFor();
- if Corrupt = 0 then
- WriteLn('ok')
- else
- WriteLn('CORRUPT')
- end.
- ''';
-
-procedure TE2EThreadingTests.TestRun_ThreadVar_RecordMethod_PerThreadIsolation;
-var
- Output: string;
- RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit end;
- AssertTrue('compile+run', CompileAndRunWithRTL(SrcThreadVarRecordMethod, Output, RCode));
- AssertEquals('exit code', 0, RCode);
- AssertEquals('stdout', 'ok' + LE, Output)
-end;
-
const
SrcPerThreadAlloc =
'''
diff --git a/compiler/src/test/pascal/cp.test.e2e.tlist.pas b/compiler/src/test/pascal/cp.test.e2e.tlist.pas
index 712fd59..e380d40 100644
--- a/compiler/src/test/pascal/cp.test.e2e.tlist.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.tlist.pas
@@ -38,10 +38,6 @@ type
{ Default array property: List[i] subscript for read and write. }
procedure TestRun_TList_DefaultProperty_ReadWrite;
procedure TestRun_TList_DefaultProperty_Polymorphic;
-
- { Clear and Free release managed elements (ARC cascade): a class element's
- destructor must run when the list is cleared or freed. }
- procedure TestRun_TList_FreeAndClear_ReleasesElements;
end;
implementation
@@ -278,43 +274,6 @@ begin
AssertEquals('List[i].Area (native)', '25' + #10, Output);
end;
-const
- SrcTListFreeClear = '''
- program P;
- uses generics.collections;
- type
- TC = class
- N: Integer;
- constructor Create(AN: Integer);
- destructor Destroy; override;
- end;
- constructor TC.Create(AN: Integer);
- begin N := AN end;
- destructor TC.Destroy;
- begin WriteLn('d', N) end;
- var
- L: TList;
- begin
- L := TList.Create();
- L.Add(TC.Create(1));
- L.Add(TC.Create(2));
- L.Clear();
- WriteLn('cleared');
- L.Add(TC.Create(3));
- L.Free();
- WriteLn('done')
- end.
- ''';
-
-procedure TE2ETListTests.TestRun_TList_FreeAndClear_ReleasesElements;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Clear releases elements 1 and 2; the final Free releases element 3 — each
- destructor fires, proving the managed-element release cascade. }
- AssertRTLRunsOnAll(SrcTListFreeClear,
- 'd1' + #10 + 'd2' + #10 + 'cleared' + #10 + 'd3' + #10 + 'done' + #10, 0);
-end;
-
initialization
RegisterTest(TE2ETListTests);
diff --git a/compiler/src/test/pascal/cp.test.e2e.useschain.pas b/compiler/src/test/pascal/cp.test.e2e.useschain.pas
index ad6309b..fbe1669 100644
--- a/compiler/src/test/pascal/cp.test.e2e.useschain.pas
+++ b/compiler/src/test/pascal/cp.test.e2e.useschain.pas
@@ -29,50 +29,6 @@ type
procedure TestRun_ImplicitSystem_NoUsesClause_WriteLnInt;
procedure TestRun_ImplicitSystem_NoUsesClause_IntToStr;
procedure TestRun_ImplicitSystem_NoUsesClause_Length;
- { Unit-qualified symbol references 'UnitName.Symbol'. }
- procedure TestRun_QualifiedSystem_CallExprAndStmt;
- procedure TestRun_QualifiedUnit_CallAndVar;
- procedure TestRun_DottedQualifiedUnit_CallAndVar;
- { Cross-unit const shadowing: two used units export the same const name;
- the unit later in the `uses` clause wins (last-in-uses), and reversing
- the order flips the winner. }
- procedure TestRun_CrossUnitConst_LastWins;
- procedure TestRun_CrossUnitConst_LastWins_Reversed;
- { Unit-qualified const disambiguation: a 'Unit.Foo' reference resolves
- against that specific unit's exports, so it is never shadowed by a
- same-named const in another used unit, regardless of `uses` order. }
- procedure TestRun_CrossUnitConst_QualifiedDisambig;
- { Unit-qualified ancestor in a class declaration: class(Unit.TParent)
- binds to that unit's type so inheritance works across units. }
- procedure TestRun_QualifiedInheritance;
- { Two units each declare an impl-private global of the SAME name; with
- unit-prefix mangling on module-scope globals they no longer collide at
- link, so a program using both links and runs. }
- procedure TestRun_SameNamedGlobals_NoLinkCollision;
- { Cross-unit interface VAR shadowing: two used units export the same var
- name; the unit later in `uses` wins a bare reference (last-in-uses), and
- reversing the order flips the winner — mirrors the const last-wins rule. }
- procedure TestRun_CrossUnitVar_LastWins;
- procedure TestRun_CrossUnitVar_LastWins_Reversed;
- { Unit-qualified VAR disambiguation: 'Unit.V' references that specific
- unit's own slot (distinct storage), independent of the bare last-wins
- winner, so both values are readable side by side. }
- procedure TestRun_CrossUnitVar_QualifiedDisambig;
- { Cross-unit TYPE shadowing: two used units export a class of the same name;
- they coexist (no 'Duplicate type name' error, no link collision) and a
- bare reference binds to the unit later in `uses` (last-in-uses wins),
- flipping when the order is reversed — mirrors the const/var rule. }
- procedure TestRun_CrossUnitType_LastWins;
- procedure TestRun_CrossUnitType_LastWins_Reversed;
- { Unit-qualified TYPE disambiguation: 'Unit.TShape' binds to that unit's own
- class (distinct vtable/dispatch), independent of the bare last-wins
- winner, so both behaviours are observable side by side. }
- procedure TestRun_CrossUnitType_QualifiedDisambig;
- { Unit-qualified ENUM member 'Unit.TEnum.Member' (field-access form) binds
- the enum type to that specific unit's exports via directed lookup, so it
- reaches members the bare/last-wins enum type does not — independent of
- `uses` order. }
- procedure TestRun_CrossUnitEnum_QualifiedMember;
end;
implementation
@@ -142,474 +98,6 @@ begin
AssertEquals('Length(''hello'')', '5' + LE, Output);
end;
-procedure TE2EUsesChainTests.TestRun_QualifiedSystem_CallExprAndStmt;
-const
- Src = '''
- program P;
- begin
- System.WriteLn(System.Length('hello'))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { 'System.WriteLn' (qualified call statement) and 'System.Length(...)'
- (qualified call expression) both resolve via the implicit System unit. }
- AssertTrue(CompileAndRun(Src, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('Length(''hello'') = 5', '5' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_QualifiedUnit_CallAndVar;
-const
- UnitSrc = '''
- unit qsym;
- interface
- function Add3(N: Integer): Integer;
- var
- GBase: Integer;
- implementation
- function Add3(N: Integer): Integer;
- begin
- Result := N + 3
- end;
- end.
- ''';
- DrvSrc = '''
- program P;
- uses qsym;
- begin
- qsym.GBase := 10;
- WriteLn(qsym.Add3(qsym.GBase))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Qualified assignment target (qsym.GBase :=), qualified var read
- (qsym.GBase), and qualified function call (qsym.Add3) across a used unit. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnit('qsym', UnitSrc, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('Add3(10) = 13', '13' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_DottedQualifiedUnit_CallAndVar;
-const
- UnitSrc = '''
- unit My.Pkg;
- interface
- function Add3(N: Integer): Integer;
- var
- GBase: Integer;
- implementation
- function Add3(N: Integer): Integer;
- begin
- Result := N + 3
- end;
- end.
- ''';
- DrvSrc = '''
- program P;
- uses My.Pkg;
- begin
- My.Pkg.GBase := 10;
- WriteLn(My.Pkg.Add3(My.Pkg.GBase))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Same as above but through a two-part dotted unit name 'My.Pkg'. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnit('My.Pkg', UnitSrc, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('Add3(10) = 13', '13' + LE, Output);
-end;
-
-const
- UA_Const = '''
- unit ua;
- interface
- const Foo = 100;
- implementation
- end.
- ''';
- UB_Const = '''
- unit ub;
- interface
- const Foo = 200;
- implementation
- end.
- ''';
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitConst_LastWins;
-const
- DrvSrc = '''
- program P;
- uses ua, ub;
- begin
- WriteLn(Foo)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Both ua and ub export `Foo`; ub is later in `uses`, so bare Foo = 200. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (ub) wins', '200' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitConst_LastWins_Reversed;
-const
- DrvSrc = '''
- program P;
- uses ub, ua;
- begin
- WriteLn(Foo)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Reversed `uses` order: ua is now later, so bare Foo = 100. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (ua) wins', '100' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitConst_QualifiedDisambig;
-const
- DrvSrc = '''
- program P;
- uses ua, ub;
- begin
- WriteLn(ua.Foo);
- WriteLn(ub.Foo)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Both ua and ub export `Foo`; qualified references pick each unit's own
- value (ua.Foo = 100, ub.Foo = 200) independent of the bare last-wins rule. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UA_Const, UB_Const, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('ua.Foo then ub.Foo', '100' + LE + '200' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_QualifiedInheritance;
-const
- UnitSrc = '''
- unit ua;
- interface
- type
- TParent = class
- function Base: Integer;
- end;
- implementation
- function TParent.Base: Integer;
- begin
- Result := 41
- end;
- end.
- ''';
- DrvSrc = '''
- program P;
- uses ua;
- type
- TChild = class(ua.TParent)
- function Plus1: Integer;
- end;
- function TChild.Plus1: Integer;
- begin
- Result := Base() + 1
- end;
- var
- C: TChild;
- begin
- C := TChild.Create();
- WriteLn(C.Plus1())
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { class(ua.TParent) resolves the qualified ancestor to ua's type; the child
- inherits Base (41) and adds 1 -> 42. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnit('ua', UnitSrc, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('inherited Base + 1', '42' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_SameNamedGlobals_NoLinkCollision;
-const
- UnitOne = '''
- unit uone;
- interface
- function GetOne: Integer;
- implementation
- var G: Integer;
- function GetOne: Integer;
- begin
- G := 11;
- Result := G
- end;
- end.
- ''';
- UnitTwo = '''
- unit utwo;
- interface
- function GetTwo: Integer;
- implementation
- var G: Integer;
- function GetTwo: Integer;
- begin
- G := 22;
- Result := G
- end;
- end.
- ''';
- DrvSrc = '''
- program P;
- uses uone, utwo;
- begin
- WriteLn(GetOne() + GetTwo())
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Both units emit a global named G; without unit-prefix mangling the two
- '$G' definitions collide at link. Mangling makes them distinct, so the
- program links and prints 11 + 22 = 33. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UnitOne, UnitTwo, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('GetOne + GetTwo', '33' + LE, Output);
-end;
-
-const
- UVA_Var = '''
- unit uva;
- interface
- var V: Integer = 7;
- implementation
- end.
- ''';
- UVB_Var = '''
- unit uvb;
- interface
- var V: Integer = 9;
- implementation
- end.
- ''';
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitVar_LastWins;
-const
- DrvSrc = '''
- program P;
- uses uva, uvb;
- begin
- WriteLn(V)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Both uva and uvb export `V`; uvb is later in `uses`, so bare V = 9.
- The shadowed uva.V keeps its own slot (no link collision). }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (uvb) wins', '9' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitVar_LastWins_Reversed;
-const
- DrvSrc = '''
- program P;
- uses uvb, uva;
- begin
- WriteLn(V)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Reversed `uses` order: uva is now later, so bare V = 7. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (uva) wins', '7' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitVar_QualifiedDisambig;
-const
- DrvSrc = '''
- program P;
- uses uva, uvb;
- begin
- WriteLn(uva.V);
- WriteLn(uvb.V)
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Qualified references pick each unit's own slot (uva.V = 7, uvb.V = 9)
- regardless of the bare last-wins rule — distinct storage per unit. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(UVA_Var, UVB_Var, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('uva.V then uvb.V', '7' + LE + '9' + LE, Output);
-end;
-
-const
- TCA_Type = '''
- unit tca;
- interface
- type
- TShape = class
- function Sides: Integer;
- end;
- implementation
- function TShape.Sides: Integer;
- begin
- Result := 3
- end;
- end.
- ''';
- TCB_Type = '''
- unit tcb;
- interface
- type
- TShape = class
- function Sides: Integer;
- end;
- implementation
- function TShape.Sides: Integer;
- begin
- Result := 4
- end;
- end.
- ''';
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitType_LastWins;
-const
- DrvSrc = '''
- program P;
- uses tca, tcb;
- var S: TShape;
- begin
- S := TShape.Create();
- WriteLn(S.Sides())
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Both tca and tcb export class `TShape`; tcb is later in `uses`, so bare
- TShape binds to tcb (Sides = 4). The two types coexist with distinct
- code symbols — no duplicate-identifier error and no link collision. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (tcb) wins', '4' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitType_LastWins_Reversed;
-const
- DrvSrc = '''
- program P;
- uses tcb, tca;
- var S: TShape;
- begin
- S := TShape.Create();
- WriteLn(S.Sides())
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Reversed `uses` order: tca is now later, so bare TShape binds to tca
- (Sides = 3). }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('last-in-uses (tca) wins', '3' + LE, Output);
-end;
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitType_QualifiedDisambig;
-const
- DrvSrc = '''
- program P;
- uses tca, tcb;
- var
- A: tca.TShape;
- B: tcb.TShape;
- begin
- A := tca.TShape.Create();
- B := tcb.TShape.Create();
- WriteLn(A.Sides());
- WriteLn(B.Sides())
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- { Qualified references bind each variable to its own unit's class, so
- A.Sides = 3 (tca) and B.Sides = 4 (tcb) regardless of last-wins. }
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(TCA_Type, TCB_Type, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('tca.TShape then tcb.TShape', '3' + LE + '4' + LE, Output);
-end;
-
-const
- EA_Enum = '''
- unit ea;
- interface
- type TPalette = (paOne, paTwo, paThree);
- implementation
- end.
- ''';
- EB_Enum = '''
- unit eb;
- interface
- type TPalette = (paZero, paOne);
- implementation
- end.
- ''';
-
-procedure TE2EUsesChainTests.TestRun_CrossUnitEnum_QualifiedMember;
-const
- { ea.TPalette.paThree exists only in ea (ordinal 2); eb.TPalette.paZero only
- in eb (ordinal 0). A flat/last-wins enum-type lookup would resolve one of
- them to the other unit's TPalette and fail "no member"; the qualifier picks
- each unit's own enum. }
- DrvSrc = '''
- program P;
- uses ea, eb;
- begin
- WriteLn(Ord(ea.TPalette.paThree));
- WriteLn(Ord(eb.TPalette.paZero))
- end.
- ''';
-var Output: string; RCode: Integer;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertTrue('compile+link+run',
- CompileAndRunWithUnits(EA_Enum, EB_Enum, DrvSrc, Output, RCode));
- AssertEquals('exit 0', 0, RCode);
- AssertEquals('ea.paThree=2, eb.paZero=0', '2' + LE + '0' + LE, Output);
-end;
-
initialization
RegisterTest(TE2EUsesChainTests);
diff --git a/compiler/src/test/pascal/cp.test.exceptions.pas b/compiler/src/test/pascal/cp.test.exceptions.pas
index aaf8ab4..113cc16 100644
--- a/compiler/src/test/pascal/cp.test.exceptions.pas
+++ b/compiler/src/test/pascal/cp.test.exceptions.pas
@@ -254,7 +254,7 @@ const
end
end;
begin
- Run()
+ Run
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.external.pas b/compiler/src/test/pascal/cp.test.external.pas
index 58bbf2f..449e2a0 100644
--- a/compiler/src/test/pascal/cp.test.external.pas
+++ b/compiler/src/test/pascal/cp.test.external.pas
@@ -26,9 +26,6 @@ type
procedure TestParse_ExternalProc_IsExternal;
procedure TestParse_ExternalProc_ExternalNameEmpty;
procedure TestParse_ExternalProcNamed_ExternalName;
- { Parser — library-qualified external records ExternalLib and hoists
- the bare library name into the program's LinkLibs set. }
- procedure TestParse_ExternalLibName_RecordsLibAndLinkLib;
{ Parser — standalone function }
procedure TestParse_ExternalFunc_IsExternal;
procedure TestParse_ExternalFuncNamed_ExternalName;
@@ -202,36 +199,6 @@ begin
end;
end;
-procedure TExternalTests.TestParse_ExternalLibName_RecordsLibAndLinkLib;
-var
- Prog: TProgram;
- Decl: TMethodDecl;
- Lib: TLinkLibDecl;
-begin
- Prog := ParseSrc(
- '''
- program Test;
- function c_strlen(S: PChar): Integer; external 'c' name 'strlen';
- begin
- end.
- '''
- );
- try
- Decl := TMethodDecl(Prog.Block.ProcDecls.Items[0]);
- AssertTrue('IsExternal should be True', Decl.IsExternal);
- AssertEquals('ExternalName should be strlen', 'strlen', Decl.ExternalName);
- AssertEquals('ExternalLib should be c', 'c', Decl.ExternalLib);
-
- { The bare library name is hoisted into the program's LinkLibs set so
- the link layer can expand it to -l. }
- AssertEquals('one link lib collected', 1, Prog.LinkLibs.Count);
- Lib := TLinkLibDecl(Prog.LinkLibs.Items[0]);
- AssertEquals('link lib name', 'c', Lib.LibName);
- finally
- Prog.Free();
- end;
-end;
-
procedure TExternalTests.TestParse_ExternalFunc_IsExternal;
var
Prog: TProgram;
diff --git a/compiler/src/test/pascal/cp.test.flowjumps.pas b/compiler/src/test/pascal/cp.test.flowjumps.pas
index ed24b7b..7181f11 100644
--- a/compiler/src/test/pascal/cp.test.flowjumps.pas
+++ b/compiler/src/test/pascal/cp.test.flowjumps.pas
@@ -171,7 +171,7 @@ const
Exit(5)
end;
begin
- DoIt()
+ DoIt
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.generics.pas b/compiler/src/test/pascal/cp.test.generics.pas
index e7c4c8b..b379e76 100644
--- a/compiler/src/test/pascal/cp.test.generics.pas
+++ b/compiler/src/test/pascal/cp.test.generics.pas
@@ -736,8 +736,8 @@ var
IR: string;
begin
IR := GenUnitIR(SrcUnitIntfGenericVar);
- AssertTrue('global data slot for G emitted (unit-prefix mangled)',
- Pos('data $U_G', IR) > 0);
+ AssertTrue('global data slot for G emitted',
+ Pos('data $G', IR) > 0);
AssertTrue('typeinfo for TBox_Integer emitted',
Pos('$typeinfo_TBox_Integer', IR) > 0);
end;
@@ -793,7 +793,7 @@ const
program Prg;
uses UPair;
begin
- InitPair();
+ InitPair;
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.inherit.pas b/compiler/src/test/pascal/cp.test.inherit.pas
index d5c28be..d51e73b 100644
--- a/compiler/src/test/pascal/cp.test.inherit.pas
+++ b/compiler/src/test/pascal/cp.test.inherit.pas
@@ -23,7 +23,6 @@ type
function AnalyseSrc(const ASrc: string): TProgram;
function GenIR(const ASrc: string): string;
procedure AnalyseExpectError(const ASrc: string);
- procedure ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
published
{ ------------------------------------------------------------------ }
{ nil literal }
@@ -71,11 +70,6 @@ type
procedure TestCodegen_Inherited_NoArgs_CallsParentMethod;
procedure TestCodegen_Inherited_WithArgs_ForwardsArgs;
- { Mandatory parentheses: a bare 'inherited Method' (no parens) is a
- call and must carry (), in both statement and expression position. }
- procedure TestParse_Inherited_BareStmt_RequiresParens;
- procedure TestParse_Inherited_BareExpr_RequiresParens;
-
{ ------------------------------------------------------------------ }
{ TObject.InheritsFrom }
{ ------------------------------------------------------------------ }
@@ -145,20 +139,6 @@ begin
end;
end;
-procedure TInheritTests.ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
-var Prog: TProgram;
-begin
- try
- Prog := ParseSrc(ASrc);
- Prog.Free();
- Fail('Expected EParseError');
- except
- on E: EParseError do
- AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
- E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
- end;
-end;
-
{ ------------------------------------------------------------------ }
{ Shared source snippets }
{ ------------------------------------------------------------------ }
@@ -477,7 +457,7 @@ begin
var C: TChild;
begin
C := TChild.Create();
- C.NoSuchMethod()
+ C.NoSuchMethod
end.
''');
end;
@@ -604,55 +584,6 @@ begin
AssertTrue('call $TBase_SetX in IR', Pos('call $TBase_SetX', IR) > 0);
end;
-procedure TInheritTests.TestParse_Inherited_BareStmt_RequiresParens;
-const Src = '''
- program P;
- type
- TBase = class
- procedure Init;
- end;
- TChild = class(TBase)
- procedure Init;
- end;
- procedure TBase.Init;
- begin
- end;
- procedure TChild.Init;
- begin
- inherited Init
- end;
- begin
- end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'requires () for a call');
-end;
-
-procedure TInheritTests.TestParse_Inherited_BareExpr_RequiresParens;
-const Src = '''
- program P;
- type
- TBase = class
- function Value: Integer;
- end;
- TChild = class(TBase)
- function Value: Integer;
- end;
- function TBase.Value: Integer;
- begin
- Result := 1
- end;
- function TChild.Value: Integer;
- begin
- Result := inherited Value + 1
- end;
- begin
- end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'requires () for a call');
-end;
-
{ ------------------------------------------------------------------ }
{ TObject.InheritsFrom }
{ ------------------------------------------------------------------ }
diff --git a/compiler/src/test/pascal/cp.test.interfaces.pas b/compiler/src/test/pascal/cp.test.interfaces.pas
index 62dadc7..35af657 100644
--- a/compiler/src/test/pascal/cp.test.interfaces.pas
+++ b/compiler/src/test/pascal/cp.test.interfaces.pas
@@ -130,12 +130,6 @@ type
procedure TestCodegen_IntfDispatch_RecordArg_PassesAggregate;
procedure TestCodegen_IntfDispatch_OutString_PassesSlotAddr;
procedure TestCodegen_DiscardedIntfReturnStmt_GetsSretAndRelease;
-
- { ------------------------------------------------------------------ }
- { Forward interface declarations (IFoo = interface;) }
- { ------------------------------------------------------------------ }
- procedure TestSemantic_ForwardInterface_CompletedByFullDecl;
- procedure TestSemantic_ForwardInterface_Unresolved_RaisesError;
end;
implementation
@@ -525,7 +519,7 @@ const
end;
procedure Tmi.use;
begin
- im.print();
+ im.print;
end;
var
im: Tmi;
@@ -1780,50 +1774,6 @@ begin
Pos('call $_ClassRelease', Copy(IR, CallPos, MaxInt)) > 0);
end;
-{ ------------------------------------------------------------------ }
-{ Forward interface declarations }
-{ ------------------------------------------------------------------ }
-
-procedure TInterfaceTests.TestSemantic_ForwardInterface_CompletedByFullDecl;
-var
- Prog: TProgram;
-begin
- { `IFoo = interface;` forward stub completed later in the same scope. }
- Prog := AnalyseSrc(
- '''
- program P;
- type
- IFoo = interface;
- IBar = interface
- function GetFoo: IFoo;
- end;
- IFoo = interface
- function GetBar: IBar;
- end;
- begin
- end.
- ''');
- try
- AssertTrue('forward interface completed by full decl analyses OK',
- Prog <> nil);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TInterfaceTests.TestSemantic_ForwardInterface_Unresolved_RaisesError;
-begin
- { A forward interface never completed in the scope is an error. }
- AnalyseExpectError(
- '''
- program P;
- type
- IFoo = interface;
- begin
- end.
- ''');
-end;
-
initialization
RegisterTest(TInterfaceTests);
diff --git a/compiler/src/test/pascal/cp.test.lexer.pas b/compiler/src/test/pascal/cp.test.lexer.pas
index c815183..608792f 100644
--- a/compiler/src/test/pascal/cp.test.lexer.pas
+++ b/compiler/src/test/pascal/cp.test.lexer.pas
@@ -44,11 +44,6 @@ type
procedure TestKeywords_CaseInsensitive;
procedure TestIdent_NotKeyword_Prefix;
- { Inline assembler blocks — asm ... end captured as one raw-text token }
- procedure TestAsmBlock_CapturesRawText;
- procedure TestAsmBlock_EndMentionedInComment_NotTerminator;
- procedure TestAsmBlock_FollowedByDecl_StopsAtEnd;
-
{ Identifiers }
procedure TestIdent_Simple;
procedure TestIdent_WithUnderscore;
@@ -82,11 +77,6 @@ type
procedure TestStringLit_Simple;
procedure TestStringLit_Empty;
procedure TestStringLit_EmbeddedQuote;
- { #nnnn / #$hhhh Unicode codepoint -> UTF-8 string literals }
- procedure TestCodepoint_DecimalAscii;
- procedure TestCodepoint_HexBmp_ThreeBytes;
- procedure TestCodepoint_HexAstral_FourBytes;
- procedure TestCodepoint_MergesWithStringAndEachOther;
{ Operators and punctuation }
procedure TestOp_Plus;
@@ -323,50 +313,6 @@ begin
AssertEquals('Value', 'beginning', tok.Value);
end;
-{ Inline assembler blocks }
-
-procedure TLexerTests.TestAsmBlock_CapturesRawText;
-var
- tok: TToken;
-begin
- { An asm ... end block is returned as ONE tkAsmBlock token whose Value is
- the verbatim text between (exclusive) the asm keyword and the end keyword. }
- SetLexer('asm' + #10 + ' movl %eax, %ebx' + #10 + ' ret' + #10 + 'end');
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkAsmBlock), Ord(tok.Kind));
- AssertTrue('has movl', Pos('movl %eax, %ebx', tok.Value) >= 0);
- AssertTrue('has ret', Pos('ret', tok.Value) >= 0);
- AssertTrue('no trailing end keyword captured', Pos('end', tok.Value) < 0);
-end;
-
-procedure TLexerTests.TestAsmBlock_EndMentionedInComment_NotTerminator;
-var
- tok: TToken;
-begin
- { 'end' appearing inside a # line comment must NOT terminate the block —
- only a standalone end keyword does. }
- SetLexer('asm' + #10 + ' ret # this ends the block' + #10 + 'end');
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkAsmBlock), Ord(tok.Kind));
- AssertTrue('comment text preserved', Pos('this ends the block', tok.Value) >= 0);
- AssertTrue('has ret', Pos('ret', tok.Value) >= 0);
-end;
-
-procedure TLexerTests.TestAsmBlock_FollowedByDecl_StopsAtEnd;
-var
- tok: TToken;
-begin
- { After the block's end, normal tokenising resumes — the trailing ';' and the
- next token are produced as usual. }
- SetLexer('asm' + #10 + ' ret' + #10 + 'end; begin');
- tok := FLexer.Next();
- AssertEquals('asm block', Ord(tkAsmBlock), Ord(tok.Kind));
- tok := FLexer.Next();
- AssertEquals('semicolon after end', Ord(tkSemicolon), Ord(tok.Kind));
- tok := FLexer.Next();
- AssertEquals('begin resumes', Ord(tkBegin), Ord(tok.Kind));
-end;
-
{ Identifiers }
procedure TLexerTests.TestIdent_Simple;
@@ -454,47 +400,6 @@ begin
AssertEquals('Value', 'it''s', tok.Value);
end;
-{ #nnnn / #$hhhh Unicode codepoint -> UTF-8 string literals }
-
-procedure TLexerTests.TestCodepoint_DecimalAscii;
-var tok: TToken;
-begin
- SetLexer('#65');
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
- AssertEquals('Value', 'A', tok.Value); { codepoint 65 -> 1 byte $41 }
-end;
-
-procedure TLexerTests.TestCodepoint_HexBmp_ThreeBytes;
-var tok: TToken;
-begin
- SetLexer('#$20AC'); { EURO SIGN -> UTF-8 E2 82 AC }
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
- AssertEquals('len', 3, Length(tok.Value));
- AssertEquals('Value', Chr($E2) + Chr($82) + Chr($AC), tok.Value);
-end;
-
-procedure TLexerTests.TestCodepoint_HexAstral_FourBytes;
-var tok: TToken;
-begin
- SetLexer('#$1F600'); { GRINNING FACE -> UTF-8 F0 9F 98 80 }
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
- AssertEquals('len', 4, Length(tok.Value));
- AssertEquals('Value', Chr($F0) + Chr($9F) + Chr($98) + Chr($80), tok.Value);
-end;
-
-procedure TLexerTests.TestCodepoint_MergesWithStringAndEachOther;
-var tok: TToken;
-begin
- { Adjacent # and '...' literals merge into one compile-time string. }
- SetLexer('#72#73''!'''); { 'H' 'I' '!' }
- tok := FLexer.Next();
- AssertEquals('Kind', Ord(tkStringLit), Ord(tok.Kind));
- AssertEquals('Value', 'HI!', tok.Value);
-end;
-
{ Operators and punctuation }
procedure TLexerTests.TestOp_Plus;
diff --git a/compiler/src/test/pascal/cp.test.linker.pas b/compiler/src/test/pascal/cp.test.linker.pas
index ea7086f..4566e46 100644
--- a/compiler/src/test/pascal/cp.test.linker.pas
+++ b/compiler/src/test/pascal/cp.test.linker.pas
@@ -18,7 +18,7 @@ unit cp.test.linker;
interface
uses
- classes, SysUtils, process, blaise.testing, Generics.Collections,
+ SysUtils, process, blaise.testing, Generics.Collections,
blaise.elfreader, blaise.linker.elf, blaise.assembler.x86_64;
type
@@ -58,8 +58,7 @@ type
procedure TestSym_SynthesisedSymbolsDefined;
{ Static relocations }
procedure TestReloc_PC32CrossObjectCall;
- procedure TestReloc_Quad64_ResolvesToAbsoluteAddr;
- procedure TestReloc_Abs32_ResolvesInStaticMode;
+ procedure TestReloc_Quad64_Raises;
{ Executable structure }
procedure TestExe_ElfHeaderIsExec;
procedure TestExe_EntryPointMatchesSymbol;
@@ -75,34 +74,6 @@ type
procedure SetUp; override;
published
procedure TestRun_SyscallHelloWorld;
- { Linking with the FreeBSD target stamps EI_OSABI = 9 (ELFOSABI_FREEBSD)
- in the ELF header and keeps the static ET_EXEC / _start shape. The
- FreeBSD binary cannot execute on the Linux test host (different syscall
- numbers), so this asserts the emitted header shape only — the structural
- check the cross-compile lane relies on. }
- procedure TestLink_FreeBSDTarget_StampsOSABI;
- { Step 3: linking the freestanding FreeBSD _start with the FreeBSD target
- yields a static ET_EXEC whose entry point is _start and which has no
- PT_INTERP — the Strategy-B shape a cross-compiled FreeBSD binary needs.
- Asserts header shape only (it cannot run on the Linux host). }
- procedure TestLink_FreeBSDStart_StaticExecShape;
- { Step 4a: a fixture that mirrors the runtime.syscall.freebsd file/process
- leaves (open/read/write/mmap/stat) links under the FreeBSD target with the
- bare POSIX symbols DEFINED, and the linked .text carries the FreeBSD
- ino64 syscall NUMBERS (open=5, write=4, mmap=477, fstatat=552) plus the
- CF-error-translation idiom (jae + negq). Standalone — no FreeBSD
- emulation, header/byte shape only. }
- procedure TestLink_FreeBSDSyscallLeaf_SymbolsAndNumbers;
- { Step 4b: the FreeBSD leaf additions — getrandom uses the FreeBSD number
- (563, not Linux's 318) and the mremap stub is a plain function that returns
- MAP_FAILED (-1) so runtime.mem takes its alloc-copy-free grow fallback (no
- in-place remap syscall on FreeBSD). Standalone byte/symbol shape. }
- procedure TestLink_FreeBSDSyscallLeaf_GetrandomAndMremapStub;
- { Step 4c: the FreeBSD threads/TLS leaf — thr_new (455), _umtx_op (454) and
- thr_exit (431) link under the FreeBSD target with their FreeBSD syscall
- numbers present in the linked .text, and NOT Linux's clone (56) / futex
- (202). Standalone byte/symbol shape. }
- procedure TestLink_FreeBSDThreadLeaf_SyscallNumbers;
end;
TDynLinkerTests = class(TTestCase)
@@ -147,12 +118,6 @@ type
procedure TestRun_ExceptionHandling;
procedure TestRun_ClassAndVirtual;
procedure TestLink_MissingRTL_FailsLoudly;
- { Step 6: a full compiler-CLI cross-compile with --target freebsd-x86_64
- selects the FreeBSD RTL adapter set (BuildRTLUnitList) and emits a static,
- freestanding FreeBSD ET_EXEC — EI_OSABI = 9, no PT_INTERP, entry _start —
- with no external tools. The binary cannot run on the Linux host, so this
- asserts the emitted ELF shape only. }
- procedure TestCompile_FreeBSDTarget_EmitsStaticFreeBSDExe;
end;
implementation
@@ -359,92 +324,30 @@ end;
procedure TElfReaderTests.TestArchive_ParsesRTL;
var
- Root, ObjDir, ArPath, ScriptOut: string;
- Compiler: string;
+ RTLPath: string;
Members: TList;
- ObjList: TStringList;
- Proc: TProcess;
- Chunk: string;
I: Integer;
M: TArchiveMember;
Obj: TElfObjectFile;
- SawLongName: Boolean;
+ SawSetjmp: Boolean;
begin
- { The shipped blaise_rtl.a is gone (RTL-unification Stage 3). To still
- exercise the archive parser — including the GNU long-name (//) table on the
- >15-char member rtl.platform.layout.linux.o — build the RTL objects from
- source and bundle them into a THROWAWAY .a with `ar` just for this test.
- `ar` is a test-time dependency only; the product/bootstrap no longer use it. }
- Root := ProjectRoot();
- Compiler := Root + 'compiler/target/blaise';
- if (not FileExists(Compiler))
- or (not FileExists(Root + 'compiler/src/main/pascal/runtime.arc.pas')) then
+ RTLPath := ProjectRoot() + 'compiler/target/blaise_rtl.a';
+ if not FileExists(RTLPath) then
begin
Ignore('');
Exit;
end;
- ObjDir := Root + 'compiler/target/test-archive-rtl';
- ScriptOut := '';
- Proc := TProcess.Create(nil);
- try
- Proc.Executable := Root + 'scripts/build-rtl-objects.sh';
- Proc.Parameters.Add(Compiler);
- Proc.Parameters.Add(ObjDir);
- Proc.Parameters.Add('--with-startup');
- Proc.Execute();
- repeat
- Chunk := Proc.ReadOutput();
- ScriptOut := ScriptOut + Chunk
- until (Chunk = '') and not Proc.Running;
- Proc.WaitOnExit();
- if Proc.ExitCode <> 0 then
- begin
- Ignore('');
- Exit;
- end;
- finally
- Proc.Free();
- end;
-
- { Bundle the built objects into a temp archive with ar. Split the script's
- stdout (one object path per line) via TStringList. }
- ArPath := IncludeTrailingPathDelimiter(ObjDir) + 'rtl_test.a';
- DeleteFile(ArPath);
- ObjList := TStringList.Create();
- Proc := TProcess.Create(nil);
- try
- ObjList.Text := ScriptOut;
- Proc.Executable := 'ar';
- Proc.Parameters.Add('rcs');
- Proc.Parameters.Add(ArPath);
- for I := 0 to ObjList.Count - 1 do
- if Trim(ObjList.Strings[I]) <> '' then
- Proc.Parameters.Add(Trim(ObjList.Strings[I]));
- Proc.Execute();
- Proc.WaitOnExit();
- if (Proc.ExitCode <> 0) or (not FileExists(ArPath)) then
- begin
- Ignore('');
- Exit;
- end;
- finally
- Proc.Free();
- ObjList.Free();
- end;
-
Members := TList.Create();
try
- ReadArchiveFile(ArPath, Members);
+ ReadArchiveFile(RTLPath, Members);
AssertTrue('expected several RTL members, got '
+ IntToStr(Members.Count), Members.Count >= 5);
- { A member whose name exceeds 15 chars exercises the GNU long-name (//)
- table. rtl.platform.layout.linux.o is the longest current RTL member. }
- SawLongName := False;
+ SawSetjmp := False;
for I := 0 to Members.Count - 1 do
begin
M := Members.Get(I);
- if M.Name = 'rtl.platform.layout.linux.o' then
- SawLongName := True;
+ if M.Name = 'blaise_setjmp_x86_64.o' then
+ SawSetjmp := True;
{ Every member must parse as a valid x86-64 relocatable object
with at least its NULL section + one real section. }
Obj := ParseElfObject(M.Data, M.Name);
@@ -455,8 +358,8 @@ begin
Obj.Free();
end;
end;
- AssertTrue('long-named member rtl.platform.layout.linux.o not found '
- + '(GNU long-name table mishandled?)', SawLongName);
+ AssertTrue('long-named member blaise_setjmp_x86_64.o not found '
+ + '(GNU long-name table mishandled?)', SawSetjmp);
finally
for I := 0 to Members.Count - 1 do
Members.Get(I).Free();
@@ -815,73 +718,29 @@ begin
end;
end;
-procedure TLinkerTests.TestReloc_Quad64_ResolvesToAbsoluteAddr;
+procedure TLinkerTests.TestReloc_Quad64_Raises;
var
Lk: TLinker;
Bytes: string;
+ Raised: Boolean;
begin
- { An absolute 64-bit pointer to a symbol (`.quad target`, R_X86_64_64) is
- resolvable at link time in a non-PIE ET_EXEC: every symbol has a fixed load
- address. The static linker must patch the slot with target's absolute
- address (no dynamic relocation) — this is what makes a freestanding static
- --static link possible (docs/linux-syscall-migration.adoc). }
- Lk := LinkObjs(
- ['.data' + LineEnding + 'ptr:' + LineEnding + '.quad target' + LineEnding +
- '.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
- LineEnding + 'ret' + LineEnding +
- '.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
- '_start', Bytes);
+ { An absolute 64-bit pointer to a symbol needs dynamic linking under
+ a real PIE; Phase B rejects R_X86_64_64 explicitly. }
+ Raised := False;
+ Lk := nil;
try
- { The link must succeed and produce a valid ET_EXEC. }
- AssertTrue('static R_X86_64_64 link produced no output', Length(Bytes) >= 64);
- AssertEquals('e_type ET_EXEC', 2,
- (Ord(Bytes[16]) and $FF) or ((Ord(Bytes[17]) and $FF) shl 8));
- finally
- Lk.Free();
- end;
-end;
-
-procedure TLinkerTests.TestReloc_Abs32_ResolvesInStaticMode;
-var
- Lk: TLinker;
- Bytes: string;
- Addr, Got: Int64;
- I, Slot: Integer;
-begin
- { An absolute 32-bit data reference (.long target, R_X86_64_32) is
- resolvable at link time in a non-PIE ET_EXEC: the image is linked at a
- fixed base (0x400000) and every mapped address fits in 32 bits. The
- OPDF emitter uses exactly this form (.long label) inside the .opdf
- section, so a static FreeBSD link with debug info must accept it.
- A marker word (0xDEADBEEF as decimal) precedes the slot so the test can
- locate the patched bytes in the flat image. }
- Lk := LinkObjs(
- ['.data' + LineEnding +
- 'marker:' + LineEnding + '.long 3735928559' + LineEnding +
- 'ptr32:' + LineEnding + '.long target' + LineEnding +
- '.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
- LineEnding + 'ret' + LineEnding +
- '.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
- '_start', Bytes);
- try
- Addr := Lk.AddrOfSymbol('target');
- AssertTrue('target resolved above base', Addr > $400000);
- { Find the marker; the patched abs32 slot follows it. }
- Slot := -1;
- for I := 0 to Length(Bytes) - 9 do
- if (OrdAt(Bytes, I) = $EF) and (OrdAt(Bytes, I + 1) = $BE) and
- (OrdAt(Bytes, I + 2) = $AD) and (OrdAt(Bytes, I + 3) = $DE) then
- begin
- Slot := I + 4;
- Break;
- end;
- AssertTrue('marker found in image', Slot >= 0);
- Got := OrdAt(Bytes, Slot) or (OrdAt(Bytes, Slot + 1) shl 8) or
- (OrdAt(Bytes, Slot + 2) shl 16) or (OrdAt(Bytes, Slot + 3) shl 24);
- AssertEquals('abs32 slot patched with target address', Addr, Got);
- finally
- Lk.Free();
+ Lk := LinkObjs(
+ ['.data' + LineEnding + 'ptr:' + LineEnding + '.quad target' + LineEnding +
+ '.text' + LineEnding + '.globl target' + LineEnding + 'target:' +
+ LineEnding + 'ret' + LineEnding +
+ '.globl _start' + LineEnding + '_start:' + LineEnding + 'ret' + LineEnding],
+ '_start', Bytes);
+ except
+ on E: ELinker do
+ Raised := True;
end;
+ Lk.Free();
+ AssertTrue('R_X86_64_64 must raise ELinker in Phase B', Raised);
end;
procedure TLinkerTests.TestExe_ElfHeaderIsExec;
@@ -1053,354 +912,6 @@ begin
'Hello, linker!' + Chr(10), Output);
end;
-procedure TLinkerE2ETests.TestLink_FreeBSDTarget_StampsOSABI;
-const
- FixtureAsm =
- '.text' + LineEnding +
- '.globl _start' + LineEnding +
- '_start:' + LineEnding +
- ' movq $1, %rax' + LineEnding +
- ' movq $1, %rdi' + LineEnding +
- ' movq $60, %rax' + LineEnding +
- ' movq $0, %rdi' + LineEnding +
- ' .byte 15' + LineEnding + ' .byte 5' + LineEnding;
-var
- Lk: TLinker;
- Obj: TElfObjectFile;
- BinPath, Bytes: string;
-begin
- BinPath := FScratch + '/freebsd_osabi';
- { Build the linker with the FreeBSD link target (OSABI = 9). }
- Lk := TLinker.Create(FreeBSDX86_64Target());
- try
- Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fb.o');
- Lk.AddOwnedObject(Obj);
- Lk.Link('_start', BinPath);
- finally
- Lk.Free();
- end;
-
- AssertTrue('linked FreeBSD binary missing', FileExists(BinPath));
- Bytes := ReadFile(BinPath);
- AssertTrue('output too small to be an ELF', Length(Bytes) >= 8);
- { ELF magic 0x7F 'E' 'L' 'F' at [0..3]; EI_OSABI is byte [7]. }
- AssertEquals('ELF magic byte 0', $7F, OrdAt(Bytes, 0));
- AssertEquals('EI_CLASS = ELFCLASS64', 2, OrdAt(Bytes, 4));
- AssertEquals('EI_OSABI = ELFOSABI_FREEBSD (9)', 9, OrdAt(Bytes, 7));
-end;
-
-procedure TLinkerE2ETests.TestLink_FreeBSDStart_StaticExecShape;
-const
- { A self-contained FreeBSD _start: capture the stack, then exit(0) via
- SYS_exit = 1. Mirrors runtime.start.static.freebsd's entry shape without
- pulling in main/_SetArgs, so it links with no undefined symbols. }
- FixtureAsm =
- '.text' + LineEnding +
- '.globl _start' + LineEnding +
- '_start:' + LineEnding +
- ' endbr64' + LineEnding +
- ' xorl %ebp, %ebp' + LineEnding +
- ' movq %rsp, %rdi' + LineEnding +
- ' xorl %edi, %edi' + LineEnding +
- ' movq $1, %rax' + LineEnding + { SYS_exit }
- ' syscall' + LineEnding +
- ' hlt' + LineEnding;
-var
- Lk: TLinker;
- Obj: TElfObjectFile;
- Bytes: string;
- Entry, StartAddr: Int64;
- PhOff, PhEntSz, PhCount, J, PType: Integer;
- FoundInterp: Boolean;
-begin
- { LinkToBytes returns the binary in memory — ReadFile would truncate at the
- first NUL, which an ELF header hits at byte 8. }
- Lk := TLinker.Create(FreeBSDX86_64Target());
- try
- Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbstart.o');
- Lk.AddOwnedObject(Obj);
- Bytes := Lk.LinkToBytes('_start');
- StartAddr := Lk.AddrOfSymbol('_start');
- finally
- Lk.Free();
- end;
-
- AssertTrue('output too small to be an ELF', Length(Bytes) >= 64);
-
- { e_type at offset 16 must be ET_EXEC (2) — a static, non-PIE executable. }
- AssertEquals('e_type ET_EXEC', 2, OrdAt(Bytes, 16) or (OrdAt(Bytes, 17) shl 8));
- { EI_OSABI byte 7 = ELFOSABI_FREEBSD. }
- AssertEquals('EI_OSABI FreeBSD', 9, OrdAt(Bytes, 7));
-
- { e_entry (offset 24, 8 bytes LE) must equal the address of _start. }
- Entry := Int64(OrdAt(Bytes, 24)) or (Int64(OrdAt(Bytes, 25)) shl 8) or
- (Int64(OrdAt(Bytes, 26)) shl 16) or (Int64(OrdAt(Bytes, 27)) shl 24) or
- (Int64(OrdAt(Bytes, 28)) shl 32) or (Int64(OrdAt(Bytes, 29)) shl 40) or
- (Int64(OrdAt(Bytes, 30)) shl 48) or (Int64(OrdAt(Bytes, 31)) shl 56);
- AssertEquals('entry point is _start', StartAddr, Entry);
-
- { No PT_INTERP (type 3) among the program headers — a freestanding binary has
- no dynamic loader. }
- PhOff := OrdAt(Bytes, 32) or (OrdAt(Bytes, 33) shl 8) or
- (OrdAt(Bytes, 34) shl 16) or (OrdAt(Bytes, 35) shl 24);
- PhEntSz := OrdAt(Bytes, 54) or (OrdAt(Bytes, 55) shl 8);
- PhCount := OrdAt(Bytes, 56) or (OrdAt(Bytes, 57) shl 8);
- FoundInterp := False;
- for J := 0 to PhCount - 1 do
- begin
- PType := OrdAt(Bytes, PhOff + J * PhEntSz) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 1) shl 8) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 2) shl 16) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 3) shl 24);
- if PType = 3 then FoundInterp := True;
- end;
- AssertTrue('static ET_EXEC must have no PT_INTERP', not FoundInterp);
-end;
-
-procedure TLinkerE2ETests.TestLink_FreeBSDSyscallLeaf_SymbolsAndNumbers;
-const
- { Mirrors the runtime.syscall.freebsd leaf bodies byte-for-byte (a handful of
- representative leaves): each is `movq $N, %rax; syscall; jae ok; negq %rax;
- ok: ret`, with mmap's `movq %rcx, %r10` and stat lowered to
- fstatat(AT_FDCWD, path, buf, 0). Names are the bare POSIX symbols posix
- imports. A leading _start keeps the linker's entry resolvable. }
- FixtureAsm =
- '.text' + LineEnding +
- '.globl _start' + LineEnding +
- '_start:' + LineEnding +
- ' callq open' + LineEnding +
- ' callq read' + LineEnding +
- ' callq write' + LineEnding +
- ' callq mmap' + LineEnding +
- ' callq stat' + LineEnding +
- ' xorl %edi, %edi' + LineEnding +
- ' movq $1, %rax' + LineEnding + { SYS_exit }
- ' syscall' + LineEnding +
- ' hlt' + LineEnding +
- '.globl open' + LineEnding +
- 'open:' + LineEnding +
- ' movq $5, %rax' + LineEnding + { SYS_open }
- ' syscall' + LineEnding +
- ' jae .Lok_open' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_open:' + LineEnding +
- ' ret' + LineEnding +
- '.globl read' + LineEnding +
- 'read:' + LineEnding +
- ' movq $3, %rax' + LineEnding + { SYS_read }
- ' syscall' + LineEnding +
- ' jae .Lok_read' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_read:' + LineEnding +
- ' ret' + LineEnding +
- '.globl write' + LineEnding +
- 'write:' + LineEnding +
- ' movq $4, %rax' + LineEnding + { SYS_write }
- ' syscall' + LineEnding +
- ' jae .Lok_write' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_write:' + LineEnding +
- ' ret' + LineEnding +
- '.globl mmap' + LineEnding +
- 'mmap:' + LineEnding +
- ' movq %rcx, %r10' + LineEnding +
- ' movq $477, %rax' + LineEnding + { SYS_mmap (ino64) }
- ' syscall' + LineEnding +
- ' jae .Lok_mmap' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_mmap:' + LineEnding +
- ' ret' + LineEnding +
- '.globl stat' + LineEnding +
- 'stat:' + LineEnding +
- ' movq %rsi, %rdx' + LineEnding +
- ' movq %rdi, %rsi' + LineEnding +
- ' movq $-100, %rdi' + LineEnding + { AT_FDCWD }
- ' xorq %r10, %r10' + LineEnding +
- ' movq $552, %rax' + LineEnding + { SYS_fstatat (ino64) }
- ' syscall' + LineEnding +
- ' jae .Lok_stat' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_stat:' + LineEnding +
- ' ret' + LineEnding;
- { Encoded `movq $imm32, %rax` = 48 C7 C0 . These byte strings must
- appear in the linked .text if the correct syscall number was emitted. }
- function MovRaxImm(AImm: Integer): string;
- begin
- Result := Chr($48) + Chr($C7) + Chr($C0) +
- Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
- Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
- end;
-var
- Lk: TLinker;
- Obj: TElfObjectFile;
- Bytes: string;
-begin
- Lk := TLinker.Create(FreeBSDX86_64Target());
- try
- Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbsys.o');
- Lk.AddOwnedObject(Obj);
- Bytes := Lk.LinkToBytes('_start');
-
- { 1. The bare POSIX leaf symbols must be DEFINED (non-zero address). }
- AssertTrue('open defined', Lk.AddrOfSymbol('open') > 0);
- AssertTrue('read defined', Lk.AddrOfSymbol('read') > 0);
- AssertTrue('write defined', Lk.AddrOfSymbol('write') > 0);
- AssertTrue('mmap defined', Lk.AddrOfSymbol('mmap') > 0);
- AssertTrue('stat defined', Lk.AddrOfSymbol('stat') > 0);
- finally
- Lk.Free();
- end;
-
- { 2. FreeBSD ino64 syscall NUMBERS present in the linked .text as the
- `movq $N, %rax` encoding — NOT Linux's numbers. }
- AssertTrue('SYS_open=5 movq imm present', Pos(MovRaxImm(5), Bytes) >= 0);
- AssertTrue('SYS_read=3 movq imm present', Pos(MovRaxImm(3), Bytes) >= 0);
- AssertTrue('SYS_write=4 movq imm present', Pos(MovRaxImm(4), Bytes) >= 0);
- AssertTrue('SYS_mmap=477 movq imm present', Pos(MovRaxImm(477), Bytes) >= 0);
- AssertTrue('SYS_fstatat=552 movq imm present (stat via fstatat)',
- Pos(MovRaxImm(552), Bytes) >= 0);
-
- { 3. The CF-error-translation idiom: negq %rax (48 F7 D8) must appear. This
- is the FreeBSD-specific errno translation the Linux leaf does not emit. }
- AssertTrue('negq %rax (CF translation) present',
- Pos(Chr($48) + Chr($F7) + Chr($D8), Bytes) >= 0);
- { mmap's arg4 shuffle: movq %rcx, %r10 (49 89 CA). }
- AssertTrue('movq %rcx,%r10 (mmap arg4) present',
- Pos(Chr($49) + Chr($89) + Chr($CA), Bytes) >= 0);
-end;
-
-procedure TLinkerE2ETests.TestLink_FreeBSDSyscallLeaf_GetrandomAndMremapStub;
-const
- { getrandom is a raw syscall with the FreeBSD number 563 (Linux's is 318).
- mremap has no FreeBSD syscall, so the leaf's stub just returns MAP_FAILED
- (-1) — a mov of -1 into %rax then ret; runtime.mem's realloc path treats
- that as "grow the slow way". A leading _start keeps the entry resolvable. }
- FixtureAsm =
- '.text' + LineEnding +
- '.globl _start' + LineEnding +
- '_start:' + LineEnding +
- ' callq getrandom' + LineEnding +
- ' callq mremap' + LineEnding +
- ' xorl %edi, %edi' + LineEnding +
- ' movq $1, %rax' + LineEnding + { SYS_exit }
- ' syscall' + LineEnding +
- ' hlt' + LineEnding +
- '.globl getrandom' + LineEnding +
- 'getrandom:' + LineEnding +
- ' movq $563, %rax' + LineEnding + { SYS_getrandom (FreeBSD) }
- ' syscall' + LineEnding +
- ' jae .Lok_gr' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_gr:' + LineEnding +
- ' ret' + LineEnding +
- '.globl mremap' + LineEnding +
- 'mremap:' + LineEnding +
- ' movq $-1, %rax' + LineEnding + { MAP_FAILED — no FreeBSD mremap }
- ' ret' + LineEnding;
- function MovRaxImm(AImm: Integer): string;
- begin
- Result := Chr($48) + Chr($C7) + Chr($C0) +
- Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
- Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
- end;
-var
- Lk: TLinker;
- Obj: TElfObjectFile;
- Bytes: string;
-begin
- Lk := TLinker.Create(FreeBSDX86_64Target());
- try
- Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbsys2.o');
- Lk.AddOwnedObject(Obj);
- Bytes := Lk.LinkToBytes('_start');
- AssertTrue('getrandom defined', Lk.AddrOfSymbol('getrandom') > 0);
- AssertTrue('mremap defined', Lk.AddrOfSymbol('mremap') > 0);
- finally
- Lk.Free();
- end;
- { getrandom uses the FreeBSD number 563 — NOT Linux's 318. }
- AssertTrue('SYS_getrandom=563 movq imm present', Pos(MovRaxImm(563), Bytes) >= 0);
- AssertTrue('Linux SYS_getrandom=318 NOT present', Pos(MovRaxImm(318), Bytes) < 0);
- { mremap stub loads -1 (movq $-1,%rax = 48 C7 C0 FF FF FF FF). }
- AssertTrue('mremap stub returns -1 (MAP_FAILED)', Pos(MovRaxImm(-1), Bytes) >= 0);
-end;
-
-procedure TLinkerE2ETests.TestLink_FreeBSDThreadLeaf_SyscallNumbers;
-const
- { Mirrors the runtime.syscall.freebsd threads/TLS leaf bodies: thr_new (455),
- _umtx_op (454, with its arg4 %rcx->%r10 shuffle) and thr_exit (431). These
- are the FreeBSD analogues of Linux's clone (56) / futex (202) / exit (60);
- the numbers MUST be FreeBSD's, not Linux's. A leading _start keeps the
- linker's entry resolvable. }
- FixtureAsm =
- '.text' + LineEnding +
- '.globl _start' + LineEnding +
- '_start:' + LineEnding +
- ' callq thr_new' + LineEnding +
- ' callq _umtx_op' + LineEnding +
- ' callq thr_exit' + LineEnding +
- ' xorl %edi, %edi' + LineEnding +
- ' movq $1, %rax' + LineEnding + { SYS_exit }
- ' syscall' + LineEnding +
- ' hlt' + LineEnding +
- '.globl thr_new' + LineEnding +
- 'thr_new:' + LineEnding +
- ' movq $455, %rax' + LineEnding + { SYS_thr_new }
- ' syscall' + LineEnding +
- ' jae .Lok_thr_new' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_thr_new:' + LineEnding +
- ' ret' + LineEnding +
- '.globl _umtx_op' + LineEnding +
- '_umtx_op:' + LineEnding +
- ' movq %rcx, %r10' + LineEnding +
- ' movq $454, %rax' + LineEnding + { SYS__umtx_op }
- ' syscall' + LineEnding +
- ' jae .Lok_umtx' + LineEnding +
- ' negq %rax' + LineEnding +
- '.Lok_umtx:' + LineEnding +
- ' ret' + LineEnding +
- '.globl thr_exit' + LineEnding +
- 'thr_exit:' + LineEnding +
- ' movq $431, %rax' + LineEnding + { SYS_thr_exit }
- ' syscall' + LineEnding +
- ' ret' + LineEnding;
- { Encoded `movq $imm32, %rax` = 48 C7 C0 . }
- function MovRaxImm(AImm: Integer): string;
- begin
- Result := Chr($48) + Chr($C7) + Chr($C0) +
- Chr(AImm and $FF) + Chr((AImm shr 8) and $FF) +
- Chr((AImm shr 16) and $FF) + Chr((AImm shr 24) and $FF);
- end;
-var
- Lk: TLinker;
- Obj: TElfObjectFile;
- Bytes: string;
-begin
- Lk := TLinker.Create(FreeBSDX86_64Target());
- try
- Obj := ParseElfObject(AssembleToBytes(FixtureAsm), 'fbthr.o');
- Lk.AddOwnedObject(Obj);
- Bytes := Lk.LinkToBytes('_start');
- { The bare thread-primitive symbols must be DEFINED (non-zero address). }
- AssertTrue('thr_new defined', Lk.AddrOfSymbol('thr_new') > 0);
- AssertTrue('_umtx_op defined', Lk.AddrOfSymbol('_umtx_op') > 0);
- AssertTrue('thr_exit defined', Lk.AddrOfSymbol('thr_exit') > 0);
- finally
- Lk.Free();
- end;
- { FreeBSD thread syscall NUMBERS present in the linked .text. }
- AssertTrue('SYS_thr_new=455 movq imm present', Pos(MovRaxImm(455), Bytes) >= 0);
- AssertTrue('SYS__umtx_op=454 movq imm present', Pos(MovRaxImm(454), Bytes) >= 0);
- AssertTrue('SYS_thr_exit=431 movq imm present', Pos(MovRaxImm(431), Bytes) >= 0);
- { NOT Linux's clone (56) / futex (202) — those numbers must be absent. }
- AssertTrue('Linux SYS_clone=56 NOT present', Pos(MovRaxImm(56), Bytes) < 0);
- AssertTrue('Linux SYS_futex=202 NOT present', Pos(MovRaxImm(202), Bytes) < 0);
- { _umtx_op's arg4 shuffle: movq %rcx, %r10 (49 89 CA). }
- AssertTrue('movq %rcx,%r10 (_umtx_op arg4) present',
- Pos(Chr($49) + Chr($89) + Chr($CA), Bytes) >= 0);
-end;
-
{ ---- TDynLinkerTests ---- }
function TDynLinkerTests.ProjectRoot: string;
@@ -1675,7 +1186,7 @@ procedure TInternalLinkerE2ETests.SetUp;
begin
inherited SetUp();
FCompiler := ProjectRoot() + 'compiler/target/blaise';
- FRTLPath := ProjectRoot() + 'compiler/src/main/pascal';
+ FRTLPath := ProjectRoot() + 'runtime/src/main/pascal';
FStdlibPath := ProjectRoot() + 'stdlib/src/main/pascal';
FScratch := ProjectRoot() + 'compiler/target/intlink_scratch/';
ForceDirectories(FScratch);
@@ -1684,15 +1195,13 @@ end;
function TInternalLinkerE2ETests.CompilerAvailable: Boolean;
begin
- { The compiler source-builds the RTL itself (no blaise_rtl.a); only the binary
- and the RTL source need to be present. }
Result := FileExists(FCompiler) and
- FileExists(FRTLPath + '/runtime.arc.pas');
+ FileExists(ProjectRoot() + 'compiler/target/blaise_rtl.a');
if (not Result) and (not GIntLinkSkipNoted) then
begin
GIntLinkSkipNoted := True;
WriteLn(StdErr, 'note: TInternalLinkerE2ETests skipped — compiler binary "',
- FCompiler, '" or RTL source not found');
+ FCompiler, '" not found');
end;
end;
@@ -1906,7 +1415,17 @@ begin
FCounter := FCounter + 1;
IsoDir := FScratch + 'no_rtl_' + IntToStr(FCounter) + '/';
ForceDirectories(IsoDir);
- IsoCompiler := FCompiler;
+ IsoCompiler := IsoDir + 'blaise';
+ { Symlink the real compiler into the isolated dir — argv[0]'s dirname is the
+ isolated dir, which has NO blaise_rtl.a beside it, so FindRTLArchive
+ returns ''. (A symlink avoids copying the multi-MB binary and the
+ byte-exactness pitfalls of a string round-trip.) }
+ if FileExists(IsoCompiler) then DeleteFile(IsoCompiler);
+ if _test_symlink(PChar(FCompiler), PChar(IsoCompiler)) <> 0 then
+ begin
+ Ignore('');
+ Exit;
+ end;
SrcFile := IsoDir + 'prog.pas';
OutFile := IsoDir + 'prog';
@@ -1916,93 +1435,23 @@ begin
' WriteLn(6 * 7)' + LineEnding +
'end.');
- { The RTL is now compiled from SOURCE by the compiler at link time (no prebuilt
- blaise_rtl.a). Point --rtl-src at a nonexistent directory so the RTL source
- is unreachable: the driver must fail loudly rather than emit a broken binary. }
+ { BLAISE_RTL is normally unset in the test environment; the isolated dir has
+ no blaise_rtl.a, so FindRTLArchive returns '' and the guard must fire. }
Rc := Self.RunProc(IsoCompiler, [
- '--source', SrcFile,
- '--unit-path', FStdlibPath,
- '--output', OutFile,
- '--backend', 'native',
- '--assembler', 'internal',
- '--linker', 'internal',
- '--rtl-src', IsoDir + 'no_such_rtl_src'
- ], CompOut);
-
- AssertTrue('compiler must FAIL when the RTL source is unreachable (got rc=0)',
- Rc <> 0);
- AssertTrue('error must name the missing RTL source: ' + CompOut,
- Pos('RTL source', CompOut) >= 0);
- AssertFalse('no output binary should be produced on RTL-missing failure',
- FileExists(OutFile));
-end;
-
-procedure TInternalLinkerE2ETests.TestCompile_FreeBSDTarget_EmitsStaticFreeBSDExe;
-var
- SrcFile, OutFile, CompOut, Bytes: string;
- Rc, PhOff, PhEntSz, PhCount, J, PType: Integer;
- FoundInterp: Boolean;
-begin
- if not Self.CompilerAvailable() then
- begin
- Ignore('');
- Exit;
- end;
-
- FCounter := FCounter + 1;
- SrcFile := FScratch + 'test_fbsd_' + IntToStr(FCounter) + '.pas';
- OutFile := FScratch + 'test_fbsd_' + IntToStr(FCounter);
- WriteFile(SrcFile,
- 'program test_fbsd;' + LineEnding +
- 'begin' + LineEnding +
- ' WriteLn(''Hello'')' + LineEnding +
- 'end.');
-
- { Full compiler-CLI cross-compile. --target freebsd-x86_64 must select the
- FreeBSD RTL adapter set and drive the static, freestanding link with no
- external tools (internal assembler + linker). }
- Rc := Self.RunProc(FCompiler, [
'--source', SrcFile,
'--unit-path', FRTLPath,
'--unit-path', FStdlibPath,
'--output', OutFile,
'--backend', 'native',
'--assembler', 'internal',
- '--linker', 'internal',
- '--target', 'freebsd-x86_64'
+ '--linker', 'internal'
], CompOut);
- if Rc <> 0 then
- Fail('--target freebsd-x86_64 compile failed (rc=' + IntToStr(Rc) + '): ' +
- CompOut);
- AssertTrue('FreeBSD binary was produced', FileExists(OutFile));
- { The FreeBSD binary cannot run on the Linux host — assert its ELF shape.
- ReadWholeFile is NUL-safe (unlike the RTL ReadFile, which stops at the
- first NUL — an ELF header hits one at byte 8). }
- Bytes := ReadWholeFile(OutFile);
- AssertTrue('output too small to be an ELF', Length(Bytes) >= 64);
-
- { EI_OSABI byte 7 = ELFOSABI_FREEBSD (9). }
- AssertEquals('EI_OSABI FreeBSD', 9, OrdAt(Bytes, 7));
- { e_type at offset 16 = ET_EXEC (2) — static, non-PIE. }
- AssertEquals('e_type ET_EXEC', 2, OrdAt(Bytes, 16) or (OrdAt(Bytes, 17) shl 8));
-
- { No PT_INTERP (program-header type 3): a freestanding binary has no dynamic
- loader. }
- PhOff := OrdAt(Bytes, 32) or (OrdAt(Bytes, 33) shl 8) or
- (OrdAt(Bytes, 34) shl 16) or (OrdAt(Bytes, 35) shl 24);
- PhEntSz := OrdAt(Bytes, 54) or (OrdAt(Bytes, 55) shl 8);
- PhCount := OrdAt(Bytes, 56) or (OrdAt(Bytes, 57) shl 8);
- FoundInterp := False;
- for J := 0 to PhCount - 1 do
- begin
- PType := OrdAt(Bytes, PhOff + J * PhEntSz) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 1) shl 8) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 2) shl 16) or
- (OrdAt(Bytes, PhOff + J * PhEntSz + 3) shl 24);
- if PType = 3 then FoundInterp := True;
- end;
- AssertFalse('freestanding FreeBSD exe must have no PT_INTERP', FoundInterp);
+ AssertTrue('compiler must FAIL when RTL is unreachable (got rc=0)', Rc <> 0);
+ AssertTrue('error must name the missing RTL archive: ' + CompOut,
+ Pos('blaise_rtl.a', CompOut) >= 0);
+ AssertFalse('no output binary should be produced on RTL-missing failure',
+ FileExists(OutFile));
end;
initialization
diff --git a/compiler/src/test/pascal/cp.test.math.pas b/compiler/src/test/pascal/cp.test.math.pas
index 190c4c6..8b09262 100644
--- a/compiler/src/test/pascal/cp.test.math.pas
+++ b/compiler/src/test/pascal/cp.test.math.pas
@@ -192,7 +192,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
- FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
+ FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;
diff --git a/compiler/src/test/pascal/cp.test.methods.pas b/compiler/src/test/pascal/cp.test.methods.pas
index f35ce73..e2ba165 100644
--- a/compiler/src/test/pascal/cp.test.methods.pas
+++ b/compiler/src/test/pascal/cp.test.methods.pas
@@ -376,7 +376,7 @@ begin
var F: TFoo;
begin
F := TFoo.Create();
- F.NoSuchMethod()
+ F.NoSuchMethod
end.
''');
end;
diff --git a/compiler/src/test/pascal/cp.test.multifile.pas b/compiler/src/test/pascal/cp.test.multifile.pas
index 988c26c..f5fba62 100644
--- a/compiler/src/test/pascal/cp.test.multifile.pas
+++ b/compiler/src/test/pascal/cp.test.multifile.pas
@@ -37,33 +37,17 @@ type
procedure TestUnitLoader_LocatesUnitInSearchPath;
procedure TestUnitLoader_RaisesOnMissingUnit;
procedure TestUnitLoader_DetectsCycle;
- procedure TestUnitLoader_ImplSectionBackEdge_Tolerated;
procedure TestUnitLoader_DependencyOrder;
{ ------------------------------------------------------------------ }
{ AnalyseUnitForExport }
{ ------------------------------------------------------------------ }
procedure TestSemanticAnalyser_ExportedTypeVisibleInProgram;
procedure TestSemanticAnalyser_ExportedFuncVisibleInProgram;
- { Flat-merge of units that each privately bind the same external C symbol,
- or bind to a real RTL function — must not raise a false
- "ambiguous overload" / "duplicate identifier" (bugs.txt: runtime module
- library compile failed). }
- procedure TestSemanticAnalyser_DuplicateExternalBindingTolerated;
- procedure TestSemanticAnalyser_ExternalBindingToRealFuncTolerated;
- procedure TestSemanticAnalyser_PrivateImplProcsPerUnitNotAmbiguous;
{ ------------------------------------------------------------------ }
{ Combined code generation }
{ ------------------------------------------------------------------ }
procedure TestCodegen_TwoFileCompile_UnitFuncExported;
procedure TestCodegen_TwoFileCompile_MainPresent;
- { Two used units export the same global var name; a qualified reference
- 'Unit.V' must emit each unit's own owner-prefixed storage symbol so the
- two refer to distinct slots rather than colliding on a bare '$V'. }
- procedure TestCodegen_CrossUnitQualifiedVar_DistinctSymbols;
- { Two used units export a class of the same name; each unit's codegen pass
- must emit its type's storage symbols (typeinfo/vtable/__cn) keyed on its
- own unit, so the two coexist instead of colliding on the flat winner. }
- procedure TestCodegen_CrossUnitType_DistinctSymbols;
end;
implementation
@@ -250,57 +234,6 @@ begin
end;
end;
-procedure TMultifileTests.TestUnitLoader_ImplSectionBackEdge_Tolerated;
-const
- { BackA's INTERFACE uses BackB; BackB's IMPLEMENTATION uses BackA. This is a
- legal Object Pascal arrangement — interfaces are compiled before bodies, so
- BackB's body may name BackA even though BackA's interface (transitively)
- needs BackB. It must load without an ECircularDependency, unlike the
- interface↔interface cycle above. }
- SrcA =
- '''
- unit BackA;
- interface
- uses BackB;
- implementation
- end.
- ''';
- SrcB =
- '''
- unit BackB;
- interface
- implementation
- uses BackA;
- end.
- ''';
-var
- Paths: TStringList;
- Loader: TUnitLoader;
- Names: TStringList;
- Units: TObjectList;
-begin
- WriteUnit('BackA', SrcA);
- WriteUnit('BackB', SrcB);
-
- Paths := MakeSearchPaths();
- Loader := TUnitLoader.Create(Paths);
- Names := TStringList.Create();
- try
- Names.Add('BackA');
- { Must NOT raise — the back-edge is through an implementation-section use. }
- Units := Loader.LoadAll(Names);
- try
- AssertEquals('both units loaded', 2, Units.Count);
- finally
- Units.Free();
- end;
- finally
- Names.Free();
- Loader.Free();
- Paths.Free();
- end;
-end;
-
procedure TMultifileTests.TestUnitLoader_DependencyOrder;
const
SrcC =
@@ -446,197 +379,6 @@ begin
end;
end;
-procedure TMultifileTests.TestSemanticAnalyser_DuplicateExternalBindingTolerated;
-const
- { Two units each declare the SAME parameterless external C binding in their
- implementation section and call it. In the flat-merge both land in the
- one global overload group; they denote ONE function and must collapse. }
- UnitASrc =
- '''
- unit AltA;
- interface
- procedure DoA;
- implementation
- procedure ext_abort; external name 'abort';
- procedure DoA;
- begin
- ext_abort()
- end;
- end.
- ''';
- UnitBSrc =
- '''
- unit AltB;
- interface
- procedure DoB;
- implementation
- procedure ext_abort; external name 'abort';
- procedure DoB;
- begin
- ext_abort()
- end;
- end.
- ''';
- ProgSrc =
- '''
- program TestP;
- uses AltA, AltB;
- begin
- DoA(); DoB()
- end.
- ''';
-var
- UA, UB: TUnit;
- Prog: TProgram;
- SA: TSemanticAnalyser;
-begin
- UA := ParseUnitSrc(UnitASrc);
- UB := ParseUnitSrc(UnitBSrc);
- Prog := ParseProg(ProgSrc);
- SA := TSemanticAnalyser.Create();
- try
- SA.AnalyseUnitForExport(UA);
- SA.AnalyseUnitForExport(UB);
- SA.Analyse(Prog);
- AssertNotNull('prog analysed without ambiguity', Prog.SymbolTable);
- finally
- SA.Free();
- Prog.Free();
- UB.Free();
- UA.Free();
- end;
-end;
-
-procedure TMultifileTests.TestSemanticAnalyser_ExternalBindingToRealFuncTolerated;
-const
- { An unmangled RTL-style unit (blaise_*) exports a real function whose link
- symbol is its bare name; a second unit binds to it via `external name`.
- The flat-merge sees one real def + one external binding for the same link
- symbol — must not be a duplicate identifier nor an ambiguous overload. }
- MemSrc =
- '''
- unit blaise_testmem;
- interface
- function _TestGetMem(Size: Integer): Pointer;
- implementation
- function _TestGetMem(Size: Integer): Pointer;
- begin
- Result := nil
- end;
- end.
- ''';
- UseSrc =
- '''
- unit UserU;
- interface
- function GrabMem: Pointer;
- implementation
- function _TestGetMem(Size: Integer): Pointer; external name '_TestGetMem';
- function GrabMem: Pointer;
- begin
- Result := _TestGetMem(8)
- end;
- end.
- ''';
- ProgSrc =
- '''
- program TestP;
- uses blaise_testmem, UserU;
- var p: Pointer;
- begin
- p := GrabMem()
- end.
- ''';
-var
- UM, UU: TUnit;
- Prog: TProgram;
- SA: TSemanticAnalyser;
-begin
- UM := ParseUnitSrc(MemSrc);
- UU := ParseUnitSrc(UseSrc);
- Prog := ParseProg(ProgSrc);
- SA := TSemanticAnalyser.Create();
- try
- SA.AnalyseUnitForExport(UM);
- SA.AnalyseUnitForExport(UU);
- SA.Analyse(Prog);
- AssertNotNull('prog analysed: external binding to real func', Prog.SymbolTable);
- finally
- SA.Free();
- Prog.Free();
- UU.Free();
- UM.Free();
- end;
-end;
-
-procedure TMultifileTests.TestSemanticAnalyser_PrivateImplProcsPerUnitNotAmbiguous;
-const
- { Two units each declare a PRIVATE (implementation-only, non-external) helper
- of the same name and call it. Each unit's call must bind to its own copy;
- the other unit's private helper is not a visible competing candidate. }
- UnitASrc =
- '''
- unit PrivA;
- interface
- function GoA: Integer;
- implementation
- function Helper(X: Integer): Integer;
- begin
- Result := X + 1
- end;
- function GoA: Integer;
- begin
- Result := Helper(10)
- end;
- end.
- ''';
- UnitBSrc =
- '''
- unit PrivB;
- interface
- function GoB: Integer;
- implementation
- function Helper(X: Integer): Integer;
- begin
- Result := X + 2
- end;
- function GoB: Integer;
- begin
- Result := Helper(20)
- end;
- end.
- ''';
- ProgSrc =
- '''
- program TestP;
- uses PrivA, PrivB;
- var r: Integer;
- begin
- r := GoA() + GoB()
- end.
- ''';
-var
- UA, UB: TUnit;
- Prog: TProgram;
- SA: TSemanticAnalyser;
-begin
- UA := ParseUnitSrc(UnitASrc);
- UB := ParseUnitSrc(UnitBSrc);
- Prog := ParseProg(ProgSrc);
- SA := TSemanticAnalyser.Create();
- try
- SA.AnalyseUnitForExport(UA);
- SA.AnalyseUnitForExport(UB);
- SA.Analyse(Prog);
- AssertNotNull('prog analysed: per-unit private helpers', Prog.SymbolTable);
- finally
- SA.Free();
- Prog.Free();
- UB.Free();
- UA.Free();
- end;
-end;
-
{ ------------------------------------------------------------------ }
{ Combined code generation tests }
{ ------------------------------------------------------------------ }
@@ -741,146 +483,6 @@ begin
end;
end;
-procedure TMultifileTests.TestCodegen_CrossUnitQualifiedVar_DistinctSymbols;
-const
- UnitA =
- '''
- unit uva;
- interface
- var V: Integer = 7;
- implementation
- end.
- ''';
- UnitB =
- '''
- unit uvb;
- interface
- var V: Integer = 9;
- implementation
- end.
- ''';
- ProgSrc =
- '''
- program TestP;
- uses uva, uvb;
- var r: Integer;
- begin
- r := uva.V;
- r := uvb.V
- end.
- ''';
-var
- UA, UB: TUnit;
- Prog: TProgram;
- SA: TSemanticAnalyser;
- CG: TCodeGenQBE;
- IR: string;
-begin
- UA := ParseUnitSrc(UnitA);
- UB := ParseUnitSrc(UnitB);
- Prog := ParseProg(ProgSrc);
- SA := TSemanticAnalyser.Create();
- CG := TCodeGenQBE.Create();
- try
- SA.AnalyseUnitForExport(UA);
- SA.AnalyseUnitForExport(UB);
- SA.Analyse(Prog);
- CG.AppendUnit(UA);
- CG.AppendUnit(UB);
- CG.AppendProgram(Prog);
- IR := CG.GetOutput();
- { Each unit defines its own owner-prefixed slot, and the qualified loads
- reference both — proving the two same-named vars do not collapse. }
- AssertTrue('uva.V slot referenced', Pos('$uva_V', IR) > 0);
- AssertTrue('uvb.V slot referenced', Pos('$uvb_V', IR) > 0);
- finally
- CG.Free();
- SA.Free();
- Prog.Free();
- UB.Free();
- UA.Free();
- end;
-end;
-
-procedure TMultifileTests.TestCodegen_CrossUnitType_DistinctSymbols;
-const
- UnitA =
- '''
- unit tca;
- interface
- type
- TShape = class
- function Sides: Integer;
- end;
- implementation
- function TShape.Sides: Integer;
- begin
- Result := 3
- end;
- end.
- ''';
- UnitB =
- '''
- unit tcb;
- interface
- type
- TShape = class
- function Sides: Integer;
- end;
- implementation
- function TShape.Sides: Integer;
- begin
- Result := 4
- end;
- end.
- ''';
- ProgSrc =
- '''
- program TestP;
- uses tca, tcb;
- var S: TShape;
- begin
- S := TShape.Create()
- end.
- ''';
-var
- UA, UB: TUnit;
- Prog: TProgram;
- SA: TSemanticAnalyser;
- CG: TCodeGenQBE;
- IR: string;
-begin
- UA := ParseUnitSrc(UnitA);
- UB := ParseUnitSrc(UnitB);
- Prog := ParseProg(ProgSrc);
- SA := TSemanticAnalyser.Create();
- CG := TCodeGenQBE.Create();
- try
- SA.AnalyseUnitForExport(UA);
- SA.AnalyseUnitForExport(UB);
- SA.Analyse(Prog);
- CG.SetSymbolTable(Prog.SymbolTable);
- CG.AppendUnit(UA);
- CG.AppendUnit(UB);
- CG.AppendProgram(Prog);
- IR := CG.GetOutput();
- { Each unit emits its own owner-prefixed type symbols — no collision on a
- single bare/winner symbol, and both class-name string blobs are distinct. }
- AssertTrue('tca typeinfo', Pos('typeinfo_tca_TShape', IR) > 0);
- AssertTrue('tcb typeinfo', Pos('typeinfo_tcb_TShape', IR) > 0);
- AssertTrue('tca vtable', Pos('vtable_tca_TShape', IR) > 0);
- AssertTrue('tcb vtable', Pos('vtable_tcb_TShape', IR) > 0);
- AssertTrue('tca classname', Pos('__cn_tca_TShape', IR) > 0);
- AssertTrue('tcb classname', Pos('__cn_tcb_TShape', IR) > 0);
- finally
- CG.Free();
- SA.Free();
- Prog.Free();
- UB.Free();
- UA.Free();
- end;
-end;
-
initialization
RegisterTest(TMultifileTests);
end.
diff --git a/compiler/src/test/pascal/cp.test.multiwrite.pas b/compiler/src/test/pascal/cp.test.multiwrite.pas
index 513cd55..ca08343 100644
--- a/compiler/src/test/pascal/cp.test.multiwrite.pas
+++ b/compiler/src/test/pascal/cp.test.multiwrite.pas
@@ -155,7 +155,7 @@ begin
'''
program P;
begin
- WriteLn()
+ WriteLn
end.
''');
AssertTrue('empty WriteLn still emits newline',
diff --git a/compiler/src/test/pascal/cp.test.nativeconstarg.pas b/compiler/src/test/pascal/cp.test.nativeconstarg.pas
index 952e50c..1ddd924 100644
--- a/compiler/src/test/pascal/cp.test.nativeconstarg.pas
+++ b/compiler/src/test/pascal/cp.test.nativeconstarg.pas
@@ -65,13 +65,6 @@ type
into an SSE (xmm) argument register per the System V ABI, not an integer
register. Asserts the call site emits movsd into %xmm0. }
procedure TestMethodFloatArg_LoadedIntoXmm;
- { Inline asm: a nostackframe asm-body function emits the verbatim block and
- NO compiler prologue (no pushq %rbp / frame subq). }
- procedure TestInlineAsm_VerbatimBody_NoPrologue;
- { Regression: an implicit-Self call whose Self+args exceed the six integer
- argument registers spills the overflow to the stack (it used to abort
- codegen). Asserts the slot-block overflow shape and the dispatch. }
- procedure TestImplicitSelfCall_RegisterOverflow_Spills;
end;
implementation
@@ -650,76 +643,14 @@ const
end.
''';
var
- AsmText: string;
+ Asm: string;
begin
- AsmText := GenAsm(Src);
+ Asm := GenAsm(Src);
{ The Double argument must reach the SSE arg register, not an integer one. }
AssertTrue('float method arg loaded into %xmm0',
- Pos('movsd', AsmText) >= 0);
+ Pos('movsd', Asm) >= 0);
AssertTrue('float method arg targets the SSE arg register',
- Pos('%xmm0', AsmText) >= 0);
-end;
-
-procedure TNativeConstArgTests.TestInlineAsm_VerbatimBody_NoPrologue;
-const
- Src = '''
- program P;
- function GetFortyTwo: Integer; assembler; nostackframe;
- asm
- movl $42, %eax
- ret
- end;
- begin
- WriteLn(GetFortyTwo())
- end.
- ''';
-var
- AsmText: string;
- Region: string;
-begin
- AsmText := GenAsm(Src);
- Region := Self.FuncRegion(AsmText, 'GetFortyTwo');
- { The verbatim asm instructions appear in the function body. }
- AssertTrue('verbatim movl $42', Pos('movl $42, %eax', Region) >= 0);
- AssertTrue('verbatim ret', Pos('ret', Region) >= 0);
- { nostackframe: no compiler-emitted prologue inside the function. }
- AssertTrue('no pushq %rbp prologue', Pos('pushq %rbp', Region) < 0);
-end;
-
-procedure TNativeConstArgTests.TestImplicitSelfCall_RegisterOverflow_Spills;
-const
- Src = '''
- program P;
- type
- TW = class
- function C(a, b, c, d, e, f, g: Integer): Integer;
- function D(): Integer;
- end;
- function TW.C(a, b, c, d, e, f, g: Integer): Integer;
- begin
- Result := a;
- end;
- function TW.D(): Integer;
- begin
- Result := C(1, 2, 3, 4, 5, 6, 7);
- end;
- begin
- end.
- ''';
-var
- Region: string;
-begin
- { Implicit-Self call C(...): Self (%rdi) + 7 args = 8 integer slots. Six load
- into registers; the last two spill to the stack. The slot-block overflow
- path stores Self into 0(%rsp) and fills all six integer arg registers —
- unlike the <=6 push/pop fast path. Before the fix this aborted codegen with
- 'arg register index 6 out of range'. }
- Region := FuncRegion(GenAsm(Src), 'TW_D');
- AssertTrue('overflow call dispatched', Pos('callq TW_C', Region) >= 0);
- AssertTrue('Self stored into slot 0 (overflow slot-block path)',
- Pos('movq %rax, 0(%rsp)', Region) >= 0);
- AssertTrue('arg registers filled through %r9',
- (Pos('%r8', Region) >= 0) and (Pos('%r9', Region) >= 0));
+ Pos('%xmm0', Asm) >= 0);
end;
initialization
diff --git a/compiler/src/test/pascal/cp.test.numerics.decimal.pas b/compiler/src/test/pascal/cp.test.numerics.decimal.pas
index 4327882..11b3e24 100644
--- a/compiler/src/test/pascal/cp.test.numerics.decimal.pas
+++ b/compiler/src/test/pascal/cp.test.numerics.decimal.pas
@@ -91,7 +91,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
- FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
+ FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;
diff --git a/compiler/src/test/pascal/cp.test.numerics.money.pas b/compiler/src/test/pascal/cp.test.numerics.money.pas
index 6228439..014b42f 100644
--- a/compiler/src/test/pascal/cp.test.numerics.money.pas
+++ b/compiler/src/test/pascal/cp.test.numerics.money.pas
@@ -79,7 +79,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
- FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
+ FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;
diff --git a/compiler/src/test/pascal/cp.test.opdf.pas b/compiler/src/test/pascal/cp.test.opdf.pas
index af5bc48..cd24272 100644
--- a/compiler/src/test/pascal/cp.test.opdf.pas
+++ b/compiler/src/test/pascal/cp.test.opdf.pas
@@ -27,13 +27,7 @@ type
procedure TestOPDF_Primitive_Integer;
procedure TestOPDF_Primitive_Boolean;
procedure TestOPDF_Primitive_Int64;
- procedure TestOPDF_Primitive_Double_SubKindFloat;
- procedure TestOPDF_Primitive_Single_SubKindFloat;
procedure TestOPDF_AnsiStr_Record;
- { A string constant whose value contains a double-quote, newline or
- backslash must be C-escaped in the recConstant `.ascii` line, else the
- literal closes early and the assembler sees a garbage mnemonic. }
- procedure TestOPDF_StringConst_SpecialChars_Escaped;
procedure TestOPDF_GlobalVar_QuadLabel;
procedure TestOPDF_GlobalVar_RecType;
procedure TestOPDF_Enum_RecType;
@@ -67,7 +61,6 @@ type
procedure TestOPDF_Set_RecType;
procedure TestOPDF_Set_SizeInBytes;
procedure TestOPDF_Property_RecType;
- procedure TestOPDF_Property_MethodBacked_LayoutIntact;
procedure TestOPDF_Interface_RecType;
procedure TestOPDF_Constant_OrdRecord;
procedure TestOPDF_Constant_OrdValue;
@@ -76,11 +69,6 @@ type
procedure TestOPDF_Constant_Real;
procedure TestOPDF_UnitDir_Present;
procedure TestOPDF_UnitDir_UnitCount;
- { recRuntimeHelper — RTL release routines the debugger injects to free a
- +1 transient an injected property getter returns. }
- procedure TestOPDF_RuntimeHelper_StringRelease;
- procedure TestOPDF_RuntimeHelper_DynArrayRelease;
- procedure TestOPDF_RuntimeHelper_KindOrdinals;
end;
implementation
@@ -181,44 +169,6 @@ begin
AssertTrue('recPrimitive Int64 present', Contains(IR, '# recPrimitive: Int64'));
end;
-procedure TOPDFTests.TestOPDF_Primitive_Double_SubKindFloat;
-{ Regression: float types emitted NO recPrimitive at all, so a Double/Single
- variable referenced a TypeID with no type record and pdr could not print it
- (locals/print/gl all failed for floats). A Double must now emit a recPrimitive
- with SubKind=SK_FLOAT(4) and SizeInBytes=8 so pdr's TFloatEvaluator
- (Category=tcFloat, keyed off SubKind in [skFloat, skCurrency]) renders it. }
-var
- IR: string;
- P: Integer;
-begin
- IR := GenOPDF('program P; var D: Double; begin D := 1.5 end.');
- AssertTrue('recPrimitive Double comment', Contains(IR, '# recPrimitive: Double'));
- AssertTrue('Double name emitted', Contains(IR, '.ascii "Double"'));
- P := Pos('# recPrimitive: Double', IR);
- AssertTrue('Double recPrimitive present', P >= 0);
- { SubKind must be SK_FLOAT (4) and size 8, in the Double record's payload. }
- AssertTrue('Double SubKind = 4 (skFloat)',
- Pos('.byte 4 # SubKind', Copy(IR, P, 220)) >= 0);
- AssertTrue('Double SizeInBytes = 8',
- Pos('.byte 8 # SizeInBytes', Copy(IR, P, 220)) >= 0);
-end;
-
-procedure TOPDFTests.TestOPDF_Primitive_Single_SubKindFloat;
-{ Single is the 4-byte float counterpart; same recPrimitive shape, size 4. }
-var
- IR: string;
- P: Integer;
-begin
- IR := GenOPDF('program P; var S: Single; begin S := 1.5 end.');
- AssertTrue('recPrimitive Single comment', Contains(IR, '# recPrimitive: Single'));
- P := Pos('# recPrimitive: Single', IR);
- AssertTrue('Single recPrimitive present', P >= 0);
- AssertTrue('Single SubKind = 4 (skFloat)',
- Pos('.byte 4 # SubKind', Copy(IR, P, 220)) >= 0);
- AssertTrue('Single SizeInBytes = 4',
- Pos('.byte 4 # SizeInBytes', Copy(IR, P, 220)) >= 0);
-end;
-
procedure TOPDFTests.TestOPDF_AnsiStr_Record;
var
IR: string;
@@ -228,41 +178,6 @@ begin
AssertTrue('Utf8String name emitted', Contains(IR, '.ascii "Utf8String"'));
end;
-procedure TOPDFTests.TestOPDF_StringConst_SpecialChars_Escaped;
-var
- IR: string;
-begin
- { A string const whose value is a single double-quote must be emitted as
- `.ascii "\""`, NOT `.ascii """` (which closes the literal after the first
- quote and leaves `" # Value` as a stray token). }
- IR := GenOPDF(
- '''
- program P;
- const Q = '"';
- begin end.
- ''');
- AssertTrue('quote value is escaped', Contains(IR, '.ascii "\"" # Value'));
- AssertFalse('no unescaped triple-quote', Contains(IR, '.ascii """ # Value'));
-
- { A newline in the value must become \n, not a literal line break. }
- IR := GenOPDF(
- '''
- program P;
- const NL = 'a'#10'b';
- begin end.
- ''');
- AssertTrue('newline escaped as \n', Contains(IR, '.ascii "a\nb" # Value'));
-
- { A backslash must be doubled. }
- IR := GenOPDF(
- '''
- program P;
- const BS = 'a\b';
- begin end.
- ''');
- AssertTrue('backslash doubled', Contains(IR, '.ascii "a\\b" # Value'));
-end;
-
procedure TOPDFTests.TestOPDF_GlobalVar_QuadLabel;
var
IR: string;
@@ -691,47 +606,6 @@ begin
AssertTrue('recProperty comment', Contains(IR, '# recProperty: Val'));
end;
-procedure TOPDFTests.TestOPDF_Property_MethodBacked_LayoutIntact;
-{ Regression for the recProperty corruption (bugs.txt, opdebugger #10/#13 era):
- a method-backed property must emit a COMPLETE, correctly-sized recProperty so
- the reader (which reads SizeOf(TDefProperty)=32 fixed bytes then the three
- length-prefixed strings) does not overshoot into the next record. The fixed
- payload is 32 bytes (4 ClassTypeID + 4 PropTypeID + 1 ReadType + 1 WriteType +
- 8 ReadAddr + 8 WriteAddr + 2+2+2 length words); RecSize = 32 + len(getterSym) +
- len(setterSym) + len(name). For TGadget.Val read GetVal write SetVal:
- getterSym = "TGadget_GetVal" (14), setterSym = "TGadget_SetVal" (14),
- name = "Val" (3) -> RecSize = 32 + 14 + 14 + 3 = 63. }
-var
- IR: string;
-begin
- IR := GenOPDF(
- '''
- program P;
- type TGadget = class
- FVal: Integer;
- function GetVal: Integer;
- procedure SetVal(AValue: Integer);
- property Val: Integer read GetVal write SetVal;
- end;
- function TGadget.GetVal: Integer;
- begin Result := FVal; end;
- procedure TGadget.SetVal(AValue: Integer);
- begin FVal := AValue; end;
- begin end.
- ''');
- AssertTrue('recProperty comment', Contains(IR, '# recProperty: Val'));
- { RecSize must match the fixed payload (32) + the three string lengths. }
- AssertTrue('recProperty RecSize is 63', Contains(IR, '.int 63 # RecSize'));
- { The getter/setter symbol names and the property name must be present as the
- three trailing strings (the fields the corruption garbled). }
- AssertTrue('getter method symbol string', Contains(IR, '.ascii "TGadget_GetVal"'));
- AssertTrue('setter method symbol string', Contains(IR, '.ascii "TGadget_SetVal"'));
- { The length words must match the actual symbol lengths. }
- AssertTrue('ReadMethodNameLen = 14', Contains(IR, '.word 14 # ReadMethodNameLen'));
- AssertTrue('WriteMethodNameLen = 14', Contains(IR, '.word 14 # WriteMethodNameLen'));
- AssertTrue('NameLen = 3', Contains(IR, '.word 3 # NameLen'));
-end;
-
procedure TOPDFTests.TestOPDF_Interface_RecType;
var
IR: string;
@@ -836,38 +710,6 @@ begin
AssertTrue('unit count is 1', Contains(IR, '.int 1 # UnitCount'));
end;
-procedure TOPDFTests.TestOPDF_RuntimeHelper_StringRelease;
-var
- IR: string;
-begin
- IR := GenOPDF('program P; begin end.');
- AssertTrue('recRuntimeHelper comment for _StringRelease',
- Contains(IR, '# recRuntimeHelper: _StringRelease'));
- AssertTrue('_StringRelease address quad (linker-resolved)',
- Contains(IR, '.quad _StringRelease # Address (linker-resolved)'));
-end;
-
-procedure TOPDFTests.TestOPDF_RuntimeHelper_DynArrayRelease;
-var
- IR: string;
-begin
- IR := GenOPDF('program P; begin end.');
- AssertTrue('recRuntimeHelper comment for _DynArrayRelease',
- Contains(IR, '# recRuntimeHelper: _DynArrayRelease'));
- AssertTrue('_DynArrayRelease address quad (linker-resolved)',
- Contains(IR, '.quad _DynArrayRelease # Address (linker-resolved)'));
-end;
-
-procedure TOPDFTests.TestOPDF_RuntimeHelper_KindOrdinals;
-var
- IR: string;
-begin
- { Kind ordinals must match opdf_types.TRuntimeHelperKind: string=0, dynarray=1 }
- IR := GenOPDF('program P; begin end.');
- AssertTrue('rhkStringRelease kind byte = 0', Contains(IR, '.byte 0 # Kind'));
- AssertTrue('rhkDynArrayRelease kind byte = 1', Contains(IR, '.byte 1 # Kind'));
-end;
-
procedure TOPDFTests.TestOPDF_MethodScope_Emitted;
var O: string;
begin
diff --git a/compiler/src/test/pascal/cp.test.overload.pas b/compiler/src/test/pascal/cp.test.overload.pas
index a74fed9..12b1aa9 100644
--- a/compiler/src/test/pascal/cp.test.overload.pas
+++ b/compiler/src/test/pascal/cp.test.overload.pas
@@ -175,7 +175,7 @@ const
WriteLn(N)
end;
begin
- Greet();
+ Greet;
Greet(42)
end.
''';
diff --git a/compiler/src/test/pascal/cp.test.parser.pas b/compiler/src/test/pascal/cp.test.parser.pas
index 91aa52b..4bc6e6f 100644
--- a/compiler/src/test/pascal/cp.test.parser.pas
+++ b/compiler/src/test/pascal/cp.test.parser.pas
@@ -34,21 +34,12 @@ type
procedure TestQualifiedTypeName;
procedure TestQualifiedTypeName_DottedUnit;
- { Unit-qualified symbols 'UnitName.Symbol' collapse to the bare symbol
- (resolved later through the uses chain), at any unit-name depth. }
- procedure TestUnitQualifiedProcCall_Collapses;
- procedure TestUnitQualifiedRef_Collapses;
- procedure TestDottedUnitQualifiedProcCall_Collapses;
- procedure TestNonUnitQualifier_StaysMethodCall;
- procedure TestUnitQualifierNoTrailingSymbol_StaysFieldWrite;
-
{ Statements }
procedure TestEmptyBeginEnd;
procedure TestAssignment_IntLit;
procedure TestAssignment_StringLit;
procedure TestProcCall_NoArgs;
- procedure TestProcCall_BareNoParens_RequiresParens;
- procedure TestMethodCall_BareNoParens_RequiresParens;
+ procedure TestProcCall_NoParens;
procedure TestProcCall_OneStringArg;
procedure TestProcCall_OneIntArg;
@@ -214,96 +205,6 @@ begin
end;
end;
-procedure TParserTests.TestUnitQualifiedProcCall_Collapses;
-var
- Prog: TProgram;
- Call: TProcCall;
-begin
- { 'MyUnit.DoIt()' with MyUnit in the uses clause collapses to a bare free
- call 'DoIt()' — the qualifier is dropped by the parser. }
- Prog := ParseSource('program P; uses MyUnit; begin MyUnit.DoIt() end.');
- try
- AssertTrue('collapsed to TProcCall',
- Prog.Block.Stmts.Items[0] is TProcCall);
- Call := TProcCall(Prog.Block.Stmts.Items[0]);
- AssertEquals('bare symbol name', 'DoIt', Call.Name);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TParserTests.TestUnitQualifiedRef_Collapses;
-var
- Prog: TProgram;
- Assign: TAssignment;
-begin
- { 'MyUnit.Val' in expression position collapses to a bare identifier. }
- Prog := ParseSource(
- 'program P; uses MyUnit; var x: Integer; begin x := MyUnit.Val end.');
- try
- Assign := TAssignment(Prog.Block.Stmts.Items[0]);
- AssertTrue('RHS collapsed to TIdentExpr', Assign.Expr is TIdentExpr);
- AssertEquals('bare symbol name', 'Val', TIdentExpr(Assign.Expr).Name);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TParserTests.TestDottedUnitQualifiedProcCall_Collapses;
-var
- Prog: TProgram;
- Call: TProcCall;
-begin
- { The unit qualifier may be dotted to any depth (here three components). }
- Prog := ParseSource('program P; uses A.B.C; begin A.B.C.DoIt() end.');
- try
- AssertTrue('collapsed to TProcCall',
- Prog.Block.Stmts.Items[0] is TProcCall);
- Call := TProcCall(Prog.Block.Stmts.Items[0]);
- AssertEquals('bare symbol name', 'DoIt', Call.Name);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TParserTests.TestNonUnitQualifier_StaysMethodCall;
-var
- Prog: TProgram;
-begin
- { 'r.DoIt()' where 'r' is NOT a used unit stays an object method call —
- the parser must not collapse a plain receiver. }
- Prog := ParseSource('program P; begin r.DoIt() end.');
- try
- AssertTrue('stays a method call on the receiver',
- Prog.Block.Stmts.Items[0] is TMethodCallStmt);
- AssertEquals('receiver kept', 'r',
- TMethodCallStmt(Prog.Block.Stmts.Items[0]).ObjectName);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TParserTests.TestUnitQualifierNoTrailingSymbol_StaysFieldWrite;
-var
- Prog: TProgram;
- Fld: TFieldAssignment;
-begin
- { 'My.Pkg := 4' where 'My.Pkg' is a used unit but no '.Symbol' follows is a
- record field write, NOT a unit qualifier — the trailing symbol is what
- distinguishes the two, so this must stay a TFieldAssignment. }
- Prog := ParseSource(
- 'program P; uses My.Pkg; var My: Integer; begin My.Pkg := 4 end.');
- try
- AssertTrue('stays a field assignment',
- Prog.Block.Stmts.Items[0] is TFieldAssignment);
- Fld := TFieldAssignment(Prog.Block.Stmts.Items[0]);
- AssertEquals('record name kept', 'My', Fld.RecordName);
- AssertEquals('field name kept', 'Pkg', Fld.FieldName);
- finally
- Prog.Free();
- end;
-end;
-
procedure TParserTests.TestMultipleVarDecls;
var
Prog: TProgram;
@@ -407,37 +308,18 @@ begin
end;
end;
-procedure TParserTests.TestProcCall_BareNoParens_RequiresParens;
+procedure TParserTests.TestProcCall_NoParens;
+var
+ Prog: TProgram;
+ Call: TProcCall;
begin
- { Issue #148: a parameterless call in statement position requires its
- mandatory () (see language-rationale.adoc, "Mandatory parentheses on
- zero-argument calls"). `WriteLn` without () is a parse error. }
+ Prog := ParseSource('program P; begin WriteLn end.');
try
- ParseSource('program P; begin WriteLn end.').Free();
- Fail('Expected EParseError for bare parameterless call');
- except
- on E: EParseError do
- AssertTrue('mentions mandatory parens',
- Pos('requires () for a call', E.Message) >= 0);
- end;
-end;
-
-procedure TParserTests.TestMethodCall_BareNoParens_RequiresParens;
-begin
- { Issue #148: a parameterless METHOD call in statement position likewise
- requires (). `tester.print` (no parens) is a parse error. }
- try
- ParseSource(
- 'program P;' +
- ' type TC = class procedure P; end;' +
- ' procedure TC.P; begin end;' +
- ' var c: TC;' +
- ' begin c := TC.Create(); c.P end.').Free();
- Fail('Expected EParseError for bare parameterless method call');
- except
- on E: EParseError do
- AssertTrue('mentions mandatory parens',
- Pos('requires () for a call', E.Message) >= 0);
+ Call := TProcCall(Prog.Block.Stmts.Items[0]);
+ AssertEquals('Name', 'WriteLn', Call.Name);
+ AssertEquals('0 args', 0, Call.Args.Count);
+ finally
+ Prog.Free();
end;
end;
diff --git a/compiler/src/test/pascal/cp.test.platformlayout.freebsd.pas b/compiler/src/test/pascal/cp.test.platformlayout.freebsd.pas
deleted file mode 100644
index 76f5a38..0000000
--- a/compiler/src/test/pascal/cp.test.platformlayout.freebsd.pas
+++ /dev/null
@@ -1,153 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.platformlayout.freebsd;
-
-{ Tests for the FreeBSD TPlatformLayout adapter (docs/freebsd-x86_64-backend-
- design.adoc, Step 2).
-
- These run on the Linux CI host: they instantiate TPlatformLayoutFreeBSDX86_64
- directly (not the GPlatformLayout global, which the Linux RTL owns on a Linux
- build) and assert the FreeBSD 14.x amd64 constant values and struct stat field
- offsets.
-
- The struct-offset tests build a synthetic 224-byte stat buffer, plant sentinel
- Int64/Integer values at the FreeBSD offsets, and assert the accessors read them
- back. This catches an offset typo without a FreeBSD execution environment —
- the emulation lane (Step 8) validates against a real kernel-filled struct. }
-
-interface
-
-uses
- blaise.testing,
- rtl.platform, rtl.platform.layout.freebsd;
-
-type
- TFreeBSDLayoutTests = class(TTestCase)
- private
- FLayout: TPlatformLayoutFreeBSDX86_64;
- public
- procedure SetUp; override;
- procedure TearDown; override;
- published
- { OS constants — the three that differ from Linux. }
- procedure TestO_CREAT;
- procedure TestO_TRUNC;
- procedure TestO_APPEND;
- { OS constants shared with Linux — asserted to pin them. }
- procedure TestO_RDWR;
- procedure TestS_IFDIR;
- procedure TestSEEK_END;
- procedure TestWNOHANG;
- { struct stat — the FreeBSD-specific size and field offsets. }
- procedure TestStatBufSize;
- procedure TestStatSizeOffset;
- procedure TestStatMtimeOffset;
- procedure TestStatModeOffset;
- end;
-
-implementation
-
-procedure TFreeBSDLayoutTests.SetUp;
-begin
- FLayout := TPlatformLayoutFreeBSDX86_64.Create();
-end;
-
-procedure TFreeBSDLayoutTests.TearDown;
-begin
- FLayout.Free();
-end;
-
-procedure TFreeBSDLayoutTests.TestO_CREAT;
-begin
- AssertEquals('FreeBSD O_CREAT', $0200, FLayout.O_CREAT());
-end;
-
-procedure TFreeBSDLayoutTests.TestO_TRUNC;
-begin
- AssertEquals('FreeBSD O_TRUNC', $0400, FLayout.O_TRUNC());
-end;
-
-procedure TFreeBSDLayoutTests.TestO_APPEND;
-begin
- AssertEquals('FreeBSD O_APPEND', $0008, FLayout.O_APPEND());
-end;
-
-procedure TFreeBSDLayoutTests.TestO_RDWR;
-begin
- AssertEquals('O_RDWR', 2, FLayout.O_RDWR());
-end;
-
-procedure TFreeBSDLayoutTests.TestS_IFDIR;
-begin
- AssertEquals('S_IFDIR', $4000, FLayout.S_IFDIR());
-end;
-
-procedure TFreeBSDLayoutTests.TestSEEK_END;
-begin
- AssertEquals('SEEK_END', 2, FLayout.SEEK_END());
-end;
-
-procedure TFreeBSDLayoutTests.TestWNOHANG;
-begin
- AssertEquals('WNOHANG', 1, FLayout.WNOHANG());
-end;
-
-procedure TFreeBSDLayoutTests.TestStatBufSize;
-begin
- AssertEquals('FreeBSD sizeof(struct stat)', 224, FLayout.StatBufSize());
-end;
-
-{ Plant a sentinel Int64 at st_size offset (112) and read it back. }
-procedure TFreeBSDLayoutTests.TestStatSizeOffset;
-var
- Buf: array[0..223] of Byte;
- P: ^Int64;
- I: Integer;
-begin
- for I := 0 to 223 do
- Buf[I] := 0;
- P := Pointer(PChar(@Buf[0]) + 112);
- P^ := Int64(1234567890);
- AssertEquals('st_size read at offset 112', Int64(1234567890),
- FLayout.StatSize(@Buf[0]));
-end;
-
-{ Plant a sentinel Int64 at st_mtim.tv_sec offset (64) and read it back. }
-procedure TFreeBSDLayoutTests.TestStatMtimeOffset;
-var
- Buf: array[0..223] of Byte;
- P: ^Int64;
- I: Integer;
-begin
- for I := 0 to 223 do
- Buf[I] := 0;
- P := Pointer(PChar(@Buf[0]) + 64);
- P^ := Int64(1700000000);
- AssertEquals('st_mtim.tv_sec read at offset 64', Int64(1700000000),
- FLayout.StatMtime(@Buf[0]));
-end;
-
-{ Plant a sentinel Integer at st_mode offset (24) and read it back. }
-procedure TFreeBSDLayoutTests.TestStatModeOffset;
-var
- Buf: array[0..223] of Byte;
- P: ^Integer;
- I: Integer;
-begin
- for I := 0 to 223 do
- Buf[I] := 0;
- P := Pointer(PChar(@Buf[0]) + 24);
- P^ := $4000;
- AssertEquals('st_mode read at offset 24', $4000, FLayout.StatMode(@Buf[0]));
-end;
-
-initialization
- RegisterTest(TFreeBSDLayoutTests);
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.procs.pas b/compiler/src/test/pascal/cp.test.procs.pas
index e8be8e0..64f9d5c 100644
--- a/compiler/src/test/pascal/cp.test.procs.pas
+++ b/compiler/src/test/pascal/cp.test.procs.pas
@@ -72,18 +72,6 @@ type
procedure TestCodegen_NestedProc_IsEmittedBeforeOuter;
procedure TestCodegen_NestedProc_CapturedVarPassedByPtr;
procedure TestCodegen_NestedProc_SameNameInTwoOuters_NoAmbiguity;
- { Same as above but the nested routines are FUNCTIONS called as
- expressions (Helper(X) inside WriteLn), which exercises
- AnalyseFuncCallExpr rather than AnalyseProcCall. The func-call path
- previously consulted only the global FProcIndex and errored with
- "Cannot find declaration for function 'Helper'". }
- procedure TestCodegen_NestedFunc_SameNameInTwoOuters_ResolvesPerScope;
- { Two sibling METHOD bodies each declaring a same-named nested function.
- Nested-in-method decls were registered in the global overload index
- (the registration guard only excluded nested-in-standalone-proc decls),
- so they collided as "Ambiguous overload". They must be scoped to their
- enclosing method body like nested-in-proc decls. }
- procedure TestCodegen_NestedFunc_InTwoMethods_ResolvesPerScope;
end;
implementation
@@ -600,10 +588,10 @@ const
begin
end;
begin
- Inner();
+ Inner;
end;
begin
- Outer();
+ Outer;
end.
''';
var IR: string;
@@ -631,10 +619,10 @@ const
end;
begin
x := 0;
- Inner();
+ Inner;
end;
begin
- Outer();
+ Outer;
end.
''';
var IR: string;
@@ -662,7 +650,7 @@ const
WriteLn(1);
end;
begin
- Inner();
+ Inner;
end;
procedure OuterB;
procedure Inner;
@@ -670,11 +658,11 @@ const
WriteLn(2);
end;
begin
- Inner();
+ Inner;
end;
begin
- OuterA();
- OuterB();
+ OuterA;
+ OuterB;
end.
''';
var
@@ -685,87 +673,6 @@ begin
AssertTrue('OuterB_Inner is emitted', StrPos('$OuterB_Inner', IR) >= 0);
end;
-procedure TProcFuncTests.TestCodegen_NestedFunc_SameNameInTwoOuters_ResolvesPerScope;
-const
- Src =
- '''
- program TwinNestedFunc;
- procedure OuterA;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 1;
- end;
- begin
- WriteLn(IntToStr(Helper(10)));
- end;
- procedure OuterB;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 2;
- end;
- begin
- WriteLn(IntToStr(Helper(20)));
- end;
- begin
- OuterA();
- OuterB();
- end.
- ''';
-var
- IR: string;
-begin
- IR := GenIR(Src);
- { Each sibling nested function is emitted under its own enclosing-routine
- qualified label — proving they resolved to distinct decls per scope
- rather than colliding as ambiguous overloads. (The call sites may be
- inlined, so assert on the emitted function labels, not on a call.) }
- AssertTrue('OuterA_Helper is emitted', StrPos('$OuterA_Helper', IR) >= 0);
- AssertTrue('OuterB_Helper is emitted', StrPos('$OuterB_Helper', IR) >= 0);
-end;
-
-procedure TProcFuncTests.TestCodegen_NestedFunc_InTwoMethods_ResolvesPerScope;
-const
- Src =
- '''
- program TwinNestedMethod;
- type
- TFoo = class
- procedure MethodA;
- procedure MethodB;
- end;
- procedure TFoo.MethodA;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 1;
- end;
- begin
- WriteLn(IntToStr(Helper(10)));
- end;
- procedure TFoo.MethodB;
- function Helper(X: Integer): Integer;
- begin
- Result := X + 2;
- end;
- begin
- WriteLn(IntToStr(Helper(20)));
- end;
- var F: TFoo;
- begin
- F := TFoo.Create;
- F.MethodA();
- F.MethodB();
- end.
- ''';
-var
- IR: string;
-begin
- IR := GenIR(Src);
- { Compiling at all proves the nested-in-method funcs did not collide as
- ambiguous overloads; both enclosing methods are emitted. }
- AssertTrue('TFoo_MethodA is emitted', StrPos('$TFoo_MethodA', IR) >= 0);
- AssertTrue('TFoo_MethodB is emitted', StrPos('$TFoo_MethodB', IR) >= 0);
-end;
-
initialization
RegisterTest(TProcFuncTests);
diff --git a/compiler/src/test/pascal/cp.test.proctypes.pas b/compiler/src/test/pascal/cp.test.proctypes.pas
index 0d1449b..873f3a2 100644
--- a/compiler/src/test/pascal/cp.test.proctypes.pas
+++ b/compiler/src/test/pascal/cp.test.proctypes.pas
@@ -47,13 +47,6 @@ type
procedure TestCodegen_ProceduralVar_AllocatedAsPointer;
procedure TestCodegen_AddrOfFunc_EmitsFunctionLabel;
procedure TestCodegen_IndirectCall_UsesTempNotName;
- { A procedural-typed class field called through a receiver as an
- expression (Result := Self.FFn(S)) must type to the field's return
- type and dispatch through the loaded pointer, not a direct call. }
- procedure TestCodegen_ProcFieldCallExpr_IndirectNotDirect;
- { An unqualified procedural-field call via implicit Self (Result := FFn(S),
- no 'Self.' prefix) must resolve and dispatch through Self's field. }
- procedure TestCodegen_ImplicitSelfProcFieldCall_LoadsSelf;
end;
implementation
@@ -494,7 +487,7 @@ begin
begin
end;
begin
- UseFn();
+ UseFn;
end.
'''
);
@@ -555,74 +548,6 @@ begin
IRContains(IR, 'call $MyFn('));
end;
-procedure TProcTypesTests.TestCodegen_ProcFieldCallExpr_IndirectNotDirect;
-var
- IR: string;
-begin
- { Regression: this used to fail semantic analysis ("Expression has no value
- type in assignment") because a procedural-field call used as an expression
- was given a nil result type. It must now compile and dispatch indirectly. }
- IR := GenIR(
- '''
- program Test;
- type
- TFn = function(const S: string): Integer;
- TBox = class
- FFn: TFn;
- function Run(const S: string): Integer;
- end;
- function TBox.Run(const S: string): Integer;
- begin
- Result := Self.FFn(S)
- end;
- var
- B: TBox;
- begin
- end.
- '''
- );
- { The only call in the program is the indirect dispatch through the field —
- it must go through a temp (call %tmp(...)), never a direct named call. }
- AssertTrue('Procedural-field call must dispatch through a temp',
- IRContains(IR, 'call %'));
- AssertFalse('Procedural-field call must not be a direct call to $FFn',
- IRContains(IR, 'call $FFn('));
-end;
-
-procedure TProcTypesTests.TestCodegen_ImplicitSelfProcFieldCall_LoadsSelf;
-var
- IR: string;
-begin
- { Regression: an unqualified FFn(...) where FFn is a procedural field used
- to fail with "Undeclared function". It must now resolve as an implicit
- Self.Field call: load Self, then dispatch through a temp. }
- IR := GenIR(
- '''
- program Test;
- type
- TFn = function(const S: string): Integer;
- TBox = class
- FFn: TFn;
- function Run(const S: string): Integer;
- end;
- function TBox.Run(const S: string): Integer;
- begin
- Result := FFn(S)
- end;
- var
- B: TBox;
- begin
- end.
- '''
- );
- AssertTrue('Implicit-Self field call must load Self',
- IRContains(IR, 'loadl %_var_Self'));
- AssertTrue('Implicit-Self field call must dispatch through a temp',
- IRContains(IR, 'call %'));
- AssertFalse('Implicit-Self field call must not be a direct call to $FFn',
- IRContains(IR, 'call $FFn('));
-end;
-
initialization
RegisterTest(TProcTypesTests);
diff --git a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas
index beaba00..f10ed69 100644
--- a/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas
+++ b/compiler/src/test/pascal/cp.test.proctypes_ofobject.pas
@@ -20,8 +20,7 @@ interface
uses
Classes, SysUtils, Process, blaise.testing,
- uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe,
- cp.test.rtllink;
+ uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe;
function ProjectRootOFO: string;
function RunCmdOFO(const AExe: string; const AArgs: array of string): Integer;
@@ -55,9 +54,6 @@ type
procedure TestCodegen_MethodPtrField_RecordTotalSizeIncludes16;
procedure TestCodegen_MethodPtrField_DirectCall_LoadsCodeAndData;
- procedure TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable;
- procedure TestCodegen_MethodPtrReturn_UsesAggregateABI;
- procedure TestCodegen_MethodPtrField_ImplicitSelfAssignUsesMemcpy16;
{ End-to-end }
procedure TestE2E_MethodPtr_NoArgs;
@@ -161,7 +157,7 @@ function TProcTypesOfObjectTests.CompileAndRun(const ASrc: string): string;
var
IR: string;
Root: string;
- QBE, Scratch: string;
+ QBE, RTL, Scratch: string;
IRFile, AsmFile, BinFile: string;
Lst: TStringList;
Proc: TProcess;
@@ -170,7 +166,8 @@ begin
Result := '';
Root := ProjectRootOFO();
QBE := Root + 'vendor/qbe/qbe';
- if not RTLLinkToolchainAvailable(Root) then
+ RTL := Root + 'compiler/target/blaise_rtl.a';
+ if not (FileExists(QBE) and FileExists(RTL)) then
begin
Result := '';
Exit;
@@ -196,7 +193,7 @@ begin
Exit;
end;
- if LinkProgramWithRTL(Root, AsmFile, BinFile) <> 0 then
+ if RunCmdOFO('cc', ['-o', BinFile, AsmFile, RTL]) <> 0 then
begin
Result := '';
Exit;
@@ -416,7 +413,7 @@ const
program P;
type TM = procedure of object;
var G: TM;
- begin G() end.
+ begin G end.
''';
var IR: string;
begin
@@ -451,7 +448,7 @@ const
M.Code := MethodAddress(F, 'SayHi');
M.Data := F;
G := TGreet(M);
- G();
+ G;
F.Free()
end.
''';
@@ -512,7 +509,7 @@ const
M.Code := MethodAddress(C, 'Print');
M.Data := C;
G := TPrintMethod(M);
- G();
+ G;
C.Free()
end.
''';
@@ -691,119 +688,6 @@ begin
StrPos('$THolder_Handler', IR) >= 0);
end;
-procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrVirtualCapture_LoadsFromVTable;
-const
- Src =
- '''
- program P;
- type
- TSpeak = procedure of object;
- TAnimal = class(TObject)
- procedure Speak; virtual;
- end;
- TDog = class(TAnimal)
- procedure Speak; override;
- end;
- procedure TAnimal.Speak;
- begin WriteLn('animal') end;
- procedure TDog.Speak;
- begin WriteLn('dog') end;
- var A: TAnimal; M: TSpeak;
- begin
- A := TDog.Create();
- M := @A.Speak;
- M();
- A.Free()
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { Capturing @A.Speak where Speak is virtual must read the Code half from
- the receiver's vtable, not freeze the statically-resolved declared-type
- address. The buggy codegen stored the static label '$TAnimal_Speak'
- into the (Code, Data) block; the fix loads the slot through the instance
- vptr, so that static store must be absent. }
- AssertFalse('virtual capture must not store the static method address',
- StrPos('storel $TAnimal_Speak', IR) >= 0);
-end;
-
-procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrReturn_UsesAggregateABI;
-const
- Src =
- '''
- program P;
- type TBinOp = function(X, Y: Integer): Integer of object;
- type
- TCalc = class(TObject)
- function Add(X, Y: Integer): Integer;
- function GetOp: TBinOp;
- end;
- function TCalc.Add(X, Y: Integer): Integer;
- begin Result := X + Y end;
- function TCalc.GetOp: TBinOp;
- begin Result := @Self.Add end;
- var C: TCalc; Op: TBinOp;
- begin
- C := TCalc.Create();
- Op := C.GetOp();
- WriteLn(Op(3, 4));
- C.Free()
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { A 'function ... of object' is a 16-byte (Code, Data) aggregate. The
- return must go through the two-register/sret record-return ABI, not a
- scalar 'l' that drops the Data half. The fix routes it through a
- synthetic two-pointer record, so the callee's Result slot is 16 bytes
- and the function is declared with the aggregate return type. }
- AssertTrue('method-ptr-returning function allocates a 16-byte Result slot',
- StrPos('%_var_Result =l alloc8 16', IR) >= 0);
- AssertTrue('method-ptr return is routed through the aggregate return ABI',
- StrPos('_ffi__BlaiseMethodPtr', IR) >= 0);
-end;
-
-procedure TProcTypesOfObjectTests.TestCodegen_MethodPtrField_ImplicitSelfAssignUsesMemcpy16;
-const
- Src =
- '''
- program P;
- type
- TProc = procedure(const S: string) of object;
- TA = class(TObject)
- FFn: TProc;
- procedure DoIt(const S: string);
- procedure Fire;
- end;
- procedure TA.DoIt(const S: string);
- begin WriteLn(S) end;
- procedure TA.Fire;
- begin
- FFn := @Self.DoIt
- end;
- var A: TA;
- begin
- A := TA.Create();
- A.Fire();
- A.Free()
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { Assigning @Self.Method to a bare (implicit-Self) method-pointer field must
- copy the whole 16-byte (Code, Data) block into the field slot. The buggy
- codegen fell through to the scalar-store path and deposited only the 8-byte
- pointer to the source block, leaving the Data half garbage — a later call
- then dispatched on a bad Self and crashed. }
- AssertTrue('implicit-Self method-ptr field assignment emits memcpy',
- Pos('call $memcpy(', IR) > 0);
- AssertTrue('memcpy length is 16',
- Pos(', l 16)', IR) > 0);
-end;
-
procedure TProcTypesOfObjectTests.TestE2E_MethodPtrField_DirectCall_StmtForm;
const
Src =
diff --git a/compiler/src/test/pascal/cp.test.publishedrtti.pas b/compiler/src/test/pascal/cp.test.publishedrtti.pas
index 0dd39a9..1998227 100644
--- a/compiler/src/test/pascal/cp.test.publishedrtti.pas
+++ b/compiler/src/test/pascal/cp.test.publishedrtti.pas
@@ -21,8 +21,7 @@ interface
uses
Classes, SysUtils, Process, blaise.testing,
- uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe,
- cp.test.rtllink;
+ uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe;
function ProjectRootRTTI: string;
function RunCmd(const AExe: string; const AArgs: array of string): Integer;
@@ -153,7 +152,7 @@ function TPublishedRTTITests.CompileAndRun(const ASrc: string): string;
var
IR: string;
Root: string;
- QBE, Scratch: string;
+ QBE, RTL, Scratch: string;
IRFile, AsmFile, BinFile: string;
Lst: TStringList;
Proc: TProcess;
@@ -162,7 +161,8 @@ begin
Result := '';
Root := ProjectRootRTTI();
QBE := Root + 'vendor/qbe/qbe';
- if not RTLLinkToolchainAvailable(Root) then
+ RTL := Root + 'compiler/target/blaise_rtl.a';
+ if not (FileExists(QBE) and FileExists(RTL)) then
begin
Result := '';
Exit;
@@ -188,7 +188,7 @@ begin
Exit;
end;
- if LinkProgramWithRTL(Root, AsmFile, BinFile) <> 0 then
+ if RunCmd('cc', ['-o', BinFile, AsmFile, RTL]) <> 0 then
begin
Result := '';
Exit;
diff --git a/compiler/src/test/pascal/cp.test.recordret.pas b/compiler/src/test/pascal/cp.test.recordret.pas
index d391b9c..21b85a2 100644
--- a/compiler/src/test/pascal/cp.test.recordret.pas
+++ b/compiler/src/test/pascal/cp.test.recordret.pas
@@ -75,14 +75,6 @@ type
procedure TestCodegen_IntegerPlusDouble_UsesIntSSE;
procedure TestCodegen_DoublePlusInt64_UsesSSEInt;
procedure TestCodegen_Int64PlusDouble_UsesIntSSE;
- { Self-assigned record method (M := M.Method(...)): the sret destination must
- NOT be the receiver variable — the call writes into a fresh temp buffer
- that is then memcpy'd into the destination, so the callee sees an intact
- Self while constructing Result. }
- procedure TestCodegen_SelfAssignRecordMethod_RoutesThroughTemp;
- { `Result := inherited M()` returning an sret record threads the sret
- pointer (the Result slot) + Self and dispatches statically to the parent. }
- procedure TestCodegen_InheritedRecordReturn_ThreadsSret;
end;
implementation
@@ -716,9 +708,9 @@ begin
begin
end.
''');
- { 16 bytes, all-float — rcSSE2 with aggregate [ s, 4B pad, d ]. }
+ { 16 bytes, all-float — rcSSE2 with aggregate [ s, d ]. }
AssertContains('function :_ffi_TM $MakeIt', IR);
- AssertContains('type :_ffi_TM = align 8 { s, b, b, b, b, d }', IR);
+ AssertContains('type :_ffi_TM = align 8 { s, d }', IR);
end;
procedure TRecordReturnTests.TestCodegen_IntegerPlusDouble_UsesIntSSE;
@@ -742,7 +734,7 @@ begin
Eightbyte 1 = Double -> SSE class.
QBE returns in (rax, xmm0). }
AssertContains('function :_ffi_TM $MakeIt', IR);
- AssertContains('type :_ffi_TM = align 8 { w, b, b, b, b, d }', IR);
+ AssertContains('type :_ffi_TM = align 8 { w, d }', IR);
AssertContains('=:_ffi_TM call $MakeIt', IR);
AssertContains('call $memcpy(', IR);
end;
@@ -787,59 +779,6 @@ begin
AssertContains('type :_ffi_TM = align 8 { l, d }', IR);
end;
-procedure TRecordReturnTests.TestCodegen_SelfAssignRecordMethod_RoutesThroughTemp;
-var IR: string;
-begin
- IR := GenIR(
- '''
- program P;
- type
- TR = record
- S: string;
- function Up(const X: TR): TR;
- end;
- function TR.Up(const X: TR): TR;
- begin Result.S := Self.S + X.S end;
- var A, B: TR;
- begin
- A.S := 'a'; B.S := 'b';
- A := A.Up(B)
- end.
- ''');
- { The sret call must target a fresh temp (%_t...), not the destination $A —
- otherwise the sret buffer aliases Self. }
- AssertFalse('sret call aliases receiver $A',
- Pos('call $TR_Up(l $A,', IR) <> -1);
- { The constructed result is then moved into the destination. }
- AssertContains('call $memcpy(l $A,', IR);
-end;
-
-procedure TRecordReturnTests.TestCodegen_InheritedRecordReturn_ThreadsSret;
-var IR: string;
-begin
- { `Result := inherited Next()` returning an sret record must thread the
- hidden destination pointer (the override's own Result slot) as the FIRST
- argument and Self as the second, dispatched STATICALLY to the parent's
- symbol — never the scalar `=l call` shape that passes Self into the sret
- slot. }
- IR := GenIR(
- '''
- program P;
- type
- TTok = record Kind: Integer; Value: string; end;
- TBase = class function Next: TTok; virtual; end;
- TDeriv = class(TBase) function Next: TTok; override; end;
- function TBase.Next: TTok;
- begin Result.Kind := 7; Result.Value := 'x' end;
- function TDeriv.Next: TTok;
- begin Result := inherited Next() end;
- begin
- end.
- ''');
- { sret pointer (Result slot) first, Self second, static call to the parent. }
- AssertContains('call $TBase_Next(l %_var_Result, l', IR);
-end;
-
initialization
RegisterTest(TRecordReturnTests);
diff --git a/compiler/src/test/pascal/cp.test.rtllink.pas b/compiler/src/test/pascal/cp.test.rtllink.pas
deleted file mode 100644
index 26d07d8..0000000
--- a/compiler/src/test/pascal/cp.test.rtllink.pas
+++ /dev/null
@@ -1,117 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.rtllink;
-
-{ Shared RTL link helper for the standalone E2E test helpers (those that lower a
- program to assembly themselves and link it, rather than via cp.test.e2e.base).
-
- The RTL is built from source by scripts/build-rtl-objects.sh — there is no
- blaise_rtl.a archive (RTL-unification Stage 3). A whole-program assembly dump
- inlines the RTL units the program uses, so --exclude-defined-by drops the RTL
- objects whose symbols the program already defines, avoiding double-definition. }
-
-interface
-
-{ Link AAsmFile (assembled program, .s) into ABinFile against the RTL.
- AProjectRoot must end with a path delimiter. Returns the cc exit code; 0 on
- success. Non-zero (and a negative value for a failed RTL build) on failure. }
-function LinkProgramWithRTL(const AProjectRoot, AAsmFile,
- ABinFile: string): Integer;
-
-{ True when the toolchain needed by LinkProgramWithRTL is present: the QBE
- assembler, the compiler binary, and the RTL source. }
-function RTLLinkToolchainAvailable(const AProjectRoot: string): Boolean;
-
-implementation
-
-uses
- classes, sysutils, process;
-
-function RTLLinkToolchainAvailable(const AProjectRoot: string): Boolean;
-begin
- Result := FileExists(AProjectRoot + 'vendor/qbe/qbe')
- and FileExists(AProjectRoot + 'compiler/target/blaise')
- and FileExists(AProjectRoot + 'compiler/src/main/pascal/runtime.arc.pas');
-end;
-
-function RunCapture(const AExe: string; const AArgs: array of string;
- out AOut: string): Integer;
-var
- Proc: TProcess;
- I: Integer;
- Chunk: string;
-begin
- Proc := TProcess.Create(nil);
- try
- Proc.Executable := AExe;
- for I := 0 to High(AArgs) do
- Proc.Parameters.Add(AArgs[I]);
- Proc.Execute();
- AOut := '';
- repeat
- Chunk := Proc.ReadOutput();
- AOut := AOut + Chunk
- until (Chunk = '') and not Proc.Running;
- Proc.WaitOnExit();
- Result := Proc.ExitCode
- finally
- Proc.Free()
- end
-end;
-
-function LinkProgramWithRTL(const AProjectRoot, AAsmFile,
- ABinFile: string): Integer;
-var
- ProgObj, ObjDir, Compiler, ScriptOut: string;
- Objs: TStringList;
- Proc: TProcess;
- I: Integer;
-begin
- { Assemble the program so the RTL build can see which RTL symbols it inlined. }
- ProgObj := AAsmFile + '.o';
- Result := RunCapture('cc', ['-c', '-o', ProgObj, AAsmFile], ScriptOut);
- if Result <> 0 then Exit;
-
- Compiler := AProjectRoot + 'compiler/target/blaise';
- ObjDir := ExtractFilePath(AAsmFile) + 'rtlobj';
- Result := RunCapture(AProjectRoot + 'scripts/build-rtl-objects.sh',
- [Compiler, ObjDir, '--exclude-defined-by', ProgObj],
- ScriptOut);
- if Result <> 0 then
- begin
- Result := -1;
- Exit;
- end;
-
- Objs := TStringList.Create();
- Proc := TProcess.Create(nil);
- try
- Objs.Text := ScriptOut;
- Proc.Executable := 'cc';
- Proc.Parameters.Add('-o');
- Proc.Parameters.Add(ABinFile);
- Proc.Parameters.Add(ProgObj);
- for I := 0 to Objs.Count - 1 do
- if Trim(Objs.Strings[I]) <> '' then
- Proc.Parameters.Add(Trim(Objs.Strings[I]));
- Proc.Parameters.Add('-lm');
- Proc.Parameters.Add('-lpthread');
- Proc.Execute();
- repeat
- ScriptOut := Proc.ReadOutput();
- until (ScriptOut = '') and not Proc.Running;
- Proc.WaitOnExit();
- Result := Proc.ExitCode;
- finally
- Proc.Free();
- Objs.Free();
- end;
-end;
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.semantic.pas b/compiler/src/test/pascal/cp.test.semantic.pas
index 1420b15..5ed7692 100644
--- a/compiler/src/test/pascal/cp.test.semantic.pas
+++ b/compiler/src/test/pascal/cp.test.semantic.pas
@@ -36,7 +36,7 @@ type
procedure TestVarDecl_DuplicatesInterfaceType_RaisesError;
procedure TestVarDecl_ShadowsBuiltinType_RaisesError;
procedure TestVarDecl_ShadowsOuterScopeType_RaisesError;
- procedure TestVarDecl_SharesEnumMemberName_OK;
+ procedure TestVarDecl_ShadowsEnumMember_RaisesError;
{ Const then var with same name in same block is a duplicate }
procedure TestVarDecl_DuplicatesConst_RaisesError;
{ Const redeclared with same name in same block is a duplicate }
@@ -239,16 +239,13 @@ begin
'begin Q(); end.');
end;
-procedure TSemanticTests.TestVarDecl_SharesEnumMemberName_OK;
-var
- Prog: TProgram;
+procedure TSemanticTests.TestVarDecl_ShadowsEnumMember_RaisesError;
begin
- { A variable may share a name with an enum member. Enum members are not
- bare global symbols, so there is no collision: the variable wins by normal
- scoping and the member stays reachable through its type (TC.C). Here 'c'
- shares the name of member 'C' (names are case-insensitive). }
- Prog := Analyse('program P; type TC = (A, B, C); var c: TC; begin end.');
- Prog.Free();
+ { A var may not shadow a visible enum member — shadowing silently retargets
+ the member in a set literal to the variable, miscompiling the bitmask.
+ Blaise rejects it, in the same spirit as the type-name-shadow rule. }
+ AnalyseExpectError(
+ 'program P; type TC = (A, B, C); var c: TC; begin end.');
end;
procedure TSemanticTests.TestVarDecl_DuplicatesConst_RaisesError;
@@ -476,7 +473,7 @@ end;
procedure TSemanticTests.TestProcCall_WriteLn_NoArgs_OK;
begin
- Analyse('program P; begin WriteLn() end.').Free();
+ Analyse('program P; begin WriteLn end.').Free();
end;
procedure TSemanticTests.TestProcCall_WriteLn_StringArg_OK;
@@ -523,7 +520,7 @@ end;
procedure TSemanticTests.TestProcCall_UndeclaredProc_RaisesError;
begin
- AnalyseExpectError('program P; begin NoSuchProc() end.');
+ AnalyseExpectError('program P; begin NoSuchProc end.');
end;
{ ------------------------------------------------------------------ }
diff --git a/compiler/src/test/pascal/cp.test.staticarray.pas b/compiler/src/test/pascal/cp.test.staticarray.pas
index 62cb10f..a458e11 100644
--- a/compiler/src/test/pascal/cp.test.staticarray.pas
+++ b/compiler/src/test/pascal/cp.test.staticarray.pas
@@ -83,12 +83,6 @@ type
procedure TestCodegen_TypeAlias_AllocEmitted;
procedure TestCodegen_TypeAlias_ElementSizeInAlloc;
- { ------------------------------------------------------------------ }
- { Named integer subrange as an array index type }
- { ------------------------------------------------------------------ }
- procedure TestSemantic_NamedSubrange_IndexFoldsToBounds;
- procedure TestSemantic_NamedSubrange_NonZeroBase_IndexFoldsToBounds;
-
{ ------------------------------------------------------------------ }
{ Multi-dimensional arrays (comma form desugars to nested arrays) }
{ ------------------------------------------------------------------ }
@@ -619,33 +613,6 @@ const
end.
''';
- { Named integer subrange (0-based) used as the array index type.
- array[TIdx] of Integer must fold to array[0..2] of Integer. }
- SrcNamedSubrangeIndex =
- '''
- program SA;
- type
- TIdx = 0..2;
- TBuf = array[TIdx] of Integer;
- var A: TBuf;
- begin
- A[0] := 11
- end.
- ''';
-
- { Non-zero-based named integer subrange index: array[2..4]. }
- SrcNamedSubrangeIndexNonZero =
- '''
- program SA;
- type
- TIdx = 2..4;
- TBuf = array[TIdx] of Integer;
- var A: TBuf;
- begin
- A[2] := 11
- end.
- ''';
-
{ ------------------------------------------------------------------ }
{ Named array type alias — tests }
{ ------------------------------------------------------------------ }
@@ -749,37 +716,6 @@ begin
AssertTrue('size 8 appears in IR', Pos('8', IR) >= 0);
end;
-procedure TStaticArrayTests.TestSemantic_NamedSubrange_IndexFoldsToBounds;
-var P: TProgram; Sym: TSymbol; SAT: TStaticArrayTypeDesc;
-begin
- { type TIdx = 0..2; TBuf = array[TIdx] of Integer; must resolve to a static
- array with bounds 0..2, exactly as if written array[0..2]. }
- P := AnalyseSrc(SrcNamedSubrangeIndex);
- try
- Sym := P.SymbolTable.Lookup('TBuf');
- AssertTrue('TBuf found', Sym <> nil);
- AssertEquals('TBuf is static array',
- Ord(tyStaticArray), Ord(Sym.TypeDesc.Kind));
- SAT := TStaticArrayTypeDesc(Sym.TypeDesc);
- AssertEquals('low=0', 0, SAT.LowBound);
- AssertEquals('high=2', 2, SAT.HighBound);
- finally P.Free(); end;
-end;
-
-procedure TStaticArrayTests.TestSemantic_NamedSubrange_NonZeroBase_IndexFoldsToBounds;
-var P: TProgram; Sym: TSymbol; SAT: TStaticArrayTypeDesc;
-begin
- { type TIdx = 2..4; TBuf = array[TIdx] of Integer; folds to array[2..4]. }
- P := AnalyseSrc(SrcNamedSubrangeIndexNonZero);
- try
- Sym := P.SymbolTable.Lookup('TBuf');
- AssertTrue('TBuf found', Sym <> nil);
- SAT := TStaticArrayTypeDesc(Sym.TypeDesc);
- AssertEquals('low=2', 2, SAT.LowBound);
- AssertEquals('high=4', 4, SAT.HighBound);
- finally P.Free(); end;
-end;
-
{ ------------------------------------------------------------------ }
{ Multi-dimensional arrays }
{ ------------------------------------------------------------------ }
diff --git a/compiler/src/test/pascal/cp.test.staticmembers.pas b/compiler/src/test/pascal/cp.test.staticmembers.pas
deleted file mode 100644
index af8180a..0000000
--- a/compiler/src/test/pascal/cp.test.staticmembers.pas
+++ /dev/null
@@ -1,1081 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.staticmembers;
-
-{ Tests for `static` (class-level) members: static var, static const,
- static function/procedure, static property, on classes and records.
- Feature 1 of the static-members work. Covers the PARSER layer
- (TStaticMembersParseTests — the forms parse, the IsStatic / IsClassVar AST
- flags are set, and `static constructor` / `static destructor` are rejected)
- and the SEMANTIC + IR layer (TStaticMembersSemTests — resolution of static
- vars to shared globals, no-Self static methods, qualified static var/property
- reads, and the program-exit release of class-typed static vars). End-to-end
- compile+run behaviour lives in cp.test.e2e.staticmembers.pas. }
-
-interface
-
-uses
- Classes, SysUtils, blaise.testing,
- uLexer, uParser, uAST, uSemantic, uSymbolTable, blaise.codegen.qbe;
-
-type
- TStaticMembersParseTests = class(TTestCase)
- private
- function ParseSrc(const ASrc: string): TProgram;
- function ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
- function RecordOf(AProg: TProgram; AIndex: Integer): TRecordTypeDef;
- procedure ParseExpectError(const ASrc: string);
- procedure ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
- published
- { static var / static const sections on a class }
- procedure TestParse_StaticVarSection_SetsIsClassVar;
- procedure TestParse_PlainFieldAfterStaticVar_NotClassVar;
- procedure TestParse_PrivateStaticVar_SetsIsClassVar;
- procedure TestParse_StaticConstSection_OnClass;
- procedure TestParse_StaticConstSection_FollowedByMoreMembers;
-
- { static method prefix and section }
- procedure TestParse_StaticFunctionPrefix_SetsIsStatic;
- procedure TestParse_StaticProcedurePrefix_SetsIsStatic;
- procedure TestParse_StaticSection_AppliesToMethods;
- procedure TestParse_PlainMethodAfterStaticSection_NotStatic;
- procedure TestParse_BareStaticKeepsCurrentVisibility;
-
- { static property }
- procedure TestParse_StaticProperty_SetsIsStatic;
-
- { out-of-line static impl }
- procedure TestParse_StaticImpl_OutOfLine;
-
- { records }
- procedure TestParse_StaticFunctionInRecord_SetsIsStatic;
- procedure TestParse_StaticVarInRecord_SetsIsClassVar;
- procedure TestParse_StaticConstInRecord;
-
- { rejections }
- procedure TestParse_StaticConstructor_Rejected;
- procedure TestParse_StaticDestructor_Rejected;
- end;
-
-implementation
-
-function TStaticMembersParseTests.ParseSrc(const ASrc: string): TProgram;
-var L: TLexer; P: TParser;
-begin
- L := TLexer.Create(ASrc);
- P := TParser.Create(L);
- try
- Result := P.Parse();
- finally
- P.Free(); L.Free();
- end;
-end;
-
-function TStaticMembersParseTests.ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
-var TD: TTypeDecl;
-begin
- TD := TTypeDecl(AProg.Block.TypeDecls.Items[AIndex]);
- Result := TD.Def as TClassTypeDef;
-end;
-
-function TStaticMembersParseTests.RecordOf(AProg: TProgram; AIndex: Integer): TRecordTypeDef;
-var TD: TTypeDecl;
-begin
- TD := TTypeDecl(AProg.Block.TypeDecls.Items[AIndex]);
- Result := TD.Def as TRecordTypeDef;
-end;
-
-procedure TStaticMembersParseTests.ParseExpectError(const ASrc: string);
-var Prog: TProgram;
-begin
- try
- Prog := ParseSrc(ASrc);
- Prog.Free();
- Fail('Expected EParseError');
- except
- on E: EParseError do ;
- end;
-end;
-
-procedure TStaticMembersParseTests.ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
-var Prog: TProgram;
-begin
- try
- Prog := ParseSrc(ASrc);
- Prog.Free();
- Fail('Expected EParseError');
- except
- on E: EParseError do
- AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
- E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ static var / static const }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticVarSection_SetsIsClassVar;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static var
- FInstance: TFoo;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef; F: TFieldDecl;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one field', 1, C.Fields.Count);
- F := TFieldDecl(C.Fields.Items[0]);
- AssertEquals('field name', 'FInstance', F.Names[0]);
- AssertTrue('FInstance is a class var', F.IsClassVar);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_PlainFieldAfterStaticVar_NotClassVar;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static var
- FShared: Integer;
- public
- FInst: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('two fields', 2, C.Fields.Count);
- AssertTrue('FShared is class var', TFieldDecl(C.Fields.Items[0]).IsClassVar);
- AssertFalse('FInst is NOT class var (section reset by public)',
- TFieldDecl(C.Fields.Items[1]).IsClassVar);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_PrivateStaticVar_SetsIsClassVar;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FInstance: TFoo;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one field', 1, C.Fields.Count);
- AssertTrue('private static var is class var',
- TFieldDecl(C.Fields.Items[0]).IsClassVar);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticConstSection_OnClass;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static const
- MaxItems = 256;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one const', 1, C.ConstDecls.Count);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticConstSection_FollowedByMoreMembers;
-const
- { A static const section is not the last section: the const block must stop
- at the following `private` visibility keyword rather than swallowing it. }
- Src =
- '''
- program P;
- type
- TFoo = class
- private static const
- MaxEntries = 256;
- private
- FCount: Integer;
- public
- function GetCount: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one const', 1, C.ConstDecls.Count);
- AssertEquals('one field', 1, C.Fields.Count);
- AssertEquals('field name', 'FCount', TFieldDecl(C.Fields.Items[0]).Names[0]);
- AssertEquals('one method', 1, C.Methods.Count);
- finally
- Prog.Free();
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ static methods }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticFunctionPrefix_SetsIsStatic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static function GetInstance: TFoo;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef; M: TMethodDecl;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one method', 1, C.Methods.Count);
- M := TMethodDecl(C.Methods.Items[0]);
- AssertEquals('method name', 'GetInstance', M.Name);
- AssertTrue('GetInstance is static', M.IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticProcedurePrefix_SetsIsStatic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static procedure Reset;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertTrue('Reset is static', TMethodDecl(C.Methods.Items[0]).IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticSection_AppliesToMethods;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- public static
- function A: Integer;
- function B: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('two methods', 2, C.Methods.Count);
- AssertTrue('A is static', TMethodDecl(C.Methods.Items[0]).IsStatic);
- AssertTrue('B is static', TMethodDecl(C.Methods.Items[1]).IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_PlainMethodAfterStaticSection_NotStatic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- public static
- function A: Integer;
- public
- function B: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertTrue('A is static', TMethodDecl(C.Methods.Items[0]).IsStatic);
- AssertFalse('B is NOT static (section reset by public)',
- TMethodDecl(C.Methods.Items[1]).IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_BareStaticKeepsCurrentVisibility;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private
- FInst: Integer;
- static
- function A: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertFalse('FInst not class var', TFieldDecl(C.Fields.Items[0]).IsClassVar);
- AssertTrue('A is static', TMethodDecl(C.Methods.Items[0]).IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ static property }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticProperty_SetsIsStatic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static function GetInstance: TFoo;
- static property Instance: TFoo read GetInstance;
- end;
- begin end.
- ''';
-var Prog: TProgram; C: TClassTypeDef; Pr: TPropertyDecl;
-begin
- Prog := ParseSrc(Src);
- try
- C := ClassOf(Prog, 0);
- AssertEquals('one property', 1, C.Properties.Count);
- Pr := TPropertyDecl(C.Properties.Items[0]);
- AssertEquals('property name', 'Instance', Pr.Name);
- AssertTrue('Instance property is static', Pr.IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ out-of-line static impl }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticImpl_OutOfLine;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static function GetInstance: TFoo;
- end;
- static function TFoo.GetInstance: TFoo;
- begin
- Result := nil;
- end;
- begin end.
- ''';
-var Prog: TProgram; M: TMethodDecl;
-begin
- Prog := ParseSrc(Src);
- try
- { The out-of-line impl is a standalone proc decl in the block. }
- AssertEquals('one standalone proc', 1, Prog.Block.ProcDecls.Count);
- M := TMethodDecl(Prog.Block.ProcDecls.Items[0]);
- AssertTrue('out-of-line impl is static', M.IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ records }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticFunctionInRecord_SetsIsStatic;
-const
- Src =
- '''
- program P;
- type
- TInfo = record
- Category: string;
- static function New(const C: string): TInfo;
- end;
- begin end.
- ''';
-var Prog: TProgram; R: TRecordTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- R := RecordOf(Prog, 0);
- AssertEquals('one method', 1, R.Methods.Count);
- AssertTrue('New is static', TMethodDecl(R.Methods.Items[0]).IsStatic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticVarInRecord_SetsIsClassVar;
-const
- Src =
- '''
- program P;
- type
- TInfo = record
- Category: string;
- static var
- Count: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; R: TRecordTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- R := RecordOf(Prog, 0);
- AssertEquals('two fields', 2, R.Fields.Count);
- AssertFalse('Category not class var', TFieldDecl(R.Fields.Items[0]).IsClassVar);
- AssertTrue('Count is class var', TFieldDecl(R.Fields.Items[1]).IsClassVar);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticConstInRecord;
-const
- Src =
- '''
- program P;
- type
- TInfo = record
- X: Integer;
- static const
- Tag = 7;
- end;
- begin end.
- ''';
-var Prog: TProgram; R: TRecordTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- R := RecordOf(Prog, 0);
- AssertEquals('one const', 1, R.ConstDecls.Count);
- finally
- Prog.Free();
- end;
-end;
-
-{ ------------------------------------------------------------------ }
-{ rejections }
-{ ------------------------------------------------------------------ }
-
-procedure TStaticMembersParseTests.TestParse_StaticConstructor_Rejected;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static constructor Create;
- end;
- begin end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'static');
-end;
-
-procedure TStaticMembersParseTests.TestParse_StaticDestructor_Rejected;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- static destructor Destroy;
- end;
- begin end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'static');
-end;
-
-{ ================================================================== }
-{ Semantic + IR (codegen) tests }
-{ ================================================================== }
-
-type
- TStaticMembersSemTests = class(TTestCase)
- private
- function AnalyseSrc(const ASrc: string): TProgram;
- function GenIR(const ASrc: string): string;
- procedure AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
- published
- { static var resolves to a shared global, not an instance field }
- procedure TestSem_StaticVar_BareReadResolves;
- procedure TestSem_StaticVar_NotAnInstanceField;
- procedure TestSem_StaticVar_RejectsStringType;
- procedure TestSem_StaticVar_AcceptsClassType;
- procedure TestSem_StaticMethod_NoSelf_CannotTouchInstanceField;
- procedure TestSem_StaticMethod_CanReadStaticVar;
-
- { IR: static var lowers to a single global data slot; static method has
- no Self parameter. }
- procedure TestIR_StaticVar_EmitsGlobalDataSlot;
- procedure TestIR_StaticVar_NoInstanceOffset;
- procedure TestIR_StaticMethod_NoSelfParam;
- procedure TestIR_Singleton_LazyGetInstance;
- procedure TestIR_StaticVar_QualifiedRead_LoadsGlobal;
- procedure TestIR_StaticProperty_QualifiedRead_CallsGetter;
- procedure TestIR_ClassStaticVar_ReleasedAtExit;
- procedure TestIR_StaticCall_InterfaceArg_NoLeadingComma;
- procedure TestIR_StaticVar_ChainedLValueBase_LoadsGlobal;
- end;
-
-function TStaticMembersSemTests.AnalyseSrc(const ASrc: string): TProgram;
-var L: TLexer; P: TParser; A: TSemanticAnalyser;
-begin
- L := TLexer.Create(ASrc);
- P := TParser.Create(L);
- try
- Result := P.Parse();
- finally
- P.Free(); L.Free();
- end;
- A := TSemanticAnalyser.Create();
- try
- A.Analyse(Result);
- finally
- A.Free();
- end;
-end;
-
-function TStaticMembersSemTests.GenIR(const ASrc: string): string;
-var Prog: TProgram; CG: TCodeGenQBE;
-begin
- Prog := AnalyseSrc(ASrc);
- try
- CG := TCodeGenQBE.Create();
- try
- CG.Generate(Prog);
- Result := CG.GetOutput();
- finally
- CG.Free();
- end;
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersSemTests.AnalyseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
-var Prog: TProgram;
-begin
- try
- Prog := AnalyseSrc(ASrc);
- Prog.Free();
- Fail('Expected ESemanticError');
- except
- on E: ESemanticError do
- AssertTrue('error message contains "' + AExpectedSubstr + '" (got: ' +
- E.Message + ')', Pos(AExpectedSubstr, E.Message) >= 0);
- end;
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticVar_BareReadResolves;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- static procedure Bump;
- end;
- static procedure TFoo.Bump;
- begin
- FCount := FCount + 1;
- end;
- begin end.
- ''';
-var Prog: TProgram;
-begin
- { Just analysing without an "undeclared identifier" error proves the bare
- static-var name resolves inside a static method. }
- Prog := AnalyseSrc(Src);
- Prog.Free();
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticVar_NotAnInstanceField;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FShared: Integer;
- public
- FInst: Integer;
- end;
- var
- F: TFoo;
- begin
- F := TFoo.Create();
- F.FInst := 7;
- end.
- ''';
-var Prog: TProgram; RT: TRecordTypeDesc; Sym: TSymbol;
-begin
- Prog := AnalyseSrc(Src);
- try
- Sym := Prog.SymbolTable.Lookup('TFoo');
- AssertNotNull('TFoo type present', Sym);
- RT := TRecordTypeDesc(Sym.TypeDesc);
- { The class has exactly ONE instance field (FInst); FShared is a static
- var and must NOT occupy an instance slot. }
- AssertNotNull('FInst is an instance field', RT.FindField('FInst'));
- AssertNull('FShared is NOT an instance field', RT.FindField('FShared'));
- finally
- Prog.Free();
- end;
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticVar_RejectsStringType;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FName: string;
- end;
- begin end.
- ''';
-begin
- { String (and dynamic-array) static vars remain deferred; class and
- interface are supported (see TestSem_StaticVar_AcceptsClassType). }
- AnalyseExpectErrorMsg(Src, 'static var');
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticVar_AcceptsClassType;
-const
- Src =
- '''
- program P;
- type
- TConfig = class
- private static var
- FInstance: TConfig;
- public
- static function Instance: TConfig;
- end;
- static function TConfig.Instance: TConfig;
- begin
- if FInstance = nil then FInstance := TConfig.Create();
- Result := FInstance;
- end;
- begin TConfig.Instance(); end.
- ''';
-var
- Prog: TProgram;
-begin
- { A class-typed (self-referential) static var is the canonical singleton
- shape. This used to corrupt the heap during AST/symbol-table teardown
- (a double-free of the shared GlobalEmitName string registered on the two
- static-var symbols). Drive the full analyse -> Free cycle and assert it
- completes without error — the teardown is the part under test. }
- Prog := AnalyseSrc(Src);
- Prog.Free();
- AssertTrue('class-typed static var analyses and tears down cleanly', True);
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticMethod_NoSelf_CannotTouchInstanceField;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- public
- FInst: Integer;
- static procedure Bad;
- end;
- static procedure TFoo.Bad;
- begin
- FInst := 1;
- end;
- begin end.
- ''';
-begin
- { A static method has no Self, so an instance field is not in scope. }
- AnalyseExpectErrorMsg(Src, 'FInst');
-end;
-
-procedure TStaticMembersSemTests.TestSem_StaticMethod_CanReadStaticVar;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- public
- static function GetCount: Integer;
- end;
- static function TFoo.GetCount: Integer;
- begin
- Result := FCount;
- end;
- begin end.
- ''';
-var Prog: TProgram;
-begin
- Prog := AnalyseSrc(Src);
- Prog.Free();
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticVar_EmitsGlobalDataSlot;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- static procedure Bump;
- end;
- static procedure TFoo.Bump;
- begin
- FCount := FCount + 1;
- end;
- begin end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { A single shared global data slot named TFoo_FCount must be emitted. }
- AssertTrue('emits $TFoo_FCount data slot (IR: ' + Copy(IR, 0, 400) + ')',
- Pos('data $TFoo_FCount', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticVar_NoInstanceOffset;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- static procedure Bump;
- end;
- static procedure TFoo.Bump;
- begin
- FCount := FCount + 1;
- end;
- begin end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { The static var read/write must reference the global $TFoo_FCount, not an
- instance-offset load from a Self pointer. }
- AssertTrue('references $TFoo_FCount global',
- Pos('$TFoo_FCount', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticMethod_NoSelfParam;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- static procedure Bump;
- end;
- static procedure TFoo.Bump;
- begin
- FCount := FCount + 1;
- end;
- begin end.
- ''';
-var IR: string; FnPos: Integer;
-begin
- IR := GenIR(Src);
- FnPos := Pos('function $TFoo_Bump(', IR);
- if FnPos < 0 then
- FnPos := Pos('$TFoo_Bump(', IR);
- AssertTrue('TFoo_Bump function emitted', FnPos >= 0);
- { The signature must NOT contain %_par_Self. }
- AssertFalse('static method has no Self parameter',
- Pos('%_par_Self', Copy(IR, FnPos, 60)) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_Singleton_LazyGetInstance;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FInstanceId: Integer;
- public
- static function GetId: Integer;
- end;
- static function TFoo.GetId: Integer;
- begin
- if FInstanceId = 0 then
- FInstanceId := 42;
- Result := FInstanceId;
- end;
- begin end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- AssertTrue('static var global slot present',
- Pos('data $TFoo_FInstanceId', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticVar_QualifiedRead_LoadsGlobal;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- public static var
- Total: Integer;
- static procedure Bump;
- end;
- static procedure TFoo.Bump;
- begin
- Total := Total + 1;
- end;
- var n: Integer;
- begin
- n := TFoo.Total;
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { A qualified read TFoo.Total must load the SAME mangled global slot, not
- dereference an instance. }
- AssertTrue('qualified read loads $TFoo_Total (IR: ' + Copy(IR, 0, 600) + ')',
- Pos('loadw $TFoo_Total', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticProperty_QualifiedRead_CallsGetter;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FCount: Integer;
- public
- static function NextId: Integer;
- static property Counter: Integer read NextId;
- end;
- static function TFoo.NextId: Integer;
- begin
- FCount := FCount + 1;
- Result := FCount;
- end;
- var n: Integer;
- begin
- n := TFoo.Counter;
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- AssertTrue('static prop read calls $TFoo_NextId() with no Self (IR: ' +
- Copy(IR, 0, 800) + ')',
- Pos('call $TFoo_NextId()', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_ClassStaticVar_ReleasedAtExit;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private static var
- FInst: TFoo;
- public
- static procedure Init;
- end;
- static procedure TFoo.Init;
- begin
- if FInst = nil then
- FInst := TFoo.Create();
- end;
- begin
- TFoo.Init();
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { A class-typed static var holds one retained reference; the program-exit
- cleanup at @main_exit must release the shared global slot. }
- AssertTrue('static var class slot present',
- Pos('data $TFoo_FInst', IR) >= 0);
- AssertTrue('static var released at @main_exit',
- (Pos('@main_exit', IR) >= 0) and (Pos('loadl $TFoo_FInst', IR) >= 0));
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticCall_InterfaceArg_NoLeadingComma;
-{ A static method whose FIRST parameter is interface-typed must be CALLED with
- a well-formed argument list: 'call $T_M(l obj, l itab)'. The interface arg
- fragment carries a leading ', ' (it is normally appended after Self/a prior
- arg); in a static call it is the first arg, so the codegen must strip that
- comma — otherwise QBE rejects 'call $T_M(, l obj, l itab)' as an invalid
- class specifier. }
-const
- Src =
- '''
- program P;
- type
- IThing = interface
- procedure Speak;
- end;
- TThing = class(IThing)
- public
- procedure Speak;
- end;
- THolder = class
- public
- static procedure SetIt(X: IThing);
- end;
- procedure TThing.Speak;
- begin
- end;
- static procedure THolder.SetIt(X: IThing);
- begin
- end;
- var T: TThing;
- begin
- T := TThing.Create();
- THolder.SetIt(T);
- end.
- ''';
-var IR: string; CallPos: Integer;
-begin
- IR := GenIR(Src);
- CallPos := Pos('call $THolder_SetIt(', IR);
- AssertTrue('static interface-arg call emitted', CallPos >= 0);
- { The call must not begin its argument list with a comma. }
- AssertFalse('no leading comma in static interface-arg call',
- Pos('call $THolder_SetIt(,', IR) >= 0);
- AssertTrue('call passes obj+itab pair',
- Pos('call $THolder_SetIt(l ', IR) >= 0);
-end;
-
-procedure TStaticMembersSemTests.TestIR_StaticVar_ChainedLValueBase_LoadsGlobal;
-{ A qualified static var of class type used as the base of a further l-value
- chain (THolder.GObj.V := 5) must resolve and lower: the base instance pointer
- is loaded from the static var's mangled global slot. Without the fix the
- semantic pass rejected the write with "requires a record or class base, got
- 'class of THolder'". }
-const
- Src =
- '''
- program P;
- type
- TObj = class
- public
- V: Integer;
- end;
- THolder = class
- public static var
- GObj: TObj;
- end;
- begin
- THolder.GObj := TObj.Create();
- THolder.GObj.V := 5;
- end.
- ''';
-var IR: string;
-begin
- IR := GenIR(Src);
- { The chained write loads the base instance pointer from the static var slot. }
- AssertTrue('chained l-value base loads static var global',
- Pos('loadl $THolder_GObj', IR) >= 0);
-end;
-
-initialization
- RegisterTest(TStaticMembersParseTests);
- RegisterTest(TStaticMembersSemTests);
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.strutils.pas b/compiler/src/test/pascal/cp.test.strutils.pas
index 747b611..03760c8 100644
--- a/compiler/src/test/pascal/cp.test.strutils.pas
+++ b/compiler/src/test/pascal/cp.test.strutils.pas
@@ -122,7 +122,7 @@ var
begin
inherited SetUp();
ExeDir := ExtractFilePath(ParamStr(0));
- FRTLUnitPath := ExpandFileName(ExeDir + '../../compiler/src/main/pascal');
+ FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal');
FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal');
end;
diff --git a/compiler/src/test/pascal/cp.test.targettoolkit.pas b/compiler/src/test/pascal/cp.test.targettoolkit.pas
deleted file mode 100644
index de3708b..0000000
--- a/compiler/src/test/pascal/cp.test.targettoolkit.pas
+++ /dev/null
@@ -1,157 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.targettoolkit;
-
-{ Tests for the multi-target toolkit + registry (docs/native-target-
- architecture.adoc). A TTargetToolkit is the Abstract Factory that produces
- the consistent family of per-target objects (backend, link target); the
- registry resolves a toolkit by target.
-
- These tests pin the behaviour-preserving Step 0a refactor: the existing
- Linux x86_64 target must resolve through the registry, and the FreeBSD
- x86_64 target must be registered (its codegen lands in later steps, so we
- only assert it is known to the registry here, not that it emits code). }
-
-interface
-
-uses
- blaise.testing,
- blaise.codegen.target, blaise.codegen.toolkit,
- blaise.codegen.native.backend, blaise.linker.elf;
-
-type
- TTargetToolkitTests = class(TTestCase)
- private
- function LinuxTarget: TTargetDesc;
- function FreeBSDTarget: TTargetDesc;
- published
- { Linux x86_64 resolves to a toolkit, and that toolkit reports its name. }
- procedure TestResolve_LinuxX86_64_ReturnsToolkit;
- procedure TestResolve_LinuxX86_64_ToolkitName;
- { The Linux toolkit makes a real backend (the existing TX86_64Backend). }
- procedure TestLinuxToolkit_MakeBackend_NotNil;
- { The Linux toolkit makes a SysV/Linux link target (OSABI 0). }
- procedure TestLinuxToolkit_MakeLinkTarget_IsLinuxOSABI;
- { RegisteredHasNativeBackend mirrors the old TargetHasNativeBackend for
- Linux x86_64. }
- procedure TestRegistered_LinuxX86_64_HasBackend;
- { FreeBSD x86_64 is registered (resolves to a toolkit). }
- procedure TestResolve_FreeBSDX86_64_ReturnsToolkit;
- { FreeBSD toolkit produces a FreeBSD-OSABI link target (OSABI 9). }
- procedure TestFreeBSDToolkit_MakeLinkTarget_IsFreeBSDOSABI;
- { Strategy-B: FreeBSD is freestanding (no libc, always static ET_EXEC);
- Linux is not (dynamic libc by default). }
- procedure TestTargetIsFreestanding_FreeBSD_True;
- procedure TestTargetIsFreestanding_Linux_False;
- end;
-
-implementation
-
-const
- ELFOSABI_SYSV = 0;
- ELFOSABI_FREEBSD = 9;
-
-function TTargetToolkitTests.LinuxTarget: TTargetDesc;
-begin
- MakeTarget(osLinux, cpuX86_64, Result);
-end;
-
-function TTargetToolkitTests.FreeBSDTarget: TTargetDesc;
-begin
- MakeTarget(osFreeBSD, cpuX86_64, Result);
-end;
-
-procedure TTargetToolkitTests.TestResolve_LinuxX86_64_ReturnsToolkit;
-var
- Tk: TTargetToolkit;
-begin
- Tk := ResolveToolkit(Self.LinuxTarget());
- AssertTrue('linux-x86_64 must resolve to a toolkit', Tk <> nil);
-end;
-
-procedure TTargetToolkitTests.TestResolve_LinuxX86_64_ToolkitName;
-var
- Tk: TTargetToolkit;
-begin
- Tk := ResolveToolkit(Self.LinuxTarget());
- AssertEquals('linux-x86_64', Tk.Name());
-end;
-
-procedure TTargetToolkitTests.TestLinuxToolkit_MakeBackend_NotNil;
-var
- Tk: TTargetToolkit;
- B: TNativeBackend;
-begin
- Tk := ResolveToolkit(Self.LinuxTarget());
- B := Tk.MakeBackend();
- try
- AssertTrue('Linux toolkit must produce a backend', B <> nil);
- finally
- B.Free();
- end;
-end;
-
-procedure TTargetToolkitTests.TestLinuxToolkit_MakeLinkTarget_IsLinuxOSABI;
-var
- Tk: TTargetToolkit;
- Lt: TLinkTarget;
-begin
- Tk := ResolveToolkit(Self.LinuxTarget());
- Lt := Tk.MakeLinkTarget();
- try
- AssertEquals(ELFOSABI_SYSV, Lt.OSABI);
- finally
- Lt.Free();
- end;
-end;
-
-procedure TTargetToolkitTests.TestRegistered_LinuxX86_64_HasBackend;
-begin
- AssertTrue('linux-x86_64 must have a native backend',
- RegisteredHasNativeBackend(Self.LinuxTarget()));
-end;
-
-procedure TTargetToolkitTests.TestResolve_FreeBSDX86_64_ReturnsToolkit;
-var
- Tk: TTargetToolkit;
-begin
- Tk := ResolveToolkit(Self.FreeBSDTarget());
- AssertTrue('freebsd-x86_64 must resolve to a toolkit', Tk <> nil);
-end;
-
-procedure TTargetToolkitTests.TestFreeBSDToolkit_MakeLinkTarget_IsFreeBSDOSABI;
-var
- Tk: TTargetToolkit;
- Lt: TLinkTarget;
-begin
- Tk := ResolveToolkit(Self.FreeBSDTarget());
- Lt := Tk.MakeLinkTarget();
- try
- AssertEquals(ELFOSABI_FREEBSD, Lt.OSABI);
- finally
- Lt.Free();
- end;
-end;
-
-procedure TTargetToolkitTests.TestTargetIsFreestanding_FreeBSD_True;
-begin
- AssertTrue('FreeBSD is a freestanding (Strategy-B, static, no-libc) target',
- TargetIsFreestanding(Self.FreeBSDTarget()));
-end;
-
-procedure TTargetToolkitTests.TestTargetIsFreestanding_Linux_False;
-begin
- AssertFalse('Linux links dynamic libc by default, not freestanding',
- TargetIsFreestanding(Self.LinuxTarget()));
-end;
-
-initialization
- RegisterTest(TTargetToolkitTests);
-
-end.
diff --git a/compiler/src/test/pascal/cp.test.uint64.pas b/compiler/src/test/pascal/cp.test.uint64.pas
index f1dd24e..08df5c2 100644
--- a/compiler/src/test/pascal/cp.test.uint64.pas
+++ b/compiler/src/test/pascal/cp.test.uint64.pas
@@ -46,7 +46,6 @@ type
procedure TestCodegen_UInt64_Mod_UsesUrem;
procedure TestCodegen_WriteLn_UInt64_CallsSysWriteUInt64;
procedure TestCodegen_IntToStr_UInt64_CallsUInt64ToStr;
- procedure TestCodegen_Int64LargeLiteralCast_UsesLType;
end;
[Threaded]
@@ -60,12 +59,6 @@ type
procedure TestRun_UInt64_Arithmetic;
procedure TestRun_UInt64_UnsignedCompare;
procedure TestRun_Int64_MinValue;
- { Regression: a const declared with the value-cast form
- cMax = Int64(922337203685477580) must lower the large literal with the
- 'l' (64-bit) type — through const folding, arithmetic, and argument
- positions. The QBE backend once emitted a 'w'-typed operand here and
- QBE rejected the IR ("invalid type for first operand ... in arg"). }
- procedure TestRun_Int64_LargeLiteralCast;
end;
implementation
@@ -341,26 +334,6 @@ begin
AssertTrue('UInt64 mod uses urem', Pos('urem', IR) > 0);
end;
-procedure TUInt64Tests.TestCodegen_Int64LargeLiteralCast_UsesLType;
-var
- IR: string;
-begin
- IR := GenIR(
- '''
- program P;
- var N: Int64;
- begin
- N := Int64(922337203685477580)
- end.
- ''');
- { The large literal must carry the 'l' (64-bit) type. A 'w copy' of a
- >32-bit literal is the bug QBE rejected with "invalid type ... in arg". }
- AssertTrue('large Int64 literal lowered as l',
- Pos('=l copy 922337203685477580', IR) > 0);
- AssertFalse('large Int64 literal not lowered as w',
- Pos('=w copy 922337203685477580', IR) <> -1);
-end;
-
procedure TUInt64Tests.TestCodegen_WriteLn_UInt64_CallsSysWriteUInt64;
var
IR: string;
@@ -474,22 +447,6 @@ const
end.
''';
- SrcInt64LargeLiteralCast =
- '''
- program P;
- const
- cMax = Int64(922337203685477580);
- procedure Show(V: Int64);
- begin WriteLn(V) end;
- var N: Int64;
- begin
- Show(cMax);
- N := cMax div 10;
- Show(N);
- WriteLn(Int64(922337203685477580))
- end.
- ''';
-
procedure TUInt64E2ETests.TestRun_UInt64_RoundTrip;
var Output: string; RCode: Integer;
begin
@@ -548,15 +505,6 @@ begin
'-9223372036854775808' + LE, Output);
end;
-procedure TUInt64E2ETests.TestRun_Int64_LargeLiteralCast;
-begin
- if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end;
- AssertRunsOnAll(SrcInt64LargeLiteralCast,
- '922337203685477580' + LE +
- '92233720368547758' + LE +
- '922337203685477580' + LE, 0);
-end;
-
initialization
RegisterTest(TUInt64Tests);
RegisterTest(TUInt64E2ETests);
diff --git a/compiler/src/test/pascal/cp.test.unitinterface.pas b/compiler/src/test/pascal/cp.test.unitinterface.pas
index 11a186e..5b5efdc 100644
--- a/compiler/src/test/pascal/cp.test.unitinterface.pas
+++ b/compiler/src/test/pascal/cp.test.unitinterface.pas
@@ -230,13 +230,8 @@ type
procedure TestWrite_StartsWithMagicAndVersion;
{ Unit name round-trips. }
procedure TestRoundTrip_UnitNamePreserved;
- { External-library link deps (LinkLibs) round-trip via the META block. }
- procedure TestRoundTrip_LinkLibsPreserved;
{ Int const round-trips. }
procedure TestRoundTrip_IntConstPreserved;
- { Named integer subrange alias round-trips its IsSubrange + lo..hi bounds,
- so array[OtherUnit.TSub] still folds across separate compilation. }
- procedure TestRoundTrip_NamedSubrangeAlias_BoundsPreserved;
{ String const round-trips, even with newlines + colons in the value. }
procedure TestRoundTrip_StringConstWithAwkwardChars;
{ Empty interface round-trips (zero consts). }
@@ -250,8 +245,6 @@ type
procedure TestRoundTrip_ViaFile;
procedure TestRoundTrip_Record;
procedure TestRoundTrip_Class_WithVirtualMethod;
- procedure TestRoundTrip_Class_WithOverloadedMethods;
- procedure TestRoundTrip_Interface_WithOverloadedMethods;
procedure TestRoundTrip_Interface;
procedure TestRoundTrip_Interface_WithProperty;
procedure TestRoundTrip_ProceduralType;
@@ -270,16 +263,6 @@ type
preserves statements/expressions through write+read. }
procedure TestDiskPath_GenericRoutine_BodyPreserved;
procedure TestRoundTrip_InlineBody_Preserved;
- { Static (class-level) member facts must survive export-clone → encode →
- decode. The export clone previously dropped TFieldDecl.IsClassVar /
- ClassVarEmitName, TMethodDecl.IsStatic and TPropertyDecl.IsStatic, so
- they encoded as defaults. }
- procedure TestRoundTrip_StaticMembers_Preserved;
- { Pre-existing clone bug uncovered alongside the static-members work: a
- [Weak] field and a `default` property round-tripped as plain owning /
- non-default because CloneFieldDecl / ClonePropertyDecl dropped IsWeak
- and IsDefault before encoding. }
- procedure TestRoundTrip_WeakField_And_DefaultProperty_Preserved;
end;
{ ----- ImportUnitInterface round-trip (Phase 6c-A) -------------- }
@@ -2566,7 +2549,7 @@ begin
try
Parser := TParser.Create(Lex);
try
- Result := Parser.Parse(); { public entry; ParseProgram is a private internal }
+ Result := Parser.ParseProgram();
finally
Parser.Free();
end;
@@ -2698,13 +2681,9 @@ begin
Iface := TUnitInterface.Create('U');
try
Buf := WriteUnitInterface(Iface);
- { Blaise Pos is 0-based; match-at-start returns 0. Version is 8 since
- named integer subranges (IsSubrange + lo..hi bounds on the 'alias' TYPE
- entry) were added (on top of v7's LinkLibs, v6's `overload` directive,
- v5's member Visibility, v4's TRoutineSig.IsStatic, and v3's static-member
- facts). }
+ { Blaise Pos is 0-based; match-at-start returns 0. }
AssertTrue('starts with magic',
- Pos('BLAISE-IFACE 8', Buf) = 0);
+ Pos('BLAISE-IFACE 2', Buf) = 0);
finally
Iface.Free();
end;
@@ -2729,29 +2708,6 @@ begin
end;
end;
-procedure TIfaceIOTests.TestRoundTrip_LinkLibsPreserved;
-var
- Src, Dst: TUnitInterface;
- Buf: string;
-begin
- Src := TUnitInterface.Create('MyUnit');
- try
- Src.LinkLibs.Add('c');
- Src.LinkLibs.Add('m');
- Buf := WriteUnitInterface(Src);
- Dst := ReadUnitInterface(Buf);
- try
- AssertEquals('link-lib count', 2, Dst.LinkLibs.Count);
- AssertEquals('first lib', 'c', Dst.LinkLibs.Strings[0]);
- AssertEquals('second lib', 'm', Dst.LinkLibs.Strings[1]);
- finally
- Dst.Free();
- end;
- finally
- Src.Free();
- end;
-end;
-
procedure TIfaceIOTests.TestRoundTrip_IntConstPreserved;
var
Src, Dst: TUnitInterface;
@@ -2776,40 +2732,6 @@ begin
end;
end;
-procedure TIfaceIOTests.TestRoundTrip_NamedSubrangeAlias_BoundsPreserved;
-const
- SRC =
- 'unit TestU;' + #10 +
- 'interface' + #10 +
- 'type TIdx = 2..4;' + #10 +
- 'implementation' + #10 +
- 'end.' + #10;
-var
- SrcIface, Dst: TUnitInterface;
- E: TTypeEntry;
- AD: TTypeAliasDef;
- Buf: string;
-begin
- SrcIface := ParseAndExport(SRC);
- try
- Buf := WriteUnitInterface(SrcIface);
- Dst := ReadUnitInterface(Buf);
- try
- E := Dst.FindType('TIdx');
- AssertTrue('TIdx present', E <> nil);
- AssertTrue('is alias def', E.Def is TTypeAliasDef);
- AD := TTypeAliasDef(E.Def);
- AssertEquals('IsSubrange', True, AD.IsSubrange);
- AssertEquals('SubrangeLow', Int64(2), AD.SubrangeLow);
- AssertEquals('SubrangeHigh', Int64(4), AD.SubrangeHigh);
- finally
- Dst.Free();
- end;
- finally
- SrcIface.Free();
- end;
-end;
-
procedure TIfaceIOTests.TestRoundTrip_StringConstWithAwkwardChars;
const
WEIRD = 'multi' + #10 + 'line: with ":" inside';
@@ -3029,98 +2951,6 @@ begin
end;
end;
-procedure TIfaceIOTests.TestRoundTrip_Class_WithOverloadedMethods;
-{ Regression (bugs.txt: imported methods lose IsOverload). A class with an
- overloaded method set must round-trip the `overload` directive through the
- .bif: ResolveMethodOverload's hiding walk stops at the first NON-overload
- candidate, so a method imported with IsOverload=False would wrongly truncate
- an overload set that is split across an imported class and its ancestor. }
-const
- SRC =
- 'unit U;' + #10 +
- 'interface' + #10 +
- 'type TFoo = class' + #10 +
- ' procedure Add(A: Integer); overload;' + #10 +
- ' procedure Add(A: string); overload;' + #10 +
- 'end;' + #10 +
- 'implementation' + #10 +
- 'procedure TFoo.Add(A: Integer); begin end;' + #10 +
- 'procedure TFoo.Add(A: string); begin end;' + #10 +
- 'end.' + #10;
-var
- Iface, Round: TUnitInterface;
- Buf: string;
- E: TTypeEntry;
- M: TRoutineSig;
- I: Integer;
-begin
- Iface := ParseAnalyseAndExport(SRC);
- try
- Buf := WriteUnitInterface(Iface);
- Round := ReadUnitInterface(Buf);
- try
- E := Round.FindType('TFoo');
- AssertTrue('TFoo present', E <> nil);
- AssertEquals('2 methods', 2, E.Methods.Count);
- { Every Add overload must carry IsOverload across the .bif boundary. }
- for I := 0 to E.Methods.Count - 1 do
- begin
- M := TRoutineSig(E.Methods.Items[I]);
- AssertEquals('overload method name', 'Add', M.Name);
- AssertTrue('IsOverload preserved for ' + M.ResolvedQbeName, M.IsOverload);
- end;
- finally
- Round.Free();
- end;
- finally
- Iface.Free();
- end;
-end;
-
-procedure TIfaceIOTests.TestRoundTrip_Interface_WithOverloadedMethods;
-{ Interface methods serialise via EncodeMethodDecl/ReadMethodDecl (the AST
- TMethodDecl path, distinct from the class TRoutineSig path). That path also
- dropped IsOverload, so an overloaded interface method imported from a .bif
- would lose its `overload` directive. }
-const
- SRC =
- 'unit U;' + #10 +
- 'interface' + #10 +
- 'type IShape = interface' + #10 +
- ' procedure Draw(X: Integer); overload;' + #10 +
- ' procedure Draw(X: string); overload;' + #10 +
- 'end;' + #10 +
- 'implementation end.' + #10;
-var
- Iface, Round: TUnitInterface;
- Buf: string;
- E: TTypeEntry;
- M: TMethodDecl;
- I: Integer;
-begin
- Iface := ParseAnalyseAndExport(SRC);
- try
- Buf := WriteUnitInterface(Iface);
- Round := ReadUnitInterface(Buf);
- try
- E := Round.FindType('IShape');
- AssertTrue('IShape present', E <> nil);
- AssertTrue('is interface', E.Def is TInterfaceTypeDef);
- AssertEquals('2 methods', 2, TInterfaceTypeDef(E.Def).Methods.Count);
- for I := 0 to TInterfaceTypeDef(E.Def).Methods.Count - 1 do
- begin
- M := TMethodDecl(TInterfaceTypeDef(E.Def).Methods.Items[I]);
- AssertEquals('overload method name', 'Draw', M.Name);
- AssertTrue('IsOverload preserved', M.IsOverload);
- end;
- finally
- Round.Free();
- end;
- finally
- Iface.Free();
- end;
-end;
-
procedure TIfaceIOTests.TestRoundTrip_Interface;
const
SRC =
@@ -3568,121 +3398,6 @@ begin
end;
end;
-procedure TIfaceIOTests.TestRoundTrip_StaticMembers_Preserved;
-const
- SRC =
- 'unit U;' + #10 +
- 'interface' + #10 +
- 'type TReg = class' + #10 +
- ' private static var' + #10 +
- ' FCount: Integer;' + #10 +
- ' public' + #10 +
- ' static function Next: Integer;' + #10 +
- ' static property Counter: Integer read Next;' + #10 +
- ' public static const' + #10 +
- ' Tag = 7;' + #10 +
- 'end;' + #10 +
- 'implementation' + #10 +
- 'static function TReg.Next: Integer; begin Result := FCount end;' + #10 +
- 'end.' + #10;
-var
- Iface, Round: TUnitInterface;
- Buf: string;
- E: TTypeEntry;
- Def: TClassTypeDef;
- Fld: TFieldDecl;
- M: TRoutineSig;
- Prop: TPropertyDecl;
-begin
- Iface := ParseAnalyseAndExport(SRC);
- try
- Buf := WriteUnitInterface(Iface);
- Round := ReadUnitInterface(Buf);
- try
- E := Round.FindType('TReg');
- AssertTrue('TReg present', E <> nil);
- Def := TClassTypeDef(E.Def);
-
- { static var FCount: IsClassVar set, mangled emit label round-tripped. }
- AssertEquals('1 field decl', 1, Def.Fields.Count);
- Fld := TFieldDecl(Def.Fields.Items[0]);
- AssertEquals('field name', 'FCount', Fld.Names.Strings[0]);
- AssertTrue('FCount IsClassVar', Fld.IsClassVar);
- AssertEquals('FCount emit label', 'U_TReg_FCount', Fld.ClassVarEmitName);
-
- { static method Next: IsStatic carried on the routine sig. }
- AssertEquals('1 method', 1, E.Methods.Count);
- M := TRoutineSig(E.Methods.Items[0]);
- AssertEquals('method name', 'Next', M.Name);
- AssertTrue('Next IsStatic', M.IsStatic);
-
- { static property Counter: IsStatic carried on the property decl. }
- AssertEquals('1 property', 1, Def.Properties.Count);
- Prop := TPropertyDecl(Def.Properties.Items[0]);
- AssertEquals('prop name', 'Counter', Prop.Name);
- AssertTrue('Counter IsStatic', Prop.IsStatic);
-
- { static const Tag: carried in the class ConstDecls list. }
- AssertEquals('1 const decl', 1, Def.ConstDecls.Count);
- AssertEquals('const name', 'Tag',
- TConstDecl(Def.ConstDecls.Items[0]).Name);
- AssertEquals('const value', 7,
- TConstDecl(Def.ConstDecls.Items[0]).IntVal);
- finally
- Round.Free();
- end;
- finally
- Iface.Free();
- end;
-end;
-
-procedure TIfaceIOTests.TestRoundTrip_WeakField_And_DefaultProperty_Preserved;
-const
- SRC =
- 'unit U;' + #10 +
- 'interface' + #10 +
- 'type TNode = class' + #10 +
- ' [Weak] FNext: TNode;' + #10 +
- ' function Get(I: Integer): Integer;' + #10 +
- ' property Items[I: Integer]: Integer read Get; default;' + #10 +
- 'end;' + #10 +
- 'implementation' + #10 +
- 'function TNode.Get(I: Integer): Integer; begin Result := I end;' + #10 +
- 'end.' + #10;
-var
- Iface, Round: TUnitInterface;
- Buf: string;
- E: TTypeEntry;
- Def: TClassTypeDef;
- Fld: TFieldDecl;
- Prop: TPropertyDecl;
-begin
- Iface := ParseAnalyseAndExport(SRC);
- try
- Buf := WriteUnitInterface(Iface);
- Round := ReadUnitInterface(Buf);
- try
- E := Round.FindType('TNode');
- AssertTrue('TNode present', E <> nil);
- Def := TClassTypeDef(E.Def);
-
- AssertEquals('1 field decl', 1, Def.Fields.Count);
- Fld := TFieldDecl(Def.Fields.Items[0]);
- AssertEquals('field name', 'FNext', Fld.Names.Strings[0]);
- AssertTrue('FNext IsWeak survives clone+round-trip', Fld.IsWeak);
-
- AssertEquals('1 property', 1, Def.Properties.Count);
- Prop := TPropertyDecl(Def.Properties.Items[0]);
- AssertEquals('prop name', 'Items', Prop.Name);
- AssertTrue('Items IsDefault survives clone+round-trip', Prop.IsDefault);
- finally
- Round.Free();
- end;
- finally
- Iface.Free();
- end;
-end;
-
procedure TIfaceIOTests.TestRead_VersionMismatch_Raises;
var
Caught: Boolean;
diff --git a/compiler/src/test/pascal/cp.test.visibility.pas b/compiler/src/test/pascal/cp.test.visibility.pas
deleted file mode 100644
index d1c91d7..0000000
--- a/compiler/src/test/pascal/cp.test.visibility.pas
+++ /dev/null
@@ -1,868 +0,0 @@
-{
- Blaise - An Object Pascal Compiler
- Copyright (c) 2026 Graeme Geldenhuys
- SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
- Licensed under the Apache License v2.0 with Runtime Library Exception.
- See LICENSE file in the project root for full license terms.
-}
-
-unit cp.test.visibility;
-
-{ Tests for member visibility ENFORCEMENT — private / protected / strict.
- Feature 2 of the static/visibility work. Before this, Blaise parsed the
- visibility keywords but enforced none of them (private was effectively a
- comment) and had no `strict` keyword.
-
- Coverage:
- * PARSER (TVisibilityParseTests) — the visibility section keywords, the
- `strict` soft keyword before private/protected, and the rejection of
- `strict public` / `strict published` / bare `strict`. Asserts the
- Visibility flag lands on the field/method/property AST nodes.
- * SEMANTIC (TVisibilitySemTests) — qualified member access is rejected when
- out of scope and accepted when in scope, for fields, methods, and
- properties, across private / protected / strict-private / strict-protected.
-
- Cross-unit private/protected enforcement (the .bif round-trip) is exercised by
- the self-hosting warm-cache fixpoint and the standalone cross-unit compile
- checks; the in-process harness here covers the within-translation-unit rules
- (different type in the same program = "same unit", so private is visible but
- strict private is not). }
-
-interface
-
-uses
- Classes, SysUtils, blaise.testing,
- uLexer, uParser, uAST, uSemantic, uSymbolTable;
-
-type
- TVisibilityParseTests = class(TTestCase)
- private
- function ParseSrc(const ASrc: string): TProgram;
- function ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
- procedure ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
- published
- procedure TestParse_PrivateField_SetsMvPrivate;
- procedure TestParse_ProtectedField_SetsMvProtected;
- procedure TestParse_PublishedField_SetsMvPublished;
- procedure TestParse_DefaultIsPublic;
- procedure TestParse_StrictPrivateField_SetsMvStrictPrivate;
- procedure TestParse_StrictProtectedField_SetsMvStrictProtected;
- procedure TestParse_StrictComposesWithStatic;
- procedure TestParse_StrictPublic_Rejected;
- procedure TestParse_BareStrict_Rejected;
- procedure TestParse_StrictAsOrdinaryIdentOutsideClass;
- end;
-
- TVisibilitySemTests = class(TTestCase)
- private
- procedure AnalyseExpectOK(const ASrc: string);
- procedure AnalyseExpectReject(const ASrc, AExpectedSubstr: string);
- published
- { private — unit-scoped }
- procedure TestSem_PrivateField_SameUnitOtherProc_OK;
- procedure TestSem_PrivateField_OwnMethod_OK;
- procedure TestSem_PrivateMethod_SameUnitOtherType_OK;
-
- { strict private — type-scoped }
- procedure TestSem_StrictPrivateField_CrossType_Rejected;
- procedure TestSem_StrictPrivateField_OwnMethod_OK;
- procedure TestSem_StrictPrivateMethod_CrossType_Rejected;
-
- { protected — descendant types (and, being unit-scoped, same-unit code) }
- procedure TestSem_ProtectedField_Descendant_OK;
- procedure TestSem_ProtectedField_SameUnitUnrelated_OK;
-
- { strict protected — declaring type + descendants }
- procedure TestSem_StrictProtectedField_Descendant_OK;
- procedure TestSem_StrictProtectedField_NonDescendant_Rejected;
-
- { public / published — visible everywhere }
- procedure TestSem_PublicField_CrossType_OK;
-
- { strict composes with static }
- procedure TestSem_StrictPrivateStaticVar_OwnMethod_OK;
- procedure TestSem_StrictPrivateStaticVar_CrossType_Rejected;
- { bare (unqualified) static-var access is visibility-checked too }
- procedure TestSem_StrictPrivateStaticVar_BareFromOtherType_Rejected;
- procedure TestSem_StrictPrivateStaticVar_FromProgramBody_Rejected;
- procedure TestSem_PrivateStaticVar_FromUnitInit_OK;
- procedure TestSem_PublicStaticVar_QualifiedRead_CrossType_OK;
-
- { property visibility }
- procedure TestSem_PrivateProperty_CrossType_OK;
- procedure TestSem_StrictPrivateProperty_CrossType_Rejected;
- end;
-
-implementation
-
-{ ================================================================== }
-{ Parser tests }
-{ ================================================================== }
-
-function TVisibilityParseTests.ParseSrc(const ASrc: string): TProgram;
-var L: TLexer; P: TParser;
-begin
- L := TLexer.Create(ASrc);
- P := TParser.Create(L);
- try
- Result := P.Parse();
- finally
- P.Free(); L.Free();
- end;
-end;
-
-function TVisibilityParseTests.ClassOf(AProg: TProgram; AIndex: Integer): TClassTypeDef;
-var TD: TTypeDecl;
-begin
- TD := TTypeDecl(AProg.Block.TypeDecls.Items[AIndex]);
- Result := TD.Def as TClassTypeDef;
-end;
-
-procedure TVisibilityParseTests.ParseExpectErrorMsg(const ASrc, AExpectedSubstr: string);
-var Prog: TProgram;
-begin
- try
- Prog := ParseSrc(ASrc);
- Prog.Free();
- Fail('Expected EParseError');
- except
- on E: EParseError do
- AssertTrue('error contains "' + AExpectedSubstr + '" (got: ' + E.Message + ')',
- Pos(AExpectedSubstr, E.Message) >= 0);
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_PrivateField_SetsMvPrivate;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- private
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('field is mvPrivate',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvPrivate);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_ProtectedField_SetsMvProtected;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- protected
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('field is mvProtected',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvProtected);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_PublishedField_SetsMvPublished;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- published
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('field is mvPublished',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvPublished);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_DefaultIsPublic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('default field is mvPublic',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvPublic);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_StrictPrivateField_SetsMvStrictPrivate;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- strict private
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('field is mvStrictPrivate',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvStrictPrivate);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_StrictProtectedField_SetsMvStrictProtected;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- strict protected
- FX: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- AssertTrue('field is mvStrictProtected',
- TFieldDecl(CD.Fields.Items[0]).Visibility = mvStrictProtected);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_StrictComposesWithStatic;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- strict private static var
- FInst: Integer;
- end;
- begin end.
- ''';
-var Prog: TProgram; CD: TClassTypeDef; F: TFieldDecl;
-begin
- Prog := ParseSrc(Src);
- try
- CD := ClassOf(Prog, 0);
- F := TFieldDecl(CD.Fields.Items[0]);
- AssertTrue('strict private', F.Visibility = mvStrictPrivate);
- AssertTrue('also static (class var)', F.IsClassVar);
- finally
- Prog.Free();
- end;
-end;
-
-procedure TVisibilityParseTests.TestParse_StrictPublic_Rejected;
-const
- Src =
- '''
- program P;
- type
- TFoo = class
- strict public
- FX: Integer;
- end;
- begin end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'strict');
-end;
-
-procedure TVisibilityParseTests.TestParse_BareStrict_Rejected;
-const
- { `strict` not followed by private/protected — followed by `end` here. The
- parser must not silently swallow it; a bare `strict` in a member section is
- treated as an ordinary field-start identifier, so this parses `strict` as a
- field name and then errors on the missing ':'. Either way it must NOT parse
- as a valid empty class. }
- Src =
- '''
- program P;
- type
- TFoo = class
- strict public
- end;
- begin end.
- ''';
-begin
- ParseExpectErrorMsg(Src, 'strict');
-end;
-
-procedure TVisibilityParseTests.TestParse_StrictAsOrdinaryIdentOutsideClass;
-const
- { `strict` is a SOFT keyword — outside a class/record body it must remain a
- usable identifier (here a local variable name). }
- Src =
- '''
- program P;
- var
- strict: Integer;
- begin
- strict := 1;
- end.
- ''';
-var Prog: TProgram;
-begin
- Prog := ParseSrc(Src);
- AssertTrue('strict usable as ordinary identifier outside a class', Prog <> nil);
- Prog.Free();
-end;
-
-{ ================================================================== }
-{ Semantic enforcement tests }
-{ ================================================================== }
-
-procedure TVisibilitySemTests.AnalyseExpectOK(const ASrc: string);
-var L: TLexer; P: TParser; A: TSemanticAnalyser; Prog: TProgram;
-begin
- L := TLexer.Create(ASrc);
- P := TParser.Create(L);
- try
- Prog := P.Parse();
- finally
- P.Free(); L.Free();
- end;
- A := TSemanticAnalyser.Create();
- try
- A.Analyse(Prog);
- finally
- A.Free();
- end;
- Prog.Free();
-end;
-
-procedure TVisibilitySemTests.AnalyseExpectReject(const ASrc, AExpectedSubstr: string);
-var L: TLexer; P: TParser; A: TSemanticAnalyser; Prog: TProgram;
-begin
- L := TLexer.Create(ASrc);
- P := TParser.Create(L);
- try
- Prog := P.Parse();
- finally
- P.Free(); L.Free();
- end;
- A := TSemanticAnalyser.Create();
- try
- try
- A.Analyse(Prog);
- Fail('Expected ESemanticError for out-of-scope access');
- except
- on E: ESemanticError do
- AssertTrue('error contains "' + AExpectedSubstr + '" (got: ' + E.Message + ')',
- Pos(AExpectedSubstr, E.Message) >= 0);
- end;
- finally
- A.Free();
- Prog.Free();
- end;
-end;
-
-procedure TVisibilitySemTests.TestSem_PrivateField_SameUnitOtherProc_OK;
-const
- Src =
- '''
- program P;
- type
- TB = class
- private
- FSecret: Integer;
- end;
- procedure Touch(b: TB);
- begin
- b.FSecret := 1;
- end;
- var b: TB;
- begin
- b := TB.Create();
- Touch(b);
- end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_PrivateField_OwnMethod_OK;
-const
- Src =
- '''
- program P;
- type
- TB = class
- private
- FSecret: Integer;
- public
- procedure Bump;
- end;
- procedure TB.Bump;
- begin
- Self.FSecret := Self.FSecret + 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_PrivateMethod_SameUnitOtherType_OK;
-const
- Src =
- '''
- program P;
- type
- TM = class
- private
- procedure Hidden;
- end;
- TUser = class
- public
- procedure Use(m: TM);
- end;
- procedure TM.Hidden; begin end;
- procedure TUser.Use(m: TM);
- begin
- m.Hidden();
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateField_CrossType_Rejected;
-const
- Src =
- '''
- program P;
- type
- TC = class
- strict private
- FX: Integer;
- end;
- TD = class
- public
- procedure Poke(c: TC);
- end;
- procedure TD.Poke(c: TC);
- begin
- c.FX := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateField_OwnMethod_OK;
-const
- Src =
- '''
- program P;
- type
- TC = class
- strict private
- FX: Integer;
- public
- procedure Bump;
- end;
- procedure TC.Bump;
- begin
- Self.FX := Self.FX + 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateMethod_CrossType_Rejected;
-const
- Src =
- '''
- program P;
- type
- TM = class
- strict private
- procedure Hidden;
- end;
- TUser = class
- public
- procedure Use(m: TM);
- end;
- procedure TM.Hidden; begin end;
- procedure TUser.Use(m: TM);
- begin
- m.Hidden();
- end;
- begin end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_ProtectedField_Descendant_OK;
-const
- Src =
- '''
- program P;
- type
- TBase = class
- protected
- FProt: Integer;
- end;
- TDeriv = class(TBase)
- public
- procedure Use;
- end;
- procedure TDeriv.Use;
- begin
- Self.FProt := 9;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_ProtectedField_SameUnitUnrelated_OK;
-const
- { protected is private (unit-scoped) PLUS descendants — so an UNRELATED type
- in the SAME unit can still reach it. The cross-unit unrelated REJECT case
- requires a separate compilation unit and is covered by the standalone
- cross-unit compile checks + the warm-cache fixpoint. }
- Src =
- '''
- program P;
- type
- TBase = class
- protected
- FProt: Integer;
- end;
- TOther = class
- public
- procedure Poke(b: TBase);
- end;
- procedure TOther.Poke(b: TBase);
- begin
- b.FProt := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictProtectedField_Descendant_OK;
-const
- Src =
- '''
- program P;
- type
- TE = class
- strict protected
- FY: Integer;
- end;
- TSub = class(TE)
- public
- procedure Use;
- end;
- procedure TSub.Use;
- begin
- Self.FY := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictProtectedField_NonDescendant_Rejected;
-const
- Src =
- '''
- program P;
- type
- TE = class
- strict protected
- FY: Integer;
- end;
- TOther = class
- public
- procedure Poke(e: TE);
- end;
- procedure TOther.Poke(e: TE);
- begin
- e.FY := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_PublicField_CrossType_OK;
-const
- Src =
- '''
- program P;
- type
- TF = class
- public
- FOpen: Integer;
- end;
- TUser = class
- public
- procedure Poke(f: TF);
- end;
- procedure TUser.Poke(f: TF);
- begin
- f.FOpen := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_OwnMethod_OK;
-const
- Src =
- '''
- program P;
- type
- TS = class
- strict private static var
- FInst: Integer;
- public
- static procedure Init;
- end;
- static procedure TS.Init;
- begin
- FInst := 0;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_CrossType_Rejected;
-const
- Src =
- '''
- program P;
- type
- TS = class
- strict private static var
- FInst: Integer;
- end;
- TOther = class
- public
- procedure Poke;
- end;
- procedure TOther.Poke;
- begin
- TS.FInst := 1;
- end;
- begin end.
- ''';
-begin
- { A strict-private static var is reachable only from TS's own methods; a
- qualified TS.FInst from another type must be rejected. }
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_BareFromOtherType_Rejected;
-const
- { The BARE (unqualified) form resolves to the same shared global; it must be
- visibility-checked too, not just the qualified TS.FInst form. }
- Src =
- '''
- program P;
- type
- TS = class
- strict private static var
- FInst: Integer;
- end;
- TOther = class
- public
- procedure Poke;
- end;
- procedure TOther.Poke;
- begin
- FInst := 1;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateStaticVar_FromProgramBody_Rejected;
-const
- { The program body is not a method of TS, so a strict-private static var is
- out of reach (mirrors the unit initialization-section rule). }
- Src =
- '''
- program P;
- type
- TS = class
- strict private static var
- FInst: Integer;
- end;
- begin
- FInst := 1;
- end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-procedure TVisibilitySemTests.TestSem_PrivateStaticVar_FromUnitInit_OK;
-const
- { A NON-strict private static var is unit-scoped, so the program body (same
- scope as a unit's initialization section) may write it. }
- Src =
- '''
- program P;
- type
- TS = class
- private static var
- FInst: Integer;
- end;
- begin
- FInst := 7;
- end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_PublicStaticVar_QualifiedRead_CrossType_OK;
-const
- { A public static var is readable through the qualified form from anywhere. }
- Src =
- '''
- program P;
- type
- TS = class
- public static var
- GVal: Integer;
- end;
- TUser = class
- public
- function R: Integer;
- end;
- function TUser.R: Integer;
- begin
- Result := TS.GVal;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_PrivateProperty_CrossType_OK;
-const
- { private (unit-scoped) — another type in the SAME program can read it. }
- Src =
- '''
- program P;
- type
- TG = class
- private
- FVal: Integer;
- private
- property Val: Integer read FVal write FVal;
- end;
- TUser = class
- public
- function Read(g: TG): Integer;
- end;
- function TUser.Read(g: TG): Integer;
- begin
- Result := g.Val;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectOK(Src);
-end;
-
-procedure TVisibilitySemTests.TestSem_StrictPrivateProperty_CrossType_Rejected;
-const
- Src =
- '''
- program P;
- type
- TG = class
- strict private
- FVal: Integer;
- property Val: Integer read FVal write FVal;
- end;
- TUser = class
- public
- function Read(g: TG): Integer;
- end;
- function TUser.Read(g: TG): Integer;
- begin
- Result := g.Val;
- end;
- begin end.
- ''';
-begin
- AnalyseExpectReject(Src, 'not accessible');
-end;
-
-initialization
- RegisterTest(TVisibilityParseTests);
- RegisterTest(TVisibilitySemTests);
-end.
diff --git a/docs/freebsd-x86_64-backend-design.adoc b/docs/freebsd-x86_64-backend-design.adoc
deleted file mode 100644
index 2510a35..0000000
--- a/docs/freebsd-x86_64-backend-design.adoc
+++ /dev/null
@@ -1,600 +0,0 @@
-= FreeBSD x86_64 Native Backend and Cross-Compilation — Design
-:author: Graeme Geldenhuys
-:revdate: 2026-06-24
-:toc: left
-:toclevels: 3
-:source-highlighter: rouge
-:icons: font
-:sectanchors:
-:sectnums:
-
-== Context
-
-Blaise's default backend is the native x86_64 code generator with an
-in-process assembler and ELF linker. No external assembler or linker is
-invoked: source compiles directly to a runnable ELF executable. Today the
-only supported target is `linux-x86_64`.
-
-This document specifies the addition of a `freebsd-x86_64` target and, more
-broadly, the work required to make the native backend a genuine
-*cross-compiler* — producing a FreeBSD (and later Windows) binary while
-running on a Linux host, with no FreeBSD machine, no QEMU, and no external
-toolchain in the loop.
-
-FreeBSD/x86_64 is the right first cross-target: it shares the System V AMD64
-ABI and the ELF container with Linux, so the instruction selector, register
-allocator, ABI lowering, and the bulk of the ELF linker are reused unchanged.
-The differences are confined to a small, well-bounded surface.
-
-=== Is this possible?
-
-Yes. The conclusion of the investigation below is that a FreeBSD x86_64
-backend is achievable with *no changes to instruction selection or the
-register allocator*, and that the existing architecture has already been
-deliberately staged for it. The work is real but bounded — it is
-parameterisation and one new system-call surface, not a second backend.
-
-The single largest decision is how the FreeBSD binary reaches the kernel.
-That decision (libc-linked vs. direct-syscall) shapes the whole effort and is
-discussed in <>.
-
-== Current architecture: what already generalises
-
-The codebase has been written with the second target in mind. The following
-are already target-parameterised and require *no* per-OS work:
-
-[cols="2,4",options="header"]
-|===
-| Component | State
-
-| Target model (`blaise.codegen.target.pas`)
-| `TTargetOS` already enumerates `osLinux, osFreeBSD, osWindows, osMacOS`;
- `TTargetCPU` has `cpuX86_64`. `ParseTargetName` already accepts
- `"freebsd-x86_64"`. The host/`--target` plumbing exists.
-
-| Instruction selection / regalloc / ABI (`blaise.codegen.native.x86_64.pas`)
-| System V AMD64 ABI is shared between Linux and FreeBSD x86_64. Argument
- classification, the record-return classifier
- (`ClassifyRecordReturn` in `blaise.codegen.native.backend.pas`), SSE vs
- integer eightbyte rules — all identical. No change expected.
-
-| ELF object/relocation core (`blaise.linker.elf.pas`)
-| The relocation set handled
- (`R_X86_64_64/PC32/PLT32/GOTPCREL/RELATIVE/TPOFF32/JUMP_SLOT/GLOB_DAT/...`)
- is architecture-defined, not OS-defined. Section merging, symbol
- resolution, and address layout are OS-agnostic.
-
-| Linker target record (`TLinkTarget`)
-| Already carries `OSABI` (with `ELFOSABI_FREEBSD = 9` already defined),
- `EMachine`, `BaseAddr`, `PageSize` as per-target knobs rather than
- hard-coded constants.
-
-| OPDF debug section
-| The `.opdf.*` sections are non-allocatable and ride through the linker
- unchanged into the final ELF (the merger explicitly keeps them). The
- format is container-level identical on any ELF target.
-|===
-
-The design intent is recorded in the source: `blaise.codegen.target.pas`
-states that "FreeBSD/x86_64 shares the System V AMD64 ABI with Linux, so the
-x86_64 instruction selection will be reused; the OS differences are confined
-to the link line." The linker header comment notes the same for `OSABI` and
-the `-pre`-existing FreeBSD constant.
-
-== Where Linux assumptions are baked in
-
-The OS-specific assumptions are concentrated in three places. These are the
-entire FreeBSD work surface.
-
-=== The runtime reaches the kernel through glibc
-
-`compiler/src/main/pascal/rtl.platform.posix.pas` is *pure Pascal* but is not
-syscall-direct: every primitive is an `external name` binding to a libc
-symbol — `open`, `read`, `write`, `lseek`, `close`, `fstat`, `stat`,
-`mkdir`, `clock_gettime`, `fork`, `execvp`, `waitpid`, `nanosleep`,
-`getenv`, `exit`, etc.
-
-Consequences for FreeBSD:
-
-* *Symbol level — portable.* The POSIX names are the same on FreeBSD libc.
- The Pascal source needs no change for the call sites.
-* *Struct level — NOT portable.* The hand-rolled `TStatBuf` and `TTm`
- records in this unit use *Linux* `struct stat` / `struct tm` field
- ordering and sizes. FreeBSD's `struct stat` has a different layout
- (e.g. `st_ino` is 64-bit and field order differs; FreeBSD 12+ changed
- `ino_t`/`dev_t` widths). `TStatBuf.Size`, `.Mtime`, `.Mode` would read
- garbage offsets if reused verbatim. `struct tm` is largely compatible
- but `tm_gmtoff`/`tm_zone` placement must be verified.
-* *Constant level — NOT portable.* `O_CREAT`, `O_TRUNC`, `O_APPEND`,
- `S_IFDIR`, `CLOCK_REALTIME`, `WNOHANG`, `SEEK_*` are hard-coded Linux
- values in the `const` block. Several differ on FreeBSD (notably the
- `O_*` flag bits and `WNOHANG`).
-
-=== The entry/startup model assumes glibc
-
-`blaise.codegen.native.x86_64.pas` (`EmitProgram`) emits an exported
-`main(argc, argv)`. The runtime now ships its *own* `_start` (the
-`runtime.start` RTL unit, since master commit 626ee4c9) which reads
-`argc`/`argv` off the stack and calls `__libc_start_main(main, ...)`; the
-internal linker (`LinkViaInternalLinker` in `blaise.codegen.native.driver.pas`)
-no longer scans for the host CRT objects (`Scrt1.o`, `crti.o`, `crtn.o`). It
-links:
-
-* the program object and the source-built RTL objects (including
- `runtime.start`, which provides `_start`);
-* in the default dynamic mode, against `libc.so.6` via the interpreter
- `/lib64/ld-linux-x86-64.so.2` (both strings hard-coded in
- `TLinker.BuildDynamic`) — so `__libc_start_main` is still resolved from
- glibc on the Linux target.
-
-`__libc_start_main`, `libc.so.6`, and the glibc loader path are glibc-specific.
-None exist on FreeBSD, whose run-time linker (`/libexec/ld-elf.so.1`) and libc
-differ. Because the runtime already owns `_start` and the linker already has a
-static `ET_EXEC` / `_start` path (Strategy B), FreeBSD needs only a FreeBSD
-`_start` variant that calls `main` directly and exits via syscall — the
-link-time-swap seam is present (Step 3).
-
-=== Toolchain discovery is Linux-pathed
-
-`uToolchain.pas` and the driver:
-
-* `FindCrtObjects` searches Linux library directories only.
-* The RTL is no longer a pre-built per-host archive. `EnsureRTLObjects`
- (`blaise.codegen.driver.pas`) compiles the embedded RTL source
- (`compiler/src/main/pascal/runtime.*`, `rtl.platform.*`) in-process and links
- the resulting `.o` files; the legacy `FindRTLArchive`/`blaise_rtl.a` path is
- gone. The RTL unit list it compiles is Linux-specific (it names
- `rtl.platform.layout.linux`); a FreeBSD program must compile the FreeBSD
- adapter set instead (Step 5).
-* The internal linker now honours `--target` (Step 1): it builds the resolved
- toolkit's `TLinkTarget` rather than always `LinuxX86_64Target()`. What
- remains Linux-specific is the driver's unconditional `FindCrtObjects` /
- dynamic-libc link line (Step 6 selects the static, CRT-free path for FreeBSD).
-
-[#syscall-strategy]
-== The central decision: how does the FreeBSD binary reach the kernel?
-
-This is the one decision that shapes everything. Two viable strategies:
-
-=== Strategy A — link against FreeBSD libc (cross-link)
-
-Keep the existing libc-binding model. Produce a dynamically-linked ELF that
-imports FreeBSD `libc.so.7`, uses interpreter `/libexec/ld-elf.so.1`, sets
-`OSABI = ELFOSABI_FREEBSD`, and is started by FreeBSD `crt1.o`.
-
-* *Pros:* minimal new code; reuses the entire dynamic-link path; the RTL
- stays libc-based; matches how a normal FreeBSD binary is built.
-* *Cons (for a true Linux-hosted cross-compile):* the Linux host does not
- have FreeBSD's `crt1.o` / `crti.o` / `crtn.o` or a `libc.so.7` import
- stub. To cross-link you must stage a *FreeBSD sysroot* on the Linux host
- (a copy of FreeBSD's `/usr/lib` CRT objects + libc) and point
- `FindCrtObjects`/the interp/needed-lib at it. The CRT objects are
- redistributable; this is the standard cross-toolchain approach.
-
-=== Strategy B — direct syscalls, no libc (freestanding)
-
-Bypass libc entirely on FreeBSD: emit our own `_start` that reads
-`argc/argv` off the stack, and replace the `external name 'open'` bindings
-with a FreeBSD syscall stub layer. Produce a *static* `ET_EXEC`
-(the linker's Phase B static path already exists for exactly this
-"hand-written object talks to the kernel through raw syscalls" case).
-
-* *Pros:* genuine zero-dependency cross-compile from Linux with *nothing*
- staged — no FreeBSD sysroot, no CRT objects, no libc. This is the purest
- expression of the stated goal ("cross-compile a FreeBSD binary from my
- Linux system"). The produced binary is also self-contained on the target.
-* *Cons:* requires a FreeBSD syscall layer in the RTL, and — critically —
- the runtime's libc dependency is *deeper than file I/O*. An audit of the
- `external name` bindings across `runtime/` shows the RTL also binds:
-+
-[cols="2,4",options="header"]
-!===
-! libc symbol(s) ! Why a raw-syscall replacement is non-trivial
-
-! `pthread_create/join/mutex_*` (`runtime.thread.pas`)
-! Threading. Reimplementing on raw `thr_new`/`_umtx_op` FreeBSD syscalls is
- real work, not a thin stub.
-
-! `mmap/munmap/mremap` (`runtime.mem.pas`)
-! The memory manager. `mmap`/`munmap` map to syscalls cleanly, but FreeBSD
- has no `mremap`; the allocator's in-place-grow path needs a fallback.
-
-! `memcpy/memset/memcmp`
-! Hot primitives. Either bind to a freestanding implementation or emit
- inline — cannot assume libc is present.
-
-! `localtime_r/gmtime_r/timegm` (`rtl.platform.posix.pas`)
-! Timezone-aware date math. No syscall equivalent; needs a pure-Pascal
- tz/calendar implementation or shipping the rules.
-
-! `setjmp`/`longjmp` (`_blaise_longjmp`, `runtime.setjmp.pas`)
-! Exception unwinding. Hand-written inline assembly (the former
- `blaise_setjmp_x86_64.s`, since migrated into `runtime.setjmp.pas`) — portable,
- but must be verified for the FreeBSD stack/`jmp_buf` layout.
-
-! `atexit`
-! Finalisation. Replaceable with our own registry plus an `exit`-time flush.
-!===
-+
-FreeBSD's syscall ABI itself is straightforward (number in `%rax`, args in
-`rdi, rsi, rdx, r10, r8, r9` — same registers as Linux, *different syscall
-numbers*; errors via the carry flag, not a negative return). `struct stat`
-layout still differs (same issue as Strategy A). The honest cost is the
-non-I/O leaves above, not the syscall mechanism.
-
-=== Decision: Strategy B (direct syscalls)
-
-*Strategy B is chosen.* It is the only route that delivers the stated goal —
-cross-compiling a runnable FreeBSD binary from a Linux host with no external
-tools and nothing staged — and the static `ET_EXEC` / `_start` path it needs
-already exists in the linker (Phase B). Strategy A is recorded above only as
-the fallback shape for users who later want a conventional libc-linked FreeBSD
-binary; it is not on this implementation path.
-
-The audit above (the libc surface beyond file I/O — threads, the memory
-manager, libc string primitives, timezone-aware date math) is *not* a reason
-to avoid Strategy B; it is the *work breakdown* for Strategy B. Each libc leaf
-becomes a method on a target-keyed kernel port and is reimplemented hardest-
-last:
-
-. *Easy leaves first* — `open/read/write/close/lseek/fstat/stat/mkdir/unlink/
- rename/getcwd/chdir/getenv/exit/nanosleep/pipe/dup2/fork/execvp/waitpid`
- map directly to FreeBSD syscalls.
-. *`memcpy/memset/memcmp`* — bind to freestanding implementations (or emit
- inline); never assume libc is present.
-. *`localtime_r/gmtime_r/timegm`* — a pure-Pascal calendar/timezone
- implementation (no syscall equivalent).
-. *Memory manager (`mmap/munmap`, no `mremap` on FreeBSD)* — syscalls plus a
- grow-path fallback.
-. *Threads (`pthread_*`)* — FreeBSD `thr_new`/`_umtx_op`; the hardest leaf,
- done last.
-. *`setjmp/longjmp`* — already hand-written asm; verify the FreeBSD
- `jmp_buf`/stack layout.
-. *`atexit`* — our own registry flushed at `exit`.
-
-=== No `{$IFDEF}`, no scattered target code — ports and adapters
-
-A hard requirement on this work: FreeBSD support must NOT be expressed with
-`{$IFDEF}` directives or `include`-file substitution, and target-specific code
-must not be scattered across units. Blaise already rejects that model —
-`rtl.platform.pas` is explicitly `{$IFDEF}`-free and selects behaviour by
-subclassing. This backend completes that idiom.
-
-The full structural design lives in
-`docs/native-target-architecture.adoc`. In brief, each target is a *family of
-adapter classes* produced by an Abstract Factory (`TTargetToolkit`) resolved by
-name from a `TTargetRegistry`. The two per-target seams Strategy B needs:
-
-* *The kernel leaf* — the raw syscalls + `_start` entry stub. This is a
- *link-time symbol swap*, NOT a runtime port: the FreeBSD RTL archive links a
- syscall-stub object that resolves the same `external name` symbols (`open`,
- `read`, …) that libc resolves on Linux. (A runtime `TKernelABI` virtual port
- was tried and reverted — it destabilised self-hosting for zero present
- benefit; see the kernel-leaf note in the architecture doc.)
-* `TPlatformLayout` — `struct stat` layout and the OS constants (`O_*`,
- `CLOCK_*`, `WNOHANG`, `SEEK_*`), moved behind a per-target runtime port
- (Step 0b, done) instead of leaking into a "shared" adapter.
-
-Target divergence therefore lives in *which adapter object is instantiated and
-which RTL archive is linked* — and the test runner can select the FreeBSD
-adapter to test it natively on a FreeBSD host, or structurally from Linux.
-The implementation steps below assume the structural refactors in the
-architecture doc (toolkit/registry — Step 0a done; `TPlatformLayout` — Step 0b
-done) are already in place.
-
-== Implementation plan
-
-Each step states a verification check, per the project's goal-driven
-convention. Steps 0a–0b are the behaviour-preserving structural refactor from
-`docs/native-target-architecture.adoc` (no FreeBSD code, no behaviour change —
-verified against the existing Linux suite/fixpoints; *both are done*). Steps
-1–9 add the FreeBSD target as a new adapter family on those clean seams.
-Strategy B (direct syscalls, static `ET_EXEC`) is assumed throughout; there is
-no dynamic-link / sysroot work on this path.
-
-=== Step 0a — Toolkit + registry (refactor, no behaviour change)
-
-* Introduce `TTargetToolkit` (Abstract Factory) and `TTargetRegistry`
- (name → toolkit). Register the existing Linux target as
- `TLinuxX86_64Toolkit`. Re-express `--target` resolution and
- `TargetHasNativeBackend` via the registry instead of the current hard-wired
- `LinuxX86_64Target()` / `case`.
-* *Verify:* full suite + all fixpoints unchanged (pure refactor).
-
-=== Step 0b — Extract `TPlatformLayout` (refactor, no behaviour change)
-
-* Move the `TStatBuf`/`TTm` record layouts and the `O_*`/`S_*`/`CLOCK_*`/
- `WNOHANG`/`SEEK_*` constants out of `rtl.platform.posix.pas` and behind a
- `TPlatformLayout` port. The Linux adapter supplies today's values verbatim.
- No `{$IFDEF}`; the layout object is selected at startup.
-* *Verify:* full suite unchanged (the Linux layout reproduces current values).
-
-=== Step 0c — Kernel leaf: link-time swap, not a runtime port (revised)
-
-* *No refactor in this step.* A runtime `TKernelABI` virtual port was attempted
- and reverted: routing the RTL's kernel calls through a 30-method virtual class
- + a new global destabilised self-hosting (segfaulting binaries, non-converging
- across bootstrap stages) for zero present benefit — the Linux adapter was pure
- libc delegation. See the kernel-leaf note in
- `docs/native-target-architecture.adoc`.
-* The RTL keeps its `external name 'open'`/`'read'`/… bindings unchanged. The
- FreeBSD kernel leaf is introduced as a *link-time symbol-stub object* when the
- FreeBSD RTL archive is built (Step 4), resolving those same symbols with raw
- syscalls. Nothing in the Linux RTL changes.
-* The ARC-walker lift into `TNativeBackend` template methods is *deferred* —
- it is arm64 groundwork (FreeBSD reuses the x86_64 backend unchanged) and does
- not block this target.
-
-=== Step 1 — FreeBSD link target + toolkit skeleton
-
-NOTE: Done. The FreeBSD toolkit is registered and the internal linker honours
-`--target freebsd-x86_64` (stamps `EI_OSABI = 9`); test
-`TLinkerE2ETests.TestLink_FreeBSDTarget_StampsOSABI`.
-
-* Add `TFreeBSDX86_64Toolkit` and register it. Its `MakeLinkTarget` returns a
- FreeBSD `TLinkTarget` with `OSABI := ELFOSABI_FREEBSD`,
- `EMachine := EM_X86_64`, and the FreeBSD load base / page size
- (`0x200000` alignment — confirm against a reference FreeBSD `ET_EXEC`).
- `MakeBackend` reuses `TX86_64Backend` (shared System V ABI).
-* `blaise.codegen.target.pas`: `TargetHasNativeBackend` returns `True` for
- `(osFreeBSD, cpuX86_64)` via the registry.
-* *Verify:* `--target freebsd-x86_64` no longer errors "backend not yet
- implemented"; a unit test asserts the emitted ELF header `EI_OSABI` == 9.
-
-=== Step 2 — FreeBSD `TPlatformLayout` adapter
-
-NOTE: Done. `TPlatformLayoutFreeBSDX86_64` in
-`compiler/src/main/pascal/rtl.platform.layout.freebsd.pas`, pinned to FreeBSD
-14.x amd64 (also valid for 13.x — the `ino_t`/`dev_t` widening landed in
-FreeBSD 12 and has been stable since). `struct stat` offsets `st_mode` = 24,
-`st_mtim.tv_sec` = 64, `st_size` = 112, `sizeof` = 224 (all differing from
-Linux); `O_CREAT`/`O_TRUNC`/`O_APPEND` = `$200`/`$400`/`$008` (differing); the
-remaining `S_*`/`SEEK_*`/`CLOCK_REALTIME`/`WNOHANG` share Linux's values. The
-unit is a standalone sibling of `rtl.platform.layout.linux` — nothing in the
-default Linux build graph `uses` it, so it is composed only when the FreeBSD
-RTL is built (Step 5). Test `cp.test.platformlayout.freebsd` asserts every
-constant and validates the `struct stat` accessors by planting sentinels at the
-FreeBSD offsets (catching an offset typo on the Linux host, ahead of the
-emulation lane).
-
-* Add `TPlatformLayoutFreeBSDX86_64`: the FreeBSD `struct stat` field offsets
- (note FreeBSD 12+ widened `ino_t`/`dev_t`; pin to a target major version),
- and the FreeBSD `O_*` / `S_IFDIR` / `CLOCK_REALTIME` /
- `WNOHANG` / `SEEK_*` constant values. (`struct tm` is not abstracted — its
- used fields share an identical layout on Linux/FreeBSD amd64.)
-* *Verify:* a FreeBSD `fstat`-based `FileExists`/`FileAge`/`DirectoryExists`
- returns correct results under emulation (Step 8) — static checks cannot
- catch a wrong struct offset.
-
-=== Step 3 — Freestanding `_start` entry stub
-
-NOTE: Done. `runtime.start.static.freebsd.pas` (the FreeBSD sibling of
-`runtime.start.static.linux`) provides `_start`: it captures `%rsp`, aligns the
-stack, calls the Pascal `_BlaiseStartC` which parses `argc`/`argv`/`envp`,
-captures `environ`, calls `main`, and exits via the FreeBSD `exit` syscall. The
-minimum syscall primitives it needs (`_exit`, `write`, the `environ` global) are
-in `runtime.syscall.freebsd.pas` (`SYS_exit` = 1, `SYS_write` = 4); the rest of
-the leaf grows there in Step 4. Step 3 deliberately omits TLS setup — a trivial
-program performs no threadvar access — so the auxv `PT_TLS` walk (whose FreeBSD
-`AT_*` tags differ from Linux) arrives with the threads work in Step 4, exactly
-as it did on Linux. Test `TLinkerE2ETests.TestLink_FreeBSDStart_StaticExecShape`
-links the `_start` fixture with the FreeBSD target and asserts the static
-`ET_EXEC` shape: `e_type` = ET_EXEC, entry == `_start`, no `PT_INTERP`.
-
-* The FreeBSD kernel-stub object provides `_start` (not `__libc_start_main`):
- read `argc` at `[%rsp]`, `argv` at `[%rsp+8]`, align the stack, call
- `_SetArgs`, run the body, then `exit` via syscall. The linker's static
- `ET_EXEC` / `_start` path (Phase B) already supports this — no GOT/PLT, no
- interp, no CRT.
-* *Verify:* `freebsd-x86_64` link produces an `ET_EXEC` with entry `_start`
- and no `PT_INTERP`; linker unit test asserts the ELF shape.
-
-=== Step 4 — FreeBSD syscall leaf (the libc-replacement work)
-
-NOTE: Done (4a/4b/4c). 4a: the file/process leaves grew in
-`runtime.syscall.freebsd` with the FreeBSD ino64 syscall numbers and the
-carry-flag -> -errno translation. 4b: `getrandom` + an `mremap`-failure stub
-(the allocator already falls back to alloc-copy-free), and
-`runtime.libc2.freebsd` (atexit/exit/abort/date-math/mkstemp/system) — with
-`memcpy/memset/memcmp/strlen` and the x86-64 `jmp_buf` reused unchanged as
-target-invariant. 4c: `thr_new`/`_umtx_op`/`thr_exit`/`sysarch` leaves, the
-FreeBSD `%fs`-base TLS setup in `runtime.start.static.freebsd`, and the new
-`runtime.thread.static.freebsd` (pthread_* on thr_new + _umtx_op). All units
-are standalone (nothing in the Linux build graph uses them), so the Linux
-self-host is untouched; verified via the four fixpoints, the full suite, and the
-`cp.test.linker` FreeBSD fixtures. End-to-end execution under emulation is
-Step 8.
-
-* Provide a FreeBSD syscall trampoline as inline-assembly Pascal stubs (the RTL
- is now pure Pascal with `asm … end` bodies — there are no `.s` files; this
- mirrors the Linux direct-syscall leaf `runtime.syscall.linux.pas` already
- shipped under `--static`): number in `%rax`, args in
- `rdi/rsi/rdx/r10/r8/r9`, `syscall`, then branch on the *carry flag* to
- translate FreeBSD's CF-error convention into the errno-style negative return
- the existing Pascal call sites (`if Fd < 0 ...`) expect.
-* Add a FreeBSD syscall-number table (e.g. open=5, read=3, write=4, close=6,
- exit=1, plus `fstat`/`lseek`/`mmap`/`munmap`/… — FreeBSD numbers, *not*
- Linux's).
-* Implement the syscall-stub leaves (exporting `open`/`read`/`write`/… as raw
- syscalls) against the trampoline, then the harder leaves per the work
- breakdown above (`memcpy/memset/memcmp` freestanding; pure-Pascal
- `localtime_r/gmtime_r/timegm`; `mmap`-based allocator with a no-`mremap` grow
- fallback; `thr_new`/`_umtx_op` threads last; verify the FreeBSD `jmp_buf` for
- setjmp/longjmp; an `atexit` registry).
-* *Verify:* a FreeBSD hello-world + file-I/O smoke test produce correct output
- under emulation.
-
-=== Step 5 — Per-target RTL
-
-NOTE: Done. `BuildRTLUnitList(AStatic, AOS)` (`blaise.codegen.driver`) is the
-pure, unit-tested selection helper `EnsureRTLObjects` drives off `AOpts.Static`
-and `AOpts.Target.OS`. The platform-layout adapter follows the target
-(`rtl.platform.layout.`); a `--static` link swaps in the freestanding per-OS
-kernel leaf (`runtime.start.static.`, `runtime.syscall.`,
-`runtime.libc.`, `runtime.libc2.`, `runtime.thread.static.`) plus the
-OS-invariant `runtime.cstub`, replacing libc. FreeBSD selects its full adapter
-set with no Linux/libc RTL unit present. Tests:
-`TBackendDriverContractTests.TestRTLUnits_*` in `cp.test.driver`. The Linux link
-path is behaviourally unchanged (verified: `--static` Linux hello-world still
-runs; all four fixpoints + QBE & native TestRunner green).
-
-* The compiler must link a FreeBSD-built RTL (the FreeBSD `TPlatformLayout` and
- kernel-stub) into a `--target freebsd-x86_64` program, not the host RTL.
-* The RTL-unification track (`docs/native-target-architecture.adoc`) has already
- landed its end-state: there is no per-target `.a`. `EnsureRTLObjects`
- compiles the embedded RTL source in-process and links the `.o` files. So this
- step is a *unit-list* change, not an archive change: `EnsureRTLObjects` must
- select the FreeBSD adapter set (`rtl.platform.layout.freebsd` in place of
- `…layout.linux`, plus the FreeBSD kernel-stub / `runtime.start.static.freebsd`
- in place of their Linux counterparts) when the target is `freebsd-x86_64`,
- driven off `AOpts.Target` rather than the hard-coded `RTL_UNITS` list.
-* *Verify:* a `--target freebsd-x86_64` program links the FreeBSD layout +
- syscall-stub and contains no Linux/libc RTL code.
-
-=== Step 6 — Drive target selection through the linker
-
-NOTE: Done. `TargetIsFreestanding(target)` (`blaise.codegen.target`) marks
-FreeBSD as Strategy-B: `LinkViaInternalLinker` sets dynamic mode to `not
-(AOpts.Static or freestanding)` and `EnsureRTLObjects` selects the freestanding
-kernel-leaf unit list the same way, so a `freebsd-x86_64` target links static
-`ET_EXEC` / freestanding `_start` / no `PT_INTERP` / no libc regardless of
-`--static`. The per-target `TPlatformLayout` is injected by the compiler as a
-direct `main` call to `rtl.platform.layout._init`
-(`PlatformLayoutInitSym`), selected from the compile-time `--target`;
-`rtl.platform.posix` no longer `uses` a concrete layout (a weak
-`_BlaisePlatformInit` trampoline in each layout unit is the bootstrap fallback
-for older codegens, and lets both layouts coexist in one link without a
-duplicate symbol). New `runtime.libc.freebsd` supplies the libc-shaped leaf
-(getcwd/getenv/time/waitpid/execvp/sysconf; `sysctl(hw.ncpu)` via
-`SYS___sysctl`). Test:
-`TInternalLinkerE2ETests.TestCompile_FreeBSDTarget_EmitsStaticFreeBSDExe`
-(EI_OSABI=9, ET_EXEC, no PT_INTERP; the binary cannot run on the Linux host).
-
-* `LinkViaInternalLinker` already builds the resolved toolkit's `TLinkTarget`
- (Step 1), but the driver still drives the Linux dynamic-libc link line. For
- the Strategy-B static path, when the target is `freebsd-x86_64` skip dynamic
- mode entirely (static `ET_EXEC`, freestanding `_start`, no interp, no libc
- `NEEDED`).
-* *Verify:* `--target freebsd-x86_64` end-to-end emits a FreeBSD `ET_EXEC` on
- a Linux host with no external tools invoked.
-
-=== Step 7 — `--target` CLI surface
-
-NOTE: Done (satisfied by Steps 1 + 6). `Blaise.pas` already parses `--target
--` into `AOpts.Target` via `ParseTargetName` and defaults to
-`HostTarget()` when omitted. The Step-6 e2e test above is exactly this step's
-verify: `blaise --source hello.pas --target freebsd-x86_64 --output hello`
-produces a FreeBSD/x86_64 ELF.
-
-* Ensure `Blaise.pas` threads `--target freebsd-x86_64` into `AOpts.Target`
- and that defaulting (no `--target`) still resolves to the host.
-* *Verify:* `blaise --source hello.pas --target freebsd-x86_64 --output hello`
- produces a file whose ELF header is FreeBSD/x86_64.
-
-=== Step 8 — Cross-compile verification under emulation
-
-The native fixpoint and e2e suites run host binaries; FreeBSD output cannot
-execute on the Linux CI host. Add a verification lane:
-
-* *Static checks (host):* assert the emitted ELF's `EI_OSABI`, `e_type`,
- entry symbol (`_start`), and absence of `PT_INTERP` via the existing ELF
- reader. These run on every host, including Linux CI, and via the registry
- can cover *every* registered target's codegen/link shape.
-* *Dynamic checks (emulated/native):* run the produced FreeBSD binary under a
- FreeBSD VM or `qemu-user` + a FreeBSD root in CI, executing a hello-world
- and a file-I/O smoke test. This is the only way to catch `struct stat` /
- syscall-number mistakes that static checks miss. On a FreeBSD host the test
- runner self-targets (`HostTarget()` → FreeBSD toolkit) and exercises the
- adapter natively — see the testing section of
- `docs/native-target-architecture.adoc`.
-* *Verify:* CI lane green: FreeBSD hello-world prints `Hello` and exits 0
- under emulation.
-
-== The broader cross-compilation picture (Windows, and Linux-hosted everything)
-
-The user's end goal is "cross-compile from pretty much any platform to
-another target" — Linux → FreeBSD → Windows, all from Linux. FreeBSD is the
-near case because it is ELF + System V ABI. Recording the generalisation
-here so the FreeBSD work is shaped to extend rather than be re-done:
-
-* *Container abstraction.* FreeBSD reuses the ELF writer. Windows needs a
- *PE/COFF* writer and macOS a *Mach-O* writer behind the same `TLinker`
- symbol/relocation core (the linker header already anticipates "a sibling
- writer behind the same TLinker symbol/relocation core"). This is the
- large future item; FreeBSD does not touch it.
-* *ABI abstraction.* Windows x64 uses a *different calling convention*
- (RCX/RDX/R8/R9, shadow space, different callee-saved set). The record
- classifier already has an `osWindows` branch (`rcWin64Agg`), so the seam
- exists, but Windows is materially more backend work than FreeBSD.
-* *Syscall/startup abstraction.* Each OS gets its own entry stub and either
- a syscall leaf (Strategy B) or an import-library leaf (Win32: `kernel32`).
- Building the FreeBSD direct-syscall leaf as a clean, link-time-swapped
- syscall-stub object (Step 4) is the template every later OS follows.
-* *Host independence.* Strategy B's "no host CRT, no host libc" property is
- what makes Linux-hosted cross-compilation tool-free. Every target that
- can be driven by direct syscalls (Linux, FreeBSD) should support it;
- targets that cannot (Windows) fall back to a staged import library /
- sysroot, same as Strategy A.
-
-== Risks and mitigations
-
-[cols="2,1,3",options="header"]
-|===
-| Risk | Likelihood | Mitigation
-
-| FreeBSD `struct stat` layout wrong → silent garbage in file sizes/dates.
-| High.
-| This is the most error-prone item. Pin the layout against FreeBSD's
- `sys/stat.h` for the targeted major version; add an emulated CI test that
- stats a known file and asserts its size — static checks cannot catch this.
-
-| FreeBSD syscall numbers differ from Linux (Strategy B).
-| High (if reused naively).
-| Use a FreeBSD-specific number table; do NOT share Linux's. Error
- reporting is via carry flag, not negative return — the trampoline must
- translate.
-
-| No FreeBSD execution environment in CI → bugs ship untested.
-| Medium.
-| Stand up `qemu-user` + FreeBSD root, or a FreeBSD CI runner, for the
- dynamic lane (Step 8). Without it, only static ELF-shape assertions are
- possible.
-
-| FreeBSD major-version ABI drift (`ino_t`/`dev_t` widening in FreeBSD 12).
-| Medium.
-| Target a specific FreeBSD major (e.g. 13/14) and document it; the struct
- layout is version-pinned.
-
-| Self-hosting on FreeBSD (a FreeBSD-native `blaise`) is a further step.
-| Low for this task.
-| Out of scope here: this design delivers Linux-hosted *cross-compilation* to
- FreeBSD. A self-hosting FreeBSD stage-1 is a later milestone once the
- cross output is proven.
-|===
-
-== Summary
-
-A `freebsd-x86_64` native backend is feasible and the codebase is already
-staged for it: the instruction selector, register allocator, System V ABI
-lowering, ELF relocation core, and OPDF debug sections are all reused
-unchanged. The entire FreeBSD-specific surface is (1) a FreeBSD `TLinkTarget`
-(OSABI, base, page size), (2) a FreeBSD `TPlatformLayout` (`struct stat` layout
-and OS constants), and (3) a FreeBSD kernel-stub object (raw syscalls + `_start`
-entry stub) that the FreeBSD RTL archive links in place of libc.
-
-The chosen kernel-access strategy is *direct syscalls into a static `ET_EXEC`*
-(Strategy B): the linker's static path already supports it, and it is the only
-route that delivers the stated goal — cross-compiling a runnable FreeBSD binary
-from a Linux host with no external tools and nothing staged. Its cost is the
-libc-replacement leaves (threads, allocator, libc string ops, date math),
-which are implemented in that per-target syscall-stub object (a link-time swap,
-not a runtime port), done hardest-last. A conventional libc-linked path
-(Strategy A) is documented only as a fallback shape and is not on this
-implementation path.
-
-Structurally, FreeBSD is *one new adapter family* — composed by an Abstract
-Factory toolkit, resolved from a registry, with zero `{$IFDEF}` and no target
-code scattered across units (see `docs/native-target-architecture.adoc`).
-The same shape generalises: Windows (PE/COFF + Win64 ABI + `kernel32` imports)
-and macOS (Mach-O) become further adapter families behind the same linker core,
-container writer behind a Bridge, and Template-Method backend base.
diff --git a/docs/grammar.ebnf b/docs/grammar.ebnf
index aa033f6..d1a29a1 100644
--- a/docs/grammar.ebnf
+++ b/docs/grammar.ebnf
@@ -269,17 +269,13 @@ IntSubrange
* enum-bounded subranges (TLow..THigh, red..blue) are not a named-type form. *)
RecordDef
- = [ PACKED ] RECORD { VisibilitySection | FieldDecl | MethodDecl | ConstSection } END
+ = [ PACKED ] RECORD { FieldDecl | MethodDecl } END
;
(* Records may declare methods alongside fields. Method bodies are written
- * out-of-line as TRecordName.MethodName, identical to classes. An ordinary
- * record method receives the receiver by pointer (`Self` is a `var` parameter
- * under the hood); the language gives normal value semantics — assignments
- * copy the record. A method declared STATIC (see VisibilitySection /
- * MethodDecl) receives no `Self` and is the record's factory / namespaced
- * function form, called as TRecordName.Method(...). Records may also carry
- * STATIC VAR / STATIC CONST members.
+ * out-of-line as TRecordName.MethodName, identical to classes. The
+ * receiver is passed by pointer (`Self` is a `var` parameter under the hood);
+ * the language gives normal value semantics — assignments copy the record.
* No constructors, destructors, or virtual methods are allowed in records.
*
* `packed` is permitted only in front of `record`. It disables natural
@@ -293,42 +289,11 @@ RecordDef
ClassDef
= CLASS [ LPAREN GenericName { COMMA GenericName } RPAREN ]
- { VisibilitySection | ConstSection | FieldList | MethodDeclList }
+ { ConstSection | FieldList }
+ MethodDeclList
END
;
-(* A class body is a sequence of members in any order, optionally grouped under
- * visibility / storage sections. A VisibilitySection keyword sets the current
- * visibility (and, with STATIC, the current member-association) for every
- * member that follows until the next such keyword. *)
-
-VisibilitySection
- = [ STRICT ] ( PRIVATE | PROTECTED ) [ STATIC ]
- | ( PUBLIC | PUBLISHED ) [ STATIC ]
- | STATIC (* STATIC alone keeps current visibility *)
- ;
-
-(* STATIC as a section qualifier (e.g. `private static`, or a bare `static`
- * continuing the current visibility) makes every field, const, method, and
- * property declared until the next section keyword a type-associated (class-
- * level) member: no implicit Self, a single shared storage slot for vars/
- * consts. STATIC may equally be written as a per-member prefix on a single
- * method or property (see MethodDecl / PropertyDecl). `private static var`
- * and `private static const` are the section forms for static fields and
- * static constants. There is no `class var` / `class function` /
- * `class property` — the word `class` is never a member qualifier in Blaise.
- *
- * Visibility keywords (PRIVATE/PROTECTED/PUBLIC/PUBLISHED), STRICT and STATIC
- * are contextual: outside a class/record body they remain usable as
- * identifiers, except those already reserved elsewhere. STRICT is only a
- * keyword immediately before PRIVATE or PROTECTED at the start of a member
- * section; `strict public`, `strict published` and a bare `strict` are
- * errors. Visibility is ENFORCED: PRIVATE is visible only within the
- * declaring unit; PROTECTED additionally within descendant types; STRICT
- * PRIVATE only within the declaring type's own methods; STRICT PROTECTED
- * within the declaring type and its descendants; PUBLIC/PUBLISHED everywhere.
- * Visibility composes orthogonally with STATIC. *)
-
GenericName
= IDENT [ LESS TypeArgList GREATER ] (* plain name or generic specialisation *)
;
@@ -398,38 +363,21 @@ MethodDeclList
;
MethodDecl
- = [ STATIC ] (* per-member static prefix (no implicit Self) *)
- ( PROCEDURE | FUNCTION | CONSTRUCTOR | DESTRUCTOR ) IDENT
+ = ( PROCEDURE | FUNCTION | CONSTRUCTOR | DESTRUCTOR ) IDENT
[ LESS TypeParamList GREATER ] (* optional generic type params *)
[ LPAREN ParamList RPAREN ]
[ COLON TypeName ] (* return type for functions *)
SEMICOLON
{ MethodDirective SEMICOLON }
- [ ( Block | AsmBlock ) SEMICOLON ] (* body absent for forward, external, or abstract decls *)
+ [ Block SEMICOLON ] (* body absent for forward, external, or abstract decls *)
;
-(* A STATIC method (whether via the per-member prefix here or an enclosing
- * STATIC VisibilitySection) takes no implicit Self. CONSTRUCTOR / DESTRUCTOR
- * may NOT be declared STATIC: Blaise has no type-initialiser construct (no
- * `class constructor`); eager one-time setup belongs in the unit
- * initialization / finalization sections. See language-rationale.adoc. *)
-
MethodDirective
= VIRTUAL
| OVERRIDE
| ExternalDirective
| "overload" (* required on every overload of a same-named proc/func/method *)
- | "nostackframe" (* asm body owns the frame; no compiler prologue/epilogue *)
- | IDENT (* inline, stdcall, cdecl, abstract, reintroduce, assembler, … *)
- ;
-
-(* Inline-assembler body. The lexer captures everything between ASM and the
- * matching END as one opaque token (verbatim GNU/AT&T assembly text); the front
- * end never tokenises the contents. Used for the runtime's startup/setjmp/
- * atomic routines. Requires the native backend. See
- * docs/inline-asm-design.adoc. *)
-AsmBlock
- = ASM (* verbatim assembly text *) END
+ | IDENT (* inline, stdcall, cdecl, abstract, reintroduce, … *)
;
(* Calling-convention directives (cdecl, stdcall, register, pascal, safecall)
@@ -443,13 +391,9 @@ ExternalDirective
= EXTERNAL [ NAME StrLit ]
;
-(* Standalone procedure/function/constructor/destructor — top-level or within a block.
- * A leading STATIC marks an out-of-line static-method implementation
- * (`static function TName.Method ...`); it must agree with the in-class
- * declaration's static-ness and takes no implicit Self. *)
+(* Standalone procedure/function/constructor/destructor — top-level or within a block. *)
StandaloneDecl
- = [ STATIC ]
- ( PROCEDURE | FUNCTION | CONSTRUCTOR | DESTRUCTOR ) IDENT
+ = ( PROCEDURE | FUNCTION | CONSTRUCTOR | DESTRUCTOR ) IDENT
[ DOT IDENT ] (* TTypeName.MethodName — non-generic class impl *)
[ LESS TypeParamList GREATER DOT IDENT ] (* TName.MethodName — generic class impl *)
[ LESS TypeParamList GREATER ] (* function Identity — generic standalone *)
@@ -483,8 +427,7 @@ MethodSignatureList
;
PropertyDecl
- = [ STATIC ] (* per-member static prefix *)
- "property" IDENT
+ = "property" IDENT
[ LBRACKET IDENT COLON TypeName RBRACKET ] (* optional index parameter *)
COLON TypeName
[ "read" IDENT ]
@@ -493,10 +436,6 @@ PropertyDecl
[ "default" SEMICOLON ] (* default array property *)
;
-(* A STATIC property (via the prefix here or an enclosing STATIC section) is
- * sugar over a STATIC getter/setter: it occupies no slot and dispatches with
- * no Self. A static property's accessors must themselves be static. *)
-
(* If the index parameter is present, the property is indexed:
* property Items[Index: Integer]: Pointer read Get write Put;
* Indexed reads emit a getter call with one extra argument (the index).
@@ -738,18 +677,9 @@ QualIdent
ArrayType
= ARRAY LBRACKET ArrayBound DOTDOT ArrayBound
{ COMMA ArrayBound DOTDOT ArrayBound } RBRACKET OF TypeName
- | ARRAY LBRACKET IDENT RBRACKET OF TypeName (* ordinal-indexed *)
+ | ARRAY LBRACKET IDENT RBRACKET OF TypeName (* ordinal/enum-indexed *)
;
-(* The IDENT form names an ORDINAL index type. Two ordinal kinds are admitted:
- * - an enumeration type (array[TColor] of T folds to array[0..N-1] of T,
- * where N is the member count), and
- * - a NAMED integer subrange (type TIdx = lo..hi; array[TIdx] of T folds to
- * array[lo..hi] of T). The subrange supplies only the index range; the
- * values it yields remain ordinary unchecked integers of the subrange's
- * underlying storage type.
- * See language-rationale.adoc "Array index types". *)
-
ArrayBound
= ConstArithExpr
;
@@ -914,7 +844,7 @@ StaticSubscriptAssign
* assignment (SubscriptFieldAssign) or a method call on the element
* (SubscriptMethodCall). Examples:
* a[0].Name := 'x'; a[i].Inner.N := 5;
- * a[0].Bump(); a[i].Items.Add(x);
+ * a[0].Bump; a[i].Items.Add(x);
* a[i].Arr[j] := v; — element write into an array-typed field
* A terminating subscript directly over another subscript (a[i][j] := v, or
* the comma form a[i, j] := v) is a multi-dimensional element write — see
@@ -926,7 +856,7 @@ SubscriptFieldAssign
SubscriptMethodCall
= IDENT LBRACKET Expr RBRACKET { SubscriptSuffix }
- DOT IDENT LPAREN [ ArgList ] RPAREN
+ DOT IDENT [ LPAREN [ ArgList ] RPAREN ]
;
(* A subscript suffix indexes one or more dimensions. The comma form
@@ -1096,7 +1026,7 @@ Factor
| ArrayLiteral
| AddrOf
| NOT Factor (* Boolean or bitwise NOT *)
- | INHERITED IDENT LPAREN [ ArgList ] RPAREN (* inherited function call in expr position; parens mandatory *)
+ | INHERITED IDENT [ LPAREN [ ArgList ] RPAREN ] (* inherited function call in expr position *)
| "Supports" LPAREN Expr COMMA IDENT [ COMMA IDENT ] RPAREN (* compiler intrinsic *)
| IDENT DOT IDENT [ LBRACKET Expr RBRACKET ] (* indexed property read *)
LPAREN [ ArgList ] RPAREN (* constructor/method call *)
diff --git a/docs/inline-asm-design.adoc b/docs/inline-asm-design.adoc
deleted file mode 100644
index 69ca65b..0000000
--- a/docs/inline-asm-design.adoc
+++ /dev/null
@@ -1,266 +0,0 @@
-= Inline Assembler Blocks (`asm … end`)
-:toc: macro
-:toclevels: 3
-
-toc::[]
-
-== Summary
-
-Add an inline-assembler statement form so a routine body may be written in
-assembly:
-
-[source,pascal]
-----
-procedure BlaiseStart; assembler; nostackframe;
-asm
- endbr64
- xorl %ebp, %ebp
- ...
- call __libc_start_main@PLT
-end;
-----
-
-This is the FPC model (`rtl/linux/x86_64/si_c.inc`): assembly lives inside an
-ordinary Pascal routine in a standard `.pas` unit, freely mixed with normal
-Pascal routines in the same unit. Blaise needs no `.inc` include mechanism for
-this — `.inc` is only FPC's textual-splice convenience and is orthogonal to
-inline assembly.
-
-The motivation is the last gcc dependency in the runtime build: the hand-written
-`runtime/src/main/asm/*.s` files (`_start`, setjmp/longjmp, atomics, UTF-8) are
-assembled with `cc -c`. Once those bodies can be expressed as `asm` blocks in
-Pascal units, the whole RTL builds through Blaise's own pipeline with no external
-assembler (the Pascal units already do, since the Makefile uses
-`--assembler internal`).
-
-== Scope
-
-In scope:
-
-* A new statement node `TAsmStmt` carrying the verbatim assembly text of one
- `asm … end` block.
-* Lexer support to capture an `asm` block as raw text (the body is GNU/AT&T
- assembly, not Pascal tokens).
-* Parser support to attach an `asm` body to a routine and to accept the
- `nostackframe` directive.
-* Semantic pass: treat an `asm` body as opaque — no statement analysis, but
- still register the routine's signature/symbol like any other.
-* Both codegen backends:
-** *native* — emit the routine label and the verbatim asm lines into the
- assembly stream; honour `nostackframe` (no compiler-generated prologue/
- epilogue).
-** *QBE* — reject `asm` bodies with a clear diagnostic (QBE has no inline-asm
- escape; the native backend is the inline-asm target and is the default).
-* `.bif` serialisation of `TAsmStmt` so an `asm`-bodied routine in a unit
- interface round-trips through the unit cache.
-* `bif-coverage` registration for the new node.
-
-Out of scope (explicitly):
-
-* Parsing or validating the assembly instructions. The block is opaque text
- handed to the existing internal assembler (or `cc -c`), which already parses
- GNU/AT&T syntax. Blaise does not learn an assembler grammar.
-* Intel syntax, register-name remapping, or FPC's `@result` / typed local
- references inside asm. The block references symbols by their emitted name
- exactly as the hand-written `.s` files do today. (A later iteration may add
- name substitution; it is not required to retire the `.s` files.)
-* Inline asm as an *expression* or mid-statement; only a whole-routine `asm`
- body is supported (matches the RTL's needs and FPC's `assembler;` routines).
-
-== Why opaque-text, not a parsed instruction model
-
-The internal assembler (`blaise.assembler.x86_64.AssembleToObject`) already
-consumes a full GNU/AT&T assembly *text* and produces a relocatable object; the
-native backend already emits its whole output as assembly *text*. An `asm`
-block therefore needs only to reach the backend's text stream verbatim — the
-existing assembler does the real work. Parsing instructions into the AST would
-duplicate the assembler's job, couple the front end to one architecture's
-instruction set, and buy nothing: the bytes still end up as text the assembler
-re-reads.
-
-The block is thus modelled as an *opaque leaf* in the AST — text in, text out,
-inspected by no pass between parser and backend.
-
-== Design patterns applied
-
-The change is small, but two established patterns make the boundaries clean and
-keep the architecture honest. They are called out because the user asked, and
-because naming them pins the intended seams for future maintainers.
-
-=== Strategy (GoF) — already the backend seam, extended not bent
-
-Code generation is already a Strategy: `ICodeGen` is the strategy interface and
-`TCodeGenNative` / `TCodeGenQBE` are concrete strategies selected per `--backend`
-(`blaise.codegen.driver`). An `asm` body is a new *body kind* each strategy
-decides how to handle:
-
-* native translates it (emit verbatim),
-* QBE refuses it (diagnostic).
-
-No new dispatch mechanism is introduced — `TAsmStmt` flows through the same
-`EmitStmt` strategy method every other statement uses. This is the litmus test
-that the feature fits: the only per-backend code is one new `case`/`is`
-arm inside each existing strategy, not a new branch in the pipeline.
-
-=== Hexagonal / Ports-and-Adapters — the assembler is a driven adapter
-
-The compiler core (lexer → parser → AST → semantic) is the *domain*; the
-toolchain it drives out to (internal assembler, `cc`, internal linker) sits
-behind a *port*. `TAsmStmt` carries an opaque payload that the domain never
-interprets; only the *driven adapter* — the assembler behind the port —
-understands it. This is exactly the hexagonal intent: the core stays ignorant
-of x86-64 instruction encoding (a detail of the outside world), and the
-architecture-specific knowledge lives at the adapter edge
-(`blaise.assembler.x86_64`, `blaise.codegen.native.x86_64`).
-
-Concretely, this dictates *where the text may and may not be touched*: the
-front end and semantic pass must treat the block as a black box. Any future
-feature that needs to understand the asm (e.g. `@result` substitution) belongs
-in the architecture adapter, behind the same port — never in the parser or
-semantic pass. Keeping that rule is what stops inline asm from leaking
-x86-64 assumptions into the portable core as more architectures are added.
-
-=== Null Object (GoF) — `nostackframe` as the no-op frame strategy
-
-Frame setup is currently unconditional in `EmitFunctionDef`
-(`pushq %rbp` / `movq %rsp,%rbp` / `subq`). `nostackframe` selects a *null*
-frame strategy: emit no prologue/epilogue, the asm body owns the entire frame.
-Implemented as a guard around the existing prologue/epilogue emission rather
-than a parallel code path, so the two cases cannot drift.
-
-== Detailed design
-
-=== Lexing — capturing the raw block
-
-The tokeniser (`uPasTokeniser.TFpgPasToken`) records `TextStart` (1-based source
-index) and `Len` for every token, and exposes the whole `Source`. This is
-sufficient to slice the verbatim block without a second scanner:
-
-. The lexer recognises `asm` as a keyword token (`tkAsm`).
-. On `tkAsm`, a new lexer entry point `ReadAsmBody` drives the tokeniser
- forward, tracking the source offset, until it reaches the matching `end`
- keyword token. The raw text between the end of the `asm` token and the start
- of the `end` token is returned via `Source` + offsets — comments and
- whitespace preserved, nothing re-tokenised as Pascal.
-. Nesting: assembly has no `asm … end` nesting, so the first `end` keyword
- terminates the block. The one caveat is a `#` line comment or a string in
- the asm that contains the word `end`; the GNU assembler's own tokens are
- line-oriented, so the scan matches `end` only as a standalone keyword token
- at statement position (the tokeniser already classifies it as `fptkKeyword`),
- which an `end` inside a comment is not. This mirrors how the tokeniser
- already distinguishes a keyword from an identifier substring.
-
-Rationale recorded in `language-rationale.adoc`; the `asm` keyword and the
-block production added to `grammar.ebnf`.
-
-=== AST — `TAsmStmt`
-
-[source,pascal]
-----
-TAsmStmt = class(TASTStmt)
-public
- Code: string; { verbatim assembly text of the block }
-end;
-----
-
-A routine with an `asm` body holds, in its `Body.Stmts`, a single `TAsmStmt`
-(the simplest representation that reuses the existing `TBlock`/`Stmts`
-container and the existing body-present/absent logic). `TMethodDecl` gains a
-`NoStackFrame: Boolean` flag for the `nostackframe` directive.
-
-=== Parsing
-
-. Directive loop already accepts `assembler`; add `nostackframe` there, setting
- `TMethodDecl.NoStackFrame`.
-. Body parsing: when the next token is `tkAsm`, call the lexer's raw-capture
- path and wrap the returned text in a `TAsmStmt` inside a fresh `TBlock`,
- instead of `ParseBlock`. `assembler` is advisory in FPC (an `asm` body
- implies it); Blaise keys off the `asm` token, so `assembler;` without an
- `asm` body, or an `asm` body without `assembler;`, both behave sensibly.
-
-=== Semantic analysis
-
-`TAsmStmt` is opaque: `AnalyseStmt` has a no-op arm for it. The routine's
-parameters, return type, calling convention, and emitted symbol name are
-resolved exactly as for any routine, so call sites bind normally. No
-liveness, type, or ARC analysis runs over the block.
-
-=== Codegen — native
-
-In `EmitFunctionDef`:
-
-. Emit `.text`, the `.globl`/label as today.
-. If `NoStackFrame`: skip prologue, frame `subq`, and the epilogue; emit the
- `TAsmStmt.Code` verbatim (the body is responsible for `ret`).
-. Else (an `asm` body that still wants the standard frame): emit the normal
- prologue, then the verbatim asm, then the normal epilogue — supported, but
- the RTL bodies use `nostackframe`.
-
-`EmitStmt` gains a `TAsmStmt` arm that writes the verbatim lines, used when an
-`asm` block appears as the sole body statement.
-
-=== Codegen — QBE
-
-`TAsmStmt` raises a clear "inline asm requires the native backend" codegen
-error. QBE is not the inline-asm target; the native backend is the default and
-the only one that emits assembly text.
-
-=== Unit interface I/O (`.bif`)
-
-`TAsmStmt` gains encode/decode in `uUnitInterfaceIO` (one string field) and a
-`bif-coverage.status` entry, so an `asm`-bodied routine exported by a unit
-round-trips through the unit cache. `NoStackFrame` joins the `TMethodDecl`
-directive flags already serialised (`IsVirtual`, `IsOverride`, …).
-
-== Migration of the `.s` files
-
-Once `asm` blocks land, each `runtime/src/main/asm/*_x86_64.s` body can move
-into an `asm` routine in a `.pas` unit (e.g. `blaise_start.pas`,
-`blaise_cpu.pas`), the Makefile's `$(CC) -c` asm rule and `$(ASM_DIR)` go away,
-and the RTL builds with zero external-assembler invocations. That migration is
-a *follow-up* commit per file, gated on this feature; it is not part of the
-feature commit, so a regression is bisectable to one body at a time.
-
-The `_start` body is the natural first migration and its e2e guards already
-exist (`TInternalAsmE2ETests.TestEntry_*`).
-
-== Testing
-
-Per project policy, both layers:
-
-. *IR/asm unit test* — compile a tiny `asm`-body routine and assert the emitted
- native assembly contains the verbatim instructions and, for `nostackframe`,
- omits the `pushq %rbp` prologue.
-. *E2E (internal assembler + linker)* — a program that calls an `asm` routine
- returning a known value in `%rax`, run end-to-end, asserting stdout/exit.
- This is the only layer that proves the block assembles and executes; it runs
- through `TInternalAsmE2ETests`’ real-compiler harness.
-. *QBE rejection* — assert the QBE backend errors on an `asm` body.
-. *.bif round-trip* — a unit exporting an `asm` routine, imported via the unit
- cache, still links and runs (guards the serialiser).
-. *Fixpoints* — once a `.s` body is migrated, the native fixpoints exercise it
- (the compiler links its own RTL).
-
-== Risks
-
-* *Block-termination scanning* — a mis-scan that swallows past the real `end`
- would corrupt the following declarations. Mitigated by matching `end` only
- as a standalone keyword token and by the parser re-synchronising on the
- routine's trailing `;`. Covered by a test with an `end`-mentioning comment
- inside the block.
-* *Symbol naming* — the asm references callees/globals by their emitted symbol
- name; a mismatch is a link error, caught by the e2e/fixpoint link step.
-* *`nostackframe` misuse* — a body that omits `ret` or corrupts the stack
- crashes at run time; the e2e execution test is the guard.
-
-== Alternatives considered
-
-* *Keep the `.s` files, add a `blaise --assemble file.s` mode (Route A).*
- Smaller, and reaches "no gcc in the RTL build" too, but leaves assembly
- outside the language and keeps a parallel build path. Inline `asm` blocks
- (this design, Route B) fold the assembly into ordinary units, matching FPC and
- removing the `$(ASM_DIR)` special case entirely. Route A remains a valid
- stepping stone but is not pursued.
-* *Parse instructions into a structured AST.* Rejected — duplicates the
- assembler, couples the front end to x86-64, and provides no benefit for the
- text-to-text path (see "Why opaque-text").
diff --git a/docs/language-rationale.adoc b/docs/language-rationale.adoc
index f8be8db..2e4cffc 100644
--- a/docs/language-rationale.adoc
+++ b/docs/language-rationale.adoc
@@ -1154,9 +1154,6 @@ Blaise supports fixed-size, stack-allocated arrays declared as
| `array[TEnum] of T` — enum-type index
| Supported
-| `array[TSubrange] of T` — named integer-subrange index
-| Supported. The subrange (`type TIdx = lo..hi;`) supplies the index range, so `array[TIdx] of T` folds to `array[lo..hi] of T`; the subrange's values remain ordinary unchecked integers of its underlying storage type.
-
| `array[L..H, M..N] of T` — multi-dimensional
| Supported
@@ -2210,19 +2207,11 @@ the parent's method slot, bypassing vtable dispatch (that is the whole
point of `inherited`: reach the specific parent implementation, not
re-dispatch to `Self`). The only difference is what happens to the
result: the statement form stores it into the current method's `Result`
-slot (so `inherited F();` still sets `Result`), while the expression
-form yields the value to the surrounding expression.
-
-Like every other call, an `inherited` call carries mandatory
-parentheses even with no arguments (see _Mandatory parentheses on
-zero-argument calls_): `inherited Create()`, never `inherited Create`.
-`inherited` is not an exception to that rule — it is an ordinary method
-call that happens to target the parent slot, so a bare `inherited
-Method` is rejected at parse time with the same _requires () for a
-call_ diagnostic as any other parenless call.
+slot (so a bare `inherited F;` still sets `Result`), while the
+expression form yields the value to the surrounding expression.
The expression form was added because the statement-only form forced an
-awkward two-step (`inherited F(); X := Result + 1;`) and could not be
+awkward two-step (`inherited F; X := Result + 1;`) and could not be
used inside a larger expression at all. AST: `TInheritedCallExpr`
(the sibling of `TInheritedCallStmt`); both resolve and lower through
the same parent-method lookup and the same static-dispatch call
@@ -3928,9 +3917,6 @@ pattern and explains the removal.
*Decision*: every function, procedure, method, and constructor call requires
parentheses, even when there are no arguments. `Obj.Free()`, `Create()`,
`WriteLn()`, `Foo()` — never `Obj.Free`, `Create`, or `Foo` without `()`.
-This includes `inherited` calls (`inherited Create()`, not `inherited
-Create`) and constructor dispatch through a metaclass variable
-(`C.Create()`, not `C.Create`).
The `@` (address-of) operator is the sole exception: `@Obj.Method` takes a
method reference and does not invoke the method, so no `()` is written.
@@ -3957,14 +3943,6 @@ the lexical level: `Foo()` is always a call, `Foo` is always a read. The
compiler AST becomes simpler — `TMethodCallExpr` for calls with explicit
parentheses, `TFieldAccessExpr` only for field/property reads.
-The rule applies in *statement* position as well as expression position: a
-bare `Foo;`, `Obj.Method;`, or `Obj.Free;` used as a statement is a parse
-error (issue #148). Earlier the statement parser silently accepted the
-bare form — expression position was already enforced, but statement-position
-parameterless calls slipped through and built a paren-less `TProcCall` /
-`TMethodCallStmt`. Both now raise the same "requires () for a call"
-diagnostic the `inherited` and expression-position paths use.
-
=== Alternatives considered
* *Deprecation warning period* — rejected. Blaise is in alpha; there is no
@@ -5231,375 +5209,3 @@ anything that can be read as a designator can be assigned to.
* *Require an intermediate variable (status quo).* Rejected — it is a
gratuitous restriction with no semantic justification; the read side already
supported the full chain, so write-side parity is the consistent choice.
-
-== Inline Assembler — `asm … end` Routine Bodies
-
-=== Decision
-
-A routine body may be written as an inline-assembler block instead of a Pascal
-`begin … end` block:
-
-[source,pascal]
-----
-function GetSelf: Pointer; assembler; nostackframe;
-asm
- movq %rdi, %rax
- ret
-end;
-----
-
-The block content is verbatim GNU/AT&T assembly. The front end (lexer, parser,
-semantic pass) never interprets it — the lexer captures the whole `asm … end`
-as one opaque token, and the native backend emits the text verbatim into the
-assembly stream, where the existing internal (or external) assembler parses it.
-The `nostackframe` directive suppresses the compiler prologue/epilogue so the
-asm body owns the entire frame (it provides its own `ret`). Inline asm requires
-the native backend; the QBE backend rejects it with a diagnostic. `asm`
-routines mix freely with ordinary Pascal routines in a standard `.pas` unit
-(no `.inc` include mechanism is involved).
-
-=== Rationale
-
-The motivation is toolchain independence. The runtime's startup (`_start`),
-`setjmp`/`longjmp`, and atomic primitives are hand-written assembly. Shipping
-them as standalone `.s` files assembled by `cc -c` reintroduces a build-time gcc
-dependency, defeating the internal assembler/linker. Expressing them as `asm`
-bodies in Pascal units folds that assembly into Blaise's own pipeline — the same
-approach FPC takes (`rtl/linux/x86_64/si_c.inc`).
-
-The block is modelled as opaque text rather than a parsed instruction AST: the
-internal assembler already consumes GNU/AT&T text and the native backend already
-emits text, so the block needs only to reach the backend's stream verbatim.
-Parsing instructions into the AST would duplicate the assembler and couple the
-front end to one architecture's instruction set for no benefit. This keeps the
-architecture-specific knowledge at the backend/assembler edge (a ports-and-
-adapters boundary), so the portable core stays ignorant of x86-64 encoding. See
-docs/inline-asm-design.adoc for the full design and the design patterns applied.
-
-=== Alternatives considered
-
-* *A standalone `blaise --assemble file.s -o file.o` mode (Route A).* Reaches
- "no gcc in the RTL build" too and is smaller, but leaves assembly outside the
- language and keeps a parallel build path. Inline `asm` blocks fold the
- assembly into ordinary units, matching FPC and removing the special-case
- build directory. Route A remains a valid stepping stone but was not pursued.
-* *Parse instructions into a structured AST.* Rejected — duplicates the
- assembler, couples the front end to x86-64, and provides nothing for the
- text-to-text path.
-* *Reserve `asm` only contextually (keep it usable as an identifier).* Rejected
- — `asm` is a reserved word in FPC/Delphi and in the grammar; the codebase had
- a single local variable named `Asm` (renamed), and contextual keywording would
- need parser state the lexer does not have.
-
-== Implementation-section Declarations are Unit-private
-
-=== Decision
-
-A type, class, constant, or routine declared in a unit's `implementation`
-section is visible only inside that unit. It is never visible to a unit or
-program that `uses` the declaring unit, even when both sit on the same unit
-path. Only `interface`-section declarations are exported.
-
-Cross-unit visibility otherwise follows the standard Pascal transitive rule:
-a unit A sees a name from unit C when A `uses` B and B's *interface* section
-`uses` C. Implementation-section `uses` of B are private to B.
-
-=== Rationale
-
-This is the long-standing Pascal/Delphi/FPC contract — the `implementation`
-section is a unit's private body. Honouring it keeps a unit's internal helper
-types from becoming an accidental part of its public surface, so an unrelated
-unit cannot come to depend on them and the author stays free to rename or
-remove them.
-
-Mechanically, the compiler interns every unit's symbols into one shared symbol
-table. An implementation-section symbol is tagged unit-private (`IsImplPrivate`)
-at registration; `TSymbolTable.Lookup` suppresses such a symbol whenever the
-unit currently being analysed is not its owner. The flat-table fallback that
-previously returned any globally-interned symbol — and so leaked
-implementation-section declarations into unrelated units — no longer applies to
-unit-private symbols.
-
-A class declared in the implementation section keeps its symbol reachable at
-code generation (its type metadata — typeinfo, vtable, `_FieldCleanup` — is
-emitted under the owning unit's mangling prefix, identical to an
-interface-section class) by establishing the emitted unit as the symbol-table
-viewing context during code generation. Without that, the suppression would
-also hide the class from its own backend and the unit-qualified symbol names at
-the reference and definition sites would disagree.
-
-=== Alternatives considered
-
-* *Keep the flat-table leak (status quo before this change).* Rejected — it
- made every interned declaration, including private implementation-section
- ones, silently visible to every other unit on the path. That is neither the
- Pascal contract nor sound: it let a class declared in one unit's
- implementation section resolve inside an unrelated unit that never used it.
-* *Suppress all cross-unit symbols not reachable through `uses` (interface
- symbols included), enforcing strict Delphi visibility everywhere.* A larger
- correctness improvement, but it surfaces every pre-existing missing-`uses`
- in the tree at once (each its own fix). Deferred; only the
- implementation-section leak — the concrete defect — is closed here.
-* *Give code generation a dedicated per-unit symbol table instead of a viewing
- context.* Heavier plumbing for the same effect; the analyser already owns one
- shared table that carries every unit's symbols, so scoping the *view* to the
- emitted unit is the smaller, sufficient change.
-
-== `static` Class Members — One Keyword, No `class`-Keyword Overload
-
-=== Decision
-
-Type-associated (class-level) members — fields, constants, methods, and
-properties that belong to the type itself rather than to an instance — are
-declared with the `static` keyword:
-
-[source,pascal]
-----
-type
- TRegistry = class
- private static var
- FInstance: TRegistry; { one shared slot, not per-instance }
- private static const
- MaxEntries = 256;
- private
- FItems: TList; { ordinary instance field }
- static function GetInstance: TRegistry; { no Self; type-associated }
- function GetItem(I: Integer): TEntry; { ordinary instance method }
- public
- static property Instance: TRegistry read GetInstance;
- property Items[I: Integer]: TEntry read GetItem;
- end;
-
-static function TRegistry.GetInstance: TRegistry; { out-of-line impl }
-begin
- if FInstance = nil then
- FInstance := TRegistry.Create(); { lazy singleton }
- Result := FInstance;
-end;
-----
-
-`static` may appear in two positions:
-
-* as a *section qualifier* — `private static var`, `public static const`,
- `protected static` — applying to every member declared until the next
- visibility or section keyword; and
-* as a *member prefix* — `static function`, `static procedure`,
- `static property` — applying to that one member.
-
-A `static` member receives no implicit `Self`. A `static var` / `static const`
-occupies a single shared storage slot for the whole type, addressed as a
-global; it does not advance the instance layout and is not copied per object.
-A `static function` / `static procedure` is an ordinary routine that happens to
-be name-qualified by its owning type and may read the type's other `static`
-members. A `static property` is pure sugar over a `static` getter/setter.
-
-Inside a record, a method declared `static` is the record's factory /
-namespaced-function form — it takes no hidden `Self` pointer and is called as
-`RecType.Method(...)`. (An ordinary record method still receives `Self` by
-pointer; see <<_record_methods>>.) Records may also carry `static var` and
-`static const` members.
-
-Blaise has *no* `class` keyword in member position. The word `class` appears
-only where it introduces a reference type (`T = class`), never as a member
-qualifier. There is also no `static constructor` / `static destructor` — see
-_No type-initialiser construct_ below.
-
-=== Rationale
-
-Delphi and FPC overload the single word `class` into three unrelated meanings:
-the reference-type introducer (`T = class`), the member-association qualifier
-(`class var`, `class function`, `class property`), and the type-initialiser
-form (`class constructor`, `class destructor`). The three concepts have nothing
-in common; sharing one keyword forces the reader to disambiguate by position
-every time. Blaise has no existing source to keep compatible, so it splits the
-concerns: `class` keeps only its structural meaning, and `static` carries the
-member-association meaning it already carries in Java, C#, Swift, Rust, Go, and
-Kotlin (`companion`/`static`). One keyword, one meaning.
-
-The member-association concept is genuinely needed: the canonical singleton /
-registry pattern (a private shared instance reached through a type-level
-accessor) cannot be expressed with instance members alone. `static`
-delivers it with a single, universally-understood keyword.
-
-==== No type-initialiser construct (`static`/`class constructor`)
-
-Blaise deliberately omits Delphi's `class constructor` / `class destructor`
-(the run-once-at-startup type initialiser and its teardown counterpart). The
-construct is unnecessary in Blaise because the two jobs it does are already
-covered:
-
-* *Zeroing a `static var`.* Blaise guarantees every variable — including
- globals — holds its zero value before any code runs (see
- <<_zero_initialisation_of_variables>>). A `static var FInstance: TRegistry`
- is therefore `nil` at startup with no initialiser. Delphi needs the type
- constructor here only because it makes no such guarantee.
-
-* *Non-trivial one-time setup or teardown.* A lazy singleton initialises itself
- on first access inside its `static` getter (the `if FInstance = nil` pattern
- above); eager setup or teardown that genuinely must run once belongs in the
- unit's existing `initialization` / `finalization` sections, which live in the
- implementation section where code is permitted and run once in dependency
- order. This is exactly Go's package-level `init()` model.
-
-Re-using the spelling `static constructor Create` was rejected for the same
-reason `class` was: it overloads `constructor` for something that is not a
-callable constructor (it takes no arguments, is never invoked by name, and
-cannot be overloaded). A nameless `static begin … end` initialiser block (the
-Java/Kotlin shape) was also rejected: Pascal forbids code in the interface
-section, where the class declaration lives, so an inline initialiser block
-there would be alien to the language. The unit `initialization` section is the
-idiomatic Pascal home and needs no new syntax.
-
-=== Cross-language comparison
-
-[cols="1,1,1,1,2", options="header"]
-|===
-| Language | Static field | Static method | Static property | Type initialiser
-
-| *Blaise*
-| `static var`
-| `static function`
-| `static property`
-| none — zero-init + unit `initialization`
-
-| Java
-| `static`
-| `static`
-| (getter)
-| `static { }` block (lazy)
-
-| C#
-| `static`
-| `static`
-| `static P { }`
-| `static TFoo()` static constructor (lazy)
-
-| Swift
-| `static let/var`
-| `static func`
-| `static var { }`
-| none — `static let` lazily initialised per-field
-
-| Rust
-| `static` / assoc `const`
-| assoc `fn` (no `self`)
-| (none)
-| none — `static` is const-expr; lazy is library-level
-
-| Go
-| package `var`
-| package func
-| (none)
-| `func init()` (package, once at startup)
-
-| Kotlin
-| `companion object`
-| companion `fun`
-| companion `val/var`
-| companion `init { }`
-
-| Delphi / FPC / Oxygene
-| `class var`
-| `class function`
-| `class property`
-| `class constructor` (lazy)
-|===
-
-The languages divide on the type-initialiser question. Java, C#, Kotlin, and
-the Delphi family provide an explicit type-constructor block because a static
-field can be left null/indeterminate and the programmer must run code to
-populate it. Swift, Rust, and Go barely need one — either every static is
-zero/const-initialised by the language, or lazy init is a per-field runtime
-feature. Blaise sits with the second group precisely because of its zero-init
-guarantee, so it follows Swift/Rust/Go and omits the type-constructor entirely
-rather than following the Java/C#/Delphi machinery.
-
-=== Visibility
-
-`static` is orthogonal to visibility. It composes with `private`,
-`protected`, and `public` (and, once visibility enforcement lands, with
-`strict private`). `static` governs *storage and dispatch* — where the slot
-lives and whether `Self` is passed — not *who may see the member*. The two
-are independent axes and are implemented as independent features (see
-<<_member_visibility_enforcement_private_protected_strict>>).
-
-=== Alternatives rejected
-
-* *Keep Delphi's `class var` / `class function` / `class property`.* Rejected.
- It preserves the `class`-keyword overload that is the whole confusion this
- decision removes, for no compatibility benefit Blaise can collect.
-* *Infer static-ness of a record method from whether its body touches `Self`.*
- Rejected. The hidden-`Self` ABI would then flip silently when an edit adds or
- removes a `Self` reference. `static` makes the calling convention explicit at
- the declaration. (See <<_record_methods>>.)
-* *Adopt a `static constructor` or `static begin … end` type initialiser.*
- Rejected — see _No type-initialiser construct_ above.
-
-== Member Visibility Enforcement — `private` / `protected` / `strict`
-
-=== Status
-
-_Decided; implemented as the second half of the static-members work. This entry
-records the decision; the spelling and enforcement rules below are the
-committed design._
-
-=== Decision
-
-Visibility modifiers on class and record members are *enforced*, not merely
-parsed. A member declared `private` is visible only within the unit that
-declares the owning type; a `protected` member is additionally visible within
-descendant types; a `public` (or `published`) member is visible everywhere the
-type is. Blaise additionally supports `strict private` and `strict protected`,
-which narrow visibility to the declaring *type* itself (and, for
-`strict protected`, its descendants) rather than the whole declaring unit.
-
-`strict` composes with `static`: `strict private static var FInstance: TFoo;`
-is permitted, exactly as in Delphi. The `strict`-ness (who may see the member)
-is independent of the `static`-ness (where the slot lives and whether `Self`
-is passed).
-
-A non-`strict` `private` member remains visible to the unit's
-`initialization` / `finalization` sections and to other code in the same unit,
-because those sections are part of the declaring unit. A `strict private`
-member is *not* visible to them — it is reachable only from the methods of the
-declaring type. This is the one interaction point between visibility and the
-static-members feature: a `static var` that the unit `initialization` section
-must populate eagerly must therefore not be `strict private`.
-
-=== Rationale
-
-Before this change, Blaise parsed `private` / `protected` / `published` but
-enforced none of them, and had no `strict` keyword at all. `private` was
-effectively a comment. Enforcing visibility closes a real gap — a unit's
-internal class members were silently part of its usable surface — and makes the
-`static` singleton pattern honest: a `private static var FInstance` can now be
-genuinely unreachable from outside while the `public static property Instance`
-is the sole entry point.
-
-`strict` is included because the unit-scoped `private` of classic Pascal is
-looser than most programmers coming from Java, C#, Swift, or Rust expect; those
-languages scope `private` to the *type*. Offering both the Pascal unit-scoped
-`private` and the type-scoped `strict private` lets the author choose, matching
-Delphi and FPC.
-
-=== Implementation order
-
-Visibility enforcement lands *after* the `static`-members feature, as a
-separate commit. Static members are on the critical path (they unblock real
-code and exercise the codegen/OPDF stack); visibility enforcement is a pure
-rejection pass with no codegen impact, and is cleaner to write once against the
-complete, final set of member kinds (instance and static fields, methods, and
-properties) than to write first and revisit when `static` arrives.
-
-=== Alternatives rejected
-
-* *Leave visibility unenforced (status quo).* Rejected — `private` that
- protects nothing is a latent footgun and undermines the `static` singleton
- pattern's encapsulation.
-* *Enforce only the unit-scoped `private` (no `strict`).* Rejected — the
- type-scoped `strict private` is the form most non-Pascal programmers expect,
- and omitting it would force every genuinely type-private member to leak to
- the whole unit.
-* *Bundle visibility enforcement into the static-members commit.* Rejected —
- the two are independent axes; sequencing them keeps each commit focused and
- lets the codegen-touching feature accumulate field exposure first.
diff --git a/docs/native-target-architecture.adoc b/docs/native-target-architecture.adoc
deleted file mode 100644
index 28822a8..0000000
--- a/docs/native-target-architecture.adoc
+++ /dev/null
@@ -1,515 +0,0 @@
-= Native Multi-Target Architecture — Ports, Adapters, and Target Toolkits
-:author: Graeme Geldenhuys
-:revdate: 2026-06-24
-:toc: left
-:toclevels: 3
-:source-highlighter: rouge
-:icons: font
-:sectanchors:
-:sectnums:
-
-== Purpose
-
-Blaise's native backend must grow from one target (`linux-x86_64`) to many
-(`freebsd-x86_64` next, then Windows/macOS, then arm64). This document
-defines the *structural* approach for that growth so that target divergence
-is expressed through object selection at run time, never through `{$IFDEF}`
-directives or `include`-file substitution.
-
-The explicit non-goal is the FPC model, where the target is frozen at compile
-time and platform code is woven through every unit with conditional
-compilation. That model is hard to read, hard to test (you can only test the
-target you built for), and couples every unit to every platform. Blaise
-already rejects it: `runtime/src/main/pascal/rtl.platform.pas` states "No
-`{$IFDEF}` directives appear anywhere in this unit or its concrete
-implementations." This document generalises that principle across the whole
-native toolchain.
-
-== What already exists
-
-Blaise has *already* adopted the hexagonal (ports-and-adapters) pattern in two
-places. The work in this document finishes and unifies that start; it does
-not introduce a foreign idea.
-
-[cols="2,2,2,3",options="header"]
-|===
-| Layer | Port (abstract) | Adapter (concrete) | Source
-
-| Runtime OS surface
-| `TRtlPlatform`
-| `TRtlPlatformPosix`
-| `runtime/.../rtl.platform.pas` + `rtl.platform.posix.pas`
-
-| Code generation
-| `TNativeBackend`
-| `TX86_64Backend`
-| `compiler/.../blaise.codegen.native.backend.pas` + `...native.x86_64.pas`
-
-| Link target facts
-| `TLinkTarget`
-| `LinuxX86_64Target()`
-| `compiler/.../blaise.linker.elf.pas`
-|===
-
-`TNativeBackend` already applies *Template Method* deliberately: its header
-records that the ARC field-kind walk and the record-return classifier
-(`ClassifyRecordReturn`) are target-independent and live in the base, while
-"only the leaf emission (which register holds the base, which mnemonic
-loads/stores it) is CPU-specific," with a plan to "lift those walkers here as
-template methods whose leaf steps are abstract per-CPU primitives." That is
-exactly the right instinct; this document names it and extends it.
-
-== What is leaky today
-
-Two gaps make the current seams insufficient for a second target:
-
-. *`TRtlPlatformPosix` hides a Linux dependency.* It collapses Linux and
- FreeBSD into one adapter, but its `TStatBuf` / `TTm` record layouts and its
- `O_CREAT` / `O_TRUNC` / `WNOHANG` / `CLOCK_REALTIME` / `S_IFDIR` constants
- are hard-coded *Linux* values. A FreeBSD build reusing this adapter would
- read garbage at the wrong struct offsets. This is the `include`-file
- problem wearing a class's clothing.
-
-. *There is no port for the kernel leaf.* Today the runtime reaches the
- kernel through `external name 'open'` libc bindings — the "syscall leaf" is
- implicit in libc. Strategy B (direct syscalls, no libc — see
- `freebsd-x86_64-backend-design.adoc`) needs that leaf to become an explicit,
- swappable port.
-
-== The architecture
-
-=== Ports (Hexagonal / Dependency-Inversion)
-
-A *port* is an abstract base class plus a global instance pointer selected at
-startup. Callers depend on the port, never on a concrete target.
-
-[cols="2,4",options="header"]
-|===
-| Port | Responsibility
-
-| `TRtlPlatform` (exists)
-| High-level OS operations (file/dir/process/time/console). Unchanged.
-
-| Kernel leaf (NOT a runtime port — see below)
-| The *syscall + startup leaf*: `open/read/write/close/mmap/exit/…` and the
- `_start` entry stub. This is a *link-time symbol swap*, not a runtime
- virtual port: each target's RTL archive resolves the same `external name`
- symbols differently. See <> for the rationale and the design
- that was tried and rejected.
-
-| `TPlatformLayout` (new)
-| The target's *struct layouts and OS constants*: `struct stat` field
- offsets, `struct tm` layout, `O_*` flag bits, signal numbers, `SEEK_*`,
- `CLOCK_*`. This is where the Linux constants leaking into
- `TRtlPlatformPosix` go to live properly, per target. Implemented in Step 0b.
-|===
-
-[#kernel-leaf]
-[NOTE]
-.The kernel leaf is a link-time swap, not a runtime port
-====
-An earlier revision of this design specified a runtime `TKernelABI` virtual
-class (≈30 abstract methods) with a `GKernel` global, through which every
-`TRtlPlatformPosix` kernel call was routed; the Linux adapter forwarded each
-method to the existing libc binding, and a FreeBSD adapter would later issue
-raw syscalls.
-
-*That approach was implemented and reverted (2026-06-25).* Introducing the
-class and the third managed RTL global into `rtl.platform`/`rtl.platform.posix`
-— the most layout-sensitive units in the self-hosting RTL — destabilised the
-bootstrap. Binaries built against the modified RTL segfaulted at startup with
-a corrupted/overflowed stack that no debugger (gdb or pdr) could unwind. The
-failure was bootstrap-stage-dependent and non-converging: the release binary
-built a *working* hello-world from the modified RTL source, but the
-release-built stage-1 emitted a *crashing* one, and stage-2 was worse. The
-precise cause was not isolated (candidates: a `TimeNow` method-name collision
-with `TRtlPlatform.TimeNow` in the vtable, the compiler baking layout for a new
-managed global, or the large abstract vtable), but the verdict is independent
-of the cause: *the abstraction carried real self-hosting risk for zero present
-benefit* — the Linux adapter was pure libc delegation, so nothing functional
-changed until a FreeBSD syscall adapter existed.
-
-The replacement design is a *link-time symbol swap*, the pattern Blaise already
-uses for `blaise_setjmp_x86_64.s` and `blaise_atomic_x86_64.s`:
-
-* The RTL keeps its `external name 'open'` / `'read'` / `'write'` / … bindings
- exactly as today.
-* On Linux (and any libc-linked build), those symbols resolve to libc.
-* For FreeBSD Strategy B, the FreeBSD RTL archive instead links a small
- syscall-stub object that *exports the same symbol names* (`open`, `read`,
- …) implemented as raw `syscall` instructions with the FreeBSD numbers and
- carry-flag error translation, plus a `_start`.
-* The kernel leaf therefore varies by *which object the per-target archive
- composes* — selected at link time by the toolkit/RTL-archive choice — with
- *no new runtime virtual dispatch, no new global, and no change to the
- layout-sensitive RTL units*.
-
-Why this is better here: the kernel mechanism is genuinely a build-time
-property of a target (a binary is libc-linked *or* freestanding; it never
-switches at run time), so a link-time swap models it exactly, while a runtime
-port adds vtable/global surface to the RTL for a choice that is never made at
-run time. `TPlatformLayout` stays a runtime object because its values
-(struct offsets, flag bits) are read by shared method bodies and genuinely
-differ per target instance; the kernel leaf does not need that — it needs a
-different *symbol implementation*, which the linker already selects.
-
-`TPlatformLayout` and the kernel leaf still vary on *different axes* (a future
-`freebsd-arm64` may reuse FreeBSD syscall numbers but need different struct
-packing), so they remain separate concerns; they are simply realised by
-*different mechanisms* — a runtime object for layout, a link-time symbol set
-for the kernel leaf.
-====
-
-Compiler-side ports (already present, kept as ports):
-
-* `TNativeBackend` — instruction selection / ABI lowering / asm printing.
-* `TLinkTarget` + the linker's container writer — ELF today (PE/Mach-O later).
-
-=== Which runtime units change, and which do not
-
-The runtime binds libc / syscalls across *eight* units today
-(`rtl.platform.posix.pas`, `blaise_arc.pas`, `blaise_exc.pas`,
-`blaise_mem.pas`, `blaise_thread.pas`, `blaise_weak.pas`, `blaise_float.pas`,
-`blaise_str.pas`, plus `streams.pas` in stdlib). It is tempting to conclude
-that all of them must be "made hexagonal." They must not. Refactoring each
-unit into its own platform abstraction would produce eight mini-hexagons and
-*recreate* the scattered-target-code problem this architecture exists to
-avoid.
-
-The governing distinction is *not* "does this unit call libc" but *"does this
-call vary by target"*:
-
-[cols="3,2,3",options="header"]
-|===
-| Bound symbol(s) | Varies by OS? | Action
-
-| `open/read/write/close/lseek/fstat/stat/mkdir/unlink/rename/getcwd/chdir/
- getenv/exit/nanosleep/pipe/dup2/fork/execvp/waitpid`
-| *Yes* — different syscall numbers; FreeBSD reports errors via the carry
- flag, not a negative return.
-| Link-time symbol swap: the FreeBSD archive links a syscall-stub object
- exporting these names; the RTL's `external name` bindings are unchanged
- (see <>).
-
-| `mmap/munmap/mremap` (`blaise_mem.pas`)
-| *Yes* — and FreeBSD has no `mremap`.
-| Link-time symbol swap (memory leaf, with a grow-path fallback for the
- missing `mremap`).
-
-| `pthread_create/join/mutex_*` (`blaise_thread.pas`, and the mutexes used by
- `blaise_exc.pas`/`blaise_weak.pas`)
-| *Yes* — no pthreads without libc; FreeBSD uses `thr_new`/`_umtx_op`.
-| Link-time symbol swap (threads leaf — the hardest, done last).
-
-| `localtime_r/gmtime_r/timegm` (`rtl.platform.posix.pas`)
-| *Yes* — libc-dependent, no syscall equivalent.
-| Replace with a *target-independent* pure-Pascal calendar/timezone unit
- (no port needed — same code everywhere).
-
-| `memcpy/memset/memcmp`
-| *No* — pure computation, never touches the kernel.
-| Provide ONE freestanding implementation (CPU-keyed `.s`/Pascal primitive,
- like the existing atomic stubs). *Not* a `TKernelABI` method — this is a
- "no libc is present" concern, not a "target differs" concern.
-
-| `_AtomicAddInt32`/`_AtomicSubInt32` (`blaise_atomic_x86_64.s`),
- `_blaise_longjmp` (`blaise_setjmp_x86_64.s`)
-| *No* — same x86_64 instruction sequence on every OS.
-| Leave as-is (CPU-keyed assembly, already correctly isolated). For FreeBSD,
- only *verify* the `jmp_buf`/stack layout used by setjmp/longjmp.
-
-| `_IntToStr`/`_DoubleToStr`/string helpers (`blaise_str.pas`,
- `blaise_float.pas`)
-| *No* — pure computation over Blaise string headers.
-| Leave as-is.
-|===
-
-So the refactor is *narrow and link-time*, not unit-by-unit:
-
-. *No RTL unit changes shape for the kernel leaf* — `rtl.platform.posix.pas`
- keeps its `external name 'open'` bindings verbatim. The FreeBSD difference is
- *which object resolves those symbols* (libc vs a raw-syscall stub), chosen
- when the per-target RTL archive is composed — not a code change in the unit.
-. *Units keep all their logic* — `blaise_mem`, `blaise_thread`, `blaise_exc`,
- `blaise_weak` are untouched; their `mmap`/`pthread_*` `external name`
- bindings are satisfied by the target's chosen kernel-stub object. The units
- are *not* re-architected.
-. *Most units are left alone* — pure-computation and CPU-keyed-asm units
- (`blaise_str`, `blaise_float`, the atomic/setjmp stubs) need nothing.
- `localtime_r`/etc. become one target-independent Pascal unit.
-
-The principle: *the kernel-varying leaves are satisfied by one per-target
-symbol set chosen at link time; everything that does not vary by target stays
-where it is.* That single stub object is the one place "what does FreeBSD do
-differently at the syscall level" lives. Routing these through a runtime
-virtual port instead was tried and reverted (<>): it added
-vtable/global surface to the layout-sensitive RTL for a choice that is never
-made at run time. Forcing target-invariant code (memcpy, string formatting,
-atomics) through any indirection would likewise be abstraction for its own sake
-— the over-engineering this design rejects.
-
-The migration sequence below exploits this: Step 0c introduces the kernel leaf
-with a Linux adapter that *still delegates to the existing libc bindings*, so
-every caller is repointed at the port with *zero behaviour change* (verified
-against the current Linux suite) before a single syscall is rewritten. No unit
-is touched twice.
-
-=== Abstract Factory — the Target Toolkit
-
-The single most important new type. A `TTargetToolkit` takes a `TTargetDesc`
-and produces the *consistent family* of adapters for that target:
-
-[source,pascal]
-----
-type
- TTargetToolkit = class
- public
- function Name: string; virtual; abstract; { "linux-x86_64" }
- function MakeBackend: TNativeBackend; virtual; abstract;
- function MakeLinkTarget: TLinkTarget; virtual; abstract;
- end;
-----
-
-The compiler-side toolkit (Step 0a, as built) makes the backend and the link
-target. It does *not* have a `MakeKernelABI` — the kernel leaf is a link-time
-symbol set in the per-target RTL archive, not a runtime object the compiler
-constructs (<>). `TPlatformLayout` is also not made here: it is a
-runtime RTL object selected at the produced binary's startup, in that binary's
-own RTL archive, not in the compiler. (The method is named `Name`, not
-`TargetName`, to avoid colliding with the unit-level `TargetName` free
-function.)
-
-Why Abstract Factory and not free functions: the produced objects must be
-*coherent as a set*. A FreeBSD backend paired with a Linux link target is a
-silent bug. A factory guarantees the family is internally consistent — this is
-the textbook
-Abstract Factory motivation (families of related products that must be used
-together).
-
-Concrete factories: `TLinuxX86_64Toolkit`, `TFreeBSDX86_64Toolkit`.
-
-=== Registry — name → toolkit
-
-A `TTargetRegistry` maps a canonical name (`"freebsd-x86_64"`) to its
-`TTargetToolkit`. Adding a target is *one registration call plus the new
-adapter files* — no existing `case` statement is edited, satisfying the
-Open/Closed Principle.
-
-[source,pascal]
-----
-TargetRegistry.Register('linux-x86_64', TLinuxX86_64Toolkit.Create);
-TargetRegistry.Register('freebsd-x86_64', TFreeBSDX86_64Toolkit.Create);
-
-{ --target resolution, and the test harness, both go through this: }
-Toolkit := TargetRegistry.Resolve(ParseTargetName(Opts.Target));
-----
-
-This replaces the current `TargetHasNativeBackend` / `LinuxX86_64Target()`
-hard-wiring with a lookup that the CLI *and* the test runner share.
-
-=== Pattern summary
-
-[cols="2,3,3",options="header"]
-|===
-| GoF pattern | Applied to | Why it earns its place
-
-| Strategy
-| `TNativeBackend`, `TRtlPlatform`, `TPlatformLayout`
-| Interchangeable target behaviour chosen at run time. Already in use
- (`TProfilerStrategy`, `TNativeBackend`). Note the kernel leaf is *not* a
- Strategy object — it is a link-time symbol swap (<>).
-
-| Abstract Factory
-| `TTargetToolkit`
-| Produces a *consistent family* of target adapters; prevents
- mismatched-target bugs.
-
-| Template Method
-| `TNativeBackend` base (ARC walk, record classifier)
-| Shared algorithm, target-specific leaves. Already started in the backend
- base class; lift the ARC walkers here as planned.
-
-| Bridge
-| Linker symbol/reloc core × container writer (ELF/PE/Mach-O)
-| Decouples the OS-agnostic relocation core from the container format so the
- `(container × CPU × OS)` axes vary independently instead of multiplying into
- an `N×M×K` subclass explosion. The linker header already anticipates "a
- sibling writer behind the same TLinker symbol/relocation core."
-
-| Registry / Service Locator
-| `TTargetRegistry`
-| Resolve a toolkit by name without a central dispatch every new target must
- edit.
-|===
-
-== Runtime end-state: one binary, embedded RTL source, no external archives
-
-Today the runtime is a separate PasBuild module whose Makefile compiles the RTL
-units and `ar`-archives them into `blaise_rtl.a`, which `make install` copies
-beside the compiler; the internal linker then pulls members from that archive
-(`AddArchive`). The archive is a *cache/convenience*, not a necessity — the
-compiler already compiles `.pas` units to objects in-process (`AssembleToObject`),
-links them in-process (`TLinker.AddOwnedObject`), and resolves units from source
-via `TUnitLoader`.
-
-The chosen end-state (gated on finishing the `.s`→inline-asm migration, after
-which the RTL is pure Pascal): *`blaise` embeds the RTL Pascal source once and
-compiles it per target on demand*.
-
-* The single `blaise` binary carries the RTL source as embedded data. The RTL
- is overwhelmingly target-*invariant* (ARC, strings, the memory-manager logic,
- exceptions); only the leaves vary (`TPlatformLayout` values, the kernel-stub
- `_start`/syscall unit, the `TLinkTarget`).
-* For `--target X`, the compiler compiles that embedded RTL source *for X* —
- codegen already takes a `TTargetDesc`; the toolkit/registry already selects
- the per-target `TPlatformLayout` adapter, kernel-stub unit, and link target —
- and links the resulting objects in-process.
-* Result: a single `blaise` binary, with *nothing* beside it, cross-compiles to
- any registered target. There is no `blaise_rtl.a` on disk, no `ar`, no
- `make install`, and no per-target `.a` files: the per-target RTL is *produced
- on demand* from one embedded source plus a small per-target adapter set. This
- is "multiple target runtimes in one binary" realised as *one embedded source +
- N adapter sets*, not N copies of a runtime.
-
-This also collapses the bootstrap to a single `pasbuild compile -m
-blaise-compiler` (the `runtime` module folds into the compiler; `stdlib` stays
-separate as it is opt-in, not always-linked).
-
-*Performance note.* Compiling the RTL source on every program build is the cost
-to evaluate first. If it proves noticeably slower than the archive model, an
-in-memory / `--unit-cache`-backed object cache (compile the RTL once per process
-or persist the objects) recovers the speed without reintroducing an on-disk
-archive. We adopt the simple compile-per-target model first and measure before
-adding the cache.
-
-== Two selection moments (a subtlety, not a contradiction)
-
-The same ports-and-adapters pattern applies in two binaries with *different*
-selection timing. Being explicit about this avoids accidentally linking every
-target's runtime into every produced binary.
-
-[cols="2,4",options="header"]
-|===
-| Binary | Selection moment & rule
-
-| The *compiler* (`blaise`)
-| Holds *all registered* compiler-side toolkits at once (`TNativeBackend`,
- `TLinkTarget`, container writers), so one `blaise` can cross-compile to any
- target. Selection is per-invocation: `--target` (default `HostTarget()`)
- resolves one toolkit from the registry.
-
-| A *produced* binary (e.g. a FreeBSD app)
-| Must contain *only its own* target's RTL: the `TRtlPlatform`/`TPlatformLayout`
- objects and the kernel-leaf (`_start`/syscalls) for that target. In the
- end-state (above) the compiler produces those objects on demand by compiling
- the embedded RTL source for the target with that target's adapter set, then
- links them in-process — so the produced binary contains exactly one target's
- RTL with no run-time multi-target dispatch and no bloat. (Transitional
- mechanism today: a pre-built `blaise_rtl.a` linked via `AddArchive`; the
- end-state replaces it with in-process per-target compilation.)
-|===
-
-So: the compiler chooses a target *to emit for*; the produced binary chooses a
-platform *to run on*. Both use the registry/factory; the produced binary's RTL
-is fixed by which target it was compiled for — there is no run-time
-multi-target dispatch inside an application binary, and therefore no bloat.
-
-== Testing — the payoff of run-time selection
-
-Because a toolkit is resolved from a `TTargetDesc` rather than frozen by
-`{$IFDEF}`, the test runner gains two modes the FPC model cannot offer:
-
-. *Native self-target.* On a FreeBSD host, `HostTarget()` resolves the
- FreeBSD toolkit, so running the compiler's own test suite there exercises
- the FreeBSD kernel-stub object, `TPlatformLayout`, and `TNativeBackend`
- natively — no rebuild, no special flag.
-
-. *Cross-target static coverage.* On any host, the e2e harness can loop over
- *every registered toolkit*, compile a probe program for each, and assert the
- emitted object/executable is correctly shaped for that target (ELF
- `EI_OSABI`, `e_type`, entry symbol, absence/presence of `PT_INTERP`,
- relocation kinds). This gives Linux CI real coverage of the FreeBSD
- backend's *codegen and linking* even though the FreeBSD binary cannot
- execute on the Linux host. Behavioural (run-the-binary) coverage still
- needs an emulated/native FreeBSD lane, but the structural regressions are
- caught everywhere.
-
-This is a strict improvement over conditional compilation, where the only
-testable target is the one the test binary was built for.
-
-== Migration sequence (structural)
-
-This is the *structural* refactor; the FreeBSD-specific content (syscall
-numbers, struct layouts, `_start` shape) lives in
-`freebsd-x86_64-backend-design.adoc`.
-
-. *(DONE — Step 0a)* Introduce `TTargetToolkit` + `TTargetRegistry`; register
- the existing Linux target through them. Re-express `--target` resolution via
- the registry. *No behaviour change* — full suite + all fixpoints verified.
-. *(DONE — Step 0b)* Extract `TPlatformLayout` from `TRtlPlatformPosix`: move the
- `struct stat` layout (now an opaque buffer + offset accessors) and the
- `O_*`/`S_*`/`CLOCK_*`/`WNOHANG`/`SEEK_*` constants behind the port; the Linux
- adapter (`rtl.platform.layout.linux`) supplies today's values. Verified.
-. *(REVISED — kernel leaf)* The kernel leaf is a *link-time symbol swap*, NOT a
- runtime port. A runtime `TKernelABI` virtual port was attempted here and
- reverted because it destabilised self-hosting for zero present benefit
- (<>). No refactor is needed in this step: the RTL keeps its
- `external name` bindings, and the FreeBSD syscall-stub object is introduced
- when the FreeBSD RTL archive is built (FreeBSD design doc, Step 4).
-. *(DEFERRED)* Lift the ARC field-kind walkers and record classifier into
- `TNativeBackend` as template methods with abstract per-CPU leaves. This is
- *arm64 groundwork* — FreeBSD reuses the x86_64 backend unchanged, so it does
- not block the FreeBSD target and is deferred until a second CPU lands.
-. Add the `TFreeBSDX86_64Toolkit` adapters + FreeBSD kernel-stub/layout (per the
- FreeBSD design doc). Adding the target touches *no* existing target's code —
- new files plus one registry line.
-
-The completed steps are behaviour-preserving refactors verified against the
-existing Linux suite and all four fixpoints; the FreeBSD step is the actual
-FreeBSD work. Sequencing the refactors first means the FreeBSD adapter slots
-into clean seams rather than forcing them open mid-implementation.
-
-=== RTL unification (separate track, gated on the `.s` migration)
-
-Independent of the per-target work above, the runtime is being unified into the
-compiler so bootstrap is a single command and there are no external archives
-(see "Runtime end-state" above). Ordered sub-steps:
-
-. *(IN PROGRESS)* Migrate the hand-written `runtime/src/main/asm/*_x86_64.s`
- bodies to inline-assembler Pascal units (`asm … end`, `nostackframe`), one
- file per commit, expanding the internal assembler as needed. Done:
- `blaise_atomic`, `blaise_setjmp`. Remaining: `blaise_start`, `blaise_utf8`
- (the latter needs the SSE2/AVX2 instruction set). When complete the RTL is
- pure Pascal and the Makefile's `$(CC) -c` asm rule and `$(ASM_DIR)` are gone.
-. Compile the RTL units in-process into in-memory objects and link them via the
- in-process `TLinker`, dropping `ar`, `blaise_rtl.a`, and `make install`.
-. Embed the RTL Pascal source in the `blaise` binary and compile it per
- `--target` on demand (selecting that target's adapter set), so one binary
- cross-compiles to any registered target with nothing beside it. Fold the
- `runtime` PasBuild module into the compiler; bootstrap becomes a single
- `pasbuild compile -m blaise-compiler`. Measure build time; add an in-memory /
- `--unit-cache` RTL object cache only if the recompile cost proves noticeable.
-
-== Summary
-
-Hexagonal architecture is not just viable in Blaise — it is already the chosen
-idiom for the runtime platform layer and the codegen backend, explicitly
-`{$IFDEF}`-free. The path to many targets is to *complete* that idiom, using
-the right mechanism for each axis of divergence:
-
-* the struct/constant layout becomes a runtime port (`TPlatformLayout`) —
- its per-target values are read by shared method bodies;
-* the kernel leaf becomes a *link-time symbol swap* — a per-target syscall/
- startup object resolving the RTL's `external name` bindings (a runtime
- `TKernelABI` port was tried and reverted, <>);
-* each target's compiler-side adapter family (backend + link target) is
- composed by an Abstract Factory (`TTargetToolkit`) and resolved by name
- through a Registry;
-* the linker's container writer stays behind a Bridge and the backend reuses
- the Template-Method base.
-
-Target divergence then lives in *which object is instantiated or which archive
-is linked*, decided once — the compiler picks a target to emit for, a produced
-binary picks a platform to run on — with no `{$IFDEF}` and no scattered
-per-target code. The test runner can select adapters at run time to test any
-target, natively or structurally.
diff --git a/docs/rtl-unification-plan.adoc b/docs/rtl-unification-plan.adoc
deleted file mode 100644
index e1a41db..0000000
--- a/docs/rtl-unification-plan.adoc
+++ /dev/null
@@ -1,317 +0,0 @@
-= RTL Unification — Implementation Plan
-:author: Graeme Geldenhuys
-:revdate: 2026-06-25
-:toc: left
-:toclevels: 3
-:source-highlighter: rouge
-:icons: font
-:sectanchors:
-:sectnums:
-
-== Purpose
-
-Fold the always-linked runtime (`runtime/`) into the compiler so that a single
-`pasbuild compile -m blaise-compiler` produces a self-contained toolchain — no
-separate `runtime` module, no `cd runtime && make install`, no `ar`-built
-`blaise_rtl.a`. This is the first concrete step of the "one binary, embedded
-RTL, no external archives" end-state recorded in
-`docs/native-target-architecture.adoc`.
-
-This document is the execution plan: the architecture facts that constrain it,
-the chosen target shape, the full blast radius (every file/script touched), the
-ordered migration with a self-hosting re-verify after each stage, and the
-cold-bootstrap ordering that must never break mid-change.
-
-== Background facts that constrain the design
-
-These were established by investigation (2026-06-25) and dictate the approach.
-
-. *A normal program `uses` nothing of the runtime explicitly.* The compiler
- emits calls to `_SetArgs`, `_SysWriteInt`, `_BlaiseInit`, the ARC helpers,
- etc. as *undefined external symbols*. An `--emit-asm` of a hello-world is
- ~100 lines with zero RTL bodies. Those externals are satisfied at link time
- by `blaise_rtl.a`. *The archive is the implicit runtime every binary needs.*
-
-. *`blaise_rtl.a` is a Blaise-only artifact.* It is assembled by
- `runtime/Makefile` with `ar` from per-unit `.o` files. PasBuild's `library`
- packaging compiles units (`.o` + `.bif` for unit-path consumption) but does
- *not* emit an `ar` archive — so PasBuild has no native notion of this file.
-
-. *The RTL is now pure Pascal.* All four hand-written `*_x86_64.s` files were
- migrated to inline-asm `.pas` units, so every RTL unit builds through the
- compiler's own internal assembler. Nothing external (gcc/as) is needed to
- build the runtime any longer.
-
-. *The compiler already resolves RTL interfaces from the `.pas` on its
- unit-path* (for type/semantic resolution); only the *bodies* come from the
- archive. The mechanism to compile a unit to an object in-process exists
- (the incremental worker path, `LowerToObject` / `AddOwnedObject`).
-
-. *`stdlib/` stays separate.* It is opt-in, not always-linked; it is not part
- of this unification.
-
-== Unit relocation: dotted-flat names (recommended) vs subdirectory
-
-The unit loader is *filename-based*: a unit named `X` is sought as
-`/X.pas`, and a *dotted* unit name maps to a *dotted filename*
-verbatim — `rtl.platform.posix` → `rtl.platform.posix.pas` — NOT to a
-subdirectory (`uUnitLoader.pas`: `Path := Base + AName + '.pas'`). Two
-RTL units already use this convention (`rtl.platform*`).
-
-This drives the relocation choice:
-
-[cols="1,3,3",options="header"]
-|===
-| | Dotted-flat (recommended) | Subdirectory
-
-| Layout
-| `compiler/src/main/pascal/runtime.atomic.pas`
-| `compiler/src/main/pascal/runtime/blaise_atomic.pas`
-
-| Unit-path change
-| *None* — files sit directly in the compiler's existing source dir, already on
- its path. Best satisfies the "reduce unit paths" goal.
-| Needs `compiler/src/main/pascal/runtime` added as a search path — re-introduces
- a unit-path entry, since the loader does not traverse subdirs.
-
-| Unit names
-| *Renamed* (`blaise_atomic` → `runtime.atomic`): churns every `uses` clause
- and `.bif`/cache filenames.
-| *Preserved*: no `uses` churn.
-
-| Emitted symbols
-| *Unchanged* either way — runtime symbols (`_BlaiseGetMem`, `_SetArgs`, …) are
- explicit `external name` strings, independent of the unit name.
-|===
-
-Because the loader keys on filename, the dotted-flat scheme reaches the goal
-(no extra unit-path) with the trade of a one-time `uses`-clause rename sweep,
-whereas the subdirectory keeps a path entry. *Recommendation: dotted-flat.*
-Proposed name map (keep `rtl.platform*` as-is; they already fit):
-
-[cols="2,2",options="header"]
-|===
-| Today | Dotted-flat
-
-| blaise_start | runtime.start
-| blaise_atomic | runtime.atomic
-| blaise_setjmp | runtime.setjmp
-| blaise_utf8 | runtime.utf8
-| blaise_mem | runtime.mem
-| blaise_str | runtime.str
-| blaise_set | runtime.set
-| blaise_arc | runtime.arc
-| blaise_weak | runtime.weak
-| blaise_float | runtime.float
-| blaise_thread | runtime.thread
-| blaise_exc | runtime.exc
-| system | system (unchanged — implicit System unit)
-|===
-
-(Whichever scheme is chosen, the `.o`-cache and link-model changes below are
-identical.)
-
-== Target shape (dotted-flat)
-
-[source]
-----
-compiler/
- src/main/pascal/
- Blaise.pas, uParser.pas, ... (compiler sources, as today)
- runtime.start.pas runtime.atomic.pas runtime.setjmp.pas runtime.utf8.pas
- runtime.mem.pas runtime.str.pas runtime.set.pas runtime.arc.pas
- runtime.weak.pas runtime.float.pas runtime.thread.pas runtime.exc.pas
- rtl.platform.pas rtl.platform.layout.linux.pas rtl.platform.posix.pas
- system.pas
- target/
- blaise (the compiler binary)
- rtl/ (RTL .o CACHE, replaces blaise_rtl.a)
- runtime.start.o ... rtl.platform.posix.o
-----
-
-* `pasbuild compile -m blaise-compiler` builds `blaise` *and* compiles the RTL
- units to `compiler/target/rtl/*.o` (a cache dir, not an `ar` archive). No
- extra `` entry is needed — the units are in the compiler's own
- source dir.
-* At link time the native internal linker adds every `compiler/target/rtl/*.o`
- (via the existing `AddOwnedObject` path) instead of `AddArchive(blaise_rtl.a)`.
-* The `runtime` PasBuild module is removed from the reactor. Its tests
- (`runtime/src/test`, the punit programs + the `punit` framework unit) move to
- a test location under the compiler module (or a retained `runtime-tests`
- module — see open questions).
-
-Why a `.o` *cache dir* and not in-process recompile-per-program (yet): it
-matches current link performance (no per-program RTL recompile), removes
-`ar`/`make install`/the separate module today, and keeps the change to "where
-the RTL objects come from" rather than "when they are built". The
-recompile-per-target / embedded-source end-state is a *measured* follow-up
-(<>).
-
-== Blast radius
-
-Every reference to the old `runtime/` location or to `blaise_rtl.a`. Grouped by
-kind; all must move in lockstep so the bootstrap never breaks.
-
-=== Build / module wiring
-
-* `project.xml` — remove the `runtime` module from `` (keep `stdlib`).
-* `compiler/project.xml` — drop `../runtime/src/main/pascal` from ``
- (both `` and ``); the units now live under the compiler's own
- source tree (already on its path). Add the RTL `.o`-cache build step.
-* `runtime/Makefile` — removed (its per-unit compile + `ar` is replaced by the
- compiler-driven `.o` cache). Retain only if punit tests still need it.
-
-=== Compiler code
-
-* `uToolchain.pas` — `FindRTLArchive` / `ResolveToolchain.RTLPath`: replace
- "find `blaise_rtl.a`" with "find the `compiler/target/rtl/` object dir beside
- the compiler" (or, transitional, accept either).
-* `blaise.codegen.native.driver.pas` — `LinkViaInternalLinker`: replace
- `Lk.AddArchive(TC.RTLPath)` with a loop adding each cached RTL `.o` via
- `AddOwnedObject`. Update the "RTL not found" guard message.
-* Anything embedding the RTL source path for messages/docs.
-
-=== Self-hosting scripts (must stay green throughout)
-
-* `scripts/fixpoint.sh` — builds the runtime (`cd runtime && make`) as stage-0;
- resolves `blaise_rtl.a` for the link steps; uses
- `--unit-path runtime/src/main/pascal`. All three change to the new RTL
- source location + the `.o`-cache link inputs.
-* `scripts/fixpoint-native.sh`, `scripts/fixpoint-native-internal.sh`,
- `scripts/fixpoint-warmcache.sh` — each resolves `blaise_rtl.a` and passes
- `--unit-path runtime/src/main/pascal`; update both.
-* `scripts/rolling-bootstrap.sh` — replays `cd runtime && make BLAISE=… install`
- per commit and links `compiler/target/blaise_rtl.a`; update to the new build.
-* `.github/workflows/bootstrap.yml` — caches `blaise_rtl.a`, copies it into
- release dirs and stage-1 tarballs, and runs
- `( cd runtime && make … && make … install )`. Update cache key, copy paths,
- and the build step.
-
-=== Release / bootstrap artifacts
-
-* `releases/v*/` currently carry `blaise` + `blaise_rtl.a`. Decide the new
- artifact set: `blaise` + a `rtl/` object dir (or a tarball of it). The
- release/cut process (`cut-blaise-release` skill, CLAUDE.md "Release binary")
- must copy the new artifact. *The current release binary still expects
- `blaise_rtl.a`* — so the migrating commit must keep cold-bootstrap working
- from the existing release (see <>).
-
-=== Tests (≈12 files) and docs
-
-* Test files passing `--unit-path runtime/src/main/pascal` (cp.test.cli,
- cp.test.linker, cp.test.assembler, cp.test.e2e.base, cp.test.strutils,
- cp.test.math, cp.test.numerics.*, cp.test.proctypes_ofobject,
- cp.test.publishedrtti, cp.test.attributes, cp.test.config): repoint to the
- new RTL source path (ideally via a single shared `ProjectRoot`/RTL-path
- helper so future moves touch one place).
-* `runtime/src/test/pascal/*` (punit programs) — relocate or keep behind a
- retained tests-only module.
-* Docs: `CLAUDE.md` (layout table, cold-bootstrap, fixpoint steps),
- `README.adoc`, `docs/design.adoc`, `docs/testing-strategy.adoc`,
- `docs/internal-linker-design.adoc`, `docs/self-contained-start-design.adoc`,
- `scripts/BOOTSTRAP.adoc`, and the three target/arch design docs.
-
-== Migration order
-
-Each stage ends with a *full re-verify* — all four fixpoints
-(`fixpoint.sh`, `fixpoint-native.sh`, `fixpoint-native-internal.sh`,
-`fixpoint-warmcache.sh`) plus the native-built test runner suite — and a
-*cold-bootstrap-from-release* check. Do not proceed past a red stage.
-
-. *Move + rename the source, keep the archive.* `git mv` each
- `runtime/src/main/pascal/blaise_X.pas` →
- `compiler/src/main/pascal/runtime.X.pas` (dotted-flat; `rtl.platform*` and
- `system.pas` keep their names), rename the `unit blaise_X;` declaration to
- `unit runtime.X;`, and sweep every `uses blaise_X` across the RTL, stdlib,
- compiler and tests to `uses runtime.X`. Drop the `../runtime/src/main/pascal`
- `` entry (units now sit in the compiler's own dir). For the still-
- present archive build, point the Makefile's `PAS_SRC_DIR` at the new location
- (or invoke per-unit there). `blaise_rtl.a` is still produced and linked via
- `AddArchive`; emitted symbols are unchanged, so *behaviour is identical*.
- This isolates the move+rename from the link-model change.
- Verify: all fixpoints + suite green; cold-bootstrap from the existing release.
-
-. *Compiler builds the RTL `.o` cache.* Teach `pasbuild compile -m
- blaise-compiler` (or a thin post-build) to compile the RTL units to
- `compiler/target/rtl/*.o`. Still archive at link for now; just prove the
- cache is produced and correct (diff its `.o` against the Makefile's).
- Verify: cache present, byte-equivalent objects.
-
-. *Link from the `.o` cache; drop the archive.* `LinkViaInternalLinker` adds
- `compiler/target/rtl/*.o` instead of `AddArchive`. `FindRTLArchive` →
- find-the-cache-dir. Remove `ar`/`make install`/the `runtime` module and the
- Makefile. Update all scripts + CI + release artifacts to the cache dir.
- Verify: all fixpoints + suite + cold-bootstrap green; *measure build time*
- vs the archive baseline.
-
-. *Docs + release process.* Update CLAUDE.md, README, design docs, and the
- release/cut process to the new layout and artifact set.
-
-[#coldstart]
-== Cold-bootstrap ordering (the thing that must not break)
-
-The stage-1 binary is the *previous* release (`releases/v*/blaise`), which today
-links `blaise_rtl.a`. Two hazards:
-
-. *The release binary predates the move.* When stage-1 (the old release)
- builds the new compiler, it still needs a `blaise_rtl.a` to link the new
- compiler binary itself. Stage 1 of the migration keeps the Makefile +
- archive precisely so the old release can still cold-bootstrap. The archive
- is only *dropped* (stage 3) once a stage-2 binary built from moved source
- exists and can produce/consume the `.o` cache.
-
-. *Layout-change rule.* This does not change record/vtable layout, so a
- stage-2 rebuild is not strictly required for correctness — but the link-model
- change (stage 3) means the stage-1-from-old-release path and the
- stage-2-onward path briefly use *different* RTL sources (archive vs cache).
- Sequence so that at every commit, the binary that builds the next step has a
- working RTL: keep the archive available (built from the new source location)
- until the cache-link path is proven, then remove it in the same commit that
- switches `AddArchive` → cache and refreshes the `-pre` release artifact to one
- that ships the `.o` cache.
-
-Concrete safe sequence: stages 1–2 are archive-compatible (old release works);
-stage 3 is a single commit that (a) switches the link path, (b) updates all
-scripts/CI, (c) refreshes `releases/v*-pre/` to carry the `rtl/` cache, and
-(d) is validated by `rolling-bootstrap.sh` from a known-good release before any
-push.
-
-== Verification matrix
-
-[cols="2,4",options="header"]
-|===
-| Check | Gate
-
-| `fixpoint.sh` | `FIXPOINT_OK` after each stage
-| `fixpoint-native.sh` | `NATIVE_FIXPOINT_OK`
-| `fixpoint-native-internal.sh` | `NATIVE_INTERNAL_OK`
-| `fixpoint-warmcache.sh` | `WARMCACHE_FIXPOINT_OK`
-| native-built TestRunner | full suite `OK` (with `BLAISE_QBE_COMPILER` fresh)
-| cold-bootstrap | new compiler builds from the *existing* release binary
-| rolling-bootstrap | `./scripts/rolling-bootstrap.sh` green before any push
-| build-time | stage-3 link time measured vs archive baseline (perf gate)
-|===
-
-[#followups]
-== Follow-ups (not in this plan)
-
-* *Compile-per-target RTL / embedded source.* Replace the host-only `.o`
- cache with compiling the embedded RTL source per `--target`, so one binary
- cross-compiles to any target with nothing staged (the FreeBSD work needs a
- FreeBSD-built RTL). Adopt only after measuring; add an in-memory/unit-cache
- if recompile cost is visible.
-* *Drop the `.o` cache for true in-process linking.* Compile RTL units in the
- same process and hand in-memory objects to the linker — removes the cache dir
- entirely.
-
-== Open questions
-
-* *punit tests' home.* `runtime/src/test/pascal/*` are Blaise programs using
- `punit`. Options: move under `compiler/src/test/`, or keep a minimal
- `runtime-tests` module. Leaning: a retained tests-only module so the compiler
- module stays focused.
-* *Release artifact form.* Ship the `rtl/` dir as-is, or a single tarball/`.a`
- re-introduced *only* as a release-packaging convenience (built by the
- compiler, not `ar`)? Decide at stage 4.
-* *`system.pas` placement.* It is special (implicit `System`); confirm it moves
- with the rest and that `bootstrapExclude` handling still applies.
diff --git a/docs/self-contained-start-design.adoc b/docs/self-contained-start-design.adoc
deleted file mode 100644
index dc9c966..0000000
--- a/docs/self-contained-start-design.adoc
+++ /dev/null
@@ -1,203 +0,0 @@
-= Self-Contained Program Entry: Replacing System CRT Startup Objects
-:toc: macro
-:toclevels: 3
-
-toc::[]
-
-== Summary
-
-The native backend's internal linker currently links every Blaise program
-against three categories of system CRT startup object:
-
-* `Scrt1.o` — provides the `_start` entry symbol, which calls
- `__libc_start_main(main, argc, argv, ...)`.
-* `crtbeginS.o` / `crtendS.o` — gcc-provided, supply the `.init_array` /
- `.fini_array` frame and registration glue.
-* `crti.o` / `crtn.o` — supply the `_init` / `_fini` C-runtime function
- prologue/epilogue.
-
-These objects are located by `uToolchain.FindCrtObjects`, which scans a
-hard-coded list of multiarch and *versioned gcc* directories
-(`/usr/lib/gcc///`). That directory layout varies by
-distribution, so the scan fails on distributions whose triple or gcc version
-is not in the list — issue #142 reports the failure on Mageia 9
-(`internal linker: CRT startup objects not found`). The QBE backend is
-unaffected because it links through the system `cc`, which knows its own
-startup-object paths.
-
-This design removes the dependency on `Scrt1.o`, `crtbeginS.o`, and
-`crtendS.o` entirely by shipping Blaise's *own* `_start` in the runtime
-archive — the same approach FPC takes (`rtl/linux/x86_64/si_c.inc`). After
-the change the internal linker needs no gcc-provided object and no versioned
-gcc directory, so it links correctly on any glibc-based distribution without
-consulting gcc.
-
-== Motivation
-
-The internal linker exists to make Blaise *toolchain-independent* — to produce
-a self-contained executable without shelling out to `gcc` / `ld`
-(`docs/toolchain-independence.adoc`). Resolving the #142 failure by asking
-`gcc -print-file-name=` would work on every distribution, but it
-reintroduces a link-time gcc dependency and so defeats the internal linker's
-purpose. The correct fix removes the need for the gcc-specific objects rather
-than locating them more cleverly.
-
-== Background: what each CRT object contributes
-
-On modern glibc (>= 2.34) the program entry sequence is:
-
-. The kernel transfers control to `_start` (the ELF entry point) with the
- initial stack holding `argc`, `argv`, `envp`, and the auxiliary vector.
-. `_start` (from `Scrt1.o`) marshals these into the System V argument
- registers and calls
- `__libc_start_main(main, argc, argv, init, fini, rtld_fini, stack_end)`.
-+
-On glibc >= 2.34 the legacy `__libc_csu_init` / `__libc_csu_fini` were
-removed; modern `Scrt1.o` passes `init = NULL` and `fini = NULL` (`%rcx` and
-`%r8` zeroed) and glibc runs `.init_array` / `.fini_array` itself.
-. `__libc_start_main` performs libc setup, runs the init array, calls
- `main(argc, argv, envp)`, and on return calls `exit(main_result)`.
-
-The relevant disassembly of the host's `Scrt1.o` (the exact sequence to
-reproduce):
-
-[source,asm]
-----
-_start:
- endbr64
- xor %ebp, %ebp ; outermost frame marker
- mov %rdx, %r9 ; rtld_fini (passed in %rdx at entry)
- pop %rsi ; argc
- mov %rsp, %rdx ; argv
- and $0xfffffffffffffff0, %rsp ; 16-byte align
- push %rax ; pad
- push %rsp ; stack_end
- xor %r8d, %r8d ; fini = NULL
- xor %ecx, %ecx ; init = NULL
- mov main@GOTPCREL(%rip), %rdi ; main
- call *__libc_start_main@GOTPCREL(%rip)
- hlt
-----
-
-`crtbeginS.o` / `crtendS.o` provide the `.init_array` / `.fini_array`
-terminator words and the `__dso_handle` / `__cxa_atexit` registration glue
-that C and C++ static constructors rely on. `crti.o` / `crtn.o` provide the
-`_init` / `_fini` function frames.
-
-=== What Blaise actually uses
-
-Verification on the current native backend (empty and hello-world programs):
-
-* Blaise's emitted assembly defines a standard `main(argc, argv)` returning
- `int`. `main` itself calls `_SetArgs`, `_BlaiseInit`, each imported unit's
- `_init`, then the program body, then returns 0. Unit initialisation is
- therefore driven explicitly from `main`, *not* through `.init_array`.
-* Neither the emitted program assembly nor `blaise_rtl.a` references any
- crtbegin/crtend-provided symbol (`__dso_handle`, `__cxa_atexit`,
- `__gmon_start__`, `_ITM_*`, `__TMC_END__`).
-* The compiler emits nothing into `.init_array` / `.fini_array`.
-
-Consequently the *only* contribution Blaise consumes from the whole CRT set is
-the `_start` entry symbol. `crtbeginS.o` / `crtendS.o` / `crti.o` / `crtn.o`
-supply machinery Blaise does not exercise.
-
-== Design
-
-=== Ship Blaise's own `_start`
-
-Add a new platform assembly source `runtime/src/main/asm/blaise_start_x86_64.s`
-that defines the `_start` symbol, reproducing the modern-glibc sequence above:
-clear `%rbp`, marshal `argc` / `argv` / `rtld_fini` / `stack_end`, zero the
-`init` / `fini` arguments, load the address of `main`, and tail-call
-`__libc_start_main`.
-
-`main` and `__libc_start_main` are referenced through the GOT
-(`@GOTPCREL`), matching the relocation style the internal linker already
-handles for PIE output (`R_X86_64_REX_GOTPCRELX` / `R_X86_64_GOTPCRELX`).
-`main` is defined by the program object; `__libc_start_main` is an undefined
-libc import resolved through the PLT/GOT exactly as the existing linked libc
-symbols are.
-
-The object is assembled into `blaise_rtl.a` alongside the existing
-`blaise_setjmp_x86_64.o` / `blaise_atomic_x86_64.o` / `blaise_utf8_x86_64.o`.
-`TLinker.AddArchive` adds *all* archive members unconditionally (it does not
-pull members on demand by undefined symbol), so the `_start` member is always
-present in the link; the entry-name argument to `TLinker.Link` (`'_start'`)
-resolves against it.
-
-=== Stop linking the system CRT objects
-
-In `blaise.codegen.native.driver.pas`, `LinkViaInternalLinker` no longer calls
-`FindCrtObjects` and no longer issues `AddCrtObject` for `Scrt1.o`,
-`crtbeginS.o`, `crtendS.o`, `crti.o`, or `crtn.o`. The link line becomes:
-
-* program object,
-* extra unit objects,
-* `blaise_rtl.a` (now containing `_start`),
-* entry `_start`.
-
-The `.init_array` / `.fini_array` merge paths in `blaise.linker.elf.pas`
-remain — they tolerate an absent array (size 0, no `DT_INIT_ARRAY`) and cost
-nothing when no object contributes one. They are retained so that a future
-object legitimately emitting an init-array (e.g. an `external 'C'` static
-library a user links) still works.
-
-=== Removed surface
-
-* `uToolchain.FindCrtObjects` and its hard-coded `CrtDirs` / `GccVers` /
- `GccBases` lists are deleted; nothing else calls them.
-* The `Crt1 … CrtEndS` locals and the five `AddCrtObject` calls in
- `LinkViaInternalLinker` are removed.
-
-`TLinker.AddCrtObject` itself is retained: it is a generic "add this object,
-keeping its `.init_array` contribution" entry point that the linker core still
-uses internally and that the external-library path may need later.
-
-== Platform scope
-
-The change is x86-64 Linux (glibc) only — the single platform the native
-internal linker currently targets. The `_start` sequence is architecture- and
-libc-specific:
-
-* The startup object name carries the architecture suffix
- (`blaise_start_x86_64.s`), matching the existing `*_x86_64.s` convention, so
- an i386 / arm64 port adds a sibling file behind the same archive slot.
-* musl's `_start` calls `__libc_start_main` with the same prototype, so the
- glibc sequence is musl-compatible; this is consistent with the
- toolchain-independence design's musl note.
-
-== Risks and verification
-
-The risk is a malformed entry sequence: a mis-aligned stack at the
-`__libc_start_main` call, wrong argument marshalling, or a bad relocation on
-`main` / `__libc_start_main` would crash at process start rather than produce a
-diagnostic. The IR-only test harness cannot see this (it never links), so the
-guard must be executable end-to-end tests.
-
-Verification:
-
-. *E2E (both backends):* existing `AssertRunsOnAll` programs already compile →
- native link → run. Every native arm now exercises the Blaise `_start`. A
- passing suite proves the entry sequence, argument passing (`argc` / `argv`
- reach `_SetArgs`), and exit-code propagation.
-. *A dedicated entry test:* a program that reads `ParamCount` / `ParamStr`
- and returns a non-zero exit code, asserting both the forwarded arguments and
- the propagated exit status — the two things `_start` is responsible for.
-. *All four fixpoints:* the compiler links itself with the internal linker on
- the native path, so a broken `_start` breaks `fixpoint-native.sh` and
- `fixpoint-native-internal.sh` immediately.
-. *Issue #142 regression:* with the system gcc CRT directory made
- unavailable (or on a distribution without it), the internal-linker link must
- still succeed — the objects are no longer consulted.
-
-== Alternatives considered
-
-* *Probe `gcc -print-file-name=` (rejected).* Portable across
- distributions but reintroduces a link-time gcc dependency, contradicting the
- internal linker's reason to exist.
-* *Broaden the hard-coded directory scan (rejected).* Adding Mageia's triple
- and more gcc versions fixes the reported case but keeps the fundamentally
- brittle "guess the versioned gcc directory" strategy; the next unusual
- distribution re-opens the issue.
-* *Ship our own `_start` (chosen).* Removes the dependency on the
- distribution-variable objects outright and matches FPC's proven approach.
diff --git a/project.xml b/project.xml
index 1e992f2..4bfadd2 100644
--- a/project.xml
+++ b/project.xml
@@ -1,7 +1,7 @@
blaise
- 0.13.0-SNAPSHOT
+ 0.12.0
Graeme Geldenhuys
Apache-2.0 WITH Swift-exception
@@ -15,7 +15,7 @@
compiler
tools/migration-analyser
tools/kanban
- tools/bif-coverage
+ tools/bif-coverage
diff --git a/runtime/Makefile b/runtime/Makefile
index f52b540..d140272 100644
--- a/runtime/Makefile
+++ b/runtime/Makefile
@@ -5,19 +5,19 @@
# Licensed under the Apache License v2.0 with Runtime Library Exception.
# See LICENSE file in the project root for full license terms.
#
-# Builds blaise_rtl.a from the RTL units. The RTL sources now live in the
-# COMPILER's own source tree (compiler/src/main/pascal/runtime.*.pas — the
-# dotted-flat unit names runtime.atomic, runtime.str, …) as part of the
-# RTL-unification work; this Makefile is the transitional archive producer that
-# keeps cold-bootstrap working from an existing release until the compiler
-# itself produces the RTL object cache (see docs/rtl-unification-plan.adoc).
-#
-# Each RTL unit is compiled via Blaise's unit-as-top-level mode, with
-# --assembler internal so the whole archive builds through Blaise's own
-# in-process assembler — no external assembler, no gcc, no .s files.
+# Each Pascal unit is compiled directly via Blaise's unit-as-top-level
+# mode (project_unit_as_toplevel, 2026-05-24): a single
+# `blaise --source X.pas --output X.o` invocation runs qbe + cc -c
+# + objcopy-embed in one step. No build-driver shims, no IR-strip
+# sed pipelines, no intermediate .ssa/.s files needed.
SHELL = /bin/bash
-PAS_SRC_DIR = ../compiler/src/main/pascal
+CC = gcc
+CFLAGS = -O2 -Wall -Wextra -std=c11
+
+SRC_DIR = src/main/c
+PAS_SRC_DIR = src/main/pascal
+ASM_DIR = src/main/asm
OBJ_DIR = target
LIB = $(OBJ_DIR)/blaise_rtl.a
@@ -25,28 +25,33 @@ LIB = $(OBJ_DIR)/blaise_rtl.a
# driver finds it automatically next to itself.
COMPILER_BIN = ../compiler/target
BLAISE = $(COMPILER_BIN)/blaise
-# Whole-program per unit (--no-incremental) so every unit object is
-# self-contained (no undefined cross-unit typeinfo symbols at archive link).
-BLAISE_FLAGS = --no-incremental --assembler internal
+# This Makefile IS a hand-managed separate-compilation system: it compiles each
+# RTL unit to its own object and archives an explicit object list. The
+# compiler's own incremental mode (now the default) would, on top of that, write
+# per-dependency side-effect .o files next to each output and skip inlining a
+# used unit's bodies — but those side-effect objects are not in the archive's
+# object list, so a cross-unit symbol (e.g. typeinfo_TRtlPlatform, referenced by
+# the derived TRtlPlatformPosix in another unit) ends up undefined at link.
+# Force whole-program compilation per unit so every unit object is self-contained.
+BLAISE_FLAGS = --no-incremental
-# RTL unit objects. Object basenames mirror the source unit names (dots and
-# all); the archive's contents are unchanged in shape from before the rename.
-PAS_OBJS = $(OBJ_DIR)/runtime.start.o \
- $(OBJ_DIR)/runtime.atomic.o \
- $(OBJ_DIR)/runtime.setjmp.o \
- $(OBJ_DIR)/runtime.utf8.o \
- $(OBJ_DIR)/runtime.mem.o \
- $(OBJ_DIR)/runtime.str.o \
- $(OBJ_DIR)/runtime.set.o \
- $(OBJ_DIR)/runtime.arc.o \
- $(OBJ_DIR)/runtime.weak.o \
- $(OBJ_DIR)/runtime.float.o \
- $(OBJ_DIR)/runtime.thread.o \
- $(OBJ_DIR)/runtime.exc.o \
- $(OBJ_DIR)/rtl.platform.layout.linux.o \
- $(OBJ_DIR)/rtl.platform.posix.o
+# Assembly sources — platform-specific, no C compiler needed.
+ASM_OBJS = $(OBJ_DIR)/blaise_setjmp_x86_64.o \
+ $(OBJ_DIR)/blaise_atomic_x86_64.o \
+ $(OBJ_DIR)/blaise_utf8_x86_64.o
-OBJS = $(PAS_OBJS)
+# Pascal RTL units compiled via the Blaise compiler.
+PAS_OBJS = $(OBJ_DIR)/blaise_mem.o \
+ $(OBJ_DIR)/blaise_str.o \
+ $(OBJ_DIR)/blaise_set.o \
+ $(OBJ_DIR)/blaise_arc.o \
+ $(OBJ_DIR)/blaise_weak.o \
+ $(OBJ_DIR)/blaise_float.o \
+ $(OBJ_DIR)/blaise_thread.o \
+ $(OBJ_DIR)/blaise_exc.o \
+ $(OBJ_DIR)/rtl_platform_posix.o
+
+OBJS = $(ASM_OBJS) $(PAS_OBJS)
.PHONY: all install clean
@@ -55,10 +60,46 @@ all: $(LIB)
$(LIB): $(OBJS)
ar rcs $@ $^
-# --- Pascal unit rule (unit-as-top-level) ---
-# One pattern rule now suffices: every unit compiles the same way, and the
-# object basename equals the unit/source basename.
-$(OBJ_DIR)/%.o: $(PAS_SRC_DIR)/%.pas
+# --- Assembly rules ---
+$(OBJ_DIR)/%.o: $(ASM_DIR)/%.s
+ @mkdir -p $(OBJ_DIR)
+ $(CC) -c -o $@ $<
+
+# --- Pascal unit rules (unit-as-top-level) ---
+$(OBJ_DIR)/blaise_mem.o: $(PAS_SRC_DIR)/blaise_mem.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_str.o: $(PAS_SRC_DIR)/blaise_str.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_set.o: $(PAS_SRC_DIR)/blaise_set.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_arc.o: $(PAS_SRC_DIR)/blaise_arc.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_weak.o: $(PAS_SRC_DIR)/blaise_weak.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_float.o: $(PAS_SRC_DIR)/blaise_float.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_thread.o: $(PAS_SRC_DIR)/blaise_thread.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/blaise_exc.o: $(PAS_SRC_DIR)/blaise_exc.pas
+ @mkdir -p $(OBJ_DIR)
+ $(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
+
+$(OBJ_DIR)/rtl_platform_posix.o: $(PAS_SRC_DIR)/rtl.platform.posix.pas \
+ $(PAS_SRC_DIR)/rtl.platform.pas
@mkdir -p $(OBJ_DIR)
$(BLAISE) $(BLAISE_FLAGS) --source $< --unit-path $(PAS_SRC_DIR) --output $@
diff --git a/runtime/src/main/asm/blaise_atomic_x86_64.s b/runtime/src/main/asm/blaise_atomic_x86_64.s
new file mode 100644
index 0000000..8b848c7
--- /dev/null
+++ b/runtime/src/main/asm/blaise_atomic_x86_64.s
@@ -0,0 +1,44 @@
+#
+# Blaise — An Object Pascal Compiler
+# Copyright (c) 2026 Graeme Geldenhuys
+# SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
+# Licensed under the Apache License v2.0 with Runtime Library Exception.
+# See LICENSE file in the project root for full license terms.
+#
+# Atomic 32-bit integer operations for ARC thread safety (x86_64).
+#
+# These use the x86 LOCK prefix for full sequential-consistency
+# atomics. LOCK XADD atomically adds a value to a memory location
+# and returns the previous value in the source register.
+#
+
+.text
+
+# function _AtomicAddInt32(Ptr: PInteger; Delta: Integer): Integer;
+# %rdi = pointer to 32-bit integer
+# %esi = value to add
+# Returns the value BEFORE the addition.
+.globl _AtomicAddInt32
+.type _AtomicAddInt32, @function
+_AtomicAddInt32:
+ movl %esi, %eax
+ lock xaddl %eax, (%rdi)
+ ret
+.size _AtomicAddInt32, .-_AtomicAddInt32
+
+
+# function _AtomicSubInt32(Ptr: PInteger; Delta: Integer): Integer;
+# %rdi = pointer to 32-bit integer
+# %esi = value to subtract
+# Returns the value BEFORE the subtraction.
+.globl _AtomicSubInt32
+.type _AtomicSubInt32, @function
+_AtomicSubInt32:
+ negl %esi
+ movl %esi, %eax
+ lock xaddl %eax, (%rdi)
+ ret
+.size _AtomicSubInt32, .-_AtomicSubInt32
+
+
+.section .note.GNU-stack,"",@progbits
diff --git a/runtime/src/main/asm/blaise_setjmp_x86_64.s b/runtime/src/main/asm/blaise_setjmp_x86_64.s
new file mode 100644
index 0000000..6fd6ed6
--- /dev/null
+++ b/runtime/src/main/asm/blaise_setjmp_x86_64.s
@@ -0,0 +1,72 @@
+#
+# Blaise — An Object Pascal Compiler
+# Copyright (c) 2026 Graeme Geldenhuys
+# SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
+# Licensed under the Apache License v2.0 with Runtime Library Exception.
+# See LICENSE file in the project root for full license terms.
+#
+# Minimal setjmp/longjmp for Blaise exception handling (x86_64, System V ABI).
+#
+# These replace libc setjmp/longjmp so the runtime has zero C dependencies
+# for exception dispatch. Only callee-saved registers are stored — this is
+# sufficient because the compiler never promotes locals across setjmp (all
+# locals in try-bearing functions remain as stack slots).
+#
+# jmp_buf layout (64 bytes at offset 0 of BlaiseExcFrame):
+# [0] RBX
+# [8] RBP
+# [16] R12
+# [24] R13
+# [32] R14
+# [40] R15
+# [48] RSP (caller's stack pointer, after return address)
+# [56] RIP (return address)
+#
+
+.text
+
+# int _blaise_setjmp(void *buf)
+# %rdi = pointer to jmp_buf (first 64 bytes of BlaiseExcFrame)
+# Returns 0 on direct call, non-zero when restored by _blaise_longjmp.
+.globl _blaise_setjmp
+.type _blaise_setjmp, @function
+_blaise_setjmp:
+ mov %rbx, (%rdi)
+ mov %rbp, 8(%rdi)
+ mov %r12, 16(%rdi)
+ mov %r13, 24(%rdi)
+ mov %r14, 32(%rdi)
+ mov %r15, 40(%rdi)
+ lea 8(%rsp), %rax # caller's RSP (skip the return address)
+ mov %rax, 48(%rdi)
+ mov (%rsp), %rax # return address
+ mov %rax, 56(%rdi)
+ xor %eax, %eax # return 0
+ ret
+.size _blaise_setjmp, .-_blaise_setjmp
+
+
+# void _blaise_longjmp(void *buf, int val)
+# %rdi = pointer to jmp_buf
+# %esi = return value (passed back through setjmp's return)
+# Does not return to caller — jumps to the setjmp call site.
+.globl _blaise_longjmp
+.type _blaise_longjmp, @function
+_blaise_longjmp:
+ mov %esi, %eax # return value
+ test %eax, %eax
+ jnz 1f
+ inc %eax # longjmp(buf, 0) must return 1
+1:
+ mov (%rdi), %rbx
+ mov 8(%rdi), %rbp
+ mov 16(%rdi), %r12
+ mov 24(%rdi), %r13
+ mov 32(%rdi), %r14
+ mov 40(%rdi), %r15
+ mov 48(%rdi), %rsp
+ jmp *56(%rdi) # jump to saved return address
+.size _blaise_longjmp, .-_blaise_longjmp
+
+
+.section .note.GNU-stack,"",@progbits
diff --git a/runtime/src/main/asm/blaise_utf8_x86_64.s b/runtime/src/main/asm/blaise_utf8_x86_64.s
new file mode 100644
index 0000000..34a8447
--- /dev/null
+++ b/runtime/src/main/asm/blaise_utf8_x86_64.s
@@ -0,0 +1,226 @@
+#
+# Blaise — An Object Pascal Compiler
+# Copyright (c) 2026 Graeme Geldenhuys
+# SPDX-License-Identifier: Apache-2.0 WITH Swift-exception
+# Licensed under the Apache License v2.0 with Runtime Library Exception.
+# See LICENSE file in the project root for full license terms.
+#
+# SIMD-accelerated UTF-8 codepoint counting (x86_64).
+#
+# _Utf8CountCodePoints counts the number of UTF-8 codepoints in a byte buffer
+# by counting non-continuation bytes (bytes where (b & 0xC0) != 0x80).
+#
+# Strategy: use AVX2 (32 bytes/iteration) when available, fall back to SSE2
+# (16 bytes/iteration), then scalar for tail bytes.
+#
+# Calling convention (System V AMD64):
+# %rdi = pointer to first byte of string data
+# %esi = byte length of the string
+# Returns codepoint count in %eax.
+#
+
+.text
+
+.globl _Utf8CountCodePoints
+.type _Utf8CountCodePoints, @function
+_Utf8CountCodePoints:
+ # Fast path: empty or very short strings
+ testl %esi, %esi
+ jle .Lreturn_zero
+
+ movl %esi, %ecx # ecx = remaining bytes
+ xorl %eax, %eax # eax = codepoint count accumulator
+ xorl %edx, %edx # edx = current offset
+
+ # Check for AVX2 support via CPUID (cached in .Lavx2_flag)
+ cmpl $0, .Lavx2_checked(%rip)
+ jne .Lavx2_known
+ call .Lcheck_avx2
+ xorl %eax, %eax # restore accumulator (cpuid clobbers eax)
+.Lavx2_known:
+ cmpl $0, .Lavx2_flag(%rip)
+ je .Lsse2_entry
+
+ # --- AVX2 path: 32 bytes per iteration ---
+ cmpl $32, %ecx
+ jb .Lsse2_entry
+
+ # 0x80 broadcast into ymm1 (continuation byte marker)
+ vpcmpeqb %ymm2, %ymm2, %ymm2 # ymm2 = all 0xFF
+ vpsrlw $1, %ymm2, %ymm2 # ymm2 = 0x7F7F...
+ vpaddw %ymm2, %ymm2, %ymm1 # This doesn't give 0x80 correctly
+ # Correct approach: use vpbroadcastb-equivalent via stack
+ # Actually: 0x80 = set top bit of each byte
+ vpcmpeqb %ymm2, %ymm2, %ymm2 # ymm2 = all 0xFF
+ vpsllw $7, %ymm2, %ymm1 # ymm1 = 0x80 in each byte position
+ # That gives 0x80,0x00 pattern in words. Need per-byte.
+ # Use vpabsb on all-ones to get 0x01, then shift.
+ # Simplest: build 0xC0 and 0x80 masks on stack.
+
+ # Better: count bytes where (byte & 0xC0) != 0x80
+ # Equivalent: count bytes where byte < 0x80 OR byte >= 0xC0
+ # Which is: NOT a continuation byte (10xxxxxx pattern)
+ # A continuation byte has bits 7:6 == 10.
+ # (byte + 0x40) sets bit 7 for 0x80..0xBF range → overflow into 0xC0..0xFF
+ # Then test bit 7: if set = NOT continuation.
+ # Actually simplest SIMD approach: byte >= 0xC0 OR byte < 0x80
+ # = saturating subtract 0x80, then compare > 0x3F (catches >= 0xC0)
+ # OR original byte < 0x80
+ # Even simpler: (byte & 0xC0) != 0x80
+ # → XOR with 0x80 → (byte ^ 0x80) & 0xC0 != 0 iff not continuation
+ # → shift right by 6 and sum? No.
+ #
+ # Standard trick: count bytes that are NOT 10xxxxxx.
+ # A byte is a lead/ASCII byte iff its top two bits are NOT 10.
+ # pcmpgtb is signed comparison, so:
+ # (signed) byte > -65 (0xBF as signed = -65) means byte >= 0xC0
+ # (signed) byte > -1 means byte >= 0 means byte < 0x80 (ASCII)... no.
+ #
+ # Classic UTF-8 SIMD count:
+ # For each byte B: is_not_continuation = ((B & 0xC0) != 0x80)
+ # Using signed arithmetic:
+ # Treat bytes as signed: continuation bytes 0x80..0xBF = -128..-65
+ # if (signed_byte > -65) → NOT continuation (includes 0xC0..0xFF and 0x00..0x7F)
+ # pcmpgtb ymm_data, ymm_threshold(-65) → 0xFF for non-continuation bytes
+ #
+ # Wait — pcmpgtb(a, b) = a > b? No: pcmpgtb dest, src means dest[i] = (dest[i] > src[i]) ? 0xFF : 0x00
+ # We want: data[i] > -65 → is_not_continuation
+ # So we need pcmpgtb with data in dest and -65 broadcast in src.
+ # But pcmpgtb is destructive. So:
+ # 1. Load data into ymm0
+ # 2. Set ymm1 = broadcast(-65) = 0xBF bytes
+ # 3. vpcmpgtb ymm2, ymm0, ymm1 → ymm2[i] = 0xFF if data[i] > -65 (signed)
+ # 4. vpsrlw $7 on result... no, we need to count the 0xFF bytes.
+ # 5. Sum: vpsubb zeros, ymm2 (subtracting 0xFF = adding 1 per set byte)
+ # Actually -(-1) = 1, so vpsubb(0, mask) counts ones.
+ # But vpsubb has no immediate form; use pabsb on the result (abs(-1)=1, abs(0)=0)
+ # vpsabsb ymm2, ymm2 → each byte is 0 or 1
+ # 6. vpsadbw to horizontally sum bytes → 4 x 16-bit sums in qword lanes
+
+ # Build threshold: broadcast -65 (0xBF as signed) into ymm1
+ # -65 = 0xBF. All bytes 0xBF.
+ vpcmpeqb %ymm1, %ymm1, %ymm1 # ymm1 = all 0xFF
+ # We need 0xBF = ~0x40. Start from 0xFF, add 0xC0? No.
+ # 0xBF = 0xFF - 0x40. Use vpaddb with -0x40? We don't have that.
+ # Simplest: load from memory constant.
+ vmovdqa .Lthreshold_avx(%rip), %ymm1
+
+ vpxor %ymm3, %ymm3, %ymm3 # ymm3 = zero (accumulator)
+
+.Lavx2_loop:
+ vmovdqu (%rdi, %rdx), %ymm0 # load 32 bytes
+ vpcmpgtb %ymm1, %ymm0, %ymm2 # ymm2[i] = 0xFF if data[i] > -65 (signed)
+ vpabsb %ymm2, %ymm2 # ymm2[i] = 0 or 1
+ vpaddb %ymm2, %ymm3, %ymm3 # accumulate byte counts (safe for 255 iters)
+
+ addl $32, %edx
+ subl $32, %ecx
+ cmpl $32, %ecx
+ jge .Lavx2_loop
+
+ # Horizontal sum of ymm3: vpsadbw → sum each 8-byte lane into 64-bit
+ vpxor %ymm4, %ymm4, %ymm4
+ vpsadbw %ymm4, %ymm3, %ymm3 # ymm3 = 4 x 64-bit partial sums
+ # Extract and sum the 4 quadwords
+ vextracti128 $1, %ymm3, %xmm4
+ vpaddq %xmm4, %xmm3, %xmm3 # xmm3 = 2 x 64-bit sums
+ vpshufd $0x0E, %xmm3, %xmm4 # move high qword to low
+ vpaddq %xmm4, %xmm3, %xmm3
+ vmovd %xmm3, %r8d
+ addl %r8d, %eax
+
+ vzeroupper
+ jmp .Lsse2_entry
+
+ # --- SSE2 path: 16 bytes per iteration ---
+.Lsse2_entry:
+ cmpl $16, %ecx
+ jb .Lscalar_entry
+
+ # Build threshold -65 (0xBF) in xmm1
+ movdqa .Lthreshold_sse(%rip), %xmm1
+ pxor %xmm3, %xmm3 # xmm3 = zero accumulator
+
+.Lsse2_loop:
+ movdqu (%rdi, %rdx), %xmm0 # load 16 bytes
+ movdqa %xmm0, %xmm2 # copy (pcmpgtb is destructive)
+ pcmpgtb %xmm1, %xmm2 # xmm2[i] = 0xFF if data[i] > -65
+ pabsb %xmm2, %xmm2 # xmm2[i] = 0 or 1
+ paddb %xmm2, %xmm3 # accumulate (safe for 255 iters)
+
+ addl $16, %edx
+ subl $16, %ecx
+ cmpl $16, %ecx
+ jge .Lsse2_loop
+
+ # Horizontal sum of xmm3
+ pxor %xmm4, %xmm4
+ psadbw %xmm4, %xmm3 # xmm3 = 2 x 64-bit sums
+ movd %xmm3, %r8d
+ pshufd $0x0E, %xmm3, %xmm3
+ movd %xmm3, %r9d
+ addl %r8d, %eax
+ addl %r9d, %eax
+
+ # --- Scalar tail: remaining < 16 bytes ---
+.Lscalar_entry:
+ testl %ecx, %ecx
+ jle .Lreturn
+
+.Lscalar_loop:
+ movzbl (%rdi, %rdx), %r8d # load one byte
+ # Non-continuation if (byte & 0xC0) != 0x80
+ movl %r8d, %r9d
+ andl $0xC0, %r9d
+ cmpl $0x80, %r9d
+ setne %r9b
+ movzbl %r9b, %r9d
+ addl %r9d, %eax
+ incl %edx
+ decl %ecx
+ jnz .Lscalar_loop
+
+.Lreturn:
+ ret
+
+.Lreturn_zero:
+ xorl %eax, %eax
+ ret
+
+# --- AVX2 detection subroutine ---
+.Lcheck_avx2:
+ pushq %rbx
+ pushq %rcx
+ pushq %rdx
+ # CPUID leaf 7, subleaf 0 — bit 5 of EBX = AVX2
+ movl $7, %eax
+ xorl %ecx, %ecx
+ cpuid
+ testl $(1 << 5), %ebx
+ setne %al
+ movzbl %al, %eax
+ movl %eax, .Lavx2_flag(%rip)
+ movl $1, .Lavx2_checked(%rip)
+ popq %rdx
+ popq %rcx
+ popq %rbx
+ ret
+
+.size _Utf8CountCodePoints, .-_Utf8CountCodePoints
+
+
+# --- Read-only data (threshold constant) ---
+.section .rodata
+.balign 32
+.Lthreshold_avx:
+ .fill 32, 1, 0xBF
+.balign 16
+.Lthreshold_sse:
+ .fill 16, 1, 0xBF
+
+# --- Mutable data (AVX2 detection cache) ---
+.section .data
+.Lavx2_checked:
+ .long 0
+.Lavx2_flag:
+ .long 0
diff --git a/compiler/src/main/pascal/runtime.arc.pas b/runtime/src/main/pascal/blaise_arc.pas
similarity index 96%
rename from compiler/src/main/pascal/runtime.arc.pas
rename to runtime/src/main/pascal/blaise_arc.pas
index 5f418fa..7324101 100644
--- a/compiler/src/main/pascal/runtime.arc.pas
+++ b/runtime/src/main/pascal/blaise_arc.pas
@@ -31,7 +31,7 @@
destruction -- no TOCTOU race.
}
-unit runtime.arc;
+unit blaise_arc;
interface
@@ -60,15 +60,7 @@ procedure _AbstractMethodError;
procedure _LeakTrackerEnable;
procedure _LeakTrackerRegister(UserPtr: Pointer; ClassName: Pointer;
UnitName: Pointer; Line: Int64);
-{ Register an at-exit handler. Uses __cxa_atexit, NOT atexit: glibc's bare
- `atexit` lives only in the static libc_nonshared.a (it is not a dynamic export
- of libc.so.6), so a link that does not pull that archive — as the native
- backend's internal and external linkers do not — leaves `atexit` unresolved at
- load time. __cxa_atexit is a genuine dynamic libc export and resolves on
- every link path. Its third argument is the DSO handle; nil registers the
- handler against the main program. The handler is passed one (ignored) arg. }
-function _libc_cxa_atexit(Fn, Arg, DsoHandle: Pointer): Integer;
- external name '__cxa_atexit';
+procedure _libc_atexit(Fn: Pointer); external name 'atexit';
implementation
@@ -119,7 +111,7 @@ begin
_libc_write(STDERR_FD, Msg, Int64(Len));
NL := 10;
_libc_write(STDERR_FD, @NL, 1);
- _libc_abort();
+ _libc_abort;
end;
procedure _AbstractMethodError;
@@ -374,7 +366,7 @@ begin
GLTTable := PChar(_BlaiseGetMem(TableSize));
if GLTTable = nil then begin GLTEnabled := False; Exit end;
_libc_memset(GLTTable, 0, Int64(TableSize));
- _libc_cxa_atexit(Pointer(@_LeakTrackerReport), nil, nil);
+ _libc_atexit(Pointer(@_LeakTrackerReport));
end;
{ ------------------------------------------------------------------ }
diff --git a/compiler/src/main/pascal/runtime.exc.pas b/runtime/src/main/pascal/blaise_exc.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.exc.pas
rename to runtime/src/main/pascal/blaise_exc.pas
index d5dfa2e..390e7ea 100644
--- a/compiler/src/main/pascal/runtime.exc.pas
+++ b/runtime/src/main/pascal/blaise_exc.pas
@@ -27,7 +27,7 @@
threadvar, giving each thread its own exception chain.
}
-unit runtime.exc;
+unit blaise_exc;
interface
@@ -112,7 +112,7 @@ var
ExcSlot: PPointer;
begin
if g_exc_top = nil then
- _libc_abort();
+ _libc_abort;
g_current_exception := Obj;
ExcSlot := g_exc_top + OFS_EXCEPTION;
ExcSlot^ := Obj;
@@ -245,7 +245,7 @@ begin
_libc_write(2, Msg, Int64(Len));
NL := 10;
_libc_write(2, @NL, 1);
- _libc_abort();
+ _libc_abort;
end;
procedure _Raise_InvalidCast;
diff --git a/compiler/src/main/pascal/runtime.float.pas b/runtime/src/main/pascal/blaise_float.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.float.pas
rename to runtime/src/main/pascal/blaise_float.pas
index 407dda6..2b74549 100644
--- a/compiler/src/main/pascal/runtime.float.pas
+++ b/runtime/src/main/pascal/blaise_float.pas
@@ -24,7 +24,7 @@
data_ptr + 0 : char data + NUL
}
-unit runtime.float;
+unit blaise_float;
interface
diff --git a/compiler/src/main/pascal/runtime.mem.pas b/runtime/src/main/pascal/blaise_mem.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.mem.pas
rename to runtime/src/main/pascal/blaise_mem.pas
index 2578933..0a65305 100644
--- a/compiler/src/main/pascal/runtime.mem.pas
+++ b/runtime/src/main/pascal/blaise_mem.pas
@@ -44,7 +44,7 @@
go to the wrong thread's list).
}
-unit runtime.mem;
+unit blaise_mem;
interface
diff --git a/compiler/src/main/pascal/runtime.set.pas b/runtime/src/main/pascal/blaise_set.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.set.pas
rename to runtime/src/main/pascal/blaise_set.pas
index e592a60..91140db 100644
--- a/compiler/src/main/pascal/runtime.set.pas
+++ b/runtime/src/main/pascal/blaise_set.pas
@@ -28,7 +28,7 @@
writing Dest[i], so full overlap is safe.
}
-unit runtime.set;
+unit blaise_set;
interface
diff --git a/compiler/src/main/pascal/runtime.str.pas b/runtime/src/main/pascal/blaise_str.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.str.pas
rename to runtime/src/main/pascal/blaise_str.pas
index 2b4707a..94cf3e3 100644
--- a/compiler/src/main/pascal/runtime.str.pas
+++ b/runtime/src/main/pascal/blaise_str.pas
@@ -29,7 +29,7 @@
RefCount = -1 marks immortal (statically-allocated string literals).
}
-unit runtime.str;
+unit blaise_str;
interface
diff --git a/compiler/src/main/pascal/runtime.thread.pas b/runtime/src/main/pascal/blaise_thread.pas
similarity index 98%
rename from compiler/src/main/pascal/runtime.thread.pas
rename to runtime/src/main/pascal/blaise_thread.pas
index 6fe6c19..8d3077c 100644
--- a/compiler/src/main/pascal/runtime.thread.pas
+++ b/runtime/src/main/pascal/blaise_thread.pas
@@ -6,7 +6,7 @@
See LICENSE file in the project root for full license terms.
}
-unit runtime.thread;
+unit blaise_thread;
{ POSIX thread primitives — direct bindings to pthread and sysconf.
No C shim required; all functions use the standard C ABI which QBE
diff --git a/compiler/src/main/pascal/runtime.weak.pas b/runtime/src/main/pascal/blaise_weak.pas
similarity index 99%
rename from compiler/src/main/pascal/runtime.weak.pas
rename to runtime/src/main/pascal/blaise_weak.pas
index 5001698..2436ae1 100644
--- a/compiler/src/main/pascal/runtime.weak.pas
+++ b/runtime/src/main/pascal/blaise_weak.pas
@@ -40,7 +40,7 @@
runs and before the block is freed.
}
-unit runtime.weak;
+unit blaise_weak;
interface
diff --git a/compiler/src/main/pascal/rtl.platform.pas b/runtime/src/main/pascal/rtl.platform.pas
similarity index 68%
rename from compiler/src/main/pascal/rtl.platform.pas
rename to runtime/src/main/pascal/rtl.platform.pas
index 409e4ae..670a7ce 100644
--- a/compiler/src/main/pascal/rtl.platform.pas
+++ b/runtime/src/main/pascal/rtl.platform.pas
@@ -96,61 +96,8 @@ type
procedure ProcessFree(Proc: Pointer); virtual; abstract;
end;
- { Per-target struct layouts and OS constant values.
- (docs/native-target-architecture.adoc)
-
- Two things diverge across POSIX targets and both live here so the platform
- methods stay layout-agnostic:
-
- * OS integer constants — the open()/lseek() flag bits, clock id, and
- waitpid option whose numeric values differ between Linux and FreeBSD.
-
- * struct stat — its field OFFSETS differ (FreeBSD's stat is a different
- shape and size than Linux's). Rather than a shared TStatBuf record that
- bakes in one layout, the buffer is an opaque byte block sized by
- StatBufSize, and the three fields the RTL reads are pulled out by
- StatSize / StatMtime / StatMode at the target's offsets.
-
- struct tm is intentionally NOT abstracted: the fields the RTL uses
- (tm_year/mon/mday/hour/min/sec/gmtoff) share an identical layout on Linux
- and FreeBSD amd64, so TRtlPlatformPosix keeps a shared TTm record.
-
- The concrete layout is selected at startup alongside GRtlPlatform; nothing
- here uses conditional compilation. }
- TPlatformLayout = class
- public
- { ---- open() / file flags ---- }
- function O_RDONLY: Integer; virtual; abstract;
- function O_WRONLY: Integer; virtual; abstract;
- function O_RDWR: Integer; virtual; abstract;
- function O_CREAT: Integer; virtual; abstract;
- function O_TRUNC: Integer; virtual; abstract;
- function O_APPEND: Integer; virtual; abstract;
-
- { ---- stat mode bits ---- }
- function S_IFMT: Integer; virtual; abstract;
- function S_IFDIR: Integer; virtual; abstract;
-
- { ---- lseek whence ---- }
- function SEEK_SET: Integer; virtual; abstract;
- function SEEK_CUR: Integer; virtual; abstract;
- function SEEK_END: Integer; virtual; abstract;
-
- { ---- clock_gettime / waitpid ---- }
- function CLOCK_REALTIME: Integer; virtual; abstract;
- function WNOHANG: Integer; virtual; abstract;
-
- { ---- struct stat: opaque buffer sized for the target, fields pulled at
- the target's offsets ---- }
- function StatBufSize: Integer; virtual; abstract;
- function StatSize(Buf: Pointer): Int64; virtual; abstract;
- function StatMtime(Buf: Pointer): Int64; virtual; abstract;
- function StatMode(Buf: Pointer): Integer; virtual; abstract;
- end;
-
var
GRtlPlatform: TRtlPlatform;
- GPlatformLayout: TPlatformLayout;
implementation
diff --git a/compiler/src/main/pascal/rtl.platform.posix.pas b/runtime/src/main/pascal/rtl.platform.posix.pas
similarity index 91%
rename from compiler/src/main/pascal/rtl.platform.posix.pas
rename to runtime/src/main/pascal/rtl.platform.posix.pas
index 22bb5bd..00e161a 100644
--- a/compiler/src/main/pascal/rtl.platform.posix.pas
+++ b/runtime/src/main/pascal/rtl.platform.posix.pas
@@ -29,12 +29,6 @@ interface
uses
rtl.platform;
- { NOTE: the concrete TPlatformLayout adapter (rtl.platform.layout.) is
- deliberately NOT imported here. It is selected and linked by the driver
- for the runtime --target (BuildRTLUnitList), and its GPlatformLayout
- assignment runs via the bare `_BlaisePlatformInit` symbol that `main` calls
- at startup — a link-time swap, not a compile-time `uses`. Importing a
- concrete layout would hard-wire one OS into this shared POSIX unit. }
type
TRtlPlatformPosix = class(TRtlPlatform)
@@ -115,12 +109,26 @@ type
{ ------------------------------------------------------------------ }
type
- { Opaque struct stat buffer. The kernel fills it; the field offsets and the
- true size are target-specific (Linux 144 bytes, FreeBSD larger), so the RTL
- never names the fields directly — it sizes the buffer generously and reads
- Size/Mtime/Mode through GPlatformLayout.StatSize/StatMtime/StatMode at the
- target's offsets. 256 bytes covers every supported target's struct stat. }
- TStatBuf = array[0..255] of Byte;
+ TStatBuf = record
+ Dev: Int64;
+ Ino: Int64;
+ Nlink: Int64;
+ Mode: Integer;
+ Uid: Integer;
+ Gid: Integer;
+ Pad0: Integer;
+ Rdev: Int64;
+ Size: Int64;
+ Blksize: Int64;
+ Blocks: Int64;
+ Atime: Int64;
+ AtimeNs: Int64;
+ Mtime: Int64;
+ MtimeNs: Int64;
+ Ctime: Int64;
+ CtimeNs: Int64;
+ Unused: array[0..2] of Int64;
+ end;
PStatBuf = ^TStatBuf;
TTimeSpec = record
@@ -148,13 +156,6 @@ type
{ Memory }
function _BlaiseGetMem(Size: Integer): Pointer; external name '_BlaiseGetMem';
procedure _BlaiseFreeMem(Ptr: Pointer); external name '_BlaiseFreeMem';
-{ Bootstrap fallback for GPlatformLayout: defined WEAK by the linked target's
- concrete layout unit (rtl.platform.layout.). The current codegen assigns
- GPlatformLayout by calling that unit's init directly from main, so this call
- is redundant then (idempotent). It only matters for a binary built by an
- older codegen that does not yet emit the direct main-call — there it is the
- sole path that initialises the layout. }
-procedure _BlaisePlatformInit; external name '_BlaisePlatformInit';
{ String ARC }
function _IntToStr(N: Integer): Pointer; external name '_IntToStr';
@@ -172,8 +173,8 @@ function libc_read(Fd: Integer; Buf: Pointer; Count: Int64): Int64; exte
function libc_write(Fd: Integer; Buf: Pointer; Count: Int64): Int64; external name 'write';
function libc_lseek(Fd: Integer; Offset: Int64; Whence: Integer): Int64; external name 'lseek';
function libc_close(Fd: Integer): Integer; external name 'close';
-function libc_fstat(Fd: Integer; Buf: Pointer): Integer; external name 'fstat';
-function libc_stat(Path: PChar; Buf: Pointer): Integer; external name 'stat';
+function libc_fstat(Fd: Integer; Buf: PStatBuf): Integer; external name 'fstat';
+function libc_stat(Path: PChar; Buf: PStatBuf): Integer; external name 'stat';
function libc_mkdir(Path: PChar; Mode: Integer): Integer; external name 'mkdir';
function libc_rmdir(Path: PChar): Integer; external name 'rmdir';
function libc_unlink(Path: PChar): Integer; external name 'unlink';
@@ -287,11 +288,24 @@ implementation
const
BLAISE_STR_HDR = 12;
- NS_PER_SEC = 1000000000;
+ O_RDONLY = 0;
+ O_WRONLY = 1;
+ O_RDWR = 2;
+ O_CREAT = $40;
+ O_TRUNC = $200;
+ O_APPEND = $400;
- { O_* / S_* / SEEK_* / CLOCK_REALTIME / WNOHANG and the struct stat layout
- live in GPlatformLayout (rtl.platform.layout.) — their values/offsets
- differ across POSIX targets. See docs/native-target-architecture.adoc. }
+ S_IFMT = $F000;
+ S_IFDIR = $4000;
+
+ SEEK_SET = 0;
+ SEEK_CUR = 1;
+ SEEK_END = 2;
+
+ NS_PER_SEC = 1000000000;
+ CLOCK_REALTIME = 0;
+
+ WNOHANG = 1;
{ ------------------------------------------------------------------ }
{ Shared string helpers }
@@ -421,7 +435,7 @@ function TRtlPlatformPosix.FileExists(const APath: string): Boolean;
var
Fd: Integer;
begin
- Fd := libc_open2(StrData(Pointer(APath)), GPlatformLayout.O_RDONLY());
+ Fd := libc_open2(StrData(Pointer(APath)), O_RDONLY);
if Fd < 0 then begin Result := False; Exit end;
libc_close(Fd);
Result := True;
@@ -446,10 +460,10 @@ var
Got: Int64;
LPtr: ^Integer;
begin
- Fd := libc_open2(StrData(Pointer(APath)), GPlatformLayout.O_RDONLY());
+ Fd := libc_open2(StrData(Pointer(APath)), O_RDONLY);
if Fd < 0 then begin Result := string(PChar(StrAlloc(0))); Exit end;
if libc_fstat(Fd, @St) < 0 then begin libc_close(Fd); Result := string(PChar(StrAlloc(0))); Exit end;
- Sz := GPlatformLayout.StatSize(@St);
+ Sz := St.Size;
if Sz < 0 then begin libc_close(Fd); Result := string(PChar(StrAlloc(0))); Exit end;
R := StrAlloc(Integer(Sz));
if R = nil then begin libc_close(Fd); Result := ''; Exit end;
@@ -466,7 +480,7 @@ var
Fd: Integer;
Len: Integer;
begin
- Fd := libc_open(StrData(Pointer(APath)), GPlatformLayout.O_WRONLY() or GPlatformLayout.O_CREAT() or GPlatformLayout.O_TRUNC(), 420);
+ Fd := libc_open(StrData(Pointer(APath)), O_WRONLY or O_CREAT or O_TRUNC, 420);
if Fd < 0 then Exit;
Len := StrLen(Pointer(AContent));
if Len > 0 then
@@ -479,7 +493,7 @@ var
Fd: Integer;
Len: Integer;
begin
- Fd := libc_open(StrData(Pointer(APath)), GPlatformLayout.O_WRONLY() or GPlatformLayout.O_CREAT() or GPlatformLayout.O_APPEND(), 420);
+ Fd := libc_open(StrData(Pointer(APath)), O_WRONLY or O_CREAT or O_APPEND, 420);
if Fd < 0 then Exit;
Len := StrLen(Pointer(AContent));
if Len > 0 then
@@ -492,7 +506,7 @@ var
St: TStatBuf;
begin
if libc_stat(StrData(Pointer(APath)), @St) <> 0 then begin Result := -1; Exit end;
- Result := GPlatformLayout.StatMtime(@St);
+ Result := St.Mtime;
end;
{ ================================================================== }
@@ -504,7 +518,7 @@ var
St: TStatBuf;
begin
if libc_stat(StrData(Pointer(APath)), @St) <> 0 then begin Result := False; Exit end;
- Result := (GPlatformLayout.StatMode(@St) and GPlatformLayout.S_IFMT()) = GPlatformLayout.S_IFDIR();
+ Result := (St.Mode and S_IFMT) = S_IFDIR;
end;
function TRtlPlatformPosix.ForceDirectories(const APath: string): Boolean;
@@ -536,7 +550,7 @@ begin
begin
Result := False; Exit;
end;
- end else if (GPlatformLayout.StatMode(@St) and GPlatformLayout.S_IFMT()) <> GPlatformLayout.S_IFDIR() then
+ end else if (St.Mode and S_IFMT) <> S_IFDIR then
begin
Result := False; Exit;
end;
@@ -822,17 +836,17 @@ end;
function TRtlPlatformPosix.FdOpenRead(Path: Pointer): Integer;
begin
- Result := libc_open2(StrData(Path), GPlatformLayout.O_RDONLY());
+ Result := libc_open2(StrData(Path), O_RDONLY);
end;
function TRtlPlatformPosix.FdOpenWrite(Path: Pointer): Integer;
begin
- Result := libc_open(StrData(Path), GPlatformLayout.O_WRONLY() or GPlatformLayout.O_CREAT() or GPlatformLayout.O_TRUNC(), 420);
+ Result := libc_open(StrData(Path), O_WRONLY or O_CREAT or O_TRUNC, 420);
end;
function TRtlPlatformPosix.FdOpenAppend(Path: Pointer): Integer;
begin
- Result := libc_open(StrData(Path), GPlatformLayout.O_WRONLY() or GPlatformLayout.O_CREAT() or GPlatformLayout.O_APPEND(), 420);
+ Result := libc_open(StrData(Path), O_WRONLY or O_CREAT or O_APPEND, 420);
end;
function TRtlPlatformPosix.FdRead(Fd: Integer; Buf: Pointer; Count: Integer): Integer;
@@ -852,10 +866,10 @@ var
Whence: Integer;
begin
case Origin of
- 1: Whence := GPlatformLayout.SEEK_CUR();
- 2: Whence := GPlatformLayout.SEEK_END();
+ 1: Whence := SEEK_CUR;
+ 2: Whence := SEEK_END;
else
- Whence := GPlatformLayout.SEEK_SET();
+ Whence := SEEK_SET;
end;
Result := libc_lseek(Fd, Offset, Whence);
end;
@@ -865,7 +879,7 @@ var
St: TStatBuf;
begin
if libc_fstat(Fd, @St) <> 0 then begin Result := -1; Exit end;
- Result := GPlatformLayout.StatSize(@St);
+ Result := St.Size;
end;
procedure TRtlPlatformPosix.FdClose(Fd: Integer);
@@ -881,7 +895,7 @@ function TRtlPlatformPosix.TimeNow: Int64;
var
Ts: TTimeSpec;
begin
- libc_clock_gettime(GPlatformLayout.CLOCK_REALTIME(), @Ts);
+ libc_clock_gettime(CLOCK_REALTIME, @Ts);
Result := Ts.Sec * NS_PER_SEC + Ts.NSec;
end;
@@ -1068,7 +1082,7 @@ begin
P := Proc;
if (P^.Waited <> 0) or (P^.Pid = 0) then begin Result := 0; Exit end;
Status := 0;
- R := libc_waitpid(P^.Pid, @Status, GPlatformLayout.WNOHANG());
+ R := libc_waitpid(P^.Pid, @Status, WNOHANG);
if R = P^.Pid then
begin
if (Status and $7F) = 0 then
@@ -1157,13 +1171,6 @@ procedure _SetArgs(Argc: Integer; Argv: Pointer);
begin
GArgC := Argc;
GArgV := TPCharArray(Argv);
- { GPlatformLayout is assigned by the target's concrete layout unit
- (rtl.platform.layout.). The current codegen calls that unit's init
- directly from main (by-name, for the compile-time --target); this weak
- _BlaisePlatformInit call is the bootstrap fallback for an older codegen that
- does not. Idempotent. This shared POSIX unit references no concrete layout
- class, so it stays OS-agnostic. }
- _BlaisePlatformInit();
if GRtlPlatform = nil then
GRtlPlatform := TRtlPlatformPosix.Create();
end;
diff --git a/compiler/src/main/pascal/system.pas b/runtime/src/main/pascal/system.pas
similarity index 100%
rename from compiler/src/main/pascal/system.pas
rename to runtime/src/main/pascal/system.pas
diff --git a/runtime/src/test/pascal/bench_blaise_mem.pas b/runtime/src/test/pascal/bench_blaise_mem.pas
index 91588d6..338f5ae 100644
--- a/runtime/src/test/pascal/bench_blaise_mem.pas
+++ b/runtime/src/test/pascal/bench_blaise_mem.pas
@@ -22,10 +22,12 @@
Output: elapsed time in milliseconds per workload. Compare across
runs to detect regressions or improvements.
- Build (the compiler source-builds and links the RTL — no blaise_rtl.a):
+ Build:
blaise --source runtime/src/test/pascal/bench_blaise_mem.pas \
- --unit-path compiler/src/main/pascal \
- --output /tmp/bench_mem
+ --unit-path runtime/src/main/pascal \
+ --emit-ir > /tmp/bench_mem.ssa
+ vendor/qbe/qbe -o /tmp/bench_mem.s /tmp/bench_mem.ssa
+ gcc -o /tmp/bench_mem /tmp/bench_mem.s compiler/target/blaise_rtl.a
/tmp/bench_mem
}
diff --git a/runtime/src/test/pascal/bench_blaise_mem_custom.pas b/runtime/src/test/pascal/bench_blaise_mem_custom.pas
index 76dad05..d87741d 100644
--- a/runtime/src/test/pascal/bench_blaise_mem_custom.pas
+++ b/runtime/src/test/pascal/bench_blaise_mem_custom.pas
@@ -10,7 +10,7 @@
program bench_blaise_mem_custom;
-uses runtime.mem;
+uses blaise_mem;
function _TimeNow: Int64; external name '_TimeNow';
diff --git a/runtime/src/test/pascal/test_blaise_mem.pas b/runtime/src/test/pascal/test_blaise_mem.pas
index cbfb81c..d75dbe9 100644
--- a/runtime/src/test/pascal/test_blaise_mem.pas
+++ b/runtime/src/test/pascal/test_blaise_mem.pas
@@ -12,18 +12,20 @@
the string and ARC subsystems. punit is the correct framework here
because blaise_mem has zero dependency on stdlib or ARC.
- Build (the compiler source-builds and links the RTL — no blaise_rtl.a):
+ Build:
blaise --source runtime/src/test/pascal/test_blaise_mem.pas \
- --unit-path compiler/src/main/pascal \
+ --unit-path runtime/src/main/pascal \
--unit-path runtime/src/test/pascal \
- --output /tmp/test_mem
+ --emit-ir > /tmp/test_mem.ssa
+ vendor/qbe/qbe -o /tmp/test_mem.s /tmp/test_mem.ssa
+ gcc -o /tmp/test_mem /tmp/test_mem.s compiler/target/blaise_rtl.a
/tmp/test_mem -v
}
program test_blaise_mem;
uses
- punit, runtime.mem;
+ punit, blaise_mem;
{ ------------------------------------------------------------------ }
{ Test: basic GetMem returns non-nil }
diff --git a/runtime/src/test/pascal/test_blaise_str.pas b/runtime/src/test/pascal/test_blaise_str.pas
index 77924be..6c977d9 100644
--- a/runtime/src/test/pascal/test_blaise_str.pas
+++ b/runtime/src/test/pascal/test_blaise_str.pas
@@ -14,7 +14,7 @@
program test_blaise_str;
uses
- runtime.str;
+ blaise_str;
procedure _libc_puts(S: PChar); external name 'puts';
diff --git a/scripts/build-rtl-objects.sh b/scripts/build-rtl-objects.sh
deleted file mode 100755
index be433b7..0000000
--- a/scripts/build-rtl-objects.sh
+++ /dev/null
@@ -1,122 +0,0 @@
-#!/bin/bash
-# Build the implicit RTL object files from source, mirroring the compiler's
-# own TBackendDriver.EnsureRTLObjects. Used by the fixpoint / bootstrap
-# scripts to link a self-hosted compiler binary WITHOUT the legacy
-# blaise_rtl.a archive (RTL-unification Stage 3).
-#
-# Usage:
-# scripts/build-rtl-objects.sh [options]
-# Options:
-# --with-startup include runtime.start (its bare _start)
-# --exclude-defined-by FILE omit any RTL object that defines a symbol FILE
-# already defines (FILE is the main program object)
-#
-# Builds each RTL unit into /.o and prints, one per line on
-# stdout, the object paths to put on the link line. By default runtime.start
-# (the bare _start entry) is OMITTED — a gcc/cc link line gets _start from libc
-# and calls main. Pass --with-startup to include it (a -nostartfiles / native
-# internal link that owns the entry point).
-#
-# --exclude-defined-by handles the self-host link: a whole-program --emit-ir
-# dump INLINES the RTL units the compiler transitively uses (runtime.arc via
-# `uses classes`, etc.), so the program object already defines their symbols.
-# Linking our standalone copy too would double-define them; this option drops
-# the redundant objects, mirroring the compiler driver's own dedup.
-#
-# The build goes through a --unit-cache so each unit references its RTL deps'
-# globals externally instead of re-defining them (the archive's member
-# selection used to hide those duplicate definitions; explicit .o files do not).
-# RTL units carry inline asm, so the native backend + internal assembler is
-# mandatory. Build order is leaf-first so each unit's deps are already cached.
-
-set -e
-
-BLAISE="$1"
-OUTDIR="$2"
-shift 2 || true
-WITH_STARTUP=0
-EXCLUDE_OBJ=""
-while [ $# -gt 0 ]; do
- case "$1" in
- --with-startup) WITH_STARTUP=1; shift ;;
- --exclude-defined-by) EXCLUDE_OBJ="$2"; shift 2 ;;
- *) echo "build-rtl-objects: unknown option $1" >&2; exit 2 ;;
- esac
-done
-
-if [ -z "$BLAISE" ] || [ -z "$OUTDIR" ]; then
- echo "usage: build-rtl-objects.sh [--with-startup] [--exclude-defined-by FILE]" >&2
- exit 2
-fi
-if [ ! -x "$BLAISE" ]; then
- echo "build-rtl-objects: compiler binary not found: $BLAISE" >&2
- exit 2
-fi
-
-# Resolve the RTL source relative to THIS script (scripts/ is a sibling of
-# compiler/), so the script works regardless of the caller's CWD — the fixpoint
-# scripts run from the project root, the test runner from compiler/.
-SCRIPT_DIR=$(cd "$(dirname "${BASH_SOURCE[0]}")" && pwd)
-SRC="$SCRIPT_DIR/../compiler/src/main/pascal"
-if [ ! -f "$SRC/runtime.arc.pas" ]; then
- # Fall back to a CWD-relative path (e.g. an unusual invocation layout).
- SRC=compiler/src/main/pascal
-fi
-if [ ! -f "$SRC/runtime.arc.pas" ]; then
- echo "build-rtl-objects: RTL source not found under $SRC" >&2
- exit 2
-fi
-
-mkdir -p "$OUTDIR"
-
-# Leaf-first link order. rtl.platform owns the shared globals (GPlatformLayout,
-# GRtlPlatform) that layout.linux + posix reference externally, so it is built
-# first and linked once.
-RTL_UNITS=(
- rtl.platform
- runtime.start runtime.atomic runtime.setjmp runtime.utf8
- runtime.mem runtime.str runtime.set runtime.arc
- runtime.weak runtime.float runtime.thread runtime.exc
- rtl.platform.layout.linux rtl.platform.posix
-)
-
-# Symbols the main program object already defines (for --exclude-defined-by).
-EXCL_DEFS=""
-if [ -n "$EXCLUDE_OBJ" ]; then
- EXCL_DEFS=$(nm "$EXCLUDE_OBJ" 2>/dev/null | grep -E ' [TDBR] ' | awk '{print $3}' | sort -u)
-fi
-
-OBJS=()
-for u in "${RTL_UNITS[@]}"; do
- obj="$OUTDIR/$u.o"
- src="$SRC/$u.pas"
- # Rebuild only when the cached object is missing or older than its source, so
- # a persistent $OUTDIR (e.g. reused across a test suite) builds the RTL once.
- if [ ! -f "$obj" ] || [ "$src" -nt "$obj" ]; then
- "$BLAISE" --backend native --assembler internal \
- --source "$src" \
- --unit-path "$SRC" --unit-cache "$OUTDIR" \
- --output "$obj" >/dev/null 2>"$OUTDIR/$u.build.err" || {
- echo "build-rtl-objects: failed to build $u" >&2
- tail -5 "$OUTDIR/$u.build.err" >&2
- exit 1
- }
- # Cache this object's defined symbols so repeated --exclude-defined-by calls
- # (e.g. one per test in a suite) don't re-run nm on the stable RTL objects.
- nm "$obj" 2>/dev/null | grep -E ' [TDBR] ' | awk '{print $3}' | sort -u \
- > "$obj.syms"
- fi
- if [ "$u" = "runtime.start" ] && [ "$WITH_STARTUP" -eq 0 ]; then
- continue
- fi
- # Drop this object if it re-defines any symbol the main program already owns
- # (it was inlined into the program) — otherwise the loose .o collides.
- if [ -n "$EXCL_DEFS" ] && [ -f "$obj.syms" ] && [ -s "$obj.syms" ]; then
- if [ -n "$(comm -12 "$obj.syms" <(printf '%s\n' "$EXCL_DEFS"))" ]; then
- continue
- fi
- fi
- OBJS+=("$obj")
-done
-
-printf '%s\n' "${OBJS[@]}"
diff --git a/scripts/fixpoint-native-internal.sh b/scripts/fixpoint-native-internal.sh
index a41816a..52ec1af 100755
--- a/scripts/fixpoint-native-internal.sh
+++ b/scripts/fixpoint-native-internal.sh
@@ -32,8 +32,7 @@
# would false-positive; behavioural equivalence is the sound invariant.
#
# Requires: a native compiler at compiler/target/blaise (run the QBE
-# fixpoint or `pasbuild compile` first). The RTL is source-built by the
-# driver, so no blaise_rtl.a is needed.
+# fixpoint or `pasbuild compile` first) and compiler/target/blaise_rtl.a.
set -e
@@ -49,15 +48,18 @@ if [ ! -x "$COMPILER" ]; then
exit 10
fi
-# No RTL archive needed: the compiler driver source-builds the RTL into its
-# own object cache (EnsureRTLObjects) and links it directly. The RTL source
-# lives in compiler/src/main/pascal (resolved automatically by the driver).
-if [ ! -f compiler/src/main/pascal/runtime.arc.pas ]; then
- echo "RTL source not found under compiler/src/main/pascal" >&2
+if [ -f compiler/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=compiler/target/blaise_rtl.a
+elif [ -f runtime/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=runtime/target/blaise_rtl.a
+else
+ echo "blaise_rtl.a not found — build the runtime first" >&2
exit 11
fi
+# FindRTL looks for blaise_rtl.a beside the compiler binary.
+cp "$RTL_ARCHIVE" "$(dirname "$COMPILER")/blaise_rtl.a" 2>/dev/null || true
-UNIT_ARGS="--unit-path compiler/src/main/pascal --unit-path stdlib/src/main/pascal"
+UNIT_ARGS="--unit-path runtime/src/main/pascal --unit-path stdlib/src/main/pascal"
PROBE=/tmp/fpni_probe.pas
# Representative program. Exercises the sret-Result field-read path (a
diff --git a/scripts/fixpoint-native.sh b/scripts/fixpoint-native.sh
index 129e715..2275541 100755
--- a/scripts/fixpoint-native.sh
+++ b/scripts/fixpoint-native.sh
@@ -31,23 +31,14 @@ if [ ! -x "$COMPILER" ]; then
exit 10
fi
-# RTL is built from source (no archive). The --emit-asm dump inlines the RTL
-# units the compiler uses, so link with --exclude-defined-by to skip supplying
-# those a second time.
-RTL_OBJDIR=/tmp/fpn_rtl_obj
-ABS_COMPILER=$(readlink -f "$COMPILER")
-
-link_stage() {
- # $1 = program .s, $2 = output binary
- local prog_s="$1" out_bin="$2" prog_o rtl_objs
- prog_o="${prog_s%.s}.o"
- gcc -c -o "$prog_o" "$prog_s" 2>/tmp/fpn_cc.err || return 2
- rm -rf "$RTL_OBJDIR"
- rtl_objs=$(scripts/build-rtl-objects.sh "$ABS_COMPILER" "$RTL_OBJDIR" \
- --exclude-defined-by "$prog_o") || return 11
- gcc -o "$out_bin" "$prog_o" $rtl_objs -lm -lpthread 2>/tmp/fpn_gcc.err || return 2
- return 0
-}
+if [ -f compiler/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=compiler/target/blaise_rtl.a
+elif [ -f runtime/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=runtime/target/blaise_rtl.a
+else
+ echo "blaise_rtl.a not found — build the runtime first" >&2
+ exit 11
+fi
UNIT_ARGS="--unit-path compiler/src/main/pascal --unit-path runtime/src/main/pascal --unit-path stdlib/src/main/pascal"
SRC="--source compiler/src/main/pascal/Blaise.pas"
@@ -62,8 +53,8 @@ fi
echo " stage-1 asm: $(wc -l < /tmp/fpn_stage1.s) lines"
echo "[2/6] link stage-1 binary"
-link_stage /tmp/fpn_stage1.s /tmp/fpn_blaise1 || {
- echo "GCC1_FAIL"; cat /tmp/fpn_gcc.err 2>/dev/null; cat /tmp/fpn_cc.err 2>/dev/null; exit 2;
+gcc -o /tmp/fpn_blaise1 /tmp/fpn_stage1.s "$RTL_ARCHIVE" -lm -lpthread 2>/tmp/fpn_gcc1.err || {
+ echo "GCC1_FAIL"; cat /tmp/fpn_gcc1.err; exit 2;
}
echo "[3/6] stage-1 -> stage-2 assembly (native, 5min timeout)"
@@ -76,8 +67,8 @@ fi
echo " stage-2 asm: $(wc -l < /tmp/fpn_stage2.s) lines"
echo "[4/6] link stage-2 binary"
-link_stage /tmp/fpn_stage2.s /tmp/fpn_blaise2 || {
- echo "GCC2_FAIL"; cat /tmp/fpn_gcc.err 2>/dev/null; cat /tmp/fpn_cc.err 2>/dev/null; exit 2;
+gcc -o /tmp/fpn_blaise2 /tmp/fpn_stage2.s "$RTL_ARCHIVE" -lm -lpthread 2>/tmp/fpn_gcc2.err || {
+ echo "GCC2_FAIL"; cat /tmp/fpn_gcc2.err; exit 2;
}
echo "[5/6] stage-2 -> stage-3 assembly (native, 5min timeout)"
diff --git a/scripts/fixpoint-warmcache.sh b/scripts/fixpoint-warmcache.sh
index f905602..17a1ac5 100755
--- a/scripts/fixpoint-warmcache.sh
+++ b/scripts/fixpoint-warmcache.sh
@@ -33,8 +33,8 @@
# guard is built to catch.
#
# Requires: a current native-built compiler at compiler/target/blaise (run
-# `pasbuild compile -m blaise-compiler` first). The RTL is source-built by
-# the driver, so no blaise_rtl.a is needed.
+# `pasbuild compile -m blaise-compiler` first) and compiler/target/blaise_rtl.a
+# beside it.
set -e
@@ -50,13 +50,16 @@ if [ ! -x "$STAGE1" ]; then
exit 10
fi
-# No RTL archive needed: the driver source-builds the RTL (EnsureRTLObjects).
-if [ ! -f compiler/src/main/pascal/runtime.arc.pas ]; then
- echo "RTL source not found under compiler/src/main/pascal" >&2
+if [ ! -f compiler/target/blaise_rtl.a ]; then
+ echo "blaise_rtl.a not found beside the compiler — build the runtime first" >&2
+ echo " (cd runtime && make install) then pasbuild compile -m blaise-compiler" >&2
exit 11
fi
+# FindRTL looks for blaise_rtl.a beside the compiler binary; it already is for
+# compiler/target/blaise, but copy defensively in case the tree is partial.
+cp compiler/target/blaise_rtl.a "$(dirname "$STAGE1")/blaise_rtl.a" 2>/dev/null || true
-UNIT_PATHS="--unit-path compiler/src/main/pascal --unit-path stdlib/src/main/pascal"
+UNIT_PATHS="--unit-path compiler/src/main/pascal --unit-path runtime/src/main/pascal --unit-path stdlib/src/main/pascal"
# All temp state in one mktemp dir so cleanup is a single rm.
WORK="$(mktemp -d)"
@@ -146,9 +149,10 @@ echo "[4/4] behavioural check — both stage-2 binaries compile + run hello-worl
HELLO="$WORK/hello.pas"
printf 'program hello;\nbegin\n WriteLn(%s);\nend.\n' "'Hello'" > "$HELLO"
-# No RTL archive needed: the driver source-builds the RTL. The RTL source is
-# resolved from compiler/src/main/pascal, passed on the unit path below.
-RT_UNIT_PATHS="--unit-path compiler/src/main/pascal --unit-path stdlib/src/main/pascal"
+# FindRTL looks for blaise_rtl.a beside whichever binary is invoked.
+cp compiler/target/blaise_rtl.a "$WORK/blaise_rtl.a"
+
+RT_UNIT_PATHS="--unit-path runtime/src/main/pascal --unit-path stdlib/src/main/pascal"
check_binary() {
local label="$1"
diff --git a/scripts/fixpoint.sh b/scripts/fixpoint.sh
index 35e27e3..45ae18c 100755
--- a/scripts/fixpoint.sh
+++ b/scripts/fixpoint.sh
@@ -36,28 +36,35 @@ if [ ! -x "$STAGE1_BIN" ]; then
fi
echo "stage-1: $STAGE1_BIN"
-# The RTL is built from source (no archive) and linked alongside the assembled
-# compiler IR — exactly what the compiler driver does via EnsureRTLObjects.
-# Because the whole-program --emit-ir dump INLINES the RTL units the compiler
-# uses (runtime.arc via `uses classes`, etc.), the per-stage link below builds
-# the RTL objects with --exclude-defined-by so the inlined
-# units are not supplied twice. Helper: link_stage .
+# The runtime Makefile defaults BLAISE to ../compiler/target/blaise, which may
+# not exist yet — e.g. straight after scripts/rolling-bootstrap.sh, which
+# installs only to releases/ and leaves the live compiler/target/ empty.
+# Drive the runtime build with the stage-1 binary explicitly so fixpoint never
+# depends on a pre-existing compiler/target/blaise. make runs inside runtime/,
+# so BLAISE must be an absolute path.
ABS_STAGE1=$(readlink -f "$STAGE1_BIN")
-RTL_OBJDIR=/tmp/fp_rtl_obj
-link_stage() {
- # $1 = assembled program .s, $2 = output binary
- local prog_s="$1" out_bin="$2" prog_o rtl_objs
- prog_o="${prog_s%.s}.o"
- gcc -c -o "$prog_o" "$prog_s" 2>/tmp/fp_cc.err || return 3
- rm -rf "$RTL_OBJDIR"
- rtl_objs=$(scripts/build-rtl-objects.sh "$ABS_STAGE1" "$RTL_OBJDIR" \
- --exclude-defined-by "$prog_o") || return 11
- gcc -o "$out_bin" "$prog_o" $rtl_objs -lm -lpthread 2>/tmp/fp_gcc.err || return 3
- return 0
+echo "[1/5] rebuild + install runtime (BLAISE=$ABS_STAGE1)"
+( cd runtime && make clean > /tmp/fp_rtl.log 2>&1 \
+ && make BLAISE="$ABS_STAGE1" >> /tmp/fp_rtl.log 2>&1 \
+ && make BLAISE="$ABS_STAGE1" install >> /tmp/fp_rtl.log 2>&1 ) || {
+ if [ -f compiler/target/blaise_rtl.a ]; then
+ echo " stage-1 too old for runtime; using existing blaise_rtl.a"
+ else
+ echo "RUNTIME_FAIL"; tail -5 /tmp/fp_rtl.log; exit 11;
+ fi
}
-echo "[1/5] (RTL objects are built per-stage during linking)"
+# Resolve the RTL archive for the link steps below. `make install` copies it
+# to compiler/target/, but fall back to the runtime build dir so the link
+# never fails on a tree where compiler/target/ was not populated.
+if [ -f compiler/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=compiler/target/blaise_rtl.a
+elif [ -f runtime/target/blaise_rtl.a ]; then
+ RTL_ARCHIVE=runtime/target/blaise_rtl.a
+else
+ echo "RUNTIME_FAIL: blaise_rtl.a not found after runtime build"; exit 11
+fi
echo "[2/5] stage-1 -> stage-2 IR"
"$STAGE1_BIN" --source compiler/src/main/pascal/Blaise.pas \
@@ -75,8 +82,8 @@ echo "[3/5] assemble + link stage-2 binary"
vendor/qbe/qbe -o /tmp/fp_stage2.s /tmp/fp_stage2.ssa 2>/tmp/fp_qbe.err || {
echo "QBE_FAIL"; cat /tmp/fp_qbe.err; exit 2;
}
-link_stage /tmp/fp_stage2.s /tmp/fp_blaise2 || {
- echo "GCC_FAIL"; cat /tmp/fp_gcc.err 2>/dev/null; cat /tmp/fp_cc.err 2>/dev/null; exit 3;
+gcc -o /tmp/fp_blaise2 /tmp/fp_stage2.s "$RTL_ARCHIVE" 2>/tmp/fp_gcc.err || {
+ echo "GCC_FAIL"; cat /tmp/fp_gcc.err; exit 3;
}
echo "[4/5] stage-2 -> stage-3 IR (5min timeout)"
@@ -111,8 +118,8 @@ echo "[+1] assemble + link stage-3 binary"
vendor/qbe/qbe -o /tmp/fp_stage3.s /tmp/fp_stage3.ssa 2>/tmp/fp_qbe3.err || {
echo "QBE3_FAIL"; cat /tmp/fp_qbe3.err; exit 2;
}
-link_stage /tmp/fp_stage3.s /tmp/fp_blaise3 || {
- echo "GCC3_FAIL"; cat /tmp/fp_gcc.err 2>/dev/null; cat /tmp/fp_cc.err 2>/dev/null; exit 3;
+gcc -o /tmp/fp_blaise3 /tmp/fp_stage3.s "$RTL_ARCHIVE" 2>/tmp/fp_gcc3.err || {
+ echo "GCC3_FAIL"; cat /tmp/fp_gcc3.err; exit 3;
}
echo "[+2] stage-3 -> stage-4 IR (5min timeout)"
diff --git a/scripts/freebsd-crosscheck-build.sh b/scripts/freebsd-crosscheck-build.sh
deleted file mode 100755
index ad52272..0000000
--- a/scripts/freebsd-crosscheck-build.sh
+++ /dev/null
@@ -1,73 +0,0 @@
-#!/usr/bin/env bash
-#
-# Cross-compile the FreeBSD emulation-check fixtures (compiler/src/it/freebsd/*.pas)
-# with --target freebsd-x86_64 on a Linux host. The resulting static, freestanding
-# FreeBSD ET_EXEC binaries are then run inside a FreeBSD VM (see the freebsd-crosscheck
-# job in .github/workflows/bootstrap.yml) to validate the FreeBSD syscall leaf and
-# struct-stat layout that host-side static ELF checks cannot catch.
-#
-# Usage:
-# BLAISE=/path/to/blaise scripts/freebsd-crosscheck-build.sh [OUTDIR]
-#
-# BLAISE path to a native-backend blaise binary that supports --target
-# freebsd-x86_64 (defaults to compiler/target/blaise).
-# OUTDIR where to write the cross-compiled binaries (defaults to
-# target/freebsd-crosscheck).
-#
-# The binaries CANNOT run on the Linux host (FreeBSD syscall numbers/ABI); this
-# script only builds and sanity-checks the emitted ELF shape. Prints
-# FREEBSD_CROSSBUILD_OK on success.
-set -euo pipefail
-
-ROOT="$(cd "$(dirname "$0")/.." && pwd)"
-cd "$ROOT"
-
-BLAISE="${BLAISE:-compiler/target/blaise}"
-OUTDIR="${1:-target/freebsd-crosscheck}"
-FIXDIR="compiler/src/it/freebsd"
-
-if [ ! -x "$BLAISE" ]; then
- echo "error: blaise binary not found or not executable: $BLAISE" >&2
- exit 1
-fi
-
-mkdir -p "$OUTDIR"
-
-# The compiler resolves blaise_rtl.a / the RTL source relative to its own binary;
-# the RTL source lives in the compiler tree. Both unit paths mirror the normal
-# native build.
-UNIT_ARGS=(
- --unit-path runtime/src/main/pascal
- --unit-path stdlib/src/main/pascal
-)
-
-for src in "$FIXDIR"/*.pas; do
- name="$(basename "$src" .pas)"
- out="$OUTDIR/$name"
- echo "cross-compiling $src -> $out (freebsd-x86_64)"
- "$BLAISE" \
- --source "$src" \
- --backend native \
- --target freebsd-x86_64 \
- --output "$out" \
- "${UNIT_ARGS[@]}"
-
- # Sanity-check the emitted ELF is a FreeBSD (EI_OSABI=9) ET_EXEC. readelf is
- # part of binutils, always present on the Linux runner.
- osabi="$(readelf -hW "$out" | awk -F: '/OS\/ABI/ {print $2}' | xargs)"
- etype="$(readelf -hW "$out" | awk -F: '/Type:/ {print $2}' | awk '{print $1}')"
- case "$osabi" in
- *FreeBSD*) : ;;
- *) echo "error: $out is not a FreeBSD binary (OS/ABI=$osabi)" >&2; exit 1 ;;
- esac
- if [ "$etype" != "EXEC" ]; then
- echo "error: $out is not a static ET_EXEC (Type=$etype)" >&2
- exit 1
- fi
-done
-
-# Drop the .o intermediates the compiler leaves beside each output, so the VM
-# job can run every executable in OUTDIR without tripping over object files.
-rm -f "$OUTDIR"/*.o
-
-echo "FREEBSD_CROSSBUILD_OK"
diff --git a/scripts/rolling-bootstrap.sh b/scripts/rolling-bootstrap.sh
index dc40d8f..651bccc 100755
--- a/scripts/rolling-bootstrap.sh
+++ b/scripts/rolling-bootstrap.sh
@@ -202,7 +202,7 @@ build_step() {
}
# ---------------------------------------------------------------------------
-# smoke_test
+# smoke_test
# Compiles + runs a trivial program to prove the freshly-built binary is
# functional (source -> native backend -> internal assembler + linker ->
# runs -> correct stdout). Kept deliberately feature-agnostic: it must pass
@@ -210,7 +210,7 @@ build_step() {
# not any specific later feature.
# ---------------------------------------------------------------------------
smoke_test() {
- local cc="$1" rtl="$2" wt="$3"
+ local cc="$1" rtl="$2"
local d; d="$(mktemp -d)"
cat > "$d/s.pas" <<'PAS'
program P;
@@ -220,19 +220,11 @@ begin
WriteLn(X)
end.
PAS
- # Pre-source-build commits link the RTL archive (FindRTL beside the binary);
- # later commits source-build the RTL. Provide BOTH so this probe works across
- # the whole range: copy the archive beside the binary AND point the source
- # build at the RTL source in the worktree ($BLAISE_RTL_SRC short-circuits
- # RTLSourceDir, which is binary-relative and would otherwise miss because the
- # carried binary is not beside its compiler/ tree).
+ # FindRTL looks beside the compiler binary; ensure the matching archive is
+ # there so the internal linker finds it.
cp "$rtl" "$(dirname "$cc")/blaise_rtl.a" 2>/dev/null || true
local ok=1
- if BLAISE_RTL_SRC="$wt/compiler/src/main/pascal" \
- "$cc" --source "$d/s.pas" \
- --unit-path "$wt/compiler/src/main/pascal" \
- --unit-path "$wt/stdlib/src/main/pascal" \
- --output "$d/s" 2>"$d/s.err"; then
+ if "$cc" --source "$d/s.pas" --output "$d/s" 2>"$d/s.err"; then
[ "$("$d/s" 2>/dev/null)" = "42" ] && ok=0
fi
rm -rf "$d"
@@ -263,7 +255,7 @@ for sha in "${COMMITS[@]}"; do
exit 2
fi
- if ! smoke_test "$WT/_boot/blaise" "$WT/_boot/blaise_rtl.a" "$WT"; then
+ if ! smoke_test "$WT/_boot/blaise" "$WT/_boot/blaise_rtl.a"; then
echo
echo "SMOKE_FAILED at $short ($subj)"
echo " The binary built but produced wrong output for the local-const-array"
diff --git a/stdlib/src/main/pascal/blaise.testing.pas b/stdlib/src/main/pascal/blaise.testing.pas
index 2438314..df45fec 100644
--- a/stdlib/src/main/pascal/blaise.testing.pas
+++ b/stdlib/src/main/pascal/blaise.testing.pas
@@ -205,7 +205,7 @@ implementation
----------------------------------------------------------------------- }
var
- GTestRegistry: TList; { registered test-case classes }
+ GRegistry: TList; { registered test-case classes }
{ -----------------------------------------------------------------------
TTest
@@ -655,22 +655,22 @@ end;
procedure RegisterTest(ATestClass: TTestCaseClass);
begin
- if GTestRegistry = nil then
- GTestRegistry := TList.Create();
- GTestRegistry.Add(ATestClass);
+ if GRegistry = nil then
+ GRegistry := TList.Create();
+ GRegistry.Add(ATestClass);
end;
function GetRegisteredTestCount: Integer;
begin
- if GTestRegistry = nil then
+ if GRegistry = nil then
Result := 0
else
- Result := GTestRegistry.Count;
+ Result := GRegistry.Count;
end;
function GetRegisteredTest(AIndex: Integer): TTestCaseClass;
begin
- Result := GTestRegistry.Get(AIndex);
+ Result := GRegistry.Get(AIndex);
end;
end.
diff --git a/stdlib/src/main/pascal/classes.pas b/stdlib/src/main/pascal/classes.pas
index c2b3d6f..3798d62 100644
--- a/stdlib/src/main/pascal/classes.pas
+++ b/stdlib/src/main/pascal/classes.pas
@@ -33,7 +33,7 @@ unit Classes;
interface
uses
- runtime.arc, runtime.thread, StrUtils;
+ blaise_arc, blaise_thread, StrUtils;
type
TDuplicates = (dupAccept, dupIgnore, dupError);
diff --git a/stdlib/src/main/pascal/contnrs.pas b/stdlib/src/main/pascal/contnrs.pas
index 0dc6936..84aec4c 100644
--- a/stdlib/src/main/pascal/contnrs.pas
+++ b/stdlib/src/main/pascal/contnrs.pas
@@ -16,7 +16,7 @@ unit Contnrs;
interface
uses
- runtime.arc; { for _ClassRelease }
+ blaise_arc; { for _ClassRelease }
type
{ ------------------------------------------------------------------ }
@@ -53,7 +53,7 @@ type
procedure Clear;
function GetEnumerator: TObjectListEnumerator;
property Count: Integer read FCount;
- property Items[Index: Integer]: Pointer read Get write Put; default;
+ property Items[Index: Integer]: Pointer read Get write Put;
end;
implementation
diff --git a/stdlib/src/main/pascal/generics.collections.pas b/stdlib/src/main/pascal/generics.collections.pas
index 6199db5..7c393dd 100644
--- a/stdlib/src/main/pascal/generics.collections.pas
+++ b/stdlib/src/main/pascal/generics.collections.pas
@@ -302,10 +302,9 @@ end;
procedure TList.Delete(AIndex: Integer);
var
- Src: ^T;
- Dst: ^T;
- I: Integer;
- Empty: T;
+ Src: ^T;
+ Dst: ^T;
+ I: Integer;
begin
I := AIndex;
while I < Self.FCount - 1 do
@@ -315,47 +314,16 @@ begin
Dst^ := Src^;
I := I + 1
end;
- Self.FCount := Self.FCount - 1;
- { The shift leaves the (now unused) tail slot holding a duplicate of the last
- element; clear it so its managed ref is released, not leaked. }
- Dst := Self.FData + Self.FCount * SizeOf(T);
- Dst^ := Empty
+ Self.FCount := Self.FCount - 1
end;
procedure TList.Clear;
-var
- I: Integer;
- Slot: ^T;
- Empty: T;
begin
- { Release each managed element before dropping the count (see Destroy). }
- I := 0;
- while I < Self.FCount do
- begin
- Slot := Self.FData + I * SizeOf(T);
- Slot^ := Empty;
- I := I + 1
- end;
Self.FCount := 0
end;
procedure TList.Destroy;
-var
- I: Integer;
- Slot: ^T;
- Empty: T;
begin
- { Release each managed element so freeing the list cascades to its items
- (Blaise is reference-counted): storing a zero-initialised T through the
- slot runs the compiler's ARC discipline — the old element is released; for
- a plain (non-managed) T the store is a harmless zero write. }
- I := 0;
- while I < Self.FCount do
- begin
- Slot := Self.FData + I * SizeOf(T);
- Slot^ := Empty;
- I := I + 1
- end;
FreeMem(Self.FData);
Self.FData := nil;
Self.FCount := 0;
diff --git a/stdlib/src/main/pascal/json.writer.pas b/stdlib/src/main/pascal/json.writer.pas
index 4ecad32..31bd9e4 100644
--- a/stdlib/src/main/pascal/json.writer.pas
+++ b/stdlib/src/main/pascal/json.writer.pas
@@ -20,10 +20,10 @@
W.WriteBool('stable', True);
2. Array elements - value only, no name (the '...Value' forms):
- W.BeginArray();
+ W.BeginArray;
W.WriteStringValue('a');
W.WriteIntValue(1);
- W.EndArray();
+ W.EndArray;
3. Structure / escape hatch - when an object member's value is itself a
nested object or array, write the key, then open the container:
@@ -162,7 +162,7 @@ end;
destructor TJSONWriter.Destroy;
begin
FSB.Free();
- inherited Destroy();
+ inherited Destroy;
end;
procedure TJSONWriter.NewlineIndent(ALevel: Integer);
diff --git a/stdlib/src/main/pascal/net.http.server.pas b/stdlib/src/main/pascal/net.http.server.pas
index 80e6f54..0d4da1b 100644
--- a/stdlib/src/main/pascal/net.http.server.pas
+++ b/stdlib/src/main/pascal/net.http.server.pas
@@ -174,7 +174,7 @@ destructor THttpRequest.Destroy;
begin
Query.Free();
RawHeaders.Free();
- inherited Destroy();
+ inherited Destroy;
end;
function THttpRequest.QueryParam(const AName: string): string;
@@ -348,7 +348,7 @@ begin
if FListenFd >= 0 then
Close(FListenFd);
FWsClients.Free();
- inherited Destroy();
+ inherited Destroy;
end;
function THttpServer.Start: Boolean;
diff --git a/stdlib/src/main/pascal/security.crypto.pas b/stdlib/src/main/pascal/security.crypto.pas
index 2052c58..79a49fb 100644
--- a/stdlib/src/main/pascal/security.crypto.pas
+++ b/stdlib/src/main/pascal/security.crypto.pas
@@ -16,10 +16,6 @@
decisions. It remains required for interop where a protocol mandates it
(e.g. the WebSocket opening handshake, Git object ids).
- NB: MD5 is cryptographically broken and must not be used for new security
- decisions. It remains required for legacy interop where a protocol or
- existing system mandates it (e.g. content checksums, legacy API signatures).
-
Base64 lives in Encoding.Base64, not here: it is a text encoding, not crypto.
Compose them at the call site, e.g. Base64Encode(Sha1(Key + GUID)).
@@ -37,33 +33,10 @@ function Sha1(const AData: string): string;
{ SHA-1 digest as a 40-character lower-case hex string. }
function Sha1Hex(const AData: string): string;
-{ Raw 32-byte SHA-256 digest of AData (treated as raw bytes). }
-function Sha256(const AData: string): string;
-
-{ SHA-256 digest as a 64-character lower-case hex string. }
-function Sha256Hex(const AData: string): string;
-
-{ Raw 16-byte MD5 digest of AData (treated as raw bytes). }
-function Md5(const AData: string): string;
-
-{ MD5 digest as a 32-character lower-case hex string. }
-function Md5Hex(const AData: string): string;
-
-{ HMAC-SHA256 (RFC 2104 / RFC 4231). Returns raw 32-byte MAC.
- Keys longer than 64 bytes (SHA-256 block size) are hashed first. }
-function HmacSha256(const AKey, AData: string): string;
-
-{ HMAC-SHA256 as a 64-character lower-case hex string. }
-function HmacSha256Hex(const AKey, AData: string): string;
-
-{ Timing-safe comparison. XOR-accumulates all bytes up to the shorter
- length, then ORs in a length-mismatch flag. Never short-circuits. }
-function ConstantTimeEqual(const A, B: string): Boolean;
-
implementation
uses
- StrUtils;
+ Classes, StrUtils;
const
MASK32 = $FFFFFFFF;
@@ -73,29 +46,6 @@ begin
Result := ((V shl ABits) or (V shr (32 - ABits))) and MASK32;
end;
-function Rotr32(V: UInt32; ABits: Integer): UInt32;
-begin
- Result := ((V shr ABits) or (V shl (32 - ABits))) and MASK32;
-end;
-
-function DigestToHex(const ARaw: string): string;
-var
- SB: TStringBuilder;
- I, B: Integer;
-const
- Hex = '0123456789abcdef';
-begin
- SB := TStringBuilder.Create();
- for I := 0 to Length(ARaw) - 1 do
- begin
- B := Byte(ARaw[I]);
- SB.AppendByte(Byte(Hex[B div 16]));
- SB.AppendByte(Byte(Hex[B mod 16]));
- end;
- Result := SB.ToString();
- SB.Free();
-end;
-
function Sha1(const AData: string): string;
var
H0, H1, H2, H3, H4: UInt32;
@@ -205,326 +155,23 @@ begin
end;
function Sha1Hex(const AData: string): string;
-begin
- Result := DigestToHex(Sha1(AData));
-end;
-
-function Sha256(const AData: string): string;
-const
- K: array[0..63] of UInt32 = (
- $428a2f98, $71374491, $b5c0fbcf, $e9b5dba5,
- $3956c25b, $59f111f1, $923f82a4, $ab1c5ed5,
- $d807aa98, $12835b01, $243185be, $550c7dc3,
- $72be5d74, $80deb1fe, $9bdc06a7, $c19bf174,
- $e49b69c1, $efbe4786, $0fc19dc6, $240ca1cc,
- $2de92c6f, $4a7484aa, $5cb0a9dc, $76f988da,
- $983e5152, $a831c66d, $b00327c8, $bf597fc7,
- $c6e00bf3, $d5a79147, $06ca6351, $14292967,
- $27b70a85, $2e1b2138, $4d2c6dfc, $53380d13,
- $650a7354, $766a0abb, $81c2c92e, $92722c85,
- $a2bfe8a1, $a81a664b, $c24b8b70, $c76c51a3,
- $d192e819, $d6990624, $f40e3585, $106aa070,
- $19a4c116, $1e376c08, $2748774c, $34b0bcb5,
- $391c0cb3, $4ed8aa4a, $5b9cca4f, $682e6ff3,
- $748f82ee, $78a5636f, $84c87814, $8cc70208,
- $90befffa, $a4506ceb, $bef9a3f7, $c67178f2
- );
var
- H0, H1, H2, H3, H4, H5, H6, H7: UInt32;
- MsgLen, TotalBits: Int64;
- PadLen, I, T, ChunkStart, NumChunks, C: Integer;
- Msg: array[0..63] of Byte;
- W: array[0..63] of UInt32;
- A, B, Cc, D, E, F, G, Hh: UInt32;
- S0, S1, Ch, Maj, Temp1, Temp2: UInt32;
- PData: string;
- SB, OutSB: TStringBuilder;
+ Raw: string;
+ SB: TStringBuilder;
+ I, B: Integer;
+const
+ Hex = '0123456789abcdef';
begin
- MsgLen := Length(AData);
- TotalBits := MsgLen * 8;
-
- PadLen := 56 - ((MsgLen + 1) mod 64);
- if PadLen < 0 then
- PadLen := PadLen + 64;
-
+ Raw := Sha1(AData);
SB := TStringBuilder.Create();
- SB.Append(AData);
- SB.AppendByte(128);
- for I := 1 to PadLen do
- SB.AppendByte(0);
- for I := 7 downto 0 do
- SB.AppendByte((TotalBits shr (I * 8)) and $FF);
- PData := SB.ToString();
+ for I := 0 to Length(Raw) - 1 do
+ begin
+ B := Byte(Raw[I]);
+ SB.AppendByte(Byte(Hex[B div 16])); { Hex is 0-based in Blaise }
+ SB.AppendByte(Byte(Hex[B mod 16]));
+ end;
+ Result := SB.ToString();
SB.Free();
-
- H0 := $6a09e667;
- H1 := $bb67ae85;
- H2 := $3c6ef372;
- H3 := $a54ff53a;
- H4 := $510e527f;
- H5 := $9b05688c;
- H6 := $1f83d9ab;
- H7 := $5be0cd19;
-
- NumChunks := Length(PData) div 64;
- for C := 0 to NumChunks - 1 do
- begin
- ChunkStart := C * 64;
- for I := 0 to 63 do
- Msg[I] := Byte(PData[ChunkStart + I]);
-
- for T := 0 to 15 do
- W[T] := ((UInt32(Msg[T * 4]) shl 24) or
- (UInt32(Msg[T * 4 + 1]) shl 16) or
- (UInt32(Msg[T * 4 + 2]) shl 8) or
- UInt32(Msg[T * 4 + 3])) and MASK32;
-
- for T := 16 to 63 do
- begin
- S0 := (Rotr32(W[T-15], 7) xor Rotr32(W[T-15], 18) xor (W[T-15] shr 3)) and MASK32;
- S1 := (Rotr32(W[T-2], 17) xor Rotr32(W[T-2], 19) xor (W[T-2] shr 10)) and MASK32;
- W[T] := (W[T-16] + S0 + W[T-7] + S1) and MASK32;
- end;
-
- A := H0; B := H1; Cc := H2; D := H3;
- E := H4; F := H5; G := H6; Hh := H7;
-
- for T := 0 to 63 do
- begin
- S1 := (Rotr32(E, 6) xor Rotr32(E, 11) xor Rotr32(E, 25)) and MASK32;
- Ch := ((E and F) xor (((not E) and MASK32) and G)) and MASK32;
- Temp1 := (Hh + S1 + Ch + K[T] + W[T]) and MASK32;
- S0 := (Rotr32(A, 2) xor Rotr32(A, 13) xor Rotr32(A, 22)) and MASK32;
- Maj := ((A and B) xor (A and Cc) xor (B and Cc)) and MASK32;
- Temp2 := (S0 + Maj) and MASK32;
-
- Hh := G;
- G := F;
- F := E;
- E := (D + Temp1) and MASK32;
- D := Cc;
- Cc := B;
- B := A;
- A := (Temp1 + Temp2) and MASK32;
- end;
-
- H0 := (H0 + A) and MASK32;
- H1 := (H1 + B) and MASK32;
- H2 := (H2 + Cc) and MASK32;
- H3 := (H3 + D) and MASK32;
- H4 := (H4 + E) and MASK32;
- H5 := (H5 + F) and MASK32;
- H6 := (H6 + G) and MASK32;
- H7 := (H7 + Hh) and MASK32;
- end;
-
- OutSB := TStringBuilder.Create();
- OutSB.AppendByte((H0 shr 24) and $FF); OutSB.AppendByte((H0 shr 16) and $FF);
- OutSB.AppendByte((H0 shr 8) and $FF); OutSB.AppendByte(H0 and $FF);
- OutSB.AppendByte((H1 shr 24) and $FF); OutSB.AppendByte((H1 shr 16) and $FF);
- OutSB.AppendByte((H1 shr 8) and $FF); OutSB.AppendByte(H1 and $FF);
- OutSB.AppendByte((H2 shr 24) and $FF); OutSB.AppendByte((H2 shr 16) and $FF);
- OutSB.AppendByte((H2 shr 8) and $FF); OutSB.AppendByte(H2 and $FF);
- OutSB.AppendByte((H3 shr 24) and $FF); OutSB.AppendByte((H3 shr 16) and $FF);
- OutSB.AppendByte((H3 shr 8) and $FF); OutSB.AppendByte(H3 and $FF);
- OutSB.AppendByte((H4 shr 24) and $FF); OutSB.AppendByte((H4 shr 16) and $FF);
- OutSB.AppendByte((H4 shr 8) and $FF); OutSB.AppendByte(H4 and $FF);
- OutSB.AppendByte((H5 shr 24) and $FF); OutSB.AppendByte((H5 shr 16) and $FF);
- OutSB.AppendByte((H5 shr 8) and $FF); OutSB.AppendByte(H5 and $FF);
- OutSB.AppendByte((H6 shr 24) and $FF); OutSB.AppendByte((H6 shr 16) and $FF);
- OutSB.AppendByte((H6 shr 8) and $FF); OutSB.AppendByte(H6 and $FF);
- OutSB.AppendByte((H7 shr 24) and $FF); OutSB.AppendByte((H7 shr 16) and $FF);
- OutSB.AppendByte((H7 shr 8) and $FF); OutSB.AppendByte(H7 and $FF);
- Result := OutSB.ToString();
- OutSB.Free();
-end;
-
-function Sha256Hex(const AData: string): string;
-begin
- Result := DigestToHex(Sha256(AData));
-end;
-
-function Md5(const AData: string): string;
-const
- T: array[0..63] of UInt32 = (
- $d76aa478, $e8c7b756, $242070db, $c1bdceee,
- $f57c0faf, $4787c62a, $a8304613, $fd469501,
- $698098d8, $8b44f7af, $ffff5bb1, $895cd7be,
- $6b901122, $fd987193, $a679438e, $49b40821,
- $f61e2562, $c040b340, $265e5a51, $e9b6c7aa,
- $d62f105d, $02441453, $d8a1e681, $e7d3fbc8,
- $21e1cde6, $c33707d6, $f4d50d87, $455a14ed,
- $a9e3e905, $fcefa3f8, $676f02d9, $8d2a4c8a,
- $fffa3942, $8771f681, $6d9d6122, $fde5380c,
- $a4beea44, $4bdecfa9, $f6bb4b60, $bebfbc70,
- $289b7ec6, $eaa127fa, $d4ef3085, $04881d05,
- $d9d4d039, $e6db99e5, $1fa27cf8, $c4ac5665,
- $f4292244, $432aff97, $ab9423a7, $fc93a039,
- $655b59c3, $8f0ccc92, $ffeff47d, $85845dd1,
- $6fa87e4f, $fe2ce6e0, $a3014314, $4e0811a1,
- $f7537e82, $bd3af235, $2ad7d2bb, $eb86d391
- );
- S: array[0..63] of Integer = (
- 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22, 7, 12, 17, 22,
- 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20, 5, 9, 14, 20,
- 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23, 4, 11, 16, 23,
- 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21, 6, 10, 15, 21
- );
-var
- H0, H1, H2, H3: UInt32;
- MsgLen, TotalBits: Int64;
- PadLen, I, J, Chunk, ChunkStart, NumChunks, G: Integer;
- M: array[0..15] of UInt32;
- A, B, Cc, D, F, Tmp: UInt32;
- PData: string;
- SB, OutSB: TStringBuilder;
-begin
- MsgLen := Length(AData);
- TotalBits := MsgLen * 8;
-
- PadLen := 56 - ((MsgLen + 1) mod 64);
- if PadLen < 0 then
- PadLen := PadLen + 64;
-
- SB := TStringBuilder.Create();
- SB.Append(AData);
- SB.AppendByte(128);
- for I := 1 to PadLen do
- SB.AppendByte(0);
- { MD5 uses LITTLE-ENDIAN 64-bit bit length. }
- for I := 0 to 7 do
- SB.AppendByte((TotalBits shr (I * 8)) and $FF);
- PData := SB.ToString();
- SB.Free();
-
- H0 := $67452301;
- H1 := $efcdab89;
- H2 := $98badcfe;
- H3 := $10325476;
-
- NumChunks := Length(PData) div 64;
- for Chunk := 0 to NumChunks - 1 do
- begin
- ChunkStart := Chunk * 64;
- { Read 16 words in LITTLE-ENDIAN order. }
- for J := 0 to 15 do
- M[J] := (UInt32(Byte(PData[ChunkStart + J * 4 + 3])) shl 24) or
- (UInt32(Byte(PData[ChunkStart + J * 4 + 2])) shl 16) or
- (UInt32(Byte(PData[ChunkStart + J * 4 + 1])) shl 8) or
- UInt32(Byte(PData[ChunkStart + J * 4]));
-
- A := H0; B := H1; Cc := H2; D := H3;
-
- for I := 0 to 63 do
- begin
- if I < 16 then
- begin
- F := (B and Cc) or (((not B) and MASK32) and D);
- G := I;
- end
- else if I < 32 then
- begin
- F := (D and B) or (((not D) and MASK32) and Cc);
- G := (5 * I + 1) mod 16;
- end
- else if I < 48 then
- begin
- F := B xor Cc xor D;
- G := (3 * I + 5) mod 16;
- end
- else
- begin
- F := (Cc xor (B or ((not D) and MASK32))) and MASK32;
- G := (7 * I) mod 16;
- end;
- F := F and MASK32;
- Tmp := D;
- D := Cc;
- Cc := B;
- B := (B + Rotl32((A + F + T[I] + M[G]) and MASK32, S[I])) and MASK32;
- A := Tmp;
- end;
-
- H0 := (H0 + A) and MASK32;
- H1 := (H1 + B) and MASK32;
- H2 := (H2 + Cc) and MASK32;
- H3 := (H3 + D) and MASK32;
- end;
-
- { Emit 16 raw bytes, LITTLE-ENDIAN per word. }
- OutSB := TStringBuilder.Create();
- OutSB.AppendByte(H0 and $FF); OutSB.AppendByte((H0 shr 8) and $FF);
- OutSB.AppendByte((H0 shr 16) and $FF); OutSB.AppendByte((H0 shr 24) and $FF);
- OutSB.AppendByte(H1 and $FF); OutSB.AppendByte((H1 shr 8) and $FF);
- OutSB.AppendByte((H1 shr 16) and $FF); OutSB.AppendByte((H1 shr 24) and $FF);
- OutSB.AppendByte(H2 and $FF); OutSB.AppendByte((H2 shr 8) and $FF);
- OutSB.AppendByte((H2 shr 16) and $FF); OutSB.AppendByte((H2 shr 24) and $FF);
- OutSB.AppendByte(H3 and $FF); OutSB.AppendByte((H3 shr 8) and $FF);
- OutSB.AppendByte((H3 shr 16) and $FF); OutSB.AppendByte((H3 shr 24) and $FF);
- Result := OutSB.ToString();
- OutSB.Free();
-end;
-
-function Md5Hex(const AData: string): string;
-begin
- Result := DigestToHex(Md5(AData));
-end;
-
-function HmacSha256(const AKey, AData: string): string;
-const
- BLOCK_SIZE = 64; { SHA-256 block size; SHA-512 uses 128 }
-var
- KeyBlock: string;
- IPad, OPad: TStringBuilder;
- I: Integer;
- InnerHash: string;
-begin
- if Length(AKey) > BLOCK_SIZE then
- KeyBlock := Sha256(AKey)
- else
- KeyBlock := AKey;
-
- IPad := TStringBuilder.Create();
- OPad := TStringBuilder.Create();
- for I := 0 to BLOCK_SIZE - 1 do
- begin
- if I < Length(KeyBlock) then
- begin
- IPad.AppendByte(Byte(KeyBlock[I]) xor $36);
- OPad.AppendByte(Byte(KeyBlock[I]) xor $5C);
- end
- else
- begin
- IPad.AppendByte($36);
- OPad.AppendByte($5C);
- end;
- end;
-
- IPad.Append(AData);
- InnerHash := Sha256(IPad.ToString());
- IPad.Free();
-
- OPad.Append(InnerHash);
- Result := Sha256(OPad.ToString());
- OPad.Free();
-end;
-
-function HmacSha256Hex(const AKey, AData: string): string;
-begin
- Result := DigestToHex(HmacSha256(AKey, AData));
-end;
-
-function ConstantTimeEqual(const A, B: string): Boolean;
-var
- Diff, I, MinLen: Integer;
-begin
- Diff := Length(A) xor Length(B);
- MinLen := Length(A);
- if Length(B) < MinLen then
- MinLen := Length(B);
- for I := 0 to MinLen - 1 do
- Diff := Diff or (Byte(A[I]) xor Byte(B[I]));
- Result := Diff = 0;
end;
end.
diff --git a/stdlib/src/main/pascal/streams.pas b/stdlib/src/main/pascal/streams.pas
index f7be870..a9aaedc 100644
--- a/stdlib/src/main/pascal/streams.pas
+++ b/stdlib/src/main/pascal/streams.pas
@@ -372,17 +372,13 @@ function _FdSeek(Fd: Integer; Offset: Int64; Origin: Integer): Int64;
function _FdSize(Fd: Integer): Int64; external name '_FdSize';
procedure _FdClose(Fd: Integer); external name '_FdClose';
-{ Raw memory helpers used by the memory streams. memcpy is the C name (libc, or
- runtime.cstub under --static). malloc/free/realloc bind to the RTL's own
- mmap-backed allocator (_BlaiseGetMem/_BlaiseFreeMem/_BlaiseReallocMem) rather
- than libc, so the memory streams carry no libc dependency and link into a
- --static (libc-free) build. }
+{ Raw memory helpers used by the memory streams. These are libc functions
+ exposed by name; the Blaise codegen passes the arguments through unchanged. }
function memcpy(Dst, Src: Pointer; Count: Integer): Pointer;
external name 'memcpy';
-function malloc(Count: Integer): Pointer; external name '_BlaiseGetMem';
-procedure free(P: Pointer); external name '_BlaiseFreeMem';
-function realloc(P: Pointer; Count: Integer): Pointer;
- external name '_BlaiseReallocMem';
+function malloc(Count: Integer): Pointer; external name 'malloc';
+procedure free(P: Pointer); external name 'free';
+function realloc(P: Pointer; Count: Integer): Pointer; external name 'realloc';
{ CopyStream — transfer all readable bytes from Src to Dst.
diff --git a/stdlib/src/main/pascal/sysutils.pas b/stdlib/src/main/pascal/sysutils.pas
index e7bd525..0307789 100644
--- a/stdlib/src/main/pascal/sysutils.pas
+++ b/stdlib/src/main/pascal/sysutils.pas
@@ -64,18 +64,6 @@ function BoolToStr(B: Boolean; AUseBoolStrs: Boolean = False): string;
on paths that do not traverse symlinks. }
function ExpandFileName(const APath: string): string;
-{ SameFileName — compare two file names for equality.
-
- PARTIAL STUB: an exact, case-sensitive string comparison. This is correct
- only on case-sensitive file systems (Unix); case-insensitive platforms
- (Windows) would need the names folded before comparing. Blaise has no
- platform-variance facility yet — system.pas hardcodes DirectorySeparator,
- PathSeparator and LineEnding to their Unix values — so there is nothing to
- key the case-folding on. When a FileNameCaseSensitive constant lands
- alongside the other platform constants, add the case-insensitive branch
- here under that guard. }
-function SameFileName(const S1, S2: string): Boolean;
-
implementation
constructor Exception.Create(AMessage: string);
@@ -157,12 +145,4 @@ begin
Result := '/';
end;
-{ PARTIAL STUB — exact compare only; see the interface note. Correct on
- case-sensitive (Unix) file systems; needs a case-insensitive branch for
- Windows. }
-function SameFileName(const S1, S2: string): Boolean;
-begin
- Result := S1 = S2;
-end;
-
end.
diff --git a/stdlib/src/test/pascal/crypto.tests.pas b/stdlib/src/test/pascal/crypto.tests.pas
index dc57c03..759425e 100644
--- a/stdlib/src/test/pascal/crypto.tests.pas
+++ b/stdlib/src/test/pascal/crypto.tests.pas
@@ -14,7 +14,7 @@ unit Crypto.Tests;
interface
uses
- blaise.testing, Security.Crypto, Encoding.Base64, StrUtils;
+ blaise.testing, Security.Crypto, Encoding.Base64;
type
TCryptoTests = class(TTestCase)
@@ -22,15 +22,6 @@ type
procedure TestSha1Hex_KnownVectors;
procedure TestSha1_DigestLength;
procedure TestSha1Base64_WebSocketHandshake;
- procedure TestSha256Hex_KnownVectors;
- procedure TestSha256_DigestLength;
- procedure TestSha256Hex_BoundaryVectors;
- procedure TestMd5Hex_KnownVectors;
- procedure TestMd5_DigestLength;
- procedure TestHmacSha256Hex_KnownVectors;
- procedure TestHmacSha256_DigestLength;
- procedure TestHmacSha256Hex_LongKey;
- procedure TestConstantTimeEqual;
end;
implementation
@@ -60,148 +51,6 @@ begin
Base64Encode(Sha1('dGhlIHNhbXBsZSBub25jZQ==' + GUID)));
end;
-procedure TCryptoTests.TestSha256Hex_KnownVectors;
-begin
- { NIST CAVP / FIPS 180-4 SHA-256 test vectors. }
- AssertEquals('empty',
- 'e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855',
- Sha256Hex(''));
- AssertEquals('abc',
- 'ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad',
- Sha256Hex('abc'));
- AssertEquals('448-bit (56 bytes, 2-block)',
- '248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1',
- Sha256Hex('abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'));
- AssertEquals('896-bit (112 bytes, multi-block)',
- 'cf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1',
- Sha256Hex('abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu'));
-end;
-
-procedure TCryptoTests.TestSha256_DigestLength;
-begin
- AssertEquals('raw digest is 32 bytes', 32, Length(Sha256('anything')));
-end;
-
-procedure TCryptoTests.TestSha256Hex_BoundaryVectors;
-begin
- { 55 bytes: padding (0x80 + 8-byte length = 9 bytes) fits in one 64-byte block. }
- AssertEquals('55-byte single-block boundary',
- '9f4390f8d30c2dd92ec9f095b65e2b9ae9b0a925a5258e241c9f1e910f734318',
- Sha256Hex('aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa'));
-end;
-
-procedure TCryptoTests.TestMd5Hex_KnownVectors;
-begin
- { RFC 1321 Appendix A.5 — all 7 test vectors. }
- AssertEquals('empty',
- 'd41d8cd98f00b204e9800998ecf8427e', Md5Hex(''));
- AssertEquals('a',
- '0cc175b9c0f1b6a831c399e269772661', Md5Hex('a'));
- AssertEquals('abc',
- '900150983cd24fb0d6963f7d28e17f72', Md5Hex('abc'));
- AssertEquals('message digest',
- 'f96b697d7cb7938d525a2f31aaf161d0', Md5Hex('message digest'));
- AssertEquals('a..z',
- 'c3fcd3d76192e4007dfb496cca67e13b', Md5Hex('abcdefghijklmnopqrstuvwxyz'));
- AssertEquals('A..Za..z0..9',
- 'd174ab98d277d9f5a5611c2c9f419d9f',
- Md5Hex('ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789'));
- AssertEquals('8x 1234567890',
- '57edf4a22be3c955ac49da2e2107b67a',
- Md5Hex('12345678901234567890123456789012345678901234567890123456789012345678901234567890'));
-end;
-
-procedure TCryptoTests.TestMd5_DigestLength;
-begin
- AssertEquals('raw digest is 16 bytes', 16, Length(Md5('anything')));
-end;
-
-procedure TCryptoTests.TestHmacSha256Hex_KnownVectors;
-var
- KeySB, DataSB: TStringBuilder;
- I: Integer;
- Key1, Data1, Key3, Data3: string;
-begin
- { RFC 4231 Test Case 1: 20-byte key of 0x0b, data = "Hi There" }
- KeySB := TStringBuilder.Create();
- for I := 0 to 19 do
- KeySB.AppendByte($0b);
- Key1 := KeySB.ToString();
- KeySB.Free();
- AssertEquals('TC1',
- 'b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7',
- HmacSha256Hex(Key1, 'Hi There'));
-
- { RFC 4231 Test Case 2: key = "Jefe", data = "what do ya want for nothing?" }
- AssertEquals('TC2',
- '5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843',
- HmacSha256Hex('Jefe', 'what do ya want for nothing?'));
-
- { RFC 4231 Test Case 3: 20-byte key of 0xaa, 50-byte data of 0xdd }
- KeySB := TStringBuilder.Create();
- for I := 0 to 19 do
- KeySB.AppendByte($aa);
- Key3 := KeySB.ToString();
- KeySB.Free();
- DataSB := TStringBuilder.Create();
- for I := 0 to 49 do
- DataSB.AppendByte($dd);
- Data3 := DataSB.ToString();
- DataSB.Free();
- AssertEquals('TC3',
- '773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe',
- HmacSha256Hex(Key3, Data3));
-end;
-
-procedure TCryptoTests.TestHmacSha256_DigestLength;
-begin
- AssertEquals('raw HMAC is 32 bytes', 32,
- Length(HmacSha256('key', 'data')));
-end;
-
-procedure TCryptoTests.TestHmacSha256Hex_LongKey;
-var
- KeySB, DataSB: TStringBuilder;
- I: Integer;
- LongKey, Data: string;
-begin
- { RFC 4231 Test Case 5: 131-byte key of 0xaa (> 64-byte block size),
- data = "Test Using Larger Than Block-Size Key - Hash Key First" }
- KeySB := TStringBuilder.Create();
- for I := 0 to 130 do
- KeySB.AppendByte($aa);
- LongKey := KeySB.ToString();
- KeySB.Free();
- AssertEquals('TC5 long key',
- '60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54',
- HmacSha256Hex(LongKey, 'Test Using Larger Than Block-Size Key - Hash Key First'));
-
- { RFC 4231 Test Case 6: same 131-byte key,
- data = "This is a test using a larger than block-size key and a larger than block-size data. The key needs to be hashed before being used by the HMAC algorithm." }
- AssertEquals('TC6 long key+data',
- '9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2',
- HmacSha256Hex(LongKey,
- 'This is a test using a larger than block-size key and a ' +
- 'larger than block-size data. The key needs to be hashed ' +
- 'before being used by the HMAC algorithm.'));
-end;
-
-procedure TCryptoTests.TestConstantTimeEqual;
-begin
- AssertTrue('equal strings', ConstantTimeEqual('abc', 'abc'));
- AssertTrue('both empty', ConstantTimeEqual('', ''));
- AssertFalse('different content', ConstantTimeEqual('abc', 'abd'));
- AssertFalse('different lengths', ConstantTimeEqual('abc', 'ab'));
- AssertFalse('one empty', ConstantTimeEqual('abc', ''));
- AssertFalse('other empty', ConstantTimeEqual('', 'abc'));
- AssertTrue('long equal', ConstantTimeEqual(
- 'The quick brown fox jumps over the lazy dog',
- 'The quick brown fox jumps over the lazy dog'));
- AssertFalse('long differ last byte', ConstantTimeEqual(
- 'The quick brown fox jumps over the lazy dog',
- 'The quick brown fox jumps over the lazy doh'));
-end;
-
initialization
RegisterTest(TCryptoTests);
diff --git a/tests/phase2_milestone.pas b/tests/phase2_milestone.pas
index 8905731..82db173 100644
--- a/tests/phase2_milestone.pas
+++ b/tests/phase2_milestone.pas
@@ -92,7 +92,7 @@ begin
Result := N.FValue;
Self.FHead := N.FNext;
Self.FCount := Self.FCount - 1;
- N.Free()
+ N.Free
end;
procedure TLinkedList.Walk;
@@ -120,7 +120,7 @@ begin
while N <> nil do
begin
Next := N.FNext;
- N.Free();
+ N.Free;
N := Next
end;
Self.FHead := nil;
@@ -145,7 +145,7 @@ begin
WriteLn('count=', List.Count); { 4 }
WriteLn('--- walk ---');
- List.Walk(); { 40/tag0, 30/tag1/marked, 20/tag0, 10/tag0 }
+ List.Walk; { 40/tag0, 30/tag1/marked, 20/tag0, 10/tag0 }
{ Pop two values off the front }
V := List.Pop();
@@ -155,7 +155,7 @@ begin
WriteLn('count_after_pops=', List.Count); { 2 }
finally
- List.Clear();
- List.Free()
+ List.Clear;
+ List.Free
end
end.
diff --git a/tests/phase3_milestone.pas b/tests/phase3_milestone.pas
index beab9dc..84c4bef 100644
--- a/tests/phase3_milestone.pas
+++ b/tests/phase3_milestone.pas
@@ -56,7 +56,7 @@ var
Dest: ^Integer;
begin
if Self.FCount = Self.FCapacity then
- Self.Grow();
+ Self.Grow;
Dest := Self.FData + Self.FCount * SizeOf(Integer);
Dest^ := Value;
Self.FCount := Self.FCount + 1
@@ -147,7 +147,7 @@ begin
else
begin
if Self.FCount = Self.FCapacity then
- Self.Grow();
+ Self.Grow;
KPtr := Self.FKeys + Self.FCount * SizeOf(string);
VPtr := Self.FValues + Self.FCount * SizeOf(Integer);
KPtr^ := Key;
@@ -251,7 +251,7 @@ begin
WriteLn('count_after_delete=', List.Count); { 4 }
WriteLn('list[1]_after_delete=', List.Get(1)); { 30 }
- List.Free();
+ List.Free;
{ --- TDictionary --- }
Dict := TStrIntDict.Create;
@@ -277,5 +277,5 @@ begin
Found := Dict.ContainsKey('alpha');
WriteLn('has_alpha_after_remove=', Found); { 0 }
- Dict.Free()
+ Dict.Free
end.
diff --git a/tools/bif-coverage/bif-coverage.status b/tools/bif-coverage/bif-coverage.status
index 0b8cfe7..9eee6a0 100644
--- a/tools/bif-coverage/bif-coverage.status
+++ b/tools/bif-coverage/bif-coverage.status
@@ -42,13 +42,10 @@ TIdentExpr.IsImplicitSelf safe
TIdentExpr.IsImplicitSelfMethod safe
TIdentExpr.IsMetaclassRef safe
TIdentExpr.ConstArraySymbol safe
-TIdentExpr.QualifierUnit serialise
-TIdentExpr.ResolvedOwnerUnit safe
# TFieldAccessExpr (uAST.pas:118)
TFieldAccessExpr.RecordName serialise
TFieldAccessExpr.FieldName serialise
-TFieldAccessExpr.QualifierUnit serialise
TFieldAccessExpr.Base serialise
TFieldAccessExpr.FieldInfo safe
TFieldAccessExpr.IsConstant safe
@@ -71,38 +68,34 @@ TFieldAccessExpr.IsVarParam safe
TFieldAccessExpr.PropIndexExpr serialise
TFieldAccessExpr.IsCharAccess safe
TFieldAccessExpr.IsArrayAccess safe
-TFieldAccessExpr.IsClassVarRead safe
-TFieldAccessExpr.ClassVarEmitName safe
-TFieldAccessExpr.IsStaticPropGet safe
-TFieldAccessExpr.BackingFieldRedirect safe
-# TIsExpr (uAST.pas:154)
+# TIsExpr (uAST.pas:151)
TIsExpr.Obj serialise
TIsExpr.TypeName serialise
-# TAsExpr (uAST.pas:162)
+# TAsExpr (uAST.pas:159)
TAsExpr.Obj serialise
TAsExpr.TypeName serialise
-# TSupportsExpr (uAST.pas:171)
+# TSupportsExpr (uAST.pas:168)
TSupportsExpr.Obj serialise
TSupportsExpr.IntfTypeName serialise
TSupportsExpr.OutVarName serialise
TSupportsExpr.OutVarIsGlobal safe
-# TInheritedCallExpr (uAST.pas:185)
+# TInheritedCallExpr (uAST.pas:182)
TInheritedCallExpr.Name serialise
TInheritedCallExpr.Args serialise
-# TBinaryExpr (uAST.pas:202)
+# TBinaryExpr (uAST.pas:199)
TBinaryExpr.Op serialise
TBinaryExpr.Left serialise
TBinaryExpr.Right serialise
-# TNotExpr (uAST.pas:210)
+# TNotExpr (uAST.pas:207)
TNotExpr.Expr serialise
-# TAssignment (uAST.pas:222)
+# TAssignment (uAST.pas:219)
TAssignment.Name serialise
TAssignment.Expr serialise
TAssignment.IsVarParam safe
@@ -110,28 +103,24 @@ TAssignment.IsGlobal safe
TAssignment.IsThreadVar safe
TAssignment.IsWeakLhs safe
TAssignment.ImplicitSelfField safe
-TAssignment.ResolvedOwnerUnit safe
-# TIfStmt (uAST.pas:238)
+# TIfStmt (uAST.pas:235)
TIfStmt.Condition serialise
TIfStmt.ThenStmt serialise
TIfStmt.ElseStmt serialise
-# TCompoundStmt (uAST.pas:246)
+# TCompoundStmt (uAST.pas:243)
TCompoundStmt.Stmts serialise
-# TAsmStmt (uAST.pas:256)
-TAsmStmt.Code serialise
-
-# TWhileStmt (uAST.pas:261)
+# TWhileStmt (uAST.pas:250)
TWhileStmt.Condition serialise
TWhileStmt.Body serialise
-# TRepeatStmt (uAST.pas:268)
+# TRepeatStmt (uAST.pas:257)
TRepeatStmt.Body serialise
TRepeatStmt.Condition serialise
-# TForStmt (uAST.pas:275)
+# TForStmt (uAST.pas:264)
TForStmt.VarName serialise
TForStmt.IsGlobal safe
TForStmt.StartExpr serialise
@@ -139,7 +128,7 @@ TForStmt.EndExpr serialise
TForStmt.IsDownTo serialise
TForStmt.Body serialise
-# TForInStmt (uAST.pas:286)
+# TForInStmt (uAST.pas:275)
TForInStmt.VarName serialise
TForInStmt.VarIsGlobal safe
TForInStmt.CollExpr serialise
@@ -159,34 +148,34 @@ TForInStmt.SetBitCount safe
TForInStmt.SetMaskVarName safe
TForInStmt.SetIsJumbo safe
-# TTryFinallyStmt (uAST.pas:323)
+# TTryFinallyStmt (uAST.pas:312)
TTryFinallyStmt.TryBody serialise
TTryFinallyStmt.FinallyBody serialise
-# TTryExceptStmt (uAST.pas:340)
+# TTryExceptStmt (uAST.pas:329)
TTryExceptStmt.TryBody serialise
TTryExceptStmt.Handlers serialise
TTryExceptStmt.ElseBody serialise
TTryExceptStmt.ExceptBody serialise
-# TRaiseStmt (uAST.pas:353)
+# TRaiseStmt (uAST.pas:342)
TRaiseStmt.Expr serialise
-# TExitStmt (uAST.pas:364)
+# TExitStmt (uAST.pas:353)
TExitStmt.Value serialise
TExitStmt.ResultAssign safe
-# TBreakStmt (uAST.pas:372)
+# TBreakStmt (uAST.pas:361)
-# TContinueStmt (uAST.pas:375)
+# TContinueStmt (uAST.pas:364)
-# TCaseStmt (uAST.pas:386)
+# TCaseStmt (uAST.pas:375)
TCaseStmt.Selector serialise
TCaseStmt.Branches serialise
TCaseStmt.ElseStmt serialise
TCaseStmt.IsStringCase safe
-# TFieldAssignment (uAST.pas:397)
+# TFieldAssignment (uAST.pas:386)
TFieldAssignment.RecordName serialise
TFieldAssignment.FieldName serialise
TFieldAssignment.Expr serialise
@@ -200,10 +189,8 @@ TFieldAssignment.PropIndexExpr serialise
TFieldAssignment.PropOwnerType safe
TFieldAssignment.PropAccessorVSlot safe
TFieldAssignment.IsElemWrite safe
-TFieldAssignment.IsClassVarWrite safe
-TFieldAssignment.ClassVarEmitName safe
-# TStaticSubscriptAssign (uAST.pas:425)
+# TStaticSubscriptAssign (uAST.pas:414)
TStaticSubscriptAssign.ArrayName serialise
TStaticSubscriptAssign.IndexExpr serialise
TStaticSubscriptAssign.ValueExpr serialise
@@ -214,19 +201,18 @@ TStaticSubscriptAssign.IsImplicitSelf safe
TStaticSubscriptAssign.PropOwnerType safe
TStaticSubscriptAssign.PropAccessorVSlot safe
-# TPointerWriteStmt (uAST.pas:455)
+# TPointerWriteStmt (uAST.pas:444)
TPointerWriteStmt.PtrExpr serialise
TPointerWriteStmt.ValExpr serialise
-# TProcCall (uAST.pas:463)
+# TProcCall (uAST.pas:452)
TProcCall.Name serialise
TProcCall.Args serialise
TProcCall.IsImplicitSelfMethod safe
TProcCall.IsIndirectCall safe
TProcCall.IndirectCallIsGlobal safe
-TProcCall.IsProcFieldCall safe
-# TFuncCallExpr (uAST.pas:480)
+# TFuncCallExpr (uAST.pas:465)
TFuncCallExpr.Name serialise
TFuncCallExpr.Args serialise
TFuncCallExpr.IsImplicitSelfMethod safe
@@ -235,20 +221,19 @@ TFuncCallExpr.IndirectCallIsGlobal safe
TFuncCallExpr.IsBuiltinHasClassAttr safe
TFuncCallExpr.HasClassAttrClass safe
TFuncCallExpr.HasClassAttrAttr safe
-TFuncCallExpr.IsProcFieldCall safe
-# TIndirectFuncCallExpr (uAST.pas:510)
+# TIndirectFuncCallExpr (uAST.pas:491)
TIndirectFuncCallExpr.CalleeExpr serialise
TIndirectFuncCallExpr.Args serialise
-# TDerefExpr (uAST.pas:520)
+# TDerefExpr (uAST.pas:501)
TDerefExpr.Expr serialise
-# TAddrOfExpr (uAST.pas:527)
+# TAddrOfExpr (uAST.pas:508)
TAddrOfExpr.Expr serialise
TAddrOfExpr.ResolvedFreeRoutine safe
-# TMethodCallStmt (uAST.pas:539)
+# TMethodCallStmt (uAST.pas:520)
TMethodCallStmt.ObjectName serialise
TMethodCallStmt.Name serialise
TMethodCallStmt.Args serialise
@@ -259,22 +244,19 @@ TMethodCallStmt.IsVarParam safe
TMethodCallStmt.IsBuiltinToString safe
TMethodCallStmt.IsConstructorCall safe
TMethodCallStmt.IsMetaclassDispatch safe
-TMethodCallStmt.IsStaticCall safe
TMethodCallStmt.IsProcFieldCall safe
-# TInheritedCallStmt (uAST.pas:576)
+# TInheritedCallStmt (uAST.pas:554)
TInheritedCallStmt.Name serialise
TInheritedCallStmt.Args serialise
-# TMethodCallExpr (uAST.pas:881)
+# TMethodCallExpr (uAST.pas:835)
TMethodCallExpr.ObjectName serialise
TMethodCallExpr.Name serialise
-TMethodCallExpr.QualifierUnit serialise
TMethodCallExpr.Args serialise
TMethodCallExpr.ObjExpr serialise
TMethodCallExpr.IsConstructorCall safe
TMethodCallExpr.IsMetaclassDispatch safe
-TMethodCallExpr.IsStaticCall safe
TMethodCallExpr.IsGlobal safe
TMethodCallExpr.IsVarParam safe
TMethodCallExpr.IsBuiltinToString safe
@@ -298,20 +280,17 @@ TRoutineSig.VTableSlot serialise
TRoutineSig.ResolvedQbeName serialise
TRoutineSig.IsVirtual serialise
TRoutineSig.IsOverride serialise
-TRoutineSig.IsStatic serialise
-TRoutineSig.IsOverload serialise
-TRoutineSig.Visibility serialise
-# TConstEntry (uUnitInterface.pas:102)
+# TConstEntry (uUnitInterface.pas:97)
TConstEntry.Decl serialise
TConstEntry.TypeRef serialise
-# TVarEntry (uUnitInterface.pas:110)
+# TVarEntry (uUnitInterface.pas:105)
TVarEntry.Name serialise
TVarEntry.TypeRef serialise
TVarEntry.IsThreadVar serialise
-# TUnitInterface (uUnitInterface.pas:174)
+# TUnitInterface (uUnitInterface.pas:169)
TUnitInterface.Name serialise
TUnitInterface.SourceFile serialise
TUnitInterface.SourceHash serialise
@@ -319,10 +298,9 @@ TUnitInterface.SourceModTime serialise
TUnitInterface.CompilerId serialise
TUnitInterface.UsedUnits serialise
TUnitInterface.ImplUsedUnits serialise
-TUnitInterface.LinkLibs serialise
TUnitInterface.HasInitialization serialise
-# TMethodParam (uAST.pas:798)
+# TMethodParam (uAST.pas:764)
TMethodParam.ParamName serialise
TMethodParam.TypeName serialise
TMethodParam.IsVarParam serialise
diff --git a/tools/bif-coverage/project.xml b/tools/bif-coverage/project.xml
index 9f0c97d..fa94320 100644
--- a/tools/bif-coverage/project.xml
+++ b/tools/bif-coverage/project.xml
@@ -11,8 +11,6 @@
src/main/pascal
../../compiler/src/main/pascal
-
- ../../stdlib/src/main/pascal
diff --git a/tools/bif-coverage/src/main/pascal/BifCoverage.pas b/tools/bif-coverage/src/main/pascal/BifCoverage.pas
index 56df261..87c3c9b 100644
--- a/tools/bif-coverage/src/main/pascal/BifCoverage.pas
+++ b/tools/bif-coverage/src/main/pascal/BifCoverage.pas
@@ -135,14 +135,14 @@ var
constructor TASTClass.Create;
begin
- inherited Create();
+ inherited Create;
Fields := TList.Create;
FieldLines := TList.Create;
end;
constructor TIOBlock.Create;
begin
- inherited Create();
+ inherited Create;
end;
function IsIdentStart(C: Integer): Boolean;
@@ -357,7 +357,7 @@ begin
Tok := ReadIdent(Stripped, P);
if Tok = '' then
begin
- Result.Clear();
+ Result.Clear;
Exit;
end;
Result.Add(Tok);
@@ -372,7 +372,7 @@ begin
(* Must be followed by `:` then a type, then a `;` somewhere. *)
if (P >= Len) or (StrAt(Stripped, P) <> Ord(':')) then
begin
- Result.Clear();
+ Result.Clear;
Exit;
end;
end;
@@ -515,7 +515,7 @@ begin
Allow.Add(GIfaceTypes[I]);
ScanClassFile(GIfaceFile, GIfaceNames, GIfaceObjs, Allow);
- Allow.Clear();
+ Allow.Clear;
Allow.Add('TMethodParam');
ScanClassFile(GAstFile, GIfaceNames, GIfaceObjs, Allow);
end;
diff --git a/tools/kanban/src/main/pascal/kanban_app.pas b/tools/kanban/src/main/pascal/kanban_app.pas
index df79f09..501438c 100644
--- a/tools/kanban/src/main/pascal/kanban_app.pas
+++ b/tools/kanban/src/main/pascal/kanban_app.pas
@@ -67,7 +67,7 @@ begin
Arg := ParamStr(I);
if (Arg = '--help') or (Arg = '-h') then
- PrintUsage()
+ PrintUsage
else if Arg = '--add' then
begin