paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-18 06:09:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

* fix #39907: only load system class types from units that are marked as a System unit

Browse Source 
+ added test
This commit is contained in:
Sven/Sarah Barth 2022-09-18 12:03:48 +02:00
parent 7b09eee02a
commit c8fee69345
3 changed files with 76 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
compiler/symdef.pas
View File

@ -7772,45 +7772,53 @@ implementation
{ handles the predefined class tobject } { handles the predefined class tobject }
{ the last TOBJECT which is loaded gets } { the last TOBJECT which is loaded gets }
{ it ! } { it ! }
if (childof=nil) and { but do this only from a unit that's }
(objecttype in [odt_class,odt_javaclass]) and { marked as system unit to avoid some }
(objname^='TOBJECT') then { equally named user's type to override }
class_tobject:=self; { the internal types! }
if (childof=nil) and if mf_system_unit in current_module.moduleflags then
(objecttype=odt_interfacecom) then
if (objname^='IUNKNOWN') then
interface_iunknown:=self
else
if (objname^='IDISPATCH') then
interface_idispatch:=self;
if (childof=nil) and
(objecttype=odt_objcclass) and
(objname^='PROTOCOL') then
objc_protocoltype:=self;
if (objecttype=odt_javaclass) and
not(oo_is_formal in objectoptions) then
begin begin
if (objname^='JLOBJECT') then if (childof=nil) and
java_jlobject:=self (objecttype in [odt_class,odt_javaclass]) and
else if (objname^='JLTHROWABLE') then (objname^='TOBJECT') then
java_jlthrowable:=self class_tobject:=self;
else if (objname^='FPCBASERECORDTYPE') then if (childof=nil) and
java_fpcbaserecordtype:=self (objecttype=odt_interfacecom) then
else if (objname^='JLSTRING') then if (objname^='IUNKNOWN') then
java_jlstring:=self interface_iunknown:=self
else if (objname^='ANSISTRINGCLASS') then else
java_ansistring:=self if (objname^='IDISPATCH') then
else if (objname^='SHORTSTRINGCLASS') then interface_idispatch:=self;
java_shortstring:=self if (childof=nil) and
else if (objname^='JLENUM') then (objecttype=odt_objcclass) and
java_jlenum:=self (objname^='PROTOCOL') then
else if (objname^='JUENUMSET') then objc_protocoltype:=self;
java_juenumset:=self if (objecttype=odt_javaclass) and
else if (objname^='FPCBITSET') then not(oo_is_formal in objectoptions) then
java_jubitset:=self begin
else if (objname^='FPCBASEPROCVARTYPE') then if (objname^='JLOBJECT') then
java_procvarbase:=self; java_jlobject:=self
else if (objname^='JLTHROWABLE') then
java_jlthrowable:=self
else if (objname^='FPCBASERECORDTYPE') then
java_fpcbaserecordtype:=self
else if (objname^='JLSTRING') then
java_jlstring:=self
else if (objname^='ANSISTRINGCLASS') then
java_ansistring:=self
else if (objname^='SHORTSTRINGCLASS') then
java_shortstring:=self
else if (objname^='JLENUM') then
java_jlenum:=self
else if (objname^='JUENUMSET') then
java_juenumset:=self
else if (objname^='FPCBITSET') then
java_jubitset:=self
else if (objname^='FPCBASEPROCVARTYPE') then
java_procvarbase:=self;
end;
end; end;
writing_class_record_dbginfo:=false; writing_class_record_dbginfo:=false;
end; end;

18
tests/webtbs/tw39907.pp Normal file
View File

@ -0,0 +1,18 @@
{ %NORUN }
{ %RECOMPILE }
{$mode objfpc}
{$modeswitch functionreferences}
program tw39907;
uses
uw39907;
var
obj: TObject;
proc: reference to procedure;
begin
obj := TObject.Create;
proc := @obj.Free;
end.

13
tests/webtbs/uw39907.pp Normal file
View File

@ -0,0 +1,13 @@
{$mode objfpc}
unit uw39907;
interface
type
TObject = class
end;
implementation
end.