paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-08 09:28:19 +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 }
{ the last TOBJECT which is loaded gets }
{ it ! }
if (childof=nil) and
(objecttype in [odt_class,odt_javaclass]) and
(objname^='TOBJECT') then
class_tobject:=self;
if (childof=nil) and
(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
{ but do this only from a unit that's }
{ marked as system unit to avoid some }
{ equally named user's type to override }
{ the internal types! }
if mf_system_unit in current_module.moduleflags then
begin
if (objname^='JLOBJECT') then
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;
if (childof=nil) and
(objecttype in [odt_class,odt_javaclass]) and
(objname^='TOBJECT') then
class_tobject:=self;
if (childof=nil) and
(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
if (objname^='JLOBJECT') then
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;
writing_class_record_dbginfo:=false;
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.