Recent

Author Topic: -CR switch to build lazarus - Re bugtracker 37360  (Read 273 times)

BrunoK

  • Sr. Member
  • ****
  • Posts: 267
  • Retired programmer
-CR switch to build lazarus - Re bugtracker 37360
« on: July 24, 2020, 05:26:31 pm »
To Juha Manninen

As per our discussion here is my status about the -CR flag.

  • I have added in WSLCLClasses a list ordered by the synthetic class
  • Implemented a pendant to laz_check_object_ext that handles specifically the registered WSLCLComponent's descendants
This requires modification to FPC where I added a callback holder and modified
laz_check_object_ext so in case of inheritance error it executes the laz_check_object_ext.
  • Added  at the end of systemh.inc
Code: Pascal  [Select][+][-]
  1. {*****************************************************************************
  2.          Lazarus callback for Verify Method Call (switch -CR)
  3. *****************************************************************************}
  4.  
  5. type
  6.   TLazarusCRCallback = function(vmt, expvmt : pointer): Boolean;
  7. const
  8.   LazarusCRCallback : TLazarusCRCallback = nil;
  9.  
Patched fpc_check_object_ext in generic.inc with
Code: Pascal  [Select][+][-]
  1. procedure fpc_check_object_ext(vmt, expvmt : pointer); [public,alias:'FPC_CHECK_OBJECT_EXT']; compilerproc;
  2. var
  3.   lvmt : pointer;
  4. begin
  5.    if (vmt=nil) or
  6.       (pobjectvmt(vmt)^.size=0) or
  7.       (pobjectvmt(vmt)^.size+pobjectvmt(vmt)^.msize<>0) then
  8.         RunError(210);
  9.    lvmt := vmt;
  10.    while assigned(vmt) do
  11.      if vmt=expvmt then
  12.        exit
  13.      else
  14.        vmt:=pobjectvmt(vmt)^.parent;
  15.    if Assigned(LazarusCRCallback) and LazarusCRCallback(lvmt, expvmt) then
  16.      Exit;
  17.    RunError(219);
  18. end;

  • Implemented a callback function in laz_check_object_ext
Code: Pascal  [Select][+][-]
  1. { Extend class type verification to handle the double inheritance of the
  2.   TWSLCLComponents. If the component TWS<Widget><WSLCLClass> is found,
  3.   check that its 'lateral' component in the TWS<Class> tree matches
  4.   inheritence constraints. }
  5. function laz_check_object_ext(vmt, expvmt: pointer) : Boolean;
  6. var
  7.   idx : integer;
  8.   lComponentClass : TComponentClass;
  9. begin
  10.   Result := WSLCLClassesList.Search(TComponentClass(vmt), idx);
  11.   if Result then begin
  12.     lComponentClass := TComponentClass(PClassNode(WSLCLClassesList[idx])^.LCLParentClass);
  13.     Result := lComponentClass.InheritsFrom(TClass(expvmt));
  14.   end;
  15. end;

All that stuff goes quite well. One wrong transtype occurs quickly in TWinControl.DoAllAutoSize function CheckHandleAllocated , very easy to fix. See wincontrol.inc.patch.
The next one is in  the designer TSetDesigningComponent.SetDesigningOfComponent class procedure.

Do you want to proceed further. If yes indicate in what form you want me to return my current code.

I attach a LCLComponent_VCR.patch for LCLClasses and WSLCLClasses so you can have a look.

PascalDragon

  • Hero Member
  • *****
  • Posts: 2281
  • Compiler Developer
Re: -CR switch to build lazarus - Re bugtracker 37360
« Reply #1 on: July 30, 2020, 09:57:05 am »
FPC will not be extended for such shenigans. Disable the object checks for code that needs it using {$Push}{$ObjectChecks Off} … {$Pop}. This has the advantage that it will work with released versions of FPC as well.

 

TinyPortal © 2005-2018