Merge branch 'main' of https://gitlab.com/freepascal.org/fpc/source into main

compiler/aoptobj.pas

@@ -87,7 +87,7 @@ Unit AoptObj;
         { is Reg currently in use }
         Function IsUsed(Reg: TRegister): Boolean;
         { get all the currently used registers }
-        Function GetUsedRegs: TRegSet;
+        Function GetUsedRegs: TRegSet; {$ifdef USEINLINE}inline;{$endif USEINLINE}
 
         { outputs  the current set }
         Procedure Dump(var t : text);
@@ -405,7 +405,7 @@ Unit AoptObj;
         { Strips a label and any aligns that appear before it (if hp points to
           them rather than the label).  Only call this procedure on a label that
           you already know is no longer referenced }
-        procedure StripLabelFast(hp: tai); {$ifdef USEINLINE}inline;{$endif USEINLINE}
+        procedure StripLabelFast(hp: tai);
 
         { Checks and removes "jmp @@lbl; @lbl". Returns True if the jump was removed }
         function CollapseZeroDistJump(var p: tai; ThisLabel: TAsmLabel): Boolean;
@@ -549,7 +549,7 @@ Unit AoptObj;
       End;
 
 
-    Function TUsedRegs.GetUsedRegs: TRegSet; inline;
+    Function TUsedRegs.GetUsedRegs: TRegSet; {$ifdef USEINLINE}inline;{$endif USEINLINE}
       Begin
         GetUsedRegs := UsedRegs;
       End;
@@ -1395,6 +1395,7 @@ Unit AoptObj;
     procedure TAOptObj.AllocRegBetween(reg: tregister; p1, p2: tai; var initialusedregs: TAllUsedRegs);
       var
         hp, start: tai;
+        Po: PInteger;
         removedsomething,
         firstRemovedWasAlloc,
         lastRemovedWasDealloc: boolean;
@@ -1928,7 +1929,7 @@ Unit AoptObj;
     { Strips a label and any aligns that appear before it (if hp points to
       them rather than the label).  Only call this procedure on a label that
       you already know is no longer referenced }
-    procedure TAOptObj.StripLabelFast(hp: tai); {$ifdef USEINLINE}inline;{$endif USEINLINE}
+    procedure TAOptObj.StripLabelFast(hp: tai);
       var
         tmp: tai;
       begin

compiler/cgobj.pas

@@ -2729,8 +2729,8 @@ implementation
                   begin
                     a_load_reg_ref(list,OS_ADDR,OS_ADDR,newreg(R_INTREGISTER,regs_to_save_int[r],R_SUBWHOLE),href);
                     inc(href.offset,sizeof(aint));
+                    include(rg[R_INTREGISTER].preserved_by_proc,regs_to_save_int[r]);
                   end;
-                include(rg[R_INTREGISTER].preserved_by_proc,regs_to_save_int[r]);
               end;
             current_procinfo.saved_regs_int := rg[R_INTREGISTER].preserved_by_proc;
 
@@ -2742,8 +2742,8 @@ implementation
                       begin
                         a_load_reg_ref(list,OS_ADDR,OS_ADDR,newreg(R_ADDRESSREGISTER,regs_to_save_address[r],R_SUBWHOLE),href);
                         inc(href.offset,sizeof(aint));
+                        include(rg[R_ADDRESSREGISTER].preserved_by_proc,regs_to_save_address[r]);
                       end;
-                    include(rg[R_ADDRESSREGISTER].preserved_by_proc,regs_to_save_address[r]);
                   end;
 
                 current_procinfo.saved_regs_mm := rg[R_MMREGISTER].preserved_by_proc;
@@ -2766,8 +2766,8 @@ implementation
                           begin
                             a_loadmm_reg_ref(list,OS_VECTOR,OS_VECTOR,newreg(R_MMREGISTER,regs_to_save_mm[r],R_SUBMMWHOLE),href,nil);
                             inc(href.offset,tcgsize2size[OS_VECTOR]);
+                            include(rg[R_MMREGISTER].preserved_by_proc,regs_to_save_mm[r]);
                           end;
-                        include(rg[R_MMREGISTER].preserved_by_proc,regs_to_save_mm[r]);
                       end;
                   end;
 

compiler/m68k/aasmcpu.pas

@@ -138,6 +138,8 @@ const
 type
   toperandtypeset = set of toperandtype;
   toperandflagset = set of toperandflags;
+  topsupportedset = set of topsupported;
+  topsizeflagset  = set of topsizeflag;
 
 type
   tinsentry = record
@@ -147,8 +149,8 @@ type
     opflags  : array[0..max_operands-1] of toperandflagset;
     codelen  : byte;
     code     : array[0..1] of word;
-    support  : set of topsupported;
-    sizes    : set of topsizeflag;
+    support  : topsupportedset;
+    sizes    : topsizeflagset;
   end;
   pinsentry = ^tinsentry;
 
@@ -701,6 +703,63 @@ type
 
     function taicpu.Matches(p: PInsEntry; objdata:TObjData): boolean;
 
+      function TargetMatch: boolean;
+        const
+          CPUTypeToOpSupported: array[TCPUtype] of topsupportedset = (
+              {* cpu_none *}     [],
+              {* cpu_MC68000 *}  [OS_M68000,OS_M68000UP],
+              {* cpu_MC68020 *}  [OS_M68020,OS_M68000UP,OS_M68010UP,OS_M68020UP,OS_M68851],
+              {* cpu_MC68040 *}  [OS_M68040,OS_M68000UP,OS_M68010UP,OS_M68020UP,OS_M68040UP],
+              {* cpu_MC68060 *}  [OS_M68060,OS_M68000UP,OS_M68010UP,OS_M68020UP,OS_M68040UP],
+              {* cpu_isa_a *}    [OS_CF,OS_CF_ISA_A],
+              {* cpu_isa_a_p *}  [OS_CF,OS_CF_ISA_APL],
+              {* cpu_isa_b *}    [OS_CF,OS_CF_ISA_B],
+              {* cpu_isa_c *}    [OS_CF,OS_CF_ISA_C],
+              {* cpu_cfv4e *}    [OS_CF,OS_CF_ISA_B]
+          );
+          FPUTypeToOpSupported: array[TFPUtype] of topsupportedset = (
+              {* fpu_none *}     [],
+              {* fpu_soft *}     [],
+              {* fpu_libgcc *}   [],
+              {* fpu_68881 *}    [OS_M68881],
+              {* fpu_68040 *}    [OS_M68881,OS_M68040,OS_M68040UP],
+              {* fpu_68060 *}    [OS_M68881,OS_M68040,OS_M68040UP,OS_M68060],
+              {* fpu_coldfire *} [OS_CF_FPU]
+          );
+        begin
+          result:=((CPUTypeToOpSupported[current_settings.cputype] * p^.support) <> []) or
+                  ((FPUTypeToOpSupported[current_settings.fputype] * p^.support) <> []);
+        end;
+
+      function OpsizeMatch: boolean;
+        const
+          TOpSizeToOpSizeFlag: array[TOpSize] of TOpSizeFlagSet = (
+              { S_NO } [ OPS_UNSIZED],
+              { S_B  } [ OPS_SHORT, OPS_BYTE ],
+              { S_W  } [ OPS_WORD ],
+              { S_L  } [ OPS_LONG ],
+              { S_FS } [ OPS_SINGLE ],
+              { S_FD } [ OPS_DOUBLE ],
+              { S_FX } [ OPS_EXTENDED ]
+          );
+        begin
+          result:=(TOpSizeToOpSizeFlag[opsize] * p^.sizes) <> [];
+
+          { Special handling for instructions where the size can be
+            implicitly determined, because only one size is possible. }
+          if not result and (opsize in [S_NO]) then
+            begin
+              result:=(p^.sizes <> []) and (
+                 { if OPS_SHORT is in sizes, it means we have a branch
+                   instruction, so let unsized pass. }
+                 (OPS_SHORT in p^.sizes) or
+                 { Or only one size is possible. }
+                 ((p^.sizes - [ OPS_BYTE ]) = []) or
+                 ((p^.sizes - [ OPS_WORD ]) = []) or
+                 ((p^.sizes - [ OPS_LONG ]) = []));
+            end;
+        end;
+
       function OperandsMatch(const oper: toper; const ots: toperandtypeset): boolean;
         var
           ot: toperandtype;
@@ -786,6 +845,14 @@ type
         if (p^.opcode<>opcode) or (p^.ops<>ops) then
           exit;
 
+        { Check if opcode is valid for this target }
+        if not TargetMatch then
+          exit;
+
+        { Check if opcode size is valid }
+        if not OpsizeMatch then
+          exit;
+
         { Check the operands }
         for i:=0 to p^.ops-1 do
           if not OperandsMatch(oper[i]^,p^.optypes[i]) then

compiler/m68k/ag68kgas.pas

@@ -50,7 +50,7 @@ interface
 
     const
       gas_opsize2str : array[topsize] of string[2] =
-        ('','.b','.w','.l','.s','.d','.x','');
+        ('','.b','.w','.l','.s','.d','.x');
 
 
   implementation

compiler/m68k/cpubase.pas

@@ -156,7 +156,7 @@ unit cpubase;
        { S_FS  = single type (32 bit) }
        { S_FD  = double/64bit integer }
        { S_FX  = Extended type      }
-       topsize = (S_NO,S_B,S_W,S_L,S_FS,S_FD,S_FX,S_IQ);
+       topsize = (S_NO,S_B,S_W,S_L,S_FS,S_FD,S_FX);
 
        TOpSizes = set of topsize;
 

compiler/msg/errorct.msg

@@ -1,6 +1,6 @@
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1993-2022 by the Free Pascal Development team
+#   Copyright (c) 1993-2023 by the Free Pascal Development team
 #
 #   Catalan Language File for Free Pascal
 #
@@ -2103,7 +2103,7 @@ option_code_page_not_available=11039_E_La p
 #
 option_logo=11023_[
 Free Pascal Compiler versió $FPCFULLVERSION [$FPCDATE] per $FPCCPU
-Copyright (c) 1993-2022 per Florian Klaempfl and others
+Copyright (c) 1993-2023 per Florian Klaempfl and others
 ]
 
 #

compiler/msg/errord.msg

@@ -6,7 +6,7 @@
 #   Based on errore.msg of git commit 403292a1, 06 Jul, 2022
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1998-2022 by the Free Pascal Development team
+#   Copyright (c) 1998-2023 by the Free Pascal Development team
 #
 #   See the file COPYING.v2, included in this distribution,
 #   for details about the copyright.
@@ -3851,7 +3851,7 @@ package_u_ppl_filename=13029_U_PPL Dateiname $1
 #
 option_logo=11023_[
 Free Pascal Compiler Version $FPCFULLVERSION [$FPCDATE] f�r $FPCTARGET
-Copyright (c) 1993-2022 Florian Kl„mpfl und andere
+Copyright (c) 1993-2023 Florian Kl„mpfl und andere
 ]
 
 #

compiler/msg/errorda.msg

@@ -3535,7 +3535,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] til $FPCTARGET
-Copyright (c) 1993-2022 Florian Klaempfl and others
+Copyright (c) 1993-2023 Florian Klaempfl and others
 ]
 
 #

compiler/msg/errordu.msg

@@ -6,7 +6,7 @@
 #   Based on errore.msg of git commit 403292a1, 06 Jul, 2022
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1998-2022 by the Free Pascal Development team
+#   Copyright (c) 1998-2023 by the Free Pascal Development team
 #
 #   See the file COPYING.v2, included in this distribution,
 #   for details about the copyright.
@@ -3850,7 +3850,7 @@ package_u_ppl_filename=13029_U_PPL Dateiname $1
 #
 option_logo=11023_[
 Free Pascal Compiler Version $FPCFULLVERSION [$FPCDATE] für $FPCTARGET
-Copyright (c) 1993-2022 Florian Klämpfl und andere
+Copyright (c) 1993-2023 Florian Klämpfl und andere
 ]
 
 #

compiler/msg/errore.msg

@@ -3807,7 +3807,7 @@ package_u_ppl_filename=13029_U_PPL filename $1
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errores.msg

@@ -3477,7 +3477,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorf.msg

@@ -1715,7 +1715,7 @@ option_asm_forced=11022_W_"$1" assembler use forced
 #
 option_logo=11023_[
 Compilateur Free Pascal version $FPCFULLVERSION [$FPCDATE] pour $FPCTARGET
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorfi.msg

@@ -3499,7 +3499,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 # Logo (option -l)
 #
 option_logo=11023_[ Compilateur Free Pascal version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022, Florian Klaempfl and others]
+Copyright (c) 1993-2023, Florian Klaempfl and others]
 #
 # Info (option -i)
 #

compiler/msg/errorhe.msg

@@ -2407,7 +2407,7 @@ option_confict_asm_debug=11041_W_
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorheu.msg

@@ -3496,7 +3496,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorid.msg

@@ -3504,7 +3504,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler versi $FPCFULLVERSION [$FPCDATE] untuk $FPCCPU
-Hak Cipta (c) 1993-2022 oleh Florian Klaempfl and others
+Hak Cipta (c) 1993-2023 oleh Florian Klaempfl and others
 ]
 
 #

compiler/msg/erroriu.msg

@@ -2693,7 +2693,7 @@ wpo_cant_create_feedback_file=12019_E_Impossibile creare il file di feedback "$1
 #
 option_logo=11023_[
 Compilatore Free Pascal, versione $FPCFULLVERSION [$FPCDATE] per $FPCCPU
-Copyright (c) 1993-2022 di Florian Klaempfl and others
+Copyright (c) 1993-2023 di Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorn.msg

@@ -3485,7 +3485,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler versie $FPCFULLVERSION [$FPCDATE] voor $FPCTARGET
-Copyright (c) 1993-2022 door Florian Klaempfl en anderen
+Copyright (c) 1993-2023 door Florian Klaempfl en anderen
 ]
 #
 # Info (option -i)

compiler/msg/errorpl.msg

@@ -2119,7 +2119,7 @@ option_code_page_not_available=11039_E_Nieznana strona kodowa
 #
 option_logo=11023_[
 Free Pascal Compiler wersja $FPCFULLVERSION [$FPCDATE] dla $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorpli.msg

@@ -2119,7 +2119,7 @@ option_code_page_not_available=11039_E_Nieznana strona kodowa
 #
 option_logo=11023_[
 Free Pascal Compiler wersja $FPCFULLVERSION [$FPCDATE] dla $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorpt.msg

@@ -3086,7 +3086,7 @@ wpo_cant_create_feedback_file=12019_E_Imposs
 #
 option_logo=11023_[
 Compilador Free Pascal versÆo $FPCFULLVERSION [$FPCDATE] para $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorptu.msg

@@ -3514,7 +3514,7 @@ wpo_cant_create_feedback_file=12019_E_Impossível criar arquivo retorno otimiza
 #
 option_logo=11023_[
 Compilador Free Pascal versão $FPCFULLVERSION [$FPCDATE] para $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorr.msg

@@ -2506,7 +2506,7 @@ wpo_cant_create_feedback_file=12019_E_
 #
 option_logo=11023_[
 Š®¬¯¨«ïâ®à Free Pascal ¢¥àᨨ $FPCFULLVERSION [$FPCDATE] ¤«ï $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorru.msg

@@ -3387,7 +3387,7 @@ wpo_cant_create_feedback_file=12019_E_Невозможно создать фай
 #
 option_logo=11023_[
 Компилятор Free Pascal версии $FPCFULLVERSION [$FPCDATE] для $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msg/errorues.msg

@@ -3471,7 +3471,7 @@ wpo_cant_create_feedback_file=12019_E_Cannot create specified whole program opti
 #
 option_logo=11023_[
 Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPCCPU
-Copyright (c) 1993-2022 by Florian Klaempfl and others
+Copyright (c) 1993-2023 by Florian Klaempfl and others
 ]
 
 #

compiler/msgtxt.inc

@@ -1423,7 +1423,7 @@ const msgtxt : array[0..000377,1..240] of char=(
   '13029_U_PPL filename $1'#000+
   '11023_','Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $F'+
   'PCCPU'#010+
-  'Copyright (c) 1993-2022 by Florian Klaempfl and others'#000+
+  'Copyright (c) 1993-2023 by Florian Klaempfl and others'#000+
   '11024_Free Pascal Compiler version $FPCVERSION'#010+
   #010+
   'Compiler date      : $FPCDATE'#010+

compiler/pdecl.pas

@@ -1170,7 +1170,10 @@ implementation
 
            if isgeneric and (not(hdef.typ in [objectdef,recorddef,arraydef,procvardef])
                or is_objectpascal_helper(hdef)) then
-             message(parser_e_cant_create_generics_of_this_type);
+             begin
+               newtype.typedef:=generrordef;
+               message(parser_e_cant_create_generics_of_this_type);
+             end;
 
            { Stop recording a generic template }
            if assigned(generictypelist) then

compiler/scandir.pas

@@ -549,6 +549,16 @@ unit scandir;
         do_message(scan_f_user_defined);
       end;
 
+    procedure dir_floatingpointemulation;
+      begin
+        do_delphiswitch('E');
+      end;
+
+    procedure dir_stackchecking;
+      begin
+        do_delphiswitch('T');
+      end;
+
     procedure dir_fputype;
       begin
         current_scanner.skipspace;
@@ -1975,7 +1985,9 @@ unit scandir;
         AddDirective('EXTENDEDSYNTAX',directive_all, @dir_extendedsyntax);
         AddDirective('EXTERNALSYM',directive_all, @dir_externalsym);
         AddDirective('F',directive_all, @dir_forcefarcalls);
+        AddDirective('FARCALLS',directive_all, @dir_forcefarcalls);
         AddDirective('FATAL',directive_all, @dir_fatal);
+        AddDirective('FLOATINGPOINTEMULATION',directive_all,@dir_floatingpointemulation);
         AddDirective('FPUTYPE',directive_all, @dir_fputype);
         AddDirective('FRAMEWORKPATH',directive_all, @dir_frameworkpath);
         AddDirective('GOTO',directive_all, @dir_goto);
@@ -2050,6 +2062,7 @@ unit scandir;
         AddDirective('SETPESUBSYSVERSION', directive_all, @dir_setpesubsysversion);
         AddDirective('SCREENNAME',directive_all, @dir_screenname);
         AddDirective('SMARTLINK',directive_all, @dir_smartlink);
+        AddDirective('STACKCHECKING',directive_all,@dir_stackchecking);
         AddDirective('STACKFRAMES',directive_all, @dir_stackframes);
         AddDirective('STOP',directive_all, @dir_stop);
         AddDirective('STRINGCHECKS', directive_all, @dir_stringchecks);

packages/fcl-web/src/base/restbase.pp

@@ -48,29 +48,16 @@ Const
   IndexShift = 3; // Number of bits reserved for flags.
 
 Type
-{$M+}
+{$TYPEINFO ON}
 
   TBaseObject = CLass(TObject)
   Private
     FObjectOptions : TObjectOptions;
     fadditionalProperties : TJSONObject;
     FBits : TBits;
-
-{ #todo -oWayneSherman : can the next two private methods be removed and instead
-  use the rtl provided GetDynArrayProp / SetDynArrayProp in TypInfo.pp unit }
-    Function GetDynArrayProp(P: PPropInfo) : Pointer; virtual;
-    procedure SetDynArrayProp(P: PPropInfo; AValue : Pointer); virtual;
-
     procedure SetObjectOptions(AValue: TObjectOptions);
     Function GetAdditionalProperties : TJSONObject;
   protected
-{$ifdef ver2_6}
-    // Version 2.6.4 has a bug for i386 where the array cannot be set through RTTI.
-    // This is a helper method that sets the length of the array to the desired length,
-    // After which the new array pointer is read again.
-    // AName is guaranteed to be lowercase
-    Procedure SetArrayLength(const AName : String; ALength : Longint); virtual;
-{$endif}
     Procedure MarkPropertyChanged(AIndex : Integer);
     Function IsDateTimeProp(Info : PTypeInfo) : Boolean;
     Function DateTimePropType(Info : PTypeInfo) : TDateTimeType;
@@ -79,9 +66,7 @@ Type
     Procedure SetBooleanProperty(P: PPropInfo; AValue: Boolean); virtual;
     Procedure SetFloatProperty(P: PPropInfo; AValue: Extended); virtual;
     Procedure SetInt64Property(P: PPropInfo; AValue: Int64); virtual;
-    {$ifndef ver2_6}
     Procedure SetQWordProperty(P: PPropInfo; AValue: QWord); virtual;
-    {$endif}
     Procedure SetIntegerProperty(P: PPropInfo; AValue: Integer); virtual;
     Procedure SetStringProperty(P: PPropInfo; AValue: String); virtual;
     Procedure SetArrayProperty(P: PPropInfo; AValue : TJSONArray); virtual;
@@ -161,8 +146,6 @@ Type
     Property Objects [Aindex : Integer] : TBaseObject Read GetO Write SetO; default;
   end;
 
-  { TBaseObjectList }
-
   { TBaseNamedObjectList }
 
   TBaseNamedObjectList = Class(TBaseObject)
@@ -447,6 +430,7 @@ begin
   Result:=CreateObject(AKind);
   ObjectByName[AName]:=Result;
 end;
+
 { TJSONSchema }
 
 Procedure TJSONSchema.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
@@ -534,11 +518,6 @@ end;
 
 { TBaseObject }
 
-function TBaseObject.GetDynArrayProp(P: PPropInfo): Pointer;
-begin
-  Result:=Pointer(GetObjectProp(Self,P));
-end;
-
 { $DEFINE DUMPARRAY}
 
 {$IFDEF DUMPARRAY}
@@ -563,18 +542,19 @@ begin
     Writeln(ClassName,' property ',N, ' has ref count ',r^.refcount,' and high ',r^.high);
     end;
 end;
-{$ENDIF}
 
-procedure TBaseObject.SetDynArrayProp(P: PPropInfo; AValue: Pointer);
+function GetDynArrayProp(Instance: TObject; PropInfo: PPropInfo): Pointer;
 begin
-{$IFDEF DUMPARRAY}
-  DumpArray(ClassName+' (set)',P^.PropType^.Name,AValue);
-{$ENDIF}
-  SetObjectProp(Self,P,TObject(AValue));
-{$IFDEF DUMPARRAY}
-  DumpArray(ClassName+' (check)',P^.PropType^.Name,AValue);
-{$ENDIF}
+  Result := TypInfo.GetDynArrayProp(Instance,PropInfo);
+end;
+
+procedure SetDynArrayProp(Instance: TObject; PropInfo: PPropInfo; const Value: Pointer);
+begin
+  DumpArray(Instance.ClassName+' (set)',PropInfo^.PropType^.Name,Value);
+  TypInfo.SetDynArrayProp(Instance,PropInfo,Value);
+  DumpArray(Instance.ClassName+' (check)',PropInfo^.PropType^.Name,Value);
 end;
+{$ENDIF}
 
 procedure TBaseObject.SetObjectOptions(AValue: TObjectOptions);
 begin
@@ -607,6 +587,10 @@ begin
 end;
 
 procedure TBaseObject.ClearProperty(P: PPropInfo);
+var
+  TypeDataPtr: PTypeData;
+  ObjectArray: TObjectArray;
+  Idx: Integer;
 begin
   Case P^.PropType^.Kind of
     tkInteger,
@@ -626,10 +610,27 @@ begin
     tkQWord : SetInt64Prop(Self,P,0);
     tkClass :
       begin
+      //Writeln(ClassName,' Examining object: ',P^.Name);
       GetObjectProp(Self,P).Free;
       SetObjectProp(Self,P,Nil);
-      end
-    { #todo -oWayneSherman : is the tkDynArray type missing here?  }
+      end;
+    tkDynArray:
+      begin
+      TypeDataPtr := GetTypeData(P^.PropType);
+      if TypeDataPtr^.ElType2^.Kind = tkClass then
+        begin
+        //if the array is holding any objects, free them
+        ObjectArray := TObjectArray(GetDynArrayProp(Self,P));
+        {$IFDEF DUMPARRAY}
+          DumpArray(ClassName+' (clear)',P^.PropType^.Name,Pointer(ObjectArray));
+        {$ENDIF}
+        //Writeln(ClassName,' Examining array: ',P^.Name,'Count:',Length(ObjectArray));
+        for Idx := Low(ObjectArray) to High(ObjectArray) do
+          FreeAndNil(ObjectArray[Idx]);
+        end;
+      SetLength(ObjectArray, 0);
+      SetDynArrayProp(Self,P,nil);
+      end;
   else
     // Do nothing
   end;
@@ -658,13 +659,11 @@ begin
   SetInt64Prop(Self,P,AValue);
 end;
 
-{$ifndef ver2_6}
 procedure TBaseObject.SetQWordProperty(P: PPropInfo; AValue: QWord);
 
 begin
   SetInt64Prop(Self,P,Int64(AValue));
 end;
-{$endif}
 
 procedure TBaseObject.SetStringProperty(P: PPropInfo; AValue: String);
 Var
@@ -681,18 +680,15 @@ end;
 
 procedure TBaseObject.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
 
-  procedure SetObjectArrayProp(PropAsPtr: Pointer;
-    const TypeName: ShortString;
-    const ClassType: TClass;
+  procedure SetObjectArrayProp(const TypeName: ShortString; const ClassType: TClass;
     const JSONArray: TJSONArray);
   var
-    ObjectArray: TObjectArray;
+    ObjectArray: TObjectArray = nil;
     BaseObject: TBaseObject;
     Idx: Integer;
   begin
-    ObjectArray := TObjectArray(PropAsPtr);
-
-    // Free all objects
+    //if the array is holding any objects, free them
+    ObjectArray := TObjectArray(GetDynArrayProp(Self,P));
     for Idx := Low(ObjectArray) to High(ObjectArray) do
       FreeAndNil(ObjectArray[Idx]);
 
@@ -703,149 +699,143 @@ procedure TBaseObject.SetArrayProperty(P: PPropInfo; AValue: TJSONArray);
       ObjectArray[Idx] := BaseObject;
       BaseObject.LoadFromJSON(JSONArray.Objects[Idx]);
       end;
+    SetDynArrayProp(Self,P,Pointer(ObjectArray));
   end;
 
-  procedure SetFloatArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetFloatArrayProp(const JSONArray: TJSONArray);
   var
-    FloatArray: TFloatArray;
+    FloatArray: TFloatArray = nil;
     Idx: Integer;
   begin
-    FloatArray := TFloatArray(PropAsPtr);
     SetLength(FloatArray, JSONArray.Count);
-     for Idx := Low(FloatArray) to High(FloatArray) do
-       FloatArray[Idx] := JSONArray.Floats[Idx];
+    for Idx := Low(FloatArray) to High(FloatArray) do
+      FloatArray[Idx] := JSONArray.Floats[Idx];
+    SetDynArrayProp(Self,P,Pointer(FloatArray));
   end;
 
-  procedure SetDateTimeArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetDateTimeArrayProp(const JSONArray: TJSONArray);
   var
-    DateTimeArray: TDateTimeArray;
+    DateTimeArray: TDateTimeArray = nil;
     Idx: Integer;
   begin
-    DateTimeArray := TDateTimeArray(PropAsPtr);
     SetLength(DateTimeArray, JSONArray.Count);
     for Idx := Low(DateTimeArray) to High(DateTimeArray) do
       DateTimeArray[Idx] := RFC3339ToDateTime(JSONArray.Strings[Idx]);
+    SetDynArrayProp(Self,P,Pointer(DateTimeArray));
   end;
 
-  procedure SetInt64ArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetInt64ArrayProp(const JSONArray: TJSONArray);
   var
-    Int64Array: TInt64Array;
+    Int64Array: TInt64Array = nil;
     Idx: Integer;
   begin
-    Int64Array := TInt64Array(PropAsPtr);
     SetLength(Int64Array, JSONArray.Count);
     for Idx := Low(Int64Array) to High(Int64Array) do
       Int64Array[Idx] := JSONArray.Int64s[Idx];
+    SetDynArrayProp(Self,P,Pointer(Int64Array));
   end;
 
-  procedure SetBooleanArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetBooleanArrayProp(const JSONArray: TJSONArray);
   var
-    BooleanArray: TBooleanArray;
+    BooleanArray: TBooleanArray = nil;
     Idx: Integer;
   begin
-    BooleanArray := TBooleanArray(PropAsPtr);
     SetLength(BooleanArray, JSONArray.Count);
     for Idx := Low(BooleanArray) to High(BooleanArray) do
       BooleanArray[Idx] := JSONArray.Booleans[Idx];
+    SetDynArrayProp(Self,P,Pointer(BooleanArray));
   end;
 
-  procedure SetIntegerArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetIntegerArrayProp(const JSONArray: TJSONArray);
   var
-    IntegerArray: TIntegerArray;
+    IntegerArray: TIntegerArray = nil;
     Idx: Integer;
   begin
-    IntegerArray := TIntegerArray(PropAsPtr);
     SetLength(IntegerArray, JSONArray.Count);
     for Idx := Low(IntegerArray) to High(IntegerArray) do
       IntegerArray[Idx] := JSONArray.Integers[Idx];
+    SetDynArrayProp(Self,P,Pointer(IntegerArray));
   end;
 
-  procedure SetUnicodeStringArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetUnicodeStringArrayProp(const JSONArray: TJSONArray);
   var
-    UnicodeStringArray: TUnicodeStringArray;
+    UnicodeStringArray: TUnicodeStringArray = nil;
     Idx: Integer;
   begin
-    UnicodeStringArray := TUnicodeStringArray(PropAsPtr);
     SetLength(UnicodeStringArray, JSONArray.Count);
     for Idx := Low(UnicodeStringArray) to High(UnicodeStringArray) do
       UnicodeStringArray[Idx] := UTF8Decode(JSONArray.Strings[Idx]);
+    SetDynArrayProp(Self,P,Pointer(UnicodeStringArray));
   end;
 
-  procedure SetStringArrayProp(PropAsPtr: Pointer;
-    const JSONArray: TJSONArray);
+  procedure SetStringArrayProp(const JSONArray: TJSONArray);
   var
+    StringArray: TStringArray = nil;
     Idx: Integer;
-    StringArray: TStringArray;
   begin
-    StringArray := TStringArray(PropAsPtr);
     SetLength(StringArray, JSONArray.Count);
     for Idx := Low(StringArray) to High(StringArray) do
       StringArray[Idx] := JSONArray.Strings[Idx];
+
+    //SetDynArrayProp handles:
+    //  1)If the property holds an existing array, free it if the ref count is 0
+    //  2)Increments the ref count of our new array when it sets the property
+    SetDynArrayProp(Self,P,Pointer(StringArray));
   end;
 
 Var
-  T : PTypeData;
-  L : TBaseObjectList;
-  D : TJSONEnum;
-  PTD : PTypeData;
+  PTD: PTypeData;
+  L  : TBaseObjectList;
+  D  : TJSONEnum;
   ET : PTypeInfo;
   AN : String;
-  AP : Pointer;
-  S : TJSONSchema;
+  S  : TJSONSchema;
 
 begin
+  Assert((P<>nil) and Assigned(AValue), 'TBaseObject.SetArrayProperty: P or AValue is nil');
+
   if P^.PropType^.Kind=tkClass then
     begin
-    T:=GetTypeData(P^.PropType);
-    if T^.ClassType.InheritsFrom(TBaseObjectList) then
+    PTD:=GetTypeData(P^.PropType);
+    if PTD^.ClassType.InheritsFrom(TBaseObjectList) then
       begin
-      L:=TBaseObjectList(TBaseObjectClass(T^.ClassType).Create);
-      { #todo -oWayneSherman : what if there is an existing object, are we clobbering it? }
+      L:=TBaseObjectList(TBaseObjectClass(PTD^.ClassType).Create);
+      GetObjectProp(Self,P).Free;  //if the property holds an object, free it
       SetObjectProp(Self,P,L);
       For D in AValue do
         L.AddObject('').LoadFromJSON(D.Value as TJSONObject);
       end
-    else if T^.ClassType.InheritsFrom(TJSONSchema) then
+    else if PTD^.ClassType.InheritsFrom(TJSONSchema) then
       begin
       S:=TJSONSchema.Create;
       S.SetArrayProperty(P,AValue);
-      { #todo -oWayneSherman : what if there is an existing object, are we clobbering it? }
+      GetObjectProp(Self,P).Free;  //if the property holds an object, free it
       SetObjectProp(Self,P,S);
       end
     else
-      Raise ERESTAPI.CreateFmt('Unsupported class %s for property %s',[T^.ClassType.ClassName,P^.Name]);
+      Raise ERESTAPI.CreateFmt('Unsupported class %s for property %s',[PTD^.ClassType.ClassName,P^.Name]);
     end
   else if P^.PropType^.Kind=tkDynArray then
   begin
-    // Get array value
-    AP:=GetObjectProp(Self,P);  //NOTE: AP is dynanmic array as an untyped pointer
-                                //Getting it like this bypasses the reference count management
-                                //Be careful what do we with it to avoid leaking memory.
     PTD:=GetTypeData(P^.PropType);
     ET:=PTD^.ElType2;
     AN:=ET^.Name;
     case ET^.Kind of
-      tkClass: SetObjectArrayProp(AP, ET^.Name, GetTypeData(ET)^.ClassType, AValue);
+      tkClass: SetObjectArrayProp(ET^.Name, GetTypeData(ET)^.ClassType, AValue);
       tkFloat:
         if IsDateTimeProp(ET) then
-          SetDateTimeArrayProp(AP, AValue)
+          SetDateTimeArrayProp(AValue)
         else
-          SetFloatArrayProp(AP, AValue);
+          SetFloatArrayProp(AValue);
 
-      tkInt64: SetInt64ArrayProp(AP, AValue);
-      tkBool: SetBooleanArrayProp(AP, AValue);
-      tkInteger: SetIntegerArrayProp(AP, AValue);
+      tkInt64: SetInt64ArrayProp(AValue);
+      tkBool: SetBooleanArrayProp(AValue);
+      tkInteger: SetIntegerArrayProp(AValue);
       tkUstring,
-      tkWstring: SetUnicodeStringArrayProp(AP, AValue);
+      tkWstring: SetUnicodeStringArrayProp(AValue);
       tkString,
       tkAstring,
-      tkLString:  SetStringArrayProp(AP, AValue);
+      tkLString: SetStringArrayProp(AValue);
     else
       Raise ERESTAPI.CreateFmt('%s: unsupported array element type for property of type %s: %s',[ClassName,AN,GetEnumName(TypeInfo(TTypeKind),Ord(ET^.Kind))]);
     end;
@@ -854,8 +844,8 @@ end;
 
 procedure TBaseObject.SetObjectProperty(P: PPropInfo; AValue: TJSONObject);
 Var
+  ObjectArray : TObjectArray;
   O : TBaseObject;
-  A: Pointer;
   T : PTypeData;
   D : TJSONEnum;
   AN : String;
@@ -866,17 +856,17 @@ Var
 begin
   if P^.PropType^.Kind=tkDynArray then
     begin
-    A:=GetDynArrayProp(P);
-    For I:=0 to Length(TObjectArray(A))-1 do
-      FreeAndNil(TObjectArray(A)[i]);
-    SetLength(TObjectArray(A),AValue.Count);
+    ObjectArray:=TObjectArray(GetDynArrayProp(Self,P));
+    For I:=Low(ObjectArray) to High(ObjectArray) do
+      FreeAndNil(ObjectArray[i]);
+    SetLength(ObjectArray,AValue.Count);
     T:=GetTypeData(P^.PropType);
     AN:=T^.ElType2^.Name;
     I:=0;
     For D in AValue do
       begin
       O:=CreateObject(AN);
-      TObjectArray(A)[I]:=O;
+      (ObjectArray)[I]:=O;
       // Writeln(ClassName,' Adding instance of type: ',AN,' for key ',D.Key);
       if IsPublishedProp(O,'name') then
         SetStrProp(O,'name',D.Key);
@@ -884,7 +874,7 @@ begin
       Inc(I);
       end;
     // Writeln(ClassName,' Done with array ',P^.Name,', final array length: ', Length(TObjectArray(A)));
-    SetDynArrayProp(P,A);
+    SetDynArrayProp(Self,P,Pointer(ObjectArray));
     Exit;
     end;
   if Not (P^.PropType^.Kind=tkClass) then
@@ -1032,7 +1022,7 @@ begin
   A:=TJSONArray.Create;
   Result:=A;
   // Get array value type
-  AP:=GetObjectProp(Self,P);
+  AP:=GetDynArrayProp(Self,P);
   PTD:=GetTypeData(P^.PropType);
   ET:=PTD^.ElType2;
   // Fill in all elements
@@ -1093,18 +1083,10 @@ begin
 end;
 
 procedure TBaseObject.ClearChildren(ChildTypes: TChildTypes);
-
-
-Type
-  TObjectArr = Array of TObject;
-
 var
   PL: PPropList;
   P : PPropInfo;
-  i,j,count,len:integer;
-  A : pointer;
-  PTD : PTypeData;
-  O : TObject;
+  i,count:integer;
 
 begin
   Count:=GetPropList(Self,PL);
@@ -1115,31 +1097,13 @@ begin
       case P^.PropType^.Kind of
         tkClass:
           if (ctObject in ChildTypes) then
-            begin
-            // Writeln(ClassName,' Examining object: ',P^.Name);
-            O:=GetObjectProp(Self,P);
-            O.Free;
-            SetObjectProp(Self,P,Nil);
-            end;
+            Self.ClearProperty(P);
         tkDynArray:
           if (ctArray in ChildTypes) then
-            begin
-            len:=Length(P^.PropType^.Name);
-            PTD:=GetTypeData(P^.PropType);
-            if PTD^.ElType2^.Kind=tkClass then
-              begin
-              A:=GetDynArrayProp(P);
-{$IFDEF DUMPARRAY}
-              DumpArray(ClassName+' (clear)',P^.PropType^.Name,A);
-{$ENDIF}
-//              Writeln(ClassName,' Examining array: ',P^.Name,'Count:',Length(TObjectArr(A)));
-              For J:=0 to Length(TObjectArr(A))-1 do
-                begin
-                FreeAndNil(TObjectArr(A)[J]);
-                end;
-              end;
-            // Length is set to nil by destructor
-            end;
+            Self.ClearProperty(P);
+      else
+        //do nothing
+        //only properties with objects or dyn arrays have children
       end;
       end;
   finally
@@ -1216,13 +1180,6 @@ begin
   Result:=fAdditionalProperties
 end;
 
-{$IFDEF VER2_6}
-procedure TBaseObject.SetArrayLength(Const AName: String; ALength: Longint);
-begin
-  Raise ERestAPI.CreateFmt('Unknown Array %s',[AName]);
-end;
-{$ENDIF}
-
 class function TBaseObject.AllowAdditionalProperties: Boolean;
 begin
   Result:=False;
@@ -1331,9 +1288,7 @@ begin
           ntFloat   : SetFloatProperty(P,JSON.asFloat);
           ntInteger : SetIntegerProperty(P,JSON.asInteger);
           ntInt64   : SetInt64Property(P,JSON.asInt64);
-{$ifndef ver2_6}
           ntqword   : SetQWordProperty(P,JSON.asQWord);
-{$endif}
         end;
       jtNull    : ClearProperty(P);
       jtBoolean : SetBooleanProperty(P,json.AsBoolean);
@@ -1343,6 +1298,8 @@ begin
         else
           SetArrayProperty(P,TJSONArray(json));
       jtObject   : SetObjectProperty(P,TJSONObject(json));
+    else
+      //do nothing
     end;
 end;
 
@@ -1368,6 +1325,8 @@ begin
    tkQWord    : Result:=GetQWordProperty(Info);
    tkInt64    : Result:=GetInt64Property(Info);
    tkInteger  : Result:=GetIntegerProperty(Info);
+  else
+    //do nothing
   end;
 end;
 
@@ -1428,4 +1387,3 @@ finalization
 {$ENDIF}
   FreeAndNil(Fact);
 end.
-

packages/googleapi/generator/googleapiconv.pp

@@ -3,20 +3,11 @@
 
 { $DEFINE USESYNAPSE}
 
-{$IFDEF VER2_6}
-{$DEFINE USESYNAPSE}
-{$ENDIF}
-
 program googleapiconv;
 
 uses
   custapp, classes, sysutils, fpjson, jsonparser, fpwebclient,
-{$IFDEF USESYNAPSE}
-  ssl_openssl,
-  synapsewebclient,
-{$ELSE}
   fphttpwebclient, opensslsockets,
-{$ENDIF}
   googlediscoverytopas, googleservice, restbase, pascodegen, restcodegen;
 
 Const
@@ -116,11 +107,7 @@ begin
   Result:=True;
   Req:=Nil;
   Resp:=Nil;
-{$IFDEF USESYNAPSE}
-  WebClient:=TSynapseWebClient.Create(Self);
-{$ELSE}
   WebClient:=TFPHTTPWebClient.Create(Self);
-{$ENDIF}
   try
     Req:=WebClient.CreateRequest;
     Req.ResponseContent:=Response;
@@ -210,7 +197,7 @@ procedure TGoogleAPIConverter.RegisterUnit(FileName :String; L : TAPIEntries);
 
 Var
   I : Integer;
-  UN,N,V : String;
+  UN,N : String;
 
 begin
   UN:=ChangeFileext(ExtractFileName(FileName),'');
@@ -281,10 +268,9 @@ procedure TGoogleAPIConverter.CreateFPMake(FileName :String; L : TAPIEntries);
 
 Var
   I : Integer;
-  UN,N,V : String;
+  N : String;
 
 begin
-  UN:=ChangeFileext(ExtractFileName(FileName),'');
   With TStringList.Create do
     try
       Add('program fpmake;');
@@ -320,7 +306,7 @@ begin
       For I:=0 to L.Count-1 do
         begin
         N:=L[i].APIUnitName;
-        Add(Format('    T:=StdDep(P.Targets.AddUnit(''%s''));',[ExtractFileName(L[i].FAPIUnitName)]));
+        Add(Format('    T:=StdDep(P.Targets.AddUnit(''%s''));',[ExtractFileName(N)]));
         end;
       Add('    end;');
       Add('end;');
@@ -608,4 +594,3 @@ begin
   Application.Run;
   FreeAndNil(Application);  //gets rid of memory leak and makes Heaptrc happy
 end.
-

packages/googleapi/generator/googlediscoverytopas.pp

@@ -63,10 +63,6 @@ Type
   TGoogleAuth2 = Class(TGoogleBaseObject)
   private
     FScopes: TSchemas;
-  Protected
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
   Published
     Property Scopes : TSchemas Read Fscopes Write Fscopes;
   end;
@@ -91,10 +87,6 @@ Type
   TAnnotations = Class(TGoogleBaseObject)
   private
     FRequired: TStringArray;
-  Protected
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
   Published
     Property required : TStringArray Read FRequired Write Frequired;
   end;
@@ -144,9 +136,6 @@ Type
   Public
     Class function BaseType(ATypeName: String): Boolean;
     Class function GetBaseTypeName(AType,AFormat : String) : string;
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
     Function DebugName : String;
     function GetBaseTypeName : string;
     Function BaseType : Boolean;
@@ -228,10 +217,6 @@ Type
     FAccept: TStringArray;
     FMaxSize: String;
     Fprotocols: TMediaUploadProtocols;
-  protected
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
   Published
     Property Accept : TStringArray Read FAccept Write FAccept;
     property MaxSize : String Read FMaxSize Write FMaxSize;
@@ -294,10 +279,6 @@ Type
     FsupportsMediaDownload: Boolean;
     FsupportsMediaUpload: Boolean;
     FsupportsSubscription: Boolean;
-  protected
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
   Published
     Property name : string read fname Write fname;
     Property description : String Read FDescription Write FDescription;
@@ -349,11 +330,6 @@ Type
     fservicePath: string;
     FTitle: string;
     Fversion: String;
-  Protected
-{$ifdef ver2_6}
-    Procedure SetArrayLength(const AName : String; ALength : Longint); override;
-{$endif}
-  Public
   Published
     property Auth : TGoogleAuth Read Fauth Write Fauth;
     property basePath : string read fbasePath write FbasePath;
@@ -510,71 +486,6 @@ Type
 
 implementation
 
-{ TGoogleRestDescription }
-
-{$IFDEF VER_2_6}
-Procedure TGoogleRestDescription.SetArrayLength(const AName: String;
-  ALength: Longint);
-begin
-  case aname of
-    'schemas' : setlength(FSchemas,ALength);
-    'features' : setlength(FFeatures,ALength);
-    'labels' : setlength(FLabels,ALength);
-    'methods' : setlength(Fmethods,ALength);
-    'resources' : setlength(FResources,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-{$ENDIF}
-
-{ TRestMethod }
-{$ifdef ver2_6}
-Procedure TRestMethod.SetArrayLength(const AName: String; ALength: Longint);
-begin
-  case AName of
-   'parameterorder' : SetLength(FParameterOrder,ALength);
-   'parameters' : SetLength(FParameters,ALength);
-   'scopes' : SetLength(FScopes,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-
-{ TMediaUpload }
-
-Procedure TMediaUpload.SetArrayLength(const AName: String; ALength: Longint);
-begin
-  Case AName of
-    'accept' : SetLength(FAccept,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-
-{ TGoogleAuth2 }
-
-Procedure TGoogleAuth2.SetArrayLength(const AName: String; ALength: Longint);
-begin
-  Case AName of
-    'scopes' : SetLength(FScopes,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-
-{ TAnnotations }
-
-Procedure TAnnotations.SetArrayLength(const AName: String; ALength: Longint);
-begin
-  Case AName of
-    'required' :SetLength(FRequired,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-{$endif}
-
 { TTypeDefEnumerator }
 
 function TTypeDefEnumerator.GetCurrent: TTypeDef;
@@ -791,7 +702,9 @@ begin
         DoLog('Class type, adding properties first');
         CollectTypes(S.Properties,NamePrefix+S.Name+PropertyTypeSuffix);
         end;
-    end;
+  else
+    //no other cases to handle
+  end;
   if (NamePrefix='') then
     AddType(S,'',True)
   else if (Not S.BaseType) and (Not BaseArrayElement) and (S.Ref='') then
@@ -938,20 +851,6 @@ begin
       Result:='String';
 end;
 
-{$IFDEF VER2_6}
-Procedure TSchema.SetArrayLength(const AName: String; ALength: Longint);
-begin
-  Case AName of
-   'enumdescriptions' : SetLength(FenumDescriptions,ALength);
-   'properties' : SetLength(FProperties,ALength);
-   'methods' : SetLength(FMethods,ALength);
-   'resources' : SetLength(FResources,ALength);
-  else
-    inherited SetArrayLength(AName, ALength);
-  end;
-end;
-{$ENDIF}
-
 Function TSchema.DebugName: String;
 begin
   Result:=sysutils.Format('(Name: %s, Pascal Type : %s, type : %s, Ref: %s)',[Name,TypeName,_type,Ref]);
@@ -1023,7 +922,7 @@ Var
 begin
   if ASchema=Nil then
     Raise Exception.Create(AClassName+' : no Schema');
-  ClassHeader(AClassName);
+  ClassComment(AClassName);
   AddLn('%s = Class(%s)',[AClassName,BaseClassName]);
   AddLn('Private');
   NeedGetWriteName:=False;
@@ -1067,13 +966,6 @@ begin
     tn:=GetPropertyType(AClassName,S);
     AddLn('Procedure Set%s(AIndex : Integer; const AValue : %s); virtual;',[N,tn]);
     end;
-  if NeedSetArrayLength and not UseListForArray then
-    begin
-    Comment('2.6.4. bug workaround');
-    Addln('{$IFDEF VER2_6}');
-    Addln('Procedure SetArrayLength(Const AName : String; ALength : Longint); override;');
-    Addln('{$ENDIF VER2_6}');
-    end;
   DecIndent;
   AddLn('Public');
   IncIndent;
@@ -1108,7 +1000,7 @@ begin
     Raise Exception.Create(AClassName+' : no item Schema');
   AItemName:=GetPropertyType('',AItemSchema);
   AEnumeratorName:=AClassName+'Enumerator';
-  ClassHeader(AEnumeratorName);
+  ClassComment(AEnumeratorName);
   AddLn('%s = Class(%s)',[AEnumeratorName,'TBaseListEnumerator']);
   AddLn('Public');
   IncIndent;
@@ -1118,7 +1010,7 @@ begin
   AddLn('end;');
   AddLn('');
   AddLn('');
-  ClassHeader(AClassName);
+  ClassComment(AClassName);
   AddLn('%s = Class(%s)',[AClassName,BaseListClassName]);
   AddLn('Private');
   IncINdent;
@@ -1140,33 +1032,8 @@ end;
 
 procedure TDiscoveryJSONToPas.CreateSetArrayLength(AClassName: String; ASchema, AItemSchema: TSchema);
 
-Var
-  S : TSchema;
-  N : String;
-
 begin
-  Comment('2.6.4. bug workaround');
-  Addln('{$IFDEF VER2_6}');
-  Addln('Procedure %s.SetArrayLength(Const AName : String; ALength : Longint); ',[AClassName]);
-  Addln('');
-  AddLn('begin');
-  IncIndent;
-  AddLn('Case AName of');
-  For S in ASchema.ClassProperties do
-    if (S._type='array') then
-      begin
-      N:=S.PropertyName;
-      AddLn('''%s'' : SetLength(F%s,ALength);',[Lowercase(N),N]);
-      end;
-  AddLn('else');
-  IncIndent;
-  AddLn('Inherited SetArrayLength(AName,ALength);');
-  DecIndent;
-  AddLn('end;');
-  DecIndent;
-  AddLn('end;');
-  Addln('{$ENDIF VER2_6}');
-  Addln('');
+  //not used
 end;
 
 procedure TDiscoveryJSONToPas.CreateExportPropertyName(AClassName: String; ASchema, AItemSchema: TSchema);
@@ -1212,7 +1079,7 @@ Var
 begin
   NeedGetWriteName:=False;
   NeedSetArrayLength:=False;
-  ClassHeader(AClassName);
+  ClassComment(AClassName);
   For S in ASchema.ClassProperties do
     begin
     N:=S.PropertyName;
@@ -1251,7 +1118,7 @@ begin
   CreateArrayClassEnumeratorImplementation(ACLassName,ASchema,AItemSchema);
   AItemName:=GetPropertyType('',AItemSchema);
   AEnumeratorName:=AClassName+'Enumerator';
-  ClassHeader(AClassName);
+  ClassComment(AClassName);
   Addln('');
   Addln('Function %s.GetI (AIndex : Integer) : %s;',[AClassName,AItemName]);
   SimpleMethodBody([Format('Result:=%s(Objects[AIndex]);',[AItemName])]);
@@ -1278,7 +1145,7 @@ begin
     Raise Exception.Create(AClassName+' : no ItemSchema');
   AItemName:=GetPropertyType('',AItemSchema);
   AEnumeratorName:=AClassName+'Enumerator';
-  ClassHeader(AEnumeratorName);
+  ClassComment(AEnumeratorName);
   AddLn('Function %s.GetCurrent  : %s;',[AEnumeratorName,AItemName]);
   SimpleMethodBody([Format('Result:=%s(Inherited GetCurrent);',[AItemName])]);
 end;
@@ -1369,6 +1236,8 @@ begin
       dtClass: CreateClassImplementation(S.PascalName,S.Schema,S.ItemSchema);
       dtArray: if UseListForArray then
        CreateArrayClassImplementation(S.PascalName,S.Schema,S.ItemSchema);
+    else
+      //no other cases to handle
     end;
   CreateResourceClassImplementations('',Description.Resources);
   CreateAPIClassImplementation;
@@ -1595,7 +1464,7 @@ Var
 
 begin
   CN:=Res.TypeName;
-  ClassHeader(CN);
+  ClassComment(CN);
   For M in Res.methods do
     begin
     AssignParamNames(Res,M);
@@ -1798,7 +1667,7 @@ Var
 
 begin
   CN:=Res.TypeName;
-  ClassHeader(CN);
+  ClassComment(CN);
   CreateResourceClassMethodsImplementation(Res,CN);
   For M in Res.methods do
     begin
@@ -1884,7 +1753,7 @@ Var
 
 begin
   CN:=GetAPIClassName;
-  Classheader(CN);
+  ClassComment(CN);
   AddLn('%s = Class(TGoogleAPI)',[CN]);
   AddLn('Private');
   IncIndent;
@@ -1945,7 +1814,7 @@ Var
 
 begin
   CN:=GetAPIClassName;
-  ClassHeader(CN);
+  ClassComment(CN);
   AddLn('Class Function %s.APIName : String;',[CN]);
   StringRes(Description.name);
   AddLn('Class Function %s.APIVersion : String;',[CN]);
@@ -2097,4 +1966,3 @@ end;
 
 
 end.
-

packages/googleapi/generator/run_google_api_bindings_gen.sh

@@ -4,7 +4,7 @@
 #   If they exist, this script deletes the "./_google_api_bindings_tmp"
 #   and "./_google_api_icons_tmp" directories before attempting
 #   to convert new files. It does not download any JSON, but works on
-#   files which must already be present in "./_google_api_bindings_tmp"
+#   files which must already be present in "./_google_api_json_tmp"
 #   (use "./fetch_google_json.sh" to download the JSON files)
 
 shopt -s nocaseglob  #ignore case for filename matches

packages/ide/fpmake.pp

@@ -320,17 +320,21 @@ begin
         T.Directory:='compiler';
         T.Install:=false;
 
-        P.InstallFiles.Add('fp.ans','$(bininstalldir)');
-        P.InstallFiles.Add('gplprog.pt','$(bininstalldir)');
-        P.InstallFiles.Add('gplunit.pt','$(bininstalldir)');
-        P.InstallFiles.Add('program.pt','$(bininstalldir)');
-        P.InstallFiles.Add('unit.pt','$(bininstalldir)');
-        P.InstallFiles.Add('cvsco.tdf','$(bininstalldir)');
-        P.InstallFiles.Add('cvsdiff.tdf','$(bininstalldir)');
-        P.InstallFiles.Add('cvsup.tdf','$(bininstalldir)');
-        P.InstallFiles.Add('grep.tdf','$(bininstalldir)');
-        P.InstallFiles.Add('tpgrep.tdf','$(bininstalldir)');
-        P.InstallFiles.Add('fp32.ico', [win32, win64], '$(bininstalldir)');
+        if (OSToString(defaults.OS)=lowercase({$I %FPCTARGETOS%})) and
+          (CPUToString(defaults.CPU)=lowercase({$I %FPCTARGETCPU%})) then
+        begin
+          P.InstallFiles.Add('fp.ans','$(bininstalldir)');
+          P.InstallFiles.Add('gplprog.pt','$(bininstalldir)');
+          P.InstallFiles.Add('gplunit.pt','$(bininstalldir)');
+          P.InstallFiles.Add('program.pt','$(bininstalldir)');
+          P.InstallFiles.Add('unit.pt','$(bininstalldir)');
+          P.InstallFiles.Add('cvsco.tdf','$(bininstalldir)');
+          P.InstallFiles.Add('cvsdiff.tdf','$(bininstalldir)');
+          P.InstallFiles.Add('cvsup.tdf','$(bininstalldir)');
+          P.InstallFiles.Add('grep.tdf','$(bininstalldir)');
+          P.InstallFiles.Add('tpgrep.tdf','$(bininstalldir)');
+          P.InstallFiles.Add('fp32.ico', [win32, win64], '$(bininstalldir)');
+        end;
 
         with P.Sources do
         begin

packages/openssl/src/openssl.pas

@@ -1182,6 +1182,9 @@ var
   function Asn1IntegerGet(a: PASN1_INTEGER): integer;
   function i2dX509bio(b: PBIO; x: PX509): cInt;
   function i2dPrivateKeyBio(b: PBIO; pkey: PEVP_PKEY): cInt;
+  function d2iX509bio(b:PBIO; x:PX509):  PX509;
+  function PEMReadBioX509(b:PBIO; x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509;
+  procedure SkX509PopFree(st: SslPtr);
 
   // 3DES functions
   procedure DESsetoddparity(Key: des_cblock);
@@ -1678,6 +1681,9 @@ type
   TAsn1IntegerSet = function(a: PASN1_INTEGER; v: integer): integer; cdecl;
   TAsn1IntegerGet = function(a: PASN1_INTEGER): integer; cdecl;
   Ti2dX509bio = function(b: PBIO; x: PX509): cInt; cdecl;
+  Td2iX509bio = function(b:PBIO;  x:PX509):   PX509; cdecl;
+  TPEMReadBioX509 = function(b:PBIO; x:PSslPtr; callback:PFunction; cb_arg:SslPtr): PX509; cdecl;
+  TSkX509PopFree = procedure(st: PSslPtr; func: TX509Free); cdecl;
   Ti2dPrivateKeyBio= function(b: PBIO; pkey: PEVP_PKEY): cInt; cdecl;
 
   // 3DES functions
@@ -1922,6 +1928,9 @@ var
   _Asn1IntegerSet: TAsn1IntegerSet = nil;
   _Asn1IntegerGet: TAsn1IntegerGet = nil;
   _i2dX509bio: Ti2dX509bio = nil;
+  _d2iX509bio: Td2iX509bio = nil;
+  _PEMReadBioX509: TPEMReadBioX509 = nil;
+  _SkX509PopFree: TSkX509PopFree = nil;
   _i2dPrivateKeyBio: Ti2dPrivateKeyBio = nil;
   _EVP_enc_null : TEVP_CIPHERFunction = nil;
   _EVP_rc2_cbc : TEVP_CIPHERFunction = nil;
@@ -3028,6 +3037,28 @@ begin
     Result := 0;
 end;
 
+function d2iX509bio(b:PBIO; x:PX509):  PX509;
+begin
+  if InitSSLInterface and Assigned(_d2iX509bio) then
+    Result := _d2iX509bio(x,b)
+  else
+    Result := nil;
+end;
+
+function PEMReadBioX509(b:PBIO; x:PSslPtr; callback:PFunction; cb_arg: SslPtr): PX509;
+begin
+  if InitSSLInterface and Assigned(_PEMReadBioX509) then
+    Result := _PEMReadBioX509(b,x,callback,cb_arg)
+  else
+    Result := nil;
+end;
+
+procedure SkX509PopFree(st: SslPtr);
+begin
+  if InitSSLInterface and Assigned(_SkX509PopFree) then
+    _SkX509PopFree(st,_X509Free);
+end;
+
 function EvpGetDigestByName(Name: String): PEVP_MD;
 begin
   if InitSSLInterface and Assigned(_EvpGetDigestByName) then
@@ -5046,6 +5077,9 @@ begin
   _Asn1IntegerSet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_set');
   _Asn1IntegerGet := GetProcAddr(SSLUtilHandle, 'ASN1_INTEGER_get');
   _i2dX509bio := GetProcAddr(SSLUtilHandle, 'i2d_X509_bio');
+  _d2iX509bio := GetProcAddr(SSLUtilHandle, 'd2i_X509_bio');
+  _PEMReadBioX509 := GetProcAddr(SSLUtilHandle, 'PEM_read_bio_X509');
+  _SkX509PopFree := GetProcAddr(SSLUtilHandle, 'SK_X509_POP_FREE');
   _i2dPrivateKeyBio := GetProcAddr(SSLUtilHandle, 'i2d_PrivateKey_bio');
   _EVP_enc_null := GetProcAddr(SSLUtilHandle, 'EVP_enc_null');
   _EVP_rc2_cbc := GetProcAddr(SSLUtilHandle, 'EVP_rc2_cbc');
@@ -5495,6 +5529,9 @@ begin
   _Asn1IntegerSet:= nil;
   _Asn1IntegerGet:= nil;
   _i2dX509bio := nil;
+  _d2iX509bio := nil;
+  _PEMReadBioX509 := nil;
+  _SkX509PopFree := nil;
   _i2dPrivateKeyBio := nil;
 
   // 3DES functions

packages/rtl-extra/src/inc/sockets.inc

@@ -750,3 +750,13 @@ begin
 end;
 
 
+function NetAddrIsPrivate(const IP: in_addr): Boolean;
+begin
+  NetAddrIsPrivate:=
+     // 10.0.0.0 – 10.255.255.255
+     (IP.s_bytes[1]=10)
+     // 172.16.0.0 – 172.31.255.255
+     or ((IP.s_bytes[1]=172) and (IP.s_bytes[2]>=16) and (IP.s_bytes[2]<=31))
+     // 192.168.0.0 – 192.168.255.255
+     or ((IP.s_bytes[1]=192) and (IP.s_bytes[2]=168));
+end;

packages/rtl-extra/src/inc/socketsh.inc

@@ -203,6 +203,9 @@ Function NetToHost     (Net  : Longint) : Longint; deprecated;
 Function ShortHostToNet(Host : Word) : Word; deprecated;
 Function ShortNetToHost(Net  : Word) : Word; deprecated;
 
+function NetAddrIsPrivate(const IP: in_addr): Boolean;
+
+
 // ipv6
 function HostAddrToStr6(Entry : Tin6_addr) : AnsiString;
 function StrToHostAddr6(IP   : AnsiString) : Tin6_addr;     // not implemented?!?

rtl/inc/generic.inc

@@ -316,23 +316,18 @@ var
   psrc,pend : pbyte;
 begin
   psrc:=@buf;
+  pend:=psrc+len;
   { simulate assembler implementations behaviour, which is expected }
   { fpc_pchar_to_ansistr in astrings.inc                            }
   if (len < 0) or
-     (psrc+len < psrc) then
-    pend:=pbyte(high(PtrUInt)-sizeof(byte))
+     (pend < psrc) then
+    pend:=pbyte(high(PtrUInt)-PtrUint(sizeof(byte)));
+  while (psrc<pend) and (psrc^<>b) do
+    inc(psrc);
+  if psrc<pend then
+    result:=psrc-pbyte(@buf)
   else
-    pend:=psrc+len;
-  while (psrc<pend) do
-    begin
-      if psrc^=b then
-        begin
-          result:=psrc-pbyte(@buf);
-          exit;
-        end;
-      inc(psrc);
-    end;
-  result:=-1;
+    result:=-1;
 end;
 {$endif not FPC_SYSTEM_HAS_INDEXBYTE}
 
@@ -343,40 +338,28 @@ var
   psrc,pend : pword;
 begin
   psrc:=@buf;
+  pend:=psrc+len;
   { simulate assembler implementations behaviour, which is expected }
   { fpc_pchar_to_ansistr in astrings.inc                            }
-  if (len < 0) or
-     { is this ever true? }
-     (len > high(PtrInt)) or
-     (psrc+len < psrc) then
-    pend:=pword(high(PtrUInt)-sizeof(word))
-  else
-    pend:=psrc+len;
+  if not (
+      (len >= 0) and
+      { is this ever false? }
+      (len <= high(PtrInt))) or
+     (pend < psrc) then
+    pend:=pword(high(PtrUInt)-PtrUint(sizeof(word)));
 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
   if (ptruint(psrc) mod 2)<>0 then
-    while psrc<pend do
-      begin
-        if unaligned(psrc^)=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(word);
-            exit;
-          end;
-        inc(psrc);
-      end
+    while (psrc<pend) and (unaligned(psrc^)<>b) do
+      inc(psrc)
   else
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-    while psrc<pend do
-      begin
-        if psrc^=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(word);
-            exit;
-          end;
-        inc(psrc);
-      end;
-  result:=-1;
+    while (psrc<pend) and (psrc^<>b) do
+      inc(psrc);
+  if psrc<pend then
+    { the result is always >=0 so avoid handling of negative values }
+    result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(word)
+  else
+    result:=-1;
 end;
 {$endif not FPC_SYSTEM_HAS_INDEXWORD}
 
@@ -387,39 +370,27 @@ var
   psrc,pend : pdword;
 begin
   psrc:=@buf;
+  pend:=psrc+len;
   { simulate assembler implementations behaviour, which is expected }
   { fpc_pchar_to_ansistr in astrings.inc                            }
-  if (len < 0) or
-     (len > high(PtrInt) div 2) or
-     (psrc+len < psrc) then
-    pend:=pdword(high(PtrUInt)-PtrUInt(sizeof(dword)))
-  else
-    pend:=psrc+len;
+  if not (
+      (len >= 0) and
+      (len <= high(PtrInt) div 2)) or
+     (pend < psrc) then
+    pend:=pdword(high(PtrUInt)-PtrUInt(sizeof(dword)));
 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
   if (ptruint(psrc) mod 4)<>0 then
-    while psrc<pend do
-      begin
-        if unaligned(psrc^)=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(DWord);
-            exit;
-          end;
-        inc(psrc);
-      end
+    while (psrc<pend) and (unaligned(psrc^)<>b) do
+      inc(psrc)
   else
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-    while psrc<pend do
-      begin
-        if psrc^=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(DWord);
-            exit;
-          end;
-        inc(psrc);
-      end;
-  result:=-1;
+    while (psrc<pend) and (psrc^<>b) do
+      inc(psrc);
+  if psrc<pend then
+    { the result is always >=0 so avoid handling of negative values }
+    result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(DWord)
+  else
+    result:=-1;
 end;
 {$endif not FPC_SYSTEM_HAS_INDEXDWORD}
 
@@ -430,39 +401,27 @@ var
   psrc,pend : pqword;
 begin
   psrc:=@buf;
+  pend:=psrc+len;
   { simulate assembler implementations behaviour, which is expected }
   { fpc_pchar_to_ansistr in astrings.inc                            }
-  if (len < 0) or
-     (len > high(PtrInt) div 4) or
-     (psrc+len < psrc) then
-    pend:=pqword(high(PtrUInt)-PtrUInt(sizeof(qword)))
-  else
-    pend:=psrc+len;
+  if not (
+      (len >= 0) and
+      (len <= high(PtrInt) div 4)) or
+     (pend < psrc) then
+    pend:=pqword(high(PtrUInt)-PtrUInt(sizeof(qword)));
 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
   if (ptruint(psrc) mod 8)<>0 then
-    while psrc<pend do
-      begin
-        if unaligned(psrc^)=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(QWord);
-            exit;
-          end;
-        inc(psrc);
-      end
+    while (psrc<pend) and (unaligned(psrc^)<>b) do
+      inc(psrc)
   else
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-    while psrc<pend do
-      begin
-        if psrc^=b then
-          begin
-            { the result is always >=0 so avoid handling of negative values }
-            result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(QWord);
-            exit;
-          end;
-        inc(psrc);
-      end;
-  result:=-1;
+    while (psrc<pend) and (psrc^<>b) do
+      inc(psrc);
+  if psrc<pend then
+    { the result is always >=0 so avoid handling of negative values }
+    result:=PtrUint(pointer(psrc)-pointer(@buf)) div sizeof(QWord)
+  else
+    result:=-1;
 end;
 {$endif not FPC_SYSTEM_HAS_INDEXQWORD}
 

rtl/linux/ostypes.inc

@@ -75,14 +75,18 @@ TYPE
 { include /include/asm-<cpu>/posix-types.h                       }
 
 const
-{$ifndef cpux86_64}
+{$if not defined(cpux86_64) and not defined (cpuaarch64)}
   _STAT_VER_LINUX_OLD = 1;
   _STAT_VER_KERNEL = 1;
   _STAT_VER_SVR4 = 2;
   _STAT_VER_LINUX = 3;
 {$else}
   _STAT_VER_KERNEL = 0;
+{$if defined(cpuaarch64)}
+  _STAT_VER_LINUX = 0;
+{$else}
   _STAT_VER_LINUX = 1;
+{$endif}
 {$endif}
   _STAT_VER = _STAT_VER_LINUX;
 

tests/test/cg/tcond1.pp

@@ -0,0 +1,56 @@
+{ %CPU=i386,x86_64 }
+{ %OPT=-a -O2 -CpCOREI }
+
+{ This test evaluates OptPass2Jcc's ability to create CMOV instructions with
+  constants while ensuring correct code is still generated. }
+  
+program tcond1;
+
+uses
+  CPU;
+
+const
+  Expected: array[0..3] of array[0..2] of LongInt =
+    ((-10, 3, 2), (-10, 4, 2), (0, 0, -10), (0, 0, -10));
+
+function TestInput(Input, TestAns: LongInt): Boolean;
+  var
+    O1, O2, O3: LongInt;
+  begin
+    if Input < 2 then 
+      begin
+        O1 := -10;
+        O2 := TestAns;
+        O3 := 2;
+      end
+    else
+      begin
+        O1 := 0;
+        O2 := 0;
+        O3 := -10;
+      end;
+
+    TestInput :=
+      (O1 = Expected[Input][0]) and
+      (O2 = Expected[Input][1]) and
+      (O3 = Expected[Input][2]);
+  end;
+
+var
+  X: LongInt;
+  
+begin
+  if not CMOVSupport then
+    begin
+      WriteLn('unsupported');
+      Halt(0);
+    end;      
+
+  for X := 0 to 3 do
+    begin
+      if not TestInput(X, X + 3) then
+        Halt(1);
+    end;
+    
+  WriteLn('ok');
+end.

tests/test/cg/tcond2.pp

@@ -0,0 +1,47 @@
+{ %CPU=i386,x86_64 }
+{ %OPT=-a -O2 -CpCOREI }
+
+{ This test evaluates IsRefSafe returning false but still permitting CMOV
+  because the condition reads it }
+
+program tcond2;
+
+uses
+  CPU;
+
+type
+  PLongInt = ^LongInt;
+
+const
+  InputVal: array[0..3] of LongInt = (-1, 0, 2147483647, -2147483648);
+  Expected: array[0..3] of LongInt = (0, 0, 2147483647, 0);
+
+function ZeroClamp(const Reference: PLongInt): LongInt; noinline;
+  begin
+    ZeroClamp := 0;
+    if Reference^ > 0 then
+      ZeroClamp := Reference^;
+  end;
+
+var
+  X, Output: LongInt;
+
+begin
+  if not CMOVSupport then
+    begin
+      WriteLn('unsupported');
+      Halt(0);
+    end;      
+
+  for X := 0 to 3 do
+    begin
+      Output := ZeroClamp(@InputVal[X]);
+      if Output <> Expected[X] then
+        begin
+          WriteLn('FAIL: ZeroClamp(', InputVal[X], ') returned ', Output, '; expected ', Expected[X]);
+          Halt(1);
+        end;
+    end;
+
+  WriteLn('ok');
+end.

tests/test/cg/tcond2a.pp

@@ -0,0 +1,51 @@
+{ %CPU=i386,x86_64 }
+{ %OPT=-a -O2 -CpCOREI }
+
+{ This test evaluates IsRefSafe returning false but still permitting CMOV
+  because the condition reads it }
+
+program tcond2a;
+
+uses
+  CPU;
+
+type
+  PLongInt = ^LongInt;
+
+const
+  InputVal: array[0..3] of LongInt = (-1, 0, 2147483647, -2147483648);
+  Expected: array[0..3] of LongInt = (0, 0, 2147483647, 0);
+
+function ZeroClamp(const Reference: PLongInt): LongInt; noinline;
+  begin
+    { Note, reversing the if-statement so the Reference^ write is not in the
+      'else' block causes the code for "ZeroClamp := Reference^" to be a
+      regular MOV }
+    if Reference^ <= 0 then
+      ZeroClamp := 0
+    else
+      ZeroClamp := Reference^
+  end;
+
+var
+  X, Output: LongInt;
+
+begin
+  if not CMOVSupport then
+    begin
+      WriteLn('unsupported');
+      Halt(0);
+    end;      
+
+  for X := 0 to 3 do
+    begin
+      Output := ZeroClamp(@InputVal[X]);
+      if Output <> Expected[X] then
+        begin
+          WriteLn('FAIL: ZeroClamp(', InputVal[X], ') returned ', Output, '; expected ', Expected[X]);
+          Halt(1);
+        end;
+    end;
+
+  WriteLn('ok');
+end.