Procházet zdrojové kódy

Merge branch 'main' into val_range_check

# Conflicts:
#	rtl/inc/sstrings.inc
florian před 3 roky
rodič
revize
07cd469ade
51 změnil soubory, kde provedl 854 přidání a 273 odebrání
  1. 2 2
      compiler/msg/errorct.msg
  2. 2 2
      compiler/msg/errord.msg
  3. 1 1
      compiler/msg/errorda.msg
  4. 2 2
      compiler/msg/errordu.msg
  5. 1 1
      compiler/msg/errore.msg
  6. 1 1
      compiler/msg/errores.msg
  7. 1 1
      compiler/msg/errorf.msg
  8. 1 1
      compiler/msg/errorfi.msg
  9. 1 1
      compiler/msg/errorhe.msg
  10. 1 1
      compiler/msg/errorheu.msg
  11. 1 1
      compiler/msg/errorid.msg
  12. 1 1
      compiler/msg/erroriu.msg
  13. 1 1
      compiler/msg/errorn.msg
  14. 1 1
      compiler/msg/errorpl.msg
  15. 1 1
      compiler/msg/errorpli.msg
  16. 1 1
      compiler/msg/errorpt.msg
  17. 1 1
      compiler/msg/errorptu.msg
  18. 1 1
      compiler/msg/errorr.msg
  19. 1 1
      compiler/msg/errorru.msg
  20. 1 1
      compiler/msg/errorues.msg
  21. 1 1
      compiler/msgtxt.inc
  22. 5 13
      compiler/optdfa.pas
  23. 17 19
      compiler/optutils.pas
  24. 4 2
      compiler/pmodules.pas
  25. 4 2
      compiler/systems/t_freertos.pas
  26. 115 89
      compiler/x86/aoptx86.pas
  27. 3 1
      packages/fcl-db/src/base/bufdataset.pas
  28. 58 7
      packages/fcl-db/src/base/db.pas
  29. 21 0
      packages/fcl-db/src/base/dsparams.inc
  30. 237 34
      packages/fcl-db/src/base/fields.inc
  31. 6 1
      packages/fcl-db/src/dbase/dbf_fields.pas
  32. 10 2
      packages/fcl-db/src/memds/memds.pp
  33. 5 3
      packages/fcl-db/tests/bufdatasettoolsunit.pas
  34. 8 0
      packages/fcl-db/tests/memdstoolsunit.pas
  35. 1 1
      packages/fcl-db/tests/sqldbtoolsunit.pas
  36. 56 21
      packages/fcl-db/tests/testdbbasics.pas
  37. 3 0
      packages/fcl-db/tests/toolsunit.pas
  38. 1 1
      packages/fcl-web/examples/websocket/client/wsclient.lpr
  39. 84 0
      packages/paszlib/src/zipper.pp
  40. binární
      packages/paszlib/tests/test.zip
  41. 57 0
      packages/paszlib/tests/testsingle.lpi
  42. 19 0
      packages/paszlib/tests/testsingle.pas
  43. 31 26
      packages/wasmtime/Makefile
  44. 1 1
      rtl/freertos/Makefile
  45. 1 1
      rtl/freertos/Makefile.fpc
  46. 43 0
      rtl/freertos/xtensa/espidf_40100.pp
  47. 14 17
      rtl/inc/sstrings.inc
  48. 2 0
      rtl/objpas/classes/compon.inc
  49. 1 1
      tests/bench/bval.pp
  50. 2 2
      utils/pas2js/compileserver.lpi
  51. 21 5
      utils/pas2js/httpcompiler.pp

+ 2 - 2
compiler/msg/errorct.msg

@@ -1,6 +1,6 @@
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1993-2021 by the Free Pascal Development team
+#   Copyright (c) 1993-2022 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-2021 per Florian Klaempfl and others
+Copyright (c) 1993-2022 per Florian Klaempfl and others
 ]
 
 #

+ 2 - 2
compiler/msg/errord.msg

@@ -6,7 +6,7 @@
 #   Based on errore.msg of git commit ce1f9cce, 27 Jun, 2021
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1998-2021 by the Free Pascal Development team
+#   Copyright (c) 1998-2022 by the Free Pascal Development team
 #
 #   See the file COPYING.v2, included in this distribution,
 #   for details about the copyright.
@@ -3810,7 +3810,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-2021 Florian Kl„mpfl und andere
+Copyright (c) 1993-2022 Florian Kl„mpfl und andere
 ]
 
 #

+ 1 - 1
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-2021 Florian Klaempfl and others
+Copyright (c) 1993-2022 Florian Klaempfl and others
 ]
 
 #

+ 2 - 2
compiler/msg/errordu.msg

@@ -6,7 +6,7 @@
 #   Based on errore.msg of git commit ce1f9cce, 27 Jun, 2021
 #
 #   This file is part of the Free Pascal Compiler
-#   Copyright (c) 1998-2021 by the Free Pascal Development team
+#   Copyright (c) 1998-2022 by the Free Pascal Development team
 #
 #   See the file COPYING.v2, included in this distribution,
 #   for details about the copyright.
@@ -3809,7 +3809,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-2021 Florian Klämpfl und andere
+Copyright (c) 1993-2022 Florian Klämpfl und andere
 ]
 
 #

+ 1 - 1
compiler/msg/errore.msg

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

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021, Florian Klaempfl and others]
+Copyright (c) 1993-2022, Florian Klaempfl and others]
 #
 # Info (option -i)
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 oleh Florian Klaempfl and others
+Hak Cipta (c) 1993-2022 oleh Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 di Florian Klaempfl and others
+Copyright (c) 1993-2022 di Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 door Florian Klaempfl en anderen
+Copyright (c) 1993-2022 door Florian Klaempfl en anderen
 ]
 #
 # Info (option -i)

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
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-2021 by Florian Klaempfl and others
+Copyright (c) 1993-2022 by Florian Klaempfl and others
 ]
 
 #

+ 1 - 1
compiler/msgtxt.inc

@@ -1412,7 +1412,7 @@ const msgtxt : array[0..000371,1..240] of char=(
   '13029_U_PPL filename $1'#000+
   '11023_Free Pascal Compiler version $FPCFULLVERSION [$FPCDATE] for $FPC'+
   'CPU'#010+
-  'Copyright (c) 1993-2021 by Florian Klaempfl and other','s'#000+
+  'Copyright (c) 1993-2022 by Florian Klaempfl and other','s'#000+
   '11024_Free Pascal Compiler version $FPCVERSION'#010+
   #010+
   'Compiler date      : $FPCDATE'#010+

+ 5 - 13
compiler/optdfa.pas

@@ -185,7 +185,7 @@ unit optdfa;
         { update life entry of a node with l, set changed if this changes
           life info for the node
         }
-        procedure updatelifeinfo(n : tnode;l : TDFASet);
+        procedure updatelifeinfo(n : tnode;const l : TDFASet);
           var
             b : boolean;
           begin
@@ -675,12 +675,6 @@ unit optdfa;
         inherited destroy;
       end;
 
-    var
-      { we have to pass the address of SearchNode in a call inside of SearchNode:
-        @SearchNode does not work because the compiler thinks we take the address of the result
-        so store the address from outside }
-      SearchNodeProcPointer : function(var n: tnode; arg: pointer): foreachnoderesult;
-
     type
       { helper structure to be able to pass more than one variable to the iterator function }
       TSearchNodeInfo = record
@@ -775,8 +769,8 @@ unit optdfa;
             begin
               { take care of short boolean evaluation: if the expression to be search is found in left,
                 we do not need to search right }
-              if foreachnodestatic(pm_postprocess,taddnode(n).left,SearchNodeProcPointer,arg) or
-                foreachnodestatic(pm_postprocess,taddnode(n).right,SearchNodeProcPointer,arg) then
+              if foreachnodestatic(pm_postprocess,taddnode(n).left,@optdfa.SearchNode,arg) or
+                foreachnodestatic(pm_postprocess,taddnode(n).right,@optdfa.SearchNode,arg) then
                 result:=fen_norecurse_true
               else
                 result:=fen_norecurse_false;
@@ -809,8 +803,8 @@ unit optdfa;
                       { don't warn about the method pointer }
                       AddFilepos(hpt.fileinfo);
 
-                      if not(foreachnodestatic(pm_postprocess,tcallnode(n).left,SearchNodeProcPointer,arg)) then
-                        foreachnodestatic(pm_postprocess,tcallnode(n).right,SearchNodeProcPointer,arg);
+                      if not(foreachnodestatic(pm_postprocess,tcallnode(n).left,@optdfa.SearchNode,arg)) then
+                        foreachnodestatic(pm_postprocess,tcallnode(n).right,@optdfa.SearchNode,arg);
                       result:=fen_norecurse_true
                     end;
                  end;
@@ -1005,6 +999,4 @@ unit optdfa;
       end;
 
 
-begin
-  SearchNodeProcPointer:=@SearchNode;
 end.

+ 17 - 19
compiler/optutils.pas

@@ -402,37 +402,34 @@ unit optutils;
         BreakContinueStack.Done;
       end;
 
-    var
-      defsum : TDFASet;
 
     function adddef(var n: tnode; arg: pointer): foreachnoderesult;
+      var
+        defsum : PDFASet absolute arg;
       begin
         if assigned(n.optinfo) then
           begin
-            DFASetIncludeSet(defsum,n.optinfo^.def);
+            DFASetIncludeSet(defsum^,n.optinfo^.def);
             { for nodes itself do not necessarily expose the definition of the counter as
               the counter might be undefined after the for loop, so include here the counter
               explicitly }
             if (n.nodetype=forn) and assigned(tfornode(n).left.optinfo) then
-              DFASetInclude(defsum,tfornode(n).left.optinfo^.index);
+              DFASetInclude(defsum^,tfornode(n).left.optinfo^.index);
           end;
         Result:=fen_false;
       end;
 
 
     procedure CalcDefSum(p : tnode);
+      var
+        defsum : PDFASet;
       begin
         p.allocoptinfo;
-        if not assigned(p.optinfo^.defsum) then
-          begin
-            defsum:=nil;
-            foreachnodestatic(pm_postprocess,p,@adddef,nil);
-            p.optinfo^.defsum:=defsum;
-          end;
+        defsum:[email protected]^.defsum;
+        if not assigned(defsum^) then
+            foreachnodestatic(pm_postprocess,p,@adddef,defsum);
       end;
 
-    var
-      usesum : TDFASet;
 
     function SetExecutionWeight(var n: tnode; arg: pointer): foreachnoderesult;
       var
@@ -481,22 +478,23 @@ unit optutils;
 
 
     function adduse(var n: tnode; arg: pointer): foreachnoderesult;
+      var
+        usesum : PDFASet absolute arg;
       begin
         if assigned(n.optinfo) then
-          DFASetIncludeSet(usesum,n.optinfo^.use);
+          DFASetIncludeSet(usesum^,n.optinfo^.use);
         Result:=fen_false;
       end;
 
 
     procedure CalcUseSum(p : tnode);
+      var
+        usesum : PDFASet;
       begin
         p.allocoptinfo;
-        if not assigned(p.optinfo^.usesum) then
-          begin
-            usesum:=nil;
-            foreachnodestatic(pm_postprocess,p,@adduse,nil);
-            p.optinfo^.usesum:=usesum;
-          end;
+        usesum:[email protected]^.usesum;
+        if not assigned(usesum^) then
+            foreachnodestatic(pm_postprocess,p,@adduse,usesum);
       end;
 
 

+ 4 - 2
compiler/pmodules.pas

@@ -417,14 +417,16 @@ implementation
         if not(current_module.is_unit) and (target_info.system=system_xtensa_freertos) then
           if (current_settings.controllertype=ct_esp32) then
             begin
-              if idf_version>=40200 then
+              if (idf_version>=40100) and (idf_version<40200) then
+                AddUnit('espidf_40100')
+              else if idf_version>=40200 then
                 AddUnit('espidf_40200')
               else
                 Comment(V_Warning, 'Unsupported esp-idf version');
             end
           else if (current_settings.controllertype=ct_esp8266) then
             begin
-              if idf_version=30300 then
+              if (idf_version>=30300) and (idf_version<30400) then
                 AddUnit('esp8266rtos_30300')
               else if idf_version>=30400 then
                 AddUnit('esp8266rtos_30400')

+ 4 - 2
compiler/systems/t_freertos.pas

@@ -1176,6 +1176,7 @@ begin
   S:=FindUtil(utilsprefix+'objdump');
   if (current_settings.controllertype = ct_esp32) then
     begin
+      out_ld_filename:=outputexedir+'/esp32_out.ld';
       project_ld_filename:=outputexedir+'/esp32.project.ld';
       cmdstr:={$ifndef UNIX}'$IDF_PATH/tools/ldgen/ldgen.py '+{$endif UNIX}
               '--config $OUTPUT/sdkconfig '+
@@ -1193,6 +1194,7 @@ begin
     end
   else
     begin
+      out_ld_filename:=outputexedir+'/esp8266_out.ld';
       project_ld_filename:=outputexedir+'/esp8266.project.ld';
       cmdstr:={$ifndef UNIX}'$IDF_PATH/tools/ldgen/ldgen.py '+{$endif UNIX}
               '--config $OUTPUT/sdkconfig '+
@@ -1271,8 +1273,8 @@ begin
        '-T esp32.rom.ld -T esp32.rom.libgcc.ld -T esp32.rom.newlib-data.ld -T esp32.rom.syscalls.ld -T esp32.rom.newlib-funcs.ld '+
        '-T '+esp_out_ld_filename+' -T '+esp_project_ld_filename+' '+
        '-L $IDF_PATH/components/esp32/ld -T esp32.peripherals.ld';
-      if idf_version>=40200 then
-        Info.ExeCmd[1]:=Info.ExeCmd[1]+' -L $IDF_PATH/components/esp32_rom/esp32/ld -T esp32.rom.api.ld';
+      if idf_version>=40300 then
+        Info.ExeCmd[1]:=Info.ExeCmd[1]+' -T esp32.rom.api.ld';
     end
   else
     begin

+ 115 - 89
compiler/x86/aoptx86.pas

@@ -2092,7 +2092,38 @@ unit aoptx86;
                         RemoveInstruction(hp2);
                         result:=true;
                       end;
-                  end;
+                  end
+                else if (hp1.typ = ait_instruction) and
+                  (((taicpu(p).opcode=A_VMOVAPD) and
+                    (taicpu(hp1).opcode=A_VCOMISD)) or
+                   ((taicpu(p).opcode=A_VMOVAPS) and
+                    ((taicpu(hp1).opcode=A_VCOMISS))
+                   )
+                  ) and not(OpsEqual(taicpu(hp1).oper[1]^,taicpu(hp1).oper[0]^)) then
+                  { change
+                             movapX    reg,reg2
+                             addsX/subsX/... reg3, reg2
+                             movapX    reg2,reg
+                    to
+                             addsX/subsX/... reg3,reg
+                  }
+                  begin
+                    TransferUsedRegs(TmpUsedRegs);
+                    UpdateUsedRegs(TmpUsedRegs, tai(p.next));
+                    If not(RegUsedAfterInstruction(taicpu(p).oper[1]^.reg,hp1,TmpUsedRegs)) then
+                      begin
+                        DebugMsg(SPeepholeOptimization + 'MovapXComisX2ComisX2 ('+
+                              debug_op2str(taicpu(p).opcode)+' '+
+                              debug_op2str(taicpu(hp1).opcode)+') done',p);
+                        if OpsEqual(taicpu(p).oper[1]^,taicpu(hp1).oper[0]^) then
+                          taicpu(hp1).loadoper(0, taicpu(p).oper[1]^);
+                        if OpsEqual(taicpu(p).oper[1]^,taicpu(hp1).oper[1]^) then
+                          taicpu(hp1).loadoper(1, taicpu(p).oper[1]^);
+                        RemoveCurrentP(p, nil);
+                        result:=true;
+                        exit;
+                      end;
+                  end
               end;
           end;
       end;
@@ -8228,6 +8259,65 @@ unit aoptx86;
               end;
           end;
 
+        function AdjustInitialLoad: Boolean;
+          begin
+            Result := False;
+
+            if not p_removed then
+              begin
+                if TargetSize = MinSize then
+                  begin
+                    { Convert the input MOVZX to a MOV }
+                    if (taicpu(p).oper[0]^.typ = top_reg) and
+                      SuperRegistersEqual(taicpu(p).oper[0]^.reg, ThisReg) then
+                      begin
+                        { Or remove it completely! }
+                        DebugMsg(SPeepholeOptimization + 'Movzx2Nop 1', p);
+                        RemoveCurrentP(p);
+                        p_removed := True;
+                      end
+                    else
+                      begin
+                        DebugMsg(SPeepholeOptimization + 'Movzx2Mov 1', p);
+                        taicpu(p).opcode := A_MOV;
+                        taicpu(p).oper[1]^.reg := ThisReg;
+                        taicpu(p).opsize := TargetSize;
+                      end;
+
+                    Result := True;
+                  end
+                else if TargetSize <> MaxSize then
+                  begin
+
+                    case MaxSize of
+                      S_L:
+                        if TargetSize = S_W then
+                          begin
+                            DebugMsg(SPeepholeOptimization + 'movzbl2movzbw', p);
+                            taicpu(p).opsize := S_BW;
+                            taicpu(p).oper[1]^.reg := ThisReg;
+                            Result := True;
+                          end
+                        else
+                          InternalError(2020112341);
+
+                      S_W:
+                        if TargetSize = S_L then
+                          begin
+                            DebugMsg(SPeepholeOptimization + 'movzbw2movzbl', p);
+                            taicpu(p).opsize := S_BL;
+                            taicpu(p).oper[1]^.reg := ThisReg;
+                            Result := True;
+                          end
+                        else
+                          InternalError(2020112342);
+                      else
+                        ;
+                    end;
+                  end;
+              end;
+          end;
+
         procedure AdjustFinalLoad;
           begin
             if ((TargetSize = S_L) and (taicpu(hp1).opsize in [S_L, S_BL, S_WL])) or
@@ -8453,60 +8543,7 @@ unit aoptx86;
             else
               AdjustFinalLoad;
 
-            if not p_removed then
-              begin
-                if TargetSize = MinSize then
-                  begin
-                    { Convert the input MOVZX to a MOV }
-                    if (taicpu(p).oper[0]^.typ = top_reg) and
-                      SuperRegistersEqual(taicpu(p).oper[0]^.reg, ThisReg) then
-                      begin
-                        { Or remove it completely! }
-                        DebugMsg(SPeepholeOptimization + 'Movzx2Nop 1', p);
-                        DebugMsg(SPeepholeOptimization + tostr(InstrMax), p);
-                        RemoveCurrentP(p);
-                        p_removed := True;
-                      end
-                    else
-                      begin
-                        DebugMsg(SPeepholeOptimization + 'Movzx2Mov 1', p);
-                        taicpu(p).opcode := A_MOV;
-                        taicpu(p).oper[1]^.reg := ThisReg;
-                        taicpu(p).opsize := TargetSize;
-                      end;
-
-                    Result := True;
-                  end
-                else if TargetSize <> MaxSize then
-                  begin
-
-                    case MaxSize of
-                      S_L:
-                        if TargetSize = S_W then
-                          begin
-                            DebugMsg(SPeepholeOptimization + 'movzbl2movzbw', p);
-                            taicpu(p).opsize := S_BW;
-                            taicpu(p).oper[1]^.reg := ThisReg;
-                            Result := True;
-                          end
-                        else
-                          InternalError(2020112341);
-
-                      S_W:
-                        if TargetSize = S_L then
-                          begin
-                            DebugMsg(SPeepholeOptimization + 'movzbw2movzbl', p);
-                            taicpu(p).opsize := S_BL;
-                            taicpu(p).oper[1]^.reg := ThisReg;
-                            Result := True;
-                          end
-                        else
-                          InternalError(2020112342);
-                      else
-                        ;
-                    end;
-                  end;
-              end;
+            Result := AdjustInitialLoad or Result;
 
             { Now go through every instruction we found and change the
               size. If TargetSize = MaxSize, then almost no changes are
@@ -8820,50 +8857,39 @@ unit aoptx86;
                           InternalError(2021051002);
                       end;
 
-                      { Update the register to its new size }
-                      setsubreg(ThisReg, TargetSubReg);
+		       if TargetSize <> MaxSize then
+		         begin
+                          { Update the register to its new size }
+                          setsubreg(ThisReg, TargetSubReg);
 
-                      taicpu(hp1).oper[1]^.reg := ThisReg;
-                      taicpu(hp1).opsize := MinSize;
+                          DebugMsg(SPeepholeOptimization + 'CMP instruction resized thanks to register size optimisation (see MOV/Z assignment above)', hp1);
+                          taicpu(hp1).oper[1]^.reg := ThisReg;
+                          taicpu(hp1).opsize := TargetSize;
 
-                      { Convert the input MOVZX to a MOV }
-                      if (taicpu(p).oper[0]^.typ = top_reg) and
-                        SuperRegistersEqual(taicpu(p).oper[0]^.reg, ThisReg) then
-                        begin
-                          { Or remove it completely! }
-                          DebugMsg(SPeepholeOptimization + 'Movzx2Nop 1a', p);
-                          RemoveCurrentP(p);
-                          p_removed := True;
-                        end
-                      else
-                        begin
-                          DebugMsg(SPeepholeOptimization + 'Movzx2Mov 1a', p);
-                          taicpu(p).opcode := A_MOV;
-                          taicpu(p).oper[1]^.reg := ThisReg;
-                          taicpu(p).opsize := MinSize;
-                        end;
+                          { Convert the input MOVZX to a MOV if necessary }
+                          AdjustInitialLoad;
 
-                      if (InstrMax >= 0) then
-                        begin
-                          for Index := 0 to InstrMax do
+                          if (InstrMax >= 0) then
                             begin
+                              for Index := 0 to InstrMax do
+                                 begin
 
-                              { If p_removed is true, then the original MOV/Z was removed
-                                and removing the AND instruction may not be safe if it
-                                appears first }
-                              if (InstrList[Index].oper[InstrList[Index].ops - 1]^.typ <> top_reg) then
-                                InternalError(2020112311);
+                                  { If p_removed is true, then the original MOV/Z was removed
+                                    and removing the AND instruction may not be safe if it
+                                    appears first }
+                                  if (InstrList[Index].oper[InstrList[Index].ops - 1]^.typ <> top_reg) then
+                                    InternalError(2020112311);
 
-                              if InstrList[Index].oper[0]^.typ = top_reg then
-                                InstrList[Index].oper[0]^.reg := ThisReg;
+                                  if InstrList[Index].oper[0]^.typ = top_reg then
+                                    InstrList[Index].oper[0]^.reg := ThisReg;
 
-                              InstrList[Index].oper[InstrList[Index].ops - 1]^.reg := ThisReg;
-                              InstrList[Index].opsize := MinSize;
+                                  InstrList[Index].oper[InstrList[Index].ops - 1]^.reg := ThisReg;
+                                  InstrList[Index].opsize := MinSize;
+                                end;
                             end;
 
+                          Result := True;
                         end;
-
-                      Result := True;
                       Exit;
                     end;
                 end;

+ 3 - 1
packages/fcl-db/src/base/bufdataset.pas

@@ -1644,6 +1644,7 @@ begin
                  ftCurrency : F1.AsCurrency:=F2.AsCurrency;
                  ftBCD,
                  ftFmtBCD   : F1.AsBCD:=F2.AsBCD;
+                 ftExtended : F1.AsExtended:=F2.AsExtended;
             else
               if (F1.DataType in UseStreams) then
                 begin
@@ -2536,7 +2537,8 @@ begin
       ftTypedBinary,
       ftOraBlob,
       ftOraClob,
-      ftWideMemo : result := sizeof(TBufBlobField)
+      ftWideMemo : result := sizeof(TBufBlobField);
+    ftExtended   : Result := sizeof(Extended);
   else
     DatabaseErrorFmt(SUnsupportedFieldType,[Fieldtypenames[FieldDef.DataType]]);
   end;

+ 58 - 7
packages/fcl-db/src/base/db.pas

@@ -350,14 +350,16 @@ type
     function GetAsBoolean: Boolean; virtual;
     function GetAsBytes: TBytes; virtual;
     function GetAsCurrency: Currency; virtual;
-    function GetAsLargeInt: Largeint; virtual;
     function GetAsDateTime: TDateTime; virtual;
+    function GetAsExtended: Extended; virtual;
     function GetAsFloat: Double; virtual;
+    function GetAsLargeInt: Largeint; virtual;
     function GetAsLongint: Longint; virtual;
     function GetAsLongWord: LongWord; virtual;
     function GetAsInteger: Longint; virtual;
     function GetAsVariant: variant; virtual;
     function GetOldValue: variant; virtual;
+    function GetAsSingle: Single; virtual;
     function GetAsString: string; virtual;
     function GetAsAnsiString: AnsiString; virtual;
     function GetAsUnicodeString: UnicodeString; virtual;
@@ -382,12 +384,14 @@ type
     procedure SetAsBytes(const AValue: TBytes); virtual;
     procedure SetAsCurrency(AValue: Currency); virtual;
     procedure SetAsDateTime(AValue: TDateTime); virtual;
+    procedure SetAsExtended(AValue: Extended); virtual;
     procedure SetAsFloat(AValue: Double); virtual;
+    procedure SetAsLargeInt(AValue: Largeint); virtual;
     procedure SetAsLongint(AValue: Longint); virtual;
     procedure SetAsLongWord(AValue: LongWord); virtual;
     procedure SetAsInteger(AValue: Longint); virtual;
-    procedure SetAsLargeInt(AValue: Largeint); virtual;
     procedure SetAsVariant(const AValue: variant); virtual;
+    procedure SetAsSingle(AValue: Single); virtual;
     procedure SetAsString(const AValue: string); virtual;
     procedure SetAsAnsiString(const AValue: AnsiString); virtual;
     procedure SetAsUnicodeString(const AValue: UnicodeString); virtual;
@@ -422,11 +426,13 @@ type
     property AsBytes: TBytes read GetAsBytes write SetAsBytes;
     property AsCurrency: Currency read GetAsCurrency write SetAsCurrency;
     property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
+    property AsExtended: Extended read GetAsExtended write SetAsExtended;
     property AsFloat: Double read GetAsFloat write SetAsFloat;
     property AsLongint: Longint read GetAsLongint write SetAsLongint;
     property AsLongWord: LongWord read GetAsLongWord write SetAsLongWord;
     property AsLargeInt: LargeInt read GetAsLargeInt write SetAsLargeInt;
     property AsInteger: Longint read GetAsInteger write SetAsInteger;
+    property AsSingle: Single read GetAsSingle write SetAsSingle;
     property AsString: string read GetAsString write SetAsString;
     property AsAnsiString: AnsiString read GetAsAnsiString write SetAsAnsiString;
     property AsUnicodeString: UnicodeString read GetAsUnicodeString write SetAsUnicodeString;
@@ -570,7 +576,7 @@ type
     FEditFormat : String;
   protected
     class procedure CheckTypeSize(AValue: Longint); override;
-    procedure RangeError(AValue, Min, Max: Double);
+    procedure RangeError(const AValue, Min, Max: Extended);
     procedure SetDisplayFormat(const AValue: string);
     procedure SetEditFormat(const AValue: string);
     function  GetAsBoolean: Boolean; override;
@@ -748,8 +754,8 @@ type
     function GetAsLargeInt: LargeInt; override;
     function GetAsLongWord: LongWord; override;
     function GetAsInteger: Longint; override;
-    function GetAsVariant: variant; override;
     function GetAsString: string; override;
+    function GetAsVariant: variant; override;
     function GetDataSize: Integer; override;
     procedure GetText(var AText: string; ADisplayText: Boolean); override;
     procedure SetAsBCD(const AValue: TBCD); override;
@@ -761,7 +767,7 @@ type
     procedure SetVarValue(const AValue: Variant); override;
   public
     constructor Create(AOwner: TComponent); override;
-    Function CheckRange(AValue : Double) : Boolean;
+    function CheckRange(AValue: Double) : Boolean;
     property Value: Double read GetAsFloat write SetAsFloat;
 
   published
@@ -780,6 +786,46 @@ type
     property Currency default True;
   end;
 
+{ TExtendedField }
+
+  TExtendedField = class(TNumericField)
+  private
+    FCurrency: Boolean;
+    FMaxValue: Extended;
+    FMinValue: Extended;
+    FPrecision: Longint;
+    procedure SetCurrency(const AValue: Boolean);
+    procedure SetPrecision(const AValue: Longint);
+  protected
+    function GetAsBCD: TBCD; override;
+    function GetAsExtended: Extended; override;
+    function GetAsFloat: Double; override;
+    function GetAsLargeInt: LargeInt; override;
+    function GetAsLongWord: LongWord; override;
+    function GetAsInteger: Longint; override;
+    function GetAsString: string; override;
+    function GetAsVariant: variant; override;
+    function GetDataSize: Integer; override;
+    procedure GetText(var AText: string; ADisplayText: Boolean); override;
+    procedure SetAsBCD(const AValue: TBCD); override;
+    procedure SetAsExtended(AValue: Extended); override;
+    procedure SetAsFloat(AValue: Double); override;
+    procedure SetAsLargeInt(AValue: LargeInt); override;
+    procedure SetAsLongWord(AValue: LongWord); override;
+    procedure SetAsInteger(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+    procedure SetVarValue(const AValue: Variant); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    function CheckRange(AValue: Extended) : Boolean;
+    property Value: Extended read GetAsExtended write SetAsExtended;
+  published
+    property Currency: Boolean read FCurrency write SetCurrency default False;
+    property MaxValue: Extended read FMaxValue write FMaxValue;
+    property MinValue: Extended read FMinValue write FMinValue;
+    property Precision: Longint read FPrecision write SetPrecision default 15;
+  end;
+
 { TBooleanField }
 
   TBooleanField = class(TField)
@@ -1312,6 +1358,7 @@ type
     Function GetAsLargeInt: LargeInt;
     Function GetAsLongWord: LongWord;
     Function GetAsMemo: string;
+    Function GetAsSingle: Single;
     Function GetAsString: string;
     Function GetAsAnsiString: AnsiString;
     Function GetAsUnicodeString: UnicodeString;
@@ -1335,6 +1382,8 @@ type
     Procedure SetAsLargeInt(AValue: LargeInt);
     Procedure SetAsLongWord(AValue: LongWord);
     Procedure SetAsMemo(const AValue: string);
+    Procedure SetAsShortInt(const AValue: LongInt);
+    Procedure SetAsSingle(AValue: Single);
     Procedure SetAsSmallInt(AValue: LongInt);
     Procedure SetAsString(const AValue: string);
     Procedure SetAsAnsiString(const AValue: AnsiString);
@@ -1375,6 +1424,8 @@ type
     Property AsLargeInt : LargeInt read GetAsLargeInt write SetAsLargeInt;
     Property AsLongWord: LongWord read GetAsLongWord write SetAsLongWord;
     Property AsMemo : string read GetAsMemo write SetAsMemo;
+    Property AsShortInt : LongInt read GetAsInteger write SetAsShortInt;
+    Property AsSingle : Single read GetAsSingle write SetAsSingle;
     Property AsSmallInt : LongInt read GetAsInteger write SetAsSmallInt;
     Property AsString : string read GetAsString write SetAsString;
     Property AsAnsiString : AnsiString read GetAsAnsiString write SetAsAnsiString;
@@ -2326,7 +2377,7 @@ Const
 const
   DefaultFieldClasses : Array [TFieldType] of TFieldClass =
     (
-      { ftUnknown} Tfield,
+      { ftUnknown} TField,
       { ftString} TStringField,
       { ftSmallint} TSmallIntField,
       { ftInteger} TLongintField,
@@ -2371,7 +2422,7 @@ const
       { ftLongWord} TLongWordField,
       { ftShortint} TShortintField,
       { ftByte} TByteField,
-      { ftExtended} nil
+      { ftExtended} TExtendedField
     );
 
   dsEditModes = [dsEdit, dsInsert, dsSetKey];

+ 21 - 0
packages/fcl-db/src/base/dsparams.inc

@@ -642,6 +642,14 @@ begin
     Result:=FValue;
 end;
 
+Function TParam.GetAsSingle: Single;
+begin
+  If IsNull then
+    Result:=0.0
+  else
+    Result:=FValue;
+end;
+
 Function TParam.GetAsString: string;
 var P: Pointer;
 begin
@@ -808,6 +816,17 @@ begin
   Value:=AValue;
 end;
 
+Procedure TParam.SetAsShortInt(const AValue: LongInt);
+begin
+  FDataType:=ftShortInt;
+  Value:=AValue;
+end;
+
+Procedure TParam.SetAsSingle(AValue: Single);
+begin
+  FDataType:=ftFloat; // we doesn't have ftSingle ATM
+  Value:=AValue;
+end;
 
 Procedure TParam.SetAsSmallInt(AValue: LongInt);
 begin
@@ -974,6 +993,7 @@ begin
   if Assigned(Field) then
     case FDataType of
       ftUnknown  : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
+      ftShortInt : Field.AsInteger:=AsShortInt;
       ftByte     : Field.AsInteger:=AsByte;
       // Need TField.AsSmallInt
       ftSmallint : Field.AsInteger:=AsSmallInt;
@@ -1016,6 +1036,7 @@ begin
     FDataType:=Field.DataType;
     case Field.DataType of
       ftUnknown  : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
+      ftShortInt : AsShortInt:=Field.AsInteger;
       ftByte     : AsByte:=Field.AsInteger;
       // Need TField.AsSmallInt
       ftSmallint : AsSmallint:=Field.AsInteger;

+ 237 - 34
packages/fcl-db/src/base/fields.inc

@@ -549,7 +549,12 @@ end;
 function TField.GetAsDateTime: TDateTime;
 
 begin
-  raise AccessError(SdateTime);
+  raise AccessError(SDateTime);
+end;
+
+function TField.GetAsExtended: Extended;
+begin
+  Result := GetAsFloat;
 end;
 
 function TField.GetAsFloat: Double;
@@ -558,6 +563,11 @@ begin
   raise AccessError(SDateTime);
 end;
 
+function TField.GetAsSingle: Single;
+begin
+  Result := GetAsFloat;
+end;
+
 function TField.GetAsLargeInt: Largeint;
 begin
   Raise AccessError(SLargeInt);
@@ -586,7 +596,6 @@ begin
   raise AccessError(SVariant);
 end;
 
-
 function TField.GetAsString: string;
 begin
   Result := GetClassDesc
@@ -907,6 +916,16 @@ begin
   Raise AccessError(SDateTime);
 end;
 
+procedure TField.SetAsSingle(AValue: Single);
+begin
+  SetAsFloat(AValue);
+end;
+
+procedure TField.SetAsExtended(AValue: Extended);
+begin
+  SetAsFloat(AValue);
+end;
+
 procedure TField.SetAsFloat(AValue: Double);
 
 begin
@@ -1579,10 +1598,10 @@ begin
     DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
 end;
 
-procedure TNumericField.RangeError(AValue, Min, Max: Double);
+procedure TNumericField.RangeError(const AValue, Min, Max: Extended);
 
 begin
-  DatabaseErrorFmt(SFieldError+SRangeError2,[DisplayName,AValue,Min,Max]);
+  DatabaseErrorFmt(SFieldError+SRangeError2, [DisplayName,AValue,Min,Max]);
 end;
 
 procedure TNumericField.SetDisplayFormat(const AValue: string);
@@ -2216,17 +2235,6 @@ begin
     Result:=0.0;
 end;
 
-function TFloatField.GetAsVariant: Variant;
-
-var f : Double;
-
-begin
-  If GetData(@f) then
-    Result := f
-  else
-    Result:=Null;
-end;
-
 function TFloatField.GetAsLargeInt: LargeInt;
 begin
   Result:=Round(GetAsFloat);
@@ -2254,6 +2262,17 @@ begin
     Result:='';
 end;
 
+function TFloatField.GetAsVariant: Variant;
+
+var f : Double;
+
+begin
+  If GetData(@f) then
+    Result := f
+  else
+    Result:=Null;
+end;
+
 function TFloatField.GetDataSize: Integer;
 
 begin
@@ -2263,15 +2282,15 @@ end;
 procedure TFloatField.GetText(var AText: string; ADisplayText: Boolean);
 
 Var
-    fmt : string;
-    E : Double;
-    Digits : integer;
-    ff: TFloatFormat;
+  Fmt : string;
+  f : Double;
+  Digits : integer;
+  ff: TFloatFormat;
 
 begin
   AText:='';
-  If Not GetData(@E) then exit;
-  If ADisplayText or (Length(FEditFormat) = 0) Then
+  if not GetData(@f) then exit;
+  if ADisplayText or (Length(FEditFormat) = 0) Then
     Fmt:=FDisplayFormat
   else
     Fmt:=FEditFormat;
@@ -2281,18 +2300,17 @@ begin
     ff := ffGeneral
   else
     begin
-    Digits := CurrencyDecimals;
+    Digits := DefaultFormatSettings.CurrencyDecimals;
     if ADisplayText then
       ff := ffCurrency
     else
       ff := ffFixed;
     end;
 
-
-  If fmt<>'' then
-    AText:=FormatFloat(fmt,E)
+  if Fmt<>'' then
+    AText:=FormatFloat(Fmt, f)
   else
-    AText:=FloatToStrF(E,ff,FPrecision,Digits);
+    AText:=FloatToStrF(f, ff, FPrecision, Digits);
 end;
 
 procedure TFloatField.SetAsBCD(const AValue: TBCD);
@@ -2351,13 +2369,13 @@ begin
   Inherited Create(AOwner);
   SetDataType(ftFloat);
   FPrecision:=15;
-  FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
+  FValidChars := [DefaultFormatSettings.DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
 end;
 
-Function TFloatField.CheckRange(AValue : Double) : Boolean;
+function TFloatField.CheckRange(AValue : Double) : Boolean;
 
 begin
-  If (FMinValue<>0) or (FMaxValue<>0) then
+  if (FMinValue<>0) or (FMaxValue<>0) then
     Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
   else
     Result:=True;
@@ -2373,6 +2391,182 @@ begin
   Currency := True;
 end;
 
+{ TExtendedField }
+
+constructor TExtendedField.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  SetDataType(ftExtended);
+  FPrecision:=15;
+  FValidChars := [DefaultFormatSettings.DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
+end;
+
+procedure TExtendedField.SetCurrency(const AValue: Boolean);
+begin
+  if FCurrency=AValue then Exit;
+  FCurrency:=AValue;
+end;
+
+procedure TExtendedField.SetPrecision(const AValue: Longint);
+begin
+  if (AValue = -1) or (AValue > 1) then
+    FPrecision := AValue
+  else
+    FPrecision := 2;
+end;
+
+function TExtendedField.GetAsBCD: TBCD;
+var e: Extended;
+begin
+  if GetData(@e) then
+    Result := DoubleToBCD(e)
+  else
+    Result := NullBCD;
+end;
+
+function TExtendedField.GetAsExtended: Extended;
+var e: Extended;
+begin
+  if GetData(@e) then
+    Result := e
+  else
+    Result := 0.0;
+end;
+
+function TExtendedField.GetAsFloat: Double;
+begin
+  Result := GetAsExtended;
+end;
+
+function TExtendedField.GetAsLargeInt: LargeInt;
+begin
+  Result := Round(GetAsExtended);
+end;
+
+function TExtendedField.GetAsLongWord: LongWord;
+begin
+  Result := Round(GetAsExtended);
+end;
+
+function TExtendedField.GetAsInteger: Longint;
+begin
+  Result := Round(GetAsExtended);
+end;
+
+function TExtendedField.GetAsString: string;
+var e: Extended;
+begin
+  if GetData(@e) then
+    Result := FloatToStr(e)
+  else
+    Result := '';
+end;
+
+function TExtendedField.GetAsVariant: Variant;
+var e: Extended;
+begin
+  if GetData(@e) then
+    Result := e
+  else
+    Result := Null;
+end;
+
+function TExtendedField.GetDataSize: Integer;
+begin
+  Result:=SizeOf(Extended);
+end;
+
+procedure TExtendedField.GetText(var AText: string; ADisplayText: Boolean);
+var
+  Fmt: string;
+  e: Extended;
+  Digits: integer;
+  ff: TFloatFormat;
+begin
+  AText:='';
+  if not GetData(@e) then Exit;
+  if ADisplayText or (FEditFormat = '') then
+    Fmt := FDisplayFormat
+  else
+    Fmt := FEditFormat;
+
+  Digits := 0;
+  if not FCurrency then
+    ff := ffGeneral
+  else
+    begin
+    Digits := DefaultFormatSettings.CurrencyDecimals;
+    if ADisplayText then
+      ff := ffCurrency
+    else
+      ff := ffFixed;
+    end;
+
+  if Fmt<>'' then
+    AText := FormatFloat(Fmt, e)
+  else
+    AText := FloatToStrF(e, ff, FPrecision, Digits);
+end;
+
+procedure TExtendedField.SetAsBCD(const AValue: TBCD);
+begin
+  SetAsExtended(BCDToDouble(AValue));
+end;
+
+procedure TExtendedField.SetAsExtended(AValue: Extended);
+begin
+  if CheckRange(AValue) then
+    SetData(@AValue)
+  else
+    RangeError(AValue,FMinValue,FMaxValue);
+end;
+
+procedure TExtendedField.SetAsFloat(AValue: Double);
+begin
+  SetAsExtended(AValue);
+end;
+
+procedure TExtendedField.SetAsLargeInt(AValue: LargeInt);
+begin
+  SetAsExtended(AValue);
+end;
+
+procedure TExtendedField.SetAsLongWord(AValue: LongWord);
+begin
+  SetAsExtended(AValue);
+end;
+
+procedure TExtendedField.SetAsInteger(AValue: Longint);
+begin
+  SetAsExtended(AValue);
+end;
+
+procedure TExtendedField.SetAsString(const AValue: string);
+var e: Extended;
+begin
+  if AValue='' then
+    Clear
+  else
+    begin
+    if not TryStrToFloat(AValue, e) then
+      DatabaseErrorFmt(SNotAFloat, [AValue]);
+    SetAsExtended(e);
+    end;
+end;
+
+procedure TExtendedField.SetVarValue(const AValue: Variant);
+begin
+  SetAsExtended(AValue);
+end;
+
+function TExtendedField.CheckRange(AValue: Extended) : Boolean;
+begin
+  if (FMinValue<>0) or (FMaxValue<>0) then
+    Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
+  else
+    Result := True;
+end;
+
 { TBooleanField }
 
 function TBooleanField.GetAsBoolean: Boolean;
@@ -2448,7 +2642,14 @@ var Temp : string;
 begin
   Temp:=UpperCase(AValue);
   if Temp='' then
-    Clear
+    begin
+    if FDisplays[True,True]='' then
+      SetAsBoolean(True)
+    else if FDisplays[True,False]='' then
+      SetAsBoolean(False)
+    else
+      Clear
+    end
   else if pos(Temp, FDisplays[True,True])=1 then
     SetAsBoolean(True)
   else if pos(Temp, FDisplays[True,False])=1 then
@@ -2475,11 +2676,13 @@ Procedure TBooleanField.SetDisplayValues(const AValue : String);
 var I : longint;
 
 begin
+  if aValue='' then
+    DatabaseErrorFmt(SFieldError+SInvalidDisplayValues,[DisplayName,AValue]);
   If FDisplayValues<>AValue then
     begin
     I:=Pos(';',AValue);
-    If (I<2) or (I=Length(AValue)) then
-      DatabaseErrorFmt(SFieldError+SInvalidDisplayValues,[DisplayName,AValue]);
+    If I=0 then
+      I:=Length(aValue)+1;
     FdisplayValues:=AValue;
     // Store display values and their uppercase equivalents;
     FDisplays[False,True]:=Copy(AValue,1,I-1);
@@ -2976,7 +3179,7 @@ begin
   Inherited Create(AOwner);
   FMaxValue := 0;
   FMinValue := 0;
-  FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
+  FValidChars := [DefaultFormatSettings.DecimalSeparator, '+', '-', '0'..'9'];
   SetDataType(ftBCD);
   Precision := 18;
   Size := 4;
@@ -2996,7 +3199,7 @@ begin
   Inherited Create(AOwner);
   FMaxValue := 0;
   FMinValue := 0;
-  FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
+  FValidChars := [DefaultFormatSettings.DecimalSeparator, '+', '-', '0'..'9'];
   SetDataType(ftFMTBCD);
 // Max.precision for NUMERIC,DECIMAL datatypes supported by some databases:
 //  Firebird-18; Oracle,SqlServer-38; MySQL-65; PostgreSQL-1000

+ 6 - 1
packages/fcl-db/src/dbase/dbf_fields.pas

@@ -477,7 +477,7 @@ begin
       , ftLargeInt
 {$endif}
 {$ifdef SUPPORT_LONGWORD}
-      , ftLongWord, ftShortInt, ftByte
+      , ftLongWord, ftShortInt, ftByte, ftExtended
 {$endif}
                :
       FNativeFieldType := 'N'; //numerical
@@ -576,6 +576,11 @@ begin
         FSize := 3;
         FPrecision := 0;
       end;
+    ftExtended:
+      begin
+        FSize := 19;
+        FPrecision := 8;
+      end;
 {$endif}
     ftString {$ifdef SUPPORT_FIELDTYPES_V4}, ftFixedChar, ftWideString{$endif}:
       begin

+ 10 - 2
packages/fcl-db/src/memds/memds.pp

@@ -486,6 +486,10 @@ begin
   ftVarBytes: result := FD.Size + SizeOf(Word);
   ftBlob, ftMemo, ftWideMemo:
               result := SizeOf(TMDSBlobField);
+  ftLongWord: Result := SizeOf(LongWord);
+  ftShortInt: Result := SizeOf(ShortInt);
+  ftByte:     Result := SizeOf(Byte);
+  ftExtended: Result := SizeOf(Extended);
  else
   RaiseError(SErrFieldTypeNotSupported,[FD.Name]);
  end;
@@ -1171,11 +1175,15 @@ begin
                   ftBoolean  : F1.AsBoolean:=F2.AsBoolean;
                   ftFloat    : F1.AsFloat:=F2.AsFloat;
                   ftLargeInt : F1.AsLargeInt:=F2.AsLargeInt;
-                  ftSmallInt : F1.AsInteger:=F2.AsInteger;
-                  ftInteger  : F1.AsInteger:=F2.AsInteger;
+                  ftSmallInt,
+                  ftInteger,
+                  ftShortInt,
+                  ftByte     : F1.AsInteger:=F2.AsInteger;
                   ftDate     : F1.AsDateTime:=F2.AsDateTime;
                   ftTime     : F1.AsDateTime:=F2.AsDateTime;
                   ftDateTime : F1.AsDateTime:=F2.AsDateTime;
+                  ftLongWord : F1.AsLongWord:=F2.AsLongWord;
+                  ftExtended : F1.AsExtended:=F2.AsExtended;
                   else         F1.AsString:=F2.AsString;
                 end;
               end;

+ 5 - 3
packages/fcl-db/tests/bufdatasettoolsunit.pas

@@ -90,9 +90,9 @@ begin
 end;
 
 function TbufdatasetDBConnector.InternalGetNDataset(n: integer): TDataset;
-var BufDataset  : TPersistentBufDataSet;
-    i      : integer;
-
+var
+  BufDataset : TPersistentBufDataSet;
+  i : integer;
 begin
   BufDataset := TPersistentBufDataSet.Create(nil);
   with BufDataset do
@@ -158,6 +158,7 @@ begin
     FieldDefs.Add('FLONGWORD',ftLongWord);
     FieldDefs.Add('FSHORTINT',ftShortInt);
     FieldDefs.Add('FBYTE',ftByte);
+    FieldDefs.Add('FEXTENDED',ftExtended);
     CreateDataset;
     Open;
     for i := 0 to testValuesCount-1 do
@@ -189,6 +190,7 @@ begin
       FieldByName('FLONGWORD').AsLongWord := testLongWordValues[i];
       FieldByName('FSHORTINT').AsInteger := testShortIntValues[i];
       FieldByName('FBYTE').AsInteger := testByteValues[i];
+      FieldByName('FEXTENDED').AsExtended := testFloatValues[i];
       Post;
     end;
     MergeChangeLog;

+ 8 - 0
packages/fcl-db/tests/memdstoolsunit.pas

@@ -105,6 +105,10 @@ begin
     FieldDefs.Add('FWIDESTRING',ftWideString);
     FieldDefs.Add('FFIXEDWIDECHAR',ftFixedWideChar);
     FieldDefs.Add('FWIDEMEMO',ftWideMemo);
+    FieldDefs.Add('FLONGWORD',ftLongWord);
+    FieldDefs.Add('FSHORTINT',ftShortInt);
+    FieldDefs.Add('FBYTE',ftByte);
+    FieldDefs.Add('FEXTENDED',ftExtended);
     CreateTable;
     Open;
     for i := 0 to testValuesCount-1 do
@@ -130,6 +134,10 @@ begin
       FieldByName('FWIDESTRING').AsWideString := testValues[ftWideString, i];
       FieldByName('FFIXEDWIDECHAR').AsWideString := testValues[ftFixedWideChar, i];
       FieldByName('FWIDEMEMO').AsWideString := testValues[ftWideMemo, i];
+      FieldByName('FLONGWORD').AsLongWord := testLongWordValues[i];
+      FieldByName('FSHORTINT').AsInteger := testShortIntValues[i];
+      FieldByName('FBYTE').AsInteger := testByteValues[i];
+      FieldByName('FEXTENDED').AsExtended := testFloatValues[i];
       Post;
       end;
     Close;

+ 1 - 1
packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -150,7 +150,7 @@ const
 
   // fall back mapping (e.g. in case GetConnectionInfo(citServerType) is not implemented)
   SQLConnTypeToServerTypeMap : array[TSQLConnType] of TSQLServerType =
-    (ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMysql,ssPostgreSQL,ssFirebird,ssUnknown,ssOracle,ssSQLite,ssMSSQL,ssSybase);
+    (ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssMySQL,ssPostgreSQL,ssFirebird,ssUnknown,ssOracle,ssSQLite,ssMSSQL,ssSybase);
 
 
 function IdentifierCase(const s: string): string;

+ 56 - 21
packages/fcl-db/tests/testdbbasics.pas

@@ -20,6 +20,7 @@ type
 
   TTestDBBasics = class(TDBBasicsTestCase)
   private
+    procedure TestFieldDefinition(AFieldType: TFieldType; ADataSize: integer); overload;
     procedure TestFieldDefinition(AFieldType : TFieldType; ADataSize : integer; out ADS : TDataset; out AFld : TField); overload;
     procedure TestFieldDefinition(AFld: TField; AFieldType : TFieldType; ADataSize : integer); overload;
     procedure TestCalculatedField_OnCalcfields(DataSet: TDataSet);
@@ -35,6 +36,7 @@ type
     procedure TestSupportWordFields;
     procedure TestSupportStringFields;
     procedure TestSupportBooleanFields;
+    procedure TestSupportBooleanFieldDisplayValue;
     procedure TestSupportFloatFields;
     procedure TestSupportLargeIntFields;
     procedure TestSupportDateFields;
@@ -46,6 +48,9 @@ type
     procedure TestSupportFixedStringFields;
     procedure TestSupportBlobFields;
     procedure TestSupportMemoFields;
+    procedure TestSupportByteFields;
+    procedure TestSupportShortIntFields;
+    procedure TestSupportExtendedFields;
 
     procedure TestBlobBlobType; //bug 26064
 
@@ -2587,6 +2592,22 @@ begin
     end;
 end;
 
+procedure TTestDBBasics.TestFieldDefinition(AFieldType: TFieldType; ADataSize: integer);
+var
+  ADataSet: TDataset;
+  AField: TField;
+  i: integer;
+begin
+  TestFieldDefinition(AFieldType, ADataSize, ADataSet, AField);
+
+  for i := 0 to testValuesCount-1 do
+    begin
+    CheckEquals(testValues[AFieldType,i], AField.AsString);
+    ADataSet.Next;
+    end;
+  ADataSet.Close;
+end;
+
 procedure TTestDBBasics.TestFieldDefinition(AFieldType: TFieldType; ADataSize: integer; out ADS: TDataset; out AFld: TField);
 begin
   ADS := DBConnector.GetFieldDataset;
@@ -2716,6 +2737,26 @@ begin
   ds.Close;
 end;
 
+procedure TTestDBBasics.TestSupportBooleanFieldDisplayValue;
+var i          : byte;
+    ds         : TDataset;
+    Fld        : TField;
+    BoolFld : TBooleanField absolute Fld;
+begin
+  TestFieldDefinition(ftBoolean,2,ds,Fld);
+  CheckEquals(TBooleanField,Fld.ClassType,'Correct class');
+  BoolFld.DisplayValues:='+';
+  ds.Edit;
+  Fld.AsBoolean:=True;
+  CheckEquals('+',Fld.DisplayText,'Correct true');
+  Fld.AsBoolean:=False;
+  CheckEquals('',Fld.DisplayText,'Correct false');
+  Fld.AsString:='+';
+  CheckEquals(true,Fld.AsBoolean,'Correct true');
+  Fld.AsString:='';
+  CheckEquals(False,Fld.AsBoolean,'Correct False');
+end;
+
 procedure TTestDBBasics.TestSupportFloatFields;
 
 var i          : byte;
@@ -2890,34 +2931,28 @@ begin
 end;
 
 procedure TTestDBBasics.TestSupportBlobFields;
+begin
+  TestFieldDefinition(ftBlob,0);
+end;
 
-var i          : byte;
-    ds         : TDataset;
-    Fld        : TField;
+procedure TTestDBBasics.TestSupportMemoFields;
 begin
-  TestFieldDefinition(ftBlob,0,ds,Fld);
+  TestFieldDefinition(ftMemo,0);
+end;
 
-  for i := 0 to testValuesCount-1 do
-    begin
-    CheckEquals(testValues[ftBlob,i],Fld.AsString);
-    ds.Next;
-    end;
-  ds.Close;
+procedure TTestDBBasics.TestSupportByteFields;
+begin
+  TestFieldDefinition(ftByte, SizeOf(Byte));
 end;
 
-procedure TTestDBBasics.TestSupportMemoFields;
-var i          : byte;
-    ds         : TDataset;
-    Fld        : TField;
+procedure TTestDBBasics.TestSupportShortIntFields;
 begin
-  TestFieldDefinition(ftMemo,0,ds,Fld);
+  TestFieldDefinition(ftShortInt, SizeOf(ShortInt));
+end;
 
-  for i := 0 to testValuesCount-1 do
-    begin
-    CheckEquals(testValues[ftMemo,i],Fld.AsString);
-    ds.Next;
-    end;
-  ds.Close;
+procedure TTestDBBasics.TestSupportExtendedFields;
+begin
+  TestFieldDefinition(ftExtended, SizeOf(Extended));
 end;
 
 procedure TTestDBBasics.TestBlobBlobType;

+ 3 - 0
packages/fcl-db/tests/toolsunit.pas

@@ -577,6 +577,9 @@ begin
       testValues[ftDateTime,i] := testDateValues[i] + ' ' + testTimeValues[i]
     else
       testValues[ftDateTime,i] := testDateValues[i];
+    testValues[ftShortInt,i] := IntToStr(testShortIntValues[i]);
+    testValues[ftByte,i] := IntToStr(testByteValues[i]);
+    testValues[ftExtended,i] := FloatToStr(testFloatValues[i]);
     end;
 
   if dbconnectorname = '' then raise Exception.Create('There is no db connector specified');

+ 1 - 1
packages/fcl-web/examples/websocket/client/wsclient.lpr

@@ -6,7 +6,7 @@ uses
   {$IFDEF UNIX}
   cthreads,
   {$ENDIF}
-  Classes, jsonparser, fpJSON,SysUtils, StrUtils, CustApp, uriparser, httpprotocol, fphttpclient;
+  Classes, jsonparser, fpJSON,SysUtils, StrUtils, CustApp, uriparser, httpprotocol, fpwebsocketclient, fpwebsocket;
 
 type
 

+ 84 - 0
packages/paszlib/src/zipper.pp

@@ -585,9 +585,12 @@ Type
     Class Procedure Unzip(const AZipFileName : RawByteString);
     // Unzip a single file.
     Class Procedure Unzip(const AZipFileName : RawByteString;aExtractFileName : RawByteString);
+    Class Procedure UnZip(const AZipFileName, aExtractFileName: RawByteString; aOutputFileName : string);
     // Unzip several files
     Class Procedure Unzip(const AZipFileName : RawByteString; aFileList : Array of RawByteString);
     Class Procedure Unzip(const AZipFileName : RawByteString; aFileList : TStrings);
+    Class Procedure Unzip(const AZipFileName : RawByteString; aFileList : Array of RawByteString; aOutputDir : RawByteString; aFlat : Boolean = false);
+    Class Procedure Unzip(const AZipFileName : RawByteString; aFileList : TStrings; aOutputDir : RawByteString; aFlat : Boolean = false);
     Procedure Clear;
     Procedure Examine;
     Procedure Terminate;
@@ -3020,6 +3023,62 @@ begin
     end;
 end;
 
+Type
+
+  { TCustomExtractor }
+
+  TCustomExtractor = Class(TObject)
+  Private
+    FStream : TStream;
+    FunZipper  : TUnzipper;
+    procedure DoCreateStream(Sender: TObject; var AStream: TStream; AItem: TFullZipFileEntry);
+  Public
+    Constructor Create(aUnZipper : TUnzipper);
+    Destructor Destroy; override;
+    Procedure UnZip(const AZipFileName, aExtractFileName: RawByteString; aOutputFileName: string);
+  end;
+
+{ TCustomExtractor }
+
+procedure TCustomExtractor.DoCreateStream(Sender: TObject; var AStream: TStream; AItem: TFullZipFileEntry);
+begin
+  aStream:=FStream;
+  FStream:=Nil;
+end;
+
+constructor TCustomExtractor.Create(aUnZipper: TUnzipper);
+begin
+  FStream:=Nil;
+  FUnzipper:=aUnzipper;
+end;
+
+destructor TCustomExtractor.Destroy;
+begin
+  FreeAndNil(FUnZipper);
+  FreeAndNil(FStream);
+  Inherited;
+end;
+
+procedure TCustomExtractor.UnZip(const AZipFileName, aExtractFileName: RawByteString; aOutputFileName: string);
+begin
+  FStream:=TFileStream.Create(aOutputFileName,fmCreate);
+  FUnZipper.OnCreateStream:=@DoCreateStream;
+  FUnzipper.UnzipFile(aZipFileName,aExtractFileName);
+end;
+
+class procedure TUnZipper.UnZip(const AZipFileName, aExtractFileName: RawByteString; aOutputFileName: string);
+
+
+
+begin
+  With TCustomExtractor.Create(Self.Create) do
+    try
+      Unzip(aZipFileName,aExtractFileName,aOutputFileName);
+    Finally
+      Free;
+    end;
+end;
+
 class procedure TUnZipper.Unzip(const AZipFileName: RawByteString; aFileList: array of RawByteString);
 begin
   With Self.Create do
@@ -3040,6 +3099,31 @@ begin
     end;
 end;
 
+class procedure TUnZipper.Unzip(const AZipFileName: RawByteString; aFileList: array of RawByteString; aOutputDir: RawByteString;
+  aFlat: Boolean);
+begin
+  With Self.Create do
+    try
+      Flat:=aFlat;
+      OutputPath:=aOutputDir;
+      UnZipFiles(aZipFileName,aFileList);
+    finally
+      Free;
+    end;
+end;
+
+class procedure TUnZipper.Unzip(const AZipFileName: RawByteString; aFileList: TStrings; aOutputDir: RawByteString; aFlat: Boolean);
+begin
+  With Self.Create do
+    try
+      Flat:=aFlat;
+      OutputPath:=aOutputDir;
+      UnZipFiles(aZipFileName,aFileList);
+    finally
+      Free;
+    end;
+end;
+
 procedure TUnZipper.DoEndOfFile;
 
 Var

binární
packages/paszlib/tests/test.zip


+ 57 - 0
packages/paszlib/tests/testsingle.lpi

@@ -0,0 +1,57 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="12"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+        <MainUnitHasScaledStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <Title Value="testsingle"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <BuildModes>
+      <Item Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+      <UseFileFilters Value="True"/>
+    </PublishOptions>
+    <RunParams>
+      <FormatVersion Value="2"/>
+    </RunParams>
+    <Units>
+      <Unit>
+        <Filename Value="testsingle.pas"/>
+        <IsPartOfProject Value="True"/>
+      </Unit>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="testsingle"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <OtherUnitFiles Value="../src"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions>
+      <Item>
+        <Name Value="EAbort"/>
+      </Item>
+      <Item>
+        <Name Value="ECodetoolError"/>
+      </Item>
+      <Item>
+        <Name Value="EFOpenError"/>
+      </Item>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

+ 19 - 0
packages/paszlib/tests/testsingle.pas

@@ -0,0 +1,19 @@
+program testsingle;
+
+uses sysutils, zipper;
+
+Var
+  FN : String;
+
+begin
+  FN:=GetTempFileName;
+  TUnzipper.Unzip('test.zip','files/file1.txt',FN);
+  if not FileExists(FN) then
+    Writeln('Error: no file named ',FN)
+  else
+    begin
+//    DeleteFile(FN);
+    Writeln('OK for ',fn);
+    end;
+end.
+

+ 31 - 26
packages/wasmtime/Makefile

@@ -2,7 +2,7 @@
 # Don't edit, this file is generated by FPCMake Version 2.0.0
 #
 default: all
-MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded m68k-sinclairql powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-freertos arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android mips64el-linux jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-freebsd aarch64-darwin aarch64-win64 aarch64-android aarch64-ios wasm32-embedded wasm32-wasi sparc64-linux riscv32-linux riscv32-embedded riscv64-linux riscv64-embedded xtensa-linux xtensa-embedded xtensa-freertos z80-embedded z80-zxspectrum z80-msxdos z80-amstradcpc
+MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-netbsd m68k-amiga m68k-atari m68k-palmos m68k-macosclassic m68k-embedded m68k-sinclairql powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macosclassic powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-haiku x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-android x86_64-aros x86_64-dragonfly arm-linux arm-netbsd arm-palmos arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android arm-aros arm-freertos arm-ios powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android mips64el-linux jvm-java jvm-android i8086-embedded i8086-msdos i8086-win16 aarch64-linux aarch64-freebsd aarch64-darwin aarch64-win64 aarch64-embedded aarch64-android aarch64-ios wasm32-embedded wasm32-wasi sparc64-linux riscv32-linux riscv32-embedded riscv64-linux riscv64-embedded xtensa-linux xtensa-embedded xtensa-freertos z80-embedded z80-zxspectrum z80-msxdos z80-amstradcpc
 BSDs = freebsd netbsd openbsd darwin dragonfly
 UNIXs = linux $(BSDs) solaris qnx haiku aix
 LIMIT83fs = go32v2 os2 emx watcom msdos win16 atari
@@ -58,7 +58,7 @@ SRCBATCHEXT=.bat
 endif
 endif
 ifdef COMSPEC
-ifneq ($(findstring $(OS_SOURCE),$(OSNeedsComspecToRunBatch)),)
+ifneq ($(filter $(OS_SOURCE),$(OSNeedsComspecToRunBatch)),)
 ifndef RUNBATCH
 RUNBATCH=$(COMSPEC) /C
 endif
@@ -178,6 +178,8 @@ else
 ARCH=$(CPU_TARGET)
 endif
 endif
+ifeq ($(FULL_TARGET),aarch64-embedded)
+endif
 ifeq ($(FULL_TARGET),arm-embedded)
 ifeq ($(SUBARCH),)
 $(error When compiling for arm-embedded, a sub-architecture (e.g. SUBARCH=armv4t or SUBARCH=armv7m) must be defined)
@@ -214,11 +216,11 @@ $(error When compiling for arm-freertos, a sub-architecture (e.g. SUBARCH=armv6m
 endif
 override FPCOPT+=-Cp$(SUBARCH)
 endif
-ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
+ifneq ($(filter $(OS_SOURCE),$(LIMIT83fs)),)
 TARGETSUFFIX=$(OS_TARGET)
 SOURCESUFFIX=$(OS_SOURCE)
 else
-ifneq ($(findstring $(OS_TARGET),$(LIMIT83fs)),)
+ifneq ($(filter $(OS_TARGET),$(LIMIT83fs)),)
 TARGETSUFFIX=$(OS_TARGET)
 else
 TARGETSUFFIX=$(FULL_TARGET)
@@ -229,11 +231,11 @@ ifneq ($(FULL_TARGET),$(FULL_SOURCE))
 CROSSCOMPILE=1
 endif
 ifeq ($(findstring makefile,$(MAKECMDGOALS)),)
-ifeq ($(findstring $(FULL_TARGET),$(MAKEFILETARGETS)),)
+ifeq ($(filter $(FULL_TARGET),$(MAKEFILETARGETS)),)
 $(error The Makefile doesn't support target $(FULL_TARGET), please run fpcmake first)
 endif
 endif
-ifneq ($(findstring $(OS_TARGET),$(BSDs)),)
+ifneq ($(filter $(OS_TARGET),$(BSDs)),)
 BSDhier=1
 endif
 ifeq ($(OS_TARGET),linux)
@@ -287,8 +289,8 @@ endif
 ifndef CROSSBINDIR
 CROSSBINDIR:=$(wildcard $(FPCDIR)/bin/$(TARGETSUFFIX))
 endif
-ifneq ($(findstring $(OS_TARGET),darwin iphonesim ios),)
-ifneq ($(findstring $(OS_SOURCE),darwin ios),)
+ifneq ($(filter $(OS_TARGET),darwin iphonesim ios),)
+ifneq ($(filter $(OS_SOURCE),darwin ios),)
 DARWIN2DARWIN=1
 endif
 endif
@@ -365,11 +367,11 @@ ifdef REQUIRE_PACKAGESDIR
 override PACKAGESDIR+=$(REQUIRE_PACKAGESDIR)
 endif
 ifdef ZIPINSTALL
-ifneq ($(findstring $(OS_TARGET),$(UNIXs)),)
+ifneq ($(filter $(OS_TARGET),$(UNIXs)),)
 UNIXHier=1
 endif
 else
-ifneq ($(findstring $(OS_SOURCE),$(UNIXs)),)
+ifneq ($(filter $(OS_SOURCE),$(UNIXs)),)
 UNIXHier=1
 endif
 endif
@@ -557,7 +559,7 @@ endif
 ifeq ($(OS_SOURCE),linux)
 ifndef GCCLIBDIR
 ifeq ($(CPU_TARGET),i386)
-ifneq ($(findstring x86_64,$(shell uname -a)),)
+ifneq ($(filter x86_64,$(shell uname -a)),)
 ifeq ($(BINUTILSPREFIX),)
 GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
 else
@@ -580,11 +582,11 @@ CROSSGCCOPT=-m64
 endif
 endif
 ifeq ($(CPU_TARGET),sparc)
-ifneq ($(findstring sparc64,$(shell uname -a)),)
+ifneq ($(filter sparc64,$(shell uname -a)),)
 ifeq ($(BINUTILSPREFIX),)
 GCCLIBDIR:=$(shell dirname `gcc -m32 -print-libgcc-file-name`)
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
+ifneq ($(filter $(FPCFPMAKE_CPU_OPT),mips mipsel),)
 CROSSGCCOPT=-mabi=32
 else
 CROSSGCCOPT=-m32
@@ -598,19 +600,19 @@ FPCFPMAKE_CPU_TARGET=$(shell $(FPCFPMAKE) -iTP)
 ifeq ($(CPU_TARGET),$(FPCFPMAKE_CPU_TARGET))
 FPCMAKEGCCLIBDIR:=$(GCCLIBDIR)
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_TARGET),aarch64 powerpc64 riscv64 sparc64 x86_64),)
+ifneq ($(filter $(FPCFPMAKE_CPU_TARGET),aarch64 powerpc64 riscv64 sparc64 x86_64),)
 FPCMAKE_CROSSGCCOPT=-m64
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips64 mips64el),)
+ifneq ($(filter $(FPCFPMAKE_CPU_OPT),mips64 mips64el),)
 FPCMAKE_CROSSGCCOPT=-mabi=64
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),mips mipsel),)
+ifneq ($(filter $(FPCFPMAKE_CPU_OPT),mips mipsel),)
 FPCMAKE_CROSSGCCOPT=-mabi=32
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),riscv64),)
+ifeq ($(FPCFPMAKE_CPU_OPT),riscv64)
 FPCMAKE_CROSSGCCOPT=-mabi=lp64
 else
-ifneq ($(findstring $(FPCFPMAKE_CPU_OPT),riscv32),)
+ifeq ($(FPCFPMAKE_CPU_OPT),riscv32)
 FPCMAKE_CROSSGCCOPT=-mabi=ilp32
 else
 FPCMAKE_CROSSGCCOPT=-m32
@@ -789,7 +791,7 @@ DEBUGSYMEXT=.xcoff
 SHORTSUFFIX=mac
 IMPORTLIBPREFIX=imp
 endif
-ifneq ($(findstring $(OS_TARGET),darwin iphonesim ios),)
+ifneq ($(filter $(OS_TARGET),darwin iphonesim ios),)
 BATCHEXT=.sh
 EXEEXT=
 HASSHAREDLIB=1
@@ -868,7 +870,7 @@ endif
 ifeq ($(OS_TARGET),wasi)
 EXEEXT=.wasm
 endif
-ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
+ifneq ($(filter $(OS_SOURCE),$(LIMIT83fs)),)
 FPCMADE=fpcmade.$(SHORTSUFFIX)
 ZIPSUFFIX=$(SHORTSUFFIX)
 ZIPCROSSPREFIX=
@@ -1393,6 +1395,9 @@ endif
 ifeq ($(FULL_TARGET),aarch64-win64)
 REQUIRE_PACKAGES_RTL=1
 endif
+ifeq ($(FULL_TARGET),aarch64-embedded)
+REQUIRE_PACKAGES_RTL=1
+endif
 ifeq ($(FULL_TARGET),aarch64-android)
 REQUIRE_PACKAGES_RTL=1
 endif
@@ -1586,8 +1591,8 @@ ifdef SYSROOTPATH
 override FPCOPT+=-XR$(SYSROOTPATH)
 else
 ifeq ($(OS_TARGET),$(OS_SOURCE))
-ifneq ($(findstring $(OS_TARGET),darwin),)
-ifneq ($(findstring $(CPU_TARGET),aarch64),)
+ifeq ($(OS_TARGET),darwin)
+ifeq ($(CPU_TARGET),aarch64)
 ifneq ($(wildcard /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk),)
 override FPCOPT+=-XR/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk
 endif
@@ -1598,8 +1603,8 @@ endif
 ifdef CREATESHARED
 override FPCOPT+=-Cg
 endif
-ifneq ($(findstring $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),)
-ifneq ($(findstring $(CPU_TARGET),x86_64 mips mipsel riscv64),)
+ifneq ($(filter $(OS_TARGET),dragonfly freebsd openbsd netbsd linux solaris),)
+ifneq ($(filter $(CPU_TARGET),x86_64 mips mipsel riscv64 powerpc64),)
 override FPCOPT+=-Cg
 endif
 endif
@@ -1642,10 +1647,10 @@ ifdef ACROSSCOMPILE
 override FPCOPT+=$(CROSSOPT)
 endif
 override COMPILER:=$(strip $(FPC) $(FPCOPT))
-ifneq (,$(findstring -sh ,$(COMPILER)))
+ifneq (,$(filter -sh,$(COMPILER)))
 UseEXECPPAS=1
 endif
-ifneq (,$(findstring -s ,$(COMPILER)))
+ifneq (,$(filter -s,$(COMPILER)))
 ifeq ($(FULL_SOURCE),$(FULL_TARGET))
 UseEXECPPAS=1
 endif

+ 1 - 1
rtl/freertos/Makefile

@@ -517,7 +517,7 @@ endif
 ifeq ($(ARCH),xtensa)
 CPU_SPECIFIC_COMMON_UNITS=sysutils math classes fgl macpas typinfo types rtlconsts getopts lineinfo
 ifeq ($(SUBARCH),lx6)
-CPU_UNITS=esp32 espidf_40200
+CPU_UNITS=esp32 espidf_40100 espidf_40200
 CPU_UNITS_DEFINED=1
 endif
 ifeq ($(SUBARCH),lx106)

+ 1 - 1
rtl/freertos/Makefile.fpc

@@ -227,7 +227,7 @@ endif
 ifeq ($(ARCH),xtensa)
 CPU_SPECIFIC_COMMON_UNITS=sysutils math classes fgl macpas typinfo types rtlconsts getopts lineinfo
 ifeq ($(SUBARCH),lx6)
-CPU_UNITS=esp32 espidf_40200
+CPU_UNITS=esp32 espidf_40100 espidf_40200
 CPU_UNITS_DEFINED=1
 endif
 ifeq ($(SUBARCH),lx106)

+ 43 - 0
rtl/freertos/xtensa/espidf_40100.pp

@@ -0,0 +1,43 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2021 by Florian Klaempfl
+    member of the Free Pascal development team.
+
+    System unit for FreeRTOS systems
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit espidf_40100;
+
+interface
+
+{$linklib esp32,static}
+{$linklib soc,static}
+{$linklib driver,static}
+{$linklib freertos,static}
+{$linklib log,static}
+{$linklib esp_common,static}
+{$linklib heap,static}
+{$linklib newlib,static}
+{$linklib vfs,static}
+{$linklib esp_ringbuf,static}
+{$linklib spi_flash,static}
+{$linklib app_update,static}
+{$linklib xtensa,static}
+{$linklib bootloader_support,static}
+{$linklib pthread,static}
+{$linklib hal,static}
+{$linklib libm,static}
+{$linklib libg,static}
+{$linklib c,static}
+{$linklib esp_event,static}
+
+implementation
+
+end.

+ 14 - 17
rtl/inc/sstrings.inc

@@ -1523,17 +1523,18 @@ end;
 
   Function fpc_val_smallint_shortstr(Const S: ShortString; out Code: ValSInt): SmallInt; [public, alias:'FPC_VAL_SMALLINT_SHORTSTR']; compilerproc;
 
-  var  u, temp, prev, maxprevvalue, maxnewvalue : word;
+  var  u, temp, prev, maxprevvalue : word;
        base : byte;
        negative : boolean;
-
-  const maxlongint=longword($7fffffff);
-        maxlongword=longword($ffffffff);
-
+       UnsignedUpperLimit: ValUInt;
   begin
     fpc_val_smallint_shortstr := 0;
     Temp:=0;
     Code:=InitVal(s,negative,base);
+    if (base=10) or negative then
+      UnsignedUpperLimit := Word(High(SmallInt))+Ord(negative)
+    else
+      UnsignedUpperLimit := High(Word);
     if Code>length(s) then
      exit;
     if (s[Code]=#0) then
@@ -1542,11 +1543,7 @@ end;
           Code:=0;
         exit;
       end;
-    maxprevvalue := maxlongword div base;
-    if (base = 10) then
-      maxnewvalue := maxlongint + ord(negative)
-    else
-      maxnewvalue := maxlongword;
+    maxprevvalue := High(Word) div base;
 
     while Code<=Length(s) do
      begin
@@ -1561,17 +1558,17 @@ end;
        Prev:=Temp;
        Temp:=Temp*longword(base);
        If (u >= base) or
-         (longword(maxnewvalue-u) < temp) or
-         (prev > maxprevvalue) Then
-         Begin
-           fpc_val_smallint_shortstr := 0;
-           Exit
-         End;
+        (prev > maxPrevValue) or
+        ((Temp)>(UnsignedUpperLimit-u)) Then
+       Begin
+         fpc_val_smallint_shortstr := 0;
+         Exit
+       End;
        Temp:=Temp+u;
        inc(code);
      end;
     code:=0;
-    fpc_val_smallint_shortstr:=longint(Temp);
+    fpc_val_smallint_shortstr:=SmallInt(Temp);
     If Negative Then
       fpc_val_smallint_shortstr:=-fpc_val_smallint_shortstr;
   end;

+ 2 - 0
rtl/objpas/classes/compon.inc

@@ -603,6 +603,8 @@ Procedure TComponent.InsertComponent(AComponent: TComponent);
 begin
   AComponent.ValidateContainer(Self);
   ValidateRename(AComponent,'',AComponent.FName);
+  If AComponent.FOwner<>Nil then
+    AComponent.FOwner.Remove(AComponent);
   Insert(AComponent);
   AComponent.SetReference(True);
   If csDesigning in FComponentState then

+ 1 - 1
tests/bench/bval.pp

@@ -5,7 +5,7 @@ const
   chars : shortstring = ('0123456789AbCdEf');
   signs : shortstring = (' -');
 var
-  vals : array[0..1000] of shortstring;
+  vals : array[0..1000] of string;
   base,len,baseindex : byte;
   li,i,j : longint;
   code : word;

+ 2 - 2
utils/pas2js/compileserver.lpi

@@ -1,15 +1,15 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="11"/>
+    <Version Value="12"/>
     <General>
       <Flags>
         <MainUnitHasCreateFormStatements Value="False"/>
         <MainUnitHasTitleStatement Value="False"/>
         <MainUnitHasScaledStatement Value="False"/>
+        <CompatibilityMode Value="True"/>
       </Flags>
       <SessionStorage Value="InProjectDir"/>
-      <MainUnit Value="0"/>
       <Title Value="compileserver"/>
       <UseAppBundle Value="False"/>
       <ResourceType Value="res"/>

+ 21 - 5
utils/pas2js/httpcompiler.pp

@@ -9,10 +9,12 @@ uses
   {$ifdef unix}baseunix,{$endif}
   sysutils, classes, fpjson, contnrs, syncobjs, fpmimetypes, custhttpapp, inifiles,
   fpwebproxy, webutil, fpwebfile, httproute, httpdefs, dirwatch, Pas2JSFSCompiler,
-  Pas2JSCompilerCfg;
+  Pas2JSCompilerCfg, ssockets;
 
 Const
+  HTTPCompilerVersion = '1.0';
   nErrTooManyThreads = -1;
+  nExitCodeSocketError = 1;
 
 Type
   TDirWatcher = Class;
@@ -51,7 +53,6 @@ Type
      Property Compiles[AIndex : Integer] : TCompileItem Read GetC; default;
   end;
 
-
   { TCompileThread }
 
   TCompileThread = class(TThread)
@@ -275,6 +276,7 @@ begin
   {AllowWriteln}
   if (Msg<>'') then
     Writeln('Error: ',Msg);
+  Writeln('Version ',HTTPCompilerVersion);
   Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] ');
   Writeln('Where options is one or more of : ');
   Writeln('-A --api=location,secret Enable location management API.');
@@ -766,9 +768,15 @@ Var
   S : String;
 
 begin
-  S:=Checkoptions('shqd:ni:p:wP::cm:A:',['help','quiet','noindexpage','directory:','port:','indexpage:','watch','project::','config:','simpleserver','mimetypes:','api:']);
+  S:=Checkoptions('shqVd:ni:p:wP::cm:A:I:',['help','quiet','version','noindexpage','directory:','port:','indexpage:','watch','project::','config:','simpleserver','mimetypes:','api:','interface:']);
   if (S<>'') or HasOption('h','help') then
-    usage(S);
+    Usage(S);
+  if HasOption('V','version') then
+    begin
+    writeln(HTTPCompilerVersion);
+    Terminate;
+    exit;
+    end;
   if HasOption('c','config') then
     ConfigFile:=GetOptionValue('c','config')
   else
@@ -813,7 +821,15 @@ begin
   TSimpleFileModule.RegisterDefaultRoute;
   if InterfaceAddress<>'' then
     HTTPHandler.Address:=InterfaceAddress;
-  inherited;
+  try
+    inherited DoRun;
+  except
+    on E: ESocketError do begin
+      Log(etError,E.ClassName+': '+E.Message);
+      ExitCode:=nExitCodeSocketError;
+      Terminate;
+    end;
+  end;
 end;
 
 end.