diff --git a/compiler/src/main/pascal/uCodeGenQBE.pas b/compiler/src/main/pascal/uCodeGenQBE.pas index 1832875..96e522d 100644 --- a/compiler/src/main/pascal/uCodeGenQBE.pas +++ b/compiler/src/main/pascal/uCodeGenQBE.pas @@ -1365,6 +1365,16 @@ begin { Standalone function call expression } with TFuncCallExpr(AExpr) do begin + { SizeOf(TypeName) → integer literal = byte size of the type } + if SameText(Name, 'SizeOf') then + begin + T := AllocTemp; + EmitLine(Format(' %s =w copy %d', + [T, TASTExpr(Args[0]).ResolvedType.ByteSize])); + Result := T; + Exit; + end; + { GetMem(N) → malloc(N) → pointer } if SameText(Name, 'GetMem') then begin @@ -1476,9 +1486,9 @@ begin FldAccess := TFieldAccessExpr(AExpr); if FldAccess.IsConstructorCall then begin - { TypeName.Create — allocate instance on heap } + { TypeName.Create — allocate zeroed instance on heap (calloc zeros all fields) } T := AllocTemp; - EmitLine(Format(' %s =l call $malloc(l %d)', + EmitLine(Format(' %s =l call $calloc(l 1, l %d)', [T, TRecordTypeDesc(FldAccess.ResolvedType).TotalSize])); { Store vtable pointer at offset 0 if this class has virtual methods } if TRecordTypeDesc(FldAccess.ResolvedType).HasVTable then diff --git a/compiler/src/main/pascal/uSemantic.pas b/compiler/src/main/pascal/uSemantic.pas index e7f6fbf..8a7649e 100644 --- a/compiler/src/main/pascal/uSemantic.pas +++ b/compiler/src/main/pascal/uSemantic.pas @@ -31,6 +31,8 @@ type { Generic type instantiation: resolves 'TBox' on demand. } function FindTypeOrInstantiate(const AName: string): TTypeDesc; function InstantiateGeneric(const ATypeName: string): TRecordTypeDesc; + function SubstTypeParam(const ATypeName: string; + AParamNames, AArgs: TStringList): string; { Generic function instantiation: resolves 'Identity' on demand. } function InstantiateGenericFunc(const AInstName: string): TMethodDecl; @@ -131,9 +133,19 @@ var begin if AExpected = AActual then Exit; - { nil is compatible with any class or interface type } - if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface]) then + { nil is compatible with any class, interface, or pointer type } + if (AActual.Kind = tyNil) and (AExpected.Kind in [tyClass, tyInterface, tyPointer]) then Exit; + { Two pointer types are compatible when: + - either is untyped (Pointer), or + - both are typed pointers to the same base type } + if (AExpected.Kind = tyPointer) and (AActual.Kind = tyPointer) then + begin + if (TPointerTypeDesc(AExpected).BaseType = nil) or + (TPointerTypeDesc(AActual).BaseType = nil) or + (TPointerTypeDesc(AExpected).BaseType = TPointerTypeDesc(AActual).BaseType) then + Exit; + end; { subtype assignment: TDerived → TBase is allowed } if IsSubtypeOf(AActual, AExpected) then Exit; @@ -355,6 +367,24 @@ begin Result := InstantiateGeneric(AName); end; +function TSemanticAnalyser.SubstTypeParam(const ATypeName: string; + AParamNames, AArgs: TStringList): string; +var + I: Integer; +begin + Result := ATypeName; + { Direct match: T → Integer } + for I := 0 to AParamNames.Count - 1 do + if SameText(Result, AParamNames[I]) then + begin + Result := AArgs[I]; + Exit; + end; + { Prefix caret: ^T → ^Integer, ^^T → ^^Integer, etc. } + if (Length(Result) > 0) and (Result[1] = '^') then + Result := '^' + Self.SubstTypeParam(Copy(Result, 2, MaxInt), AParamNames, AArgs); +end; + function TSemanticAnalyser.InstantiateGeneric(const ATypeName: string): TRecordTypeDesc; var BracPos: Integer; @@ -376,8 +406,9 @@ var FldName: string; ParType: TTypeDesc; RT: TRecordTypeDesc; - GI: TGenericInstance; - Subst: string; + GI: TGenericInstance; + Subst: string; + ConcrType: TTypeDesc; begin Result := nil; @@ -420,21 +451,14 @@ begin for I := 0 to Templ.ClassDef.ImplementsNames.Count - 1 do ClonedCD.ImplementsNames.Add(Templ.ClassDef.ImplementsNames[I]); - { Clone fields with type-param substitution } + { Clone fields with type-param substitution (handles ^T → ^Integer etc.) } for I := 0 to Templ.ClassDef.Fields.Count - 1 do begin FDecl := TFieldDecl(Templ.ClassDef.Fields[I]); NewFDecl := TFieldDecl.Create; for J := 0 to FDecl.Names.Count - 1 do NewFDecl.Names.Add(FDecl.Names[J]); - Subst := FDecl.TypeName; - for K := 0 to Templ.ParamNames.Count - 1 do - if SameText(Subst, Templ.ParamNames[K]) then - begin - Subst := Args[K]; - Break; - end; - NewFDecl.TypeName := Subst; + NewFDecl.TypeName := SubstTypeParam(FDecl.TypeName, Templ.ParamNames, Args); ClonedCD.Fields.Add(NewFDecl); end; @@ -456,25 +480,12 @@ begin NewPar := TMethodParam.Create; NewPar.ParamName := Par.ParamName; NewPar.IsVarParam := Par.IsVarParam; - Subst := Par.TypeName; - for K := 0 to Templ.ParamNames.Count - 1 do - if SameText(Subst, Templ.ParamNames[K]) then - begin - Subst := Args[K]; - Break; - end; - NewPar.TypeName := Subst; + NewPar.TypeName := SubstTypeParam(Par.TypeName, Templ.ParamNames, Args); NewMDecl.Params.Add(NewPar); end; - Subst := MDecl.ReturnTypeName; - for K := 0 to Templ.ParamNames.Count - 1 do - if SameText(Subst, Templ.ParamNames[K]) then - begin - Subst := Args[K]; - Break; - end; - NewMDecl.ReturnTypeName := Subst; + NewMDecl.ReturnTypeName := + SubstTypeParam(MDecl.ReturnTypeName, Templ.ParamNames, Args); ClonedCD.Methods.Add(NewMDecl); end; @@ -542,12 +553,28 @@ begin end; end; - { Analyse method bodies with concrete types in scope } - for J := 0 to ClonedCD.Methods.Count - 1 do - begin - NewMDecl := TMethodDecl(ClonedCD.Methods[J]); - if NewMDecl.Body <> nil then - AnalyseMethodDecl(NewMDecl, RT); + { Analyse method bodies with concrete types in scope. + Push type-param bindings (T=Integer etc.) so that SizeOf(T) and + local var declarations like 'var P: ^T' resolve to concrete types. } + FTable.PushScope; + try + for K := 0 to Templ.ParamNames.Count - 1 do + begin + ConcrType := FindTypeOrInstantiate(Args[K]); + if ConcrType <> nil then + begin + Sym := TSymbol.Create(Templ.ParamNames[K], skType, ConcrType); + FTable.Define(Sym); + end; + end; + for J := 0 to ClonedCD.Methods.Count - 1 do + begin + NewMDecl := TMethodDecl(ClonedCD.Methods[J]); + if NewMDecl.Body <> nil then + AnalyseMethodDecl(NewMDecl, RT); + end; + finally + FTable.PopScope; end; { Register the instantiation for codegen } @@ -1590,6 +1617,22 @@ var Idx: Integer; I: Integer; begin + { SizeOf(TypeName) — compile-time type size, returns Integer } + if SameText(AExpr.Name, 'SizeOf') then + begin + if AExpr.Args.Count <> 1 then + SemanticError('SizeOf requires exactly one argument', AExpr.Line, AExpr.Col); + if AExpr.Args[0] is TIdentExpr then + begin + Sym := FTable.Lookup(TIdentExpr(AExpr.Args[0]).Name); + if (Sym <> nil) and (Sym.Kind = skType) then + TIdentExpr(AExpr.Args[0]).ResolvedType := Sym.TypeDesc; + end; + Result := FTable.TypeInteger; + AExpr.ResolvedType := Result; + Exit; + end; + Sym := FTable.Lookup(AExpr.Name); if Sym = nil then begin @@ -1842,11 +1885,12 @@ begin if IsComparisonOp(ABin.Op) then begin - { nil can be compared with class types } + { nil can be compared with class, interface, or pointer types } if not ( (LType = RType) or - ((LType.Kind = tyNil) and (RType.Kind = tyClass)) or - ((LType.Kind = tyClass) and (RType.Kind = tyNil)) + ((LType.Kind = tyNil) and (RType.Kind in [tyClass, tyInterface, tyPointer])) or + ((RType.Kind = tyNil) and (LType.Kind in [tyClass, tyInterface, tyPointer])) or + ((LType.Kind = tyPointer) and (RType.Kind = tyPointer)) ) then CheckTypesMatch(LType, RType, Format('comparison ''%s''', [BinaryOpName(ABin.Op)]), diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index d81deeb..7371103 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -33,7 +33,8 @@ uses cp.test.generics, cp.test.properties, cp.test.genericfuncs, - cp.test.pointers; + cp.test.pointers, + cp.test.tlist; var Application: TTestRunner; diff --git a/compiler/src/test/pascal/cp.test.classes.pas b/compiler/src/test/pascal/cp.test.classes.pas index a59248b..1228cdd 100644 --- a/compiler/src/test/pascal/cp.test.classes.pas +++ b/compiler/src/test/pascal/cp.test.classes.pas @@ -528,7 +528,7 @@ begin 'begin' + LineEnding + ' F := TFoo.Create' + LineEnding + 'end.'); - AssertTrue('calls malloc', Pos('call $malloc', IR) > 0); + AssertTrue('calls calloc', Pos('call $calloc', IR) > 0); AssertTrue('stores pointer', Pos('storel', IR) > 0); end; diff --git a/compiler/src/test/pascal/cp.test.generics.pas b/compiler/src/test/pascal/cp.test.generics.pas index f7463e7..f683408 100644 --- a/compiler/src/test/pascal/cp.test.generics.pas +++ b/compiler/src/test/pascal/cp.test.generics.pas @@ -487,7 +487,7 @@ var IR: string; begin IR := GenIR(SrcGenericUsage); - AssertTrue('constructor calls malloc', Pos('call $malloc', IR) > 0); + AssertTrue('constructor calls calloc', Pos('call $calloc', IR) > 0); end; procedure TGenericsTests.TestCodegen_Generic_MethodEmitted; diff --git a/compiler/src/test/pascal/cp.test.inherit.pas b/compiler/src/test/pascal/cp.test.inherit.pas index eb8a33a..bca8aa6 100644 --- a/compiler/src/test/pascal/cp.test.inherit.pas +++ b/compiler/src/test/pascal/cp.test.inherit.pas @@ -305,7 +305,7 @@ begin IR := GenIR(SrcSelfRef); { TNode has Integer (4 bytes) + TNode pointer (8 bytes) = 12 bytes, but aligned to 8 → 12 bytes total. malloc(12) } - AssertTrue('malloc 12 bytes for TNode', Pos('call $malloc(l 12)', IR) > 0); + AssertTrue('calloc 12 bytes for TNode', Pos('call $calloc(l 1, l 12)', IR) > 0); end; { ------------------------------------------------------------------ } @@ -346,7 +346,7 @@ var IR: string; begin IR := GenIR(SrcInherit); { TDog.Create should malloc 8 bytes (Age + Legs) } - AssertTrue('malloc 8 bytes for TDog', Pos('call $malloc(l 8)', IR) > 0); + AssertTrue('calloc 8 bytes for TDog', Pos('call $calloc(l 1, l 8)', IR) > 0); end; procedure TInheritTests.TestCodegen_Inherit_ParentFieldOffset; diff --git a/compiler/src/test/pascal/cp.test.tlist.pas b/compiler/src/test/pascal/cp.test.tlist.pas new file mode 100644 index 0000000..1cfb7ac --- /dev/null +++ b/compiler/src/test/pascal/cp.test.tlist.pas @@ -0,0 +1,346 @@ +unit cp.test.tlist; + +{$mode objfpc}{$H+} + +{ Tests for TList generic dynamic list: type substitution with ^T fields, + SizeOf built-in, nil/Pointer compatibility with typed pointers, and + end-to-end Add/Get/Count codegen. } + +interface + +uses + Classes, SysUtils, fpcunit, testregistry, + uLexer, uParser, uAST, uSymbolTable, uSemantic, uCodeGenQBE; + +type + TTListTests = class(TTestCase) + private + function ParseSrc(const ASrc: string): TProgram; + function AnalyseSrc(const ASrc: string): TProgram; + function GenIR(const ASrc: string): string; + published + { ------------------------------------------------------------------ } + { Parser — ^T field, SizeOf } + { ------------------------------------------------------------------ } + procedure TestParse_CaretT_FieldType; + procedure TestParse_SizeOf_ParsedAsFuncCall; + + { ------------------------------------------------------------------ } + { Semantic — SizeOf, nil/Pointer compat, ^T substitution } + { ------------------------------------------------------------------ } + procedure TestSemantic_SizeOf_Integer; + procedure TestSemantic_SizeOf_Pointer; + procedure TestSemantic_NilAssign_ToTypedPointer; + procedure TestSemantic_Pointer_AssignToTypedPointer; + procedure TestSemantic_TList_Instantiation; + + { ------------------------------------------------------------------ } + { Codegen — SizeOf literal, full TList add/get } + { ------------------------------------------------------------------ } + procedure TestCodegen_SizeOf_Integer_EmitsFour; + procedure TestCodegen_SizeOf_Int64_EmitsEight; + procedure TestCodegen_TList_Compiles; + procedure TestCodegen_TList_AddGet_IR; + end; + +implementation + +{ ------------------------------------------------------------------ } +{ Blaise source constants } +{ ------------------------------------------------------------------ } + +const + SrcSizeOfInteger = + 'program P;' + LineEnding + + 'var N: Integer;' + LineEnding + + 'begin' + LineEnding + + ' N := SizeOf(Integer)' + LineEnding + + 'end.'; + + SrcSizeOfInt64 = + 'program P;' + LineEnding + + 'var N: Integer;' + LineEnding + + 'begin' + LineEnding + + ' N := SizeOf(Int64)' + LineEnding + + 'end.'; + + SrcNilToTypedPtr = + 'program P;' + LineEnding + + 'var P: ^Integer;' + LineEnding + + 'begin' + LineEnding + + ' P := nil' + LineEnding + + 'end.'; + + SrcPointerToTypedPtr = + 'program P;' + LineEnding + + 'var' + LineEnding + + ' P: ^Integer;' + LineEnding + + ' Q: Pointer;' + LineEnding + + 'begin' + LineEnding + + ' Q := GetMem(4);' + LineEnding + + ' P := Q' + LineEnding + + 'end.'; + + SrcTListType = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' TList = class' + LineEnding + + ' FData: ^T;' + LineEnding + + ' FCount: Integer;' + LineEnding + + ' FCapacity: Integer;' + LineEnding + + ' procedure Add(Value: T);' + LineEnding + + ' var' + LineEnding + + ' Dest: ^T;' + LineEnding + + ' begin' + LineEnding + + ' Dest := Self.FData + Self.FCount * SizeOf(T);' + LineEnding + + ' Dest^ := Value;' + LineEnding + + ' Self.FCount := Self.FCount + 1' + LineEnding + + ' end;' + LineEnding + + ' function Get(AIndex: Integer): T;' + LineEnding + + ' var' + LineEnding + + ' Src: ^T;' + LineEnding + + ' begin' + LineEnding + + ' Src := Self.FData + AIndex * SizeOf(T);' + LineEnding + + ' Result := Src^' + LineEnding + + ' end;' + LineEnding + + ' property Count: Integer read FCount;' + LineEnding + + ' end;' + LineEnding + + 'var' + LineEnding + + ' L: TList;' + LineEnding + + 'begin' + LineEnding + + ' L := TList.Create;' + LineEnding + + ' L.Add(10);' + LineEnding + + ' L.Add(20)' + LineEnding + + 'end.'; + + SrcTListGetResult = + 'program P;' + LineEnding + + 'type' + LineEnding + + ' TList = class' + LineEnding + + ' FData: ^T;' + LineEnding + + ' FCount: Integer;' + LineEnding + + ' FCapacity: Integer;' + LineEnding + + ' procedure Add(Value: T);' + LineEnding + + ' var' + LineEnding + + ' Dest: ^T;' + LineEnding + + ' begin' + LineEnding + + ' Dest := Self.FData + Self.FCount * SizeOf(T);' + LineEnding + + ' Dest^ := Value;' + LineEnding + + ' Self.FCount := Self.FCount + 1' + LineEnding + + ' end;' + LineEnding + + ' function Get(AIndex: Integer): T;' + LineEnding + + ' var' + LineEnding + + ' Src: ^T;' + LineEnding + + ' begin' + LineEnding + + ' Src := Self.FData + AIndex * SizeOf(T);' + LineEnding + + ' Result := Src^' + LineEnding + + ' end;' + LineEnding + + ' property Count: Integer read FCount;' + LineEnding + + ' end;' + LineEnding + + 'var' + LineEnding + + ' L: TList;' + LineEnding + + ' V: Integer;' + LineEnding + + 'begin' + LineEnding + + ' L := TList.Create;' + LineEnding + + ' L.Add(42);' + LineEnding + + ' V := L.Get(0)' + LineEnding + + 'end.'; + +{ ------------------------------------------------------------------ } +{ Helpers } +{ ------------------------------------------------------------------ } + +function TTListTests.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 TTListTests.AnalyseSrc(const ASrc: string): TProgram; +var + SA: TSemanticAnalyser; +begin + Result := ParseSrc(ASrc); + SA := TSemanticAnalyser.Create; + try + SA.Analyse(Result); + finally + SA.Free; + end; +end; + +function TTListTests.GenIR(const ASrc: string): string; +var + CG: TCodeGenQBE; + Prog: TProgram; +begin + Prog := AnalyseSrc(ASrc); + CG := TCodeGenQBE.Create; + try + CG.Generate(Prog); + Result := CG.GetOutput; + finally + CG.Free; + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Parser tests } +{ ------------------------------------------------------------------ } + +procedure TTListTests.TestParse_CaretT_FieldType; +var + Prog: TProgram; + TD: TTypeDecl; + CD: TClassTypeDef; + FD: TFieldDecl; +begin + Prog := ParseSrc(SrcTListType); + try + AssertTrue('At least one type decl', Prog.Block.TypeDecls.Count > 0); + TD := TTypeDecl(Prog.Block.TypeDecls[0]); + AssertTrue('Is generic', TD.Def is TGenericTypeDef); + CD := TGenericTypeDef(TD.Def).ClassDef; + FD := TFieldDecl(CD.Fields[0]); + AssertEquals('FData field name', 'FData', FD.Names[0]); + AssertEquals('FData type is ^T', '^T', FD.TypeName); + finally + Prog.Free; + end; +end; + +procedure TTListTests.TestParse_SizeOf_ParsedAsFuncCall; +var + Prog: TProgram; + Assign: TAssignment; + Call: TFuncCallExpr; +begin + Prog := ParseSrc(SrcSizeOfInteger); + try + Assign := TAssignment(Prog.Block.Stmts[0]); + AssertTrue('RHS is TFuncCallExpr', Assign.Expr is TFuncCallExpr); + Call := TFuncCallExpr(Assign.Expr); + AssertEquals('Name is SizeOf', 'SizeOf', Call.Name); + AssertEquals('One argument', 1, Call.Args.Count); + finally + Prog.Free; + end; +end; + +{ ------------------------------------------------------------------ } +{ Semantic tests } +{ ------------------------------------------------------------------ } + +procedure TTListTests.TestSemantic_SizeOf_Integer; +var + Prog: TProgram; + Assign: TAssignment; +begin + Prog := AnalyseSrc(SrcSizeOfInteger); + try + Assign := TAssignment(Prog.Block.Stmts[0]); + AssertEquals('SizeOf(Integer) resolves to Integer type', + Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind)); + finally + Prog.Free; + end; +end; + +procedure TTListTests.TestSemantic_SizeOf_Pointer; +var + Prog: TProgram; + Assign: TAssignment; +begin + Prog := AnalyseSrc(SrcSizeOfInt64); + try + Assign := TAssignment(Prog.Block.Stmts[0]); + AssertEquals('SizeOf(Int64) resolves to Integer type', + Ord(tyInteger), Ord(Assign.Expr.ResolvedType.Kind)); + finally + Prog.Free; + end; +end; + +procedure TTListTests.TestSemantic_NilAssign_ToTypedPointer; +var + Prog: TProgram; +begin + { Should not raise — nil is compatible with ^Integer } + Prog := AnalyseSrc(SrcNilToTypedPtr); + Prog.Free; +end; + +procedure TTListTests.TestSemantic_Pointer_AssignToTypedPointer; +var + Prog: TProgram; +begin + { Should not raise — Pointer (untyped) is compatible with ^Integer } + Prog := AnalyseSrc(SrcPointerToTypedPtr); + Prog.Free; +end; + +procedure TTListTests.TestSemantic_TList_Instantiation; +var + Prog: TProgram; +begin + { Full TList source with ^T fields and SizeOf should analyse without errors } + Prog := AnalyseSrc(SrcTListType); + Prog.Free; +end; + +{ ------------------------------------------------------------------ } +{ Codegen tests } +{ ------------------------------------------------------------------ } + +procedure TTListTests.TestCodegen_SizeOf_Integer_EmitsFour; +var + IR: string; +begin + IR := GenIR(SrcSizeOfInteger); + AssertTrue('SizeOf(Integer) emits copy 4', Pos('copy 4', IR) > 0); +end; + +procedure TTListTests.TestCodegen_SizeOf_Int64_EmitsEight; +var + IR: string; +begin + IR := GenIR(SrcSizeOfInt64); + AssertTrue('SizeOf(Int64) emits copy 8', Pos('copy 8', IR) > 0); +end; + +procedure TTListTests.TestCodegen_TList_Compiles; +var + IR: string; +begin + { Full TList program should produce valid IR without raising } + IR := GenIR(SrcTListType); + AssertTrue('IR is non-empty', Length(IR) > 0); +end; + +procedure TTListTests.TestCodegen_TList_AddGet_IR; +var + IR: string; +begin + IR := GenIR(SrcTListGetResult); + { Add method stores through a typed pointer } + AssertTrue('Add emits storew', Pos('storew', IR) > 0); + { Get method loads through a typed pointer } + AssertTrue('Get emits loadw', Pos('loadw', IR) > 0); + { Memory allocation via calloc } + AssertTrue('Create emits calloc', Pos('calloc', IR) > 0); +end; + +initialization + RegisterTest(TTListTests); + +end. diff --git a/compiler/src/test/pascal/cp.test.vtable.pas b/compiler/src/test/pascal/cp.test.vtable.pas index b6853ac..85698ab 100644 --- a/compiler/src/test/pascal/cp.test.vtable.pas +++ b/compiler/src/test/pascal/cp.test.vtable.pas @@ -399,8 +399,8 @@ var begin { TPoint has one Integer field (4 bytes) + vptr (8 bytes) = 12 bytes } IR := GenIR(SrcBaseWithField); - AssertTrue('malloc includes vptr size', - IRContains(IR, 'call $malloc(l 12)')); + AssertTrue('calloc includes vptr size', + IRContains(IR, 'call $calloc(l 1, l 12)')); end; procedure TVTableTests.TestCodegen_FieldOffset_ShiftedByEight;