-CR switch to build lazarus - Re bugtracker 37360

[BrunoK]

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]

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.