Merge remote-tracking branch 'origin/main' into tg74/avx512-0037785

.gitattributes

@@ -1 +1,3 @@
 * text=auto !eol
+*.pp gitlab-language=pascal
+*.inc gitlab-language=pascal

.gitignore

@@ -39,10 +39,12 @@ lazbuild
 *.wpo
 a.out
 /compiler/ppc*
+/compiler/gppc*
 !/compiler/ppc*.lpi
 *.lpi
 !/compiler/ppc*.pas
 /compiler/*/pp
+/compiler/revision.inc
 /compiler/utils/fpc
 /compiler/utils/msg2inc
 /compiler/utils/mka64ins
@@ -57,7 +59,19 @@ a.out
 /packages/fpmkunit/units_bs
 /utils/fpmake
 units
+/tests/createlst
+/tests/gparmake
 /tests/output
+/tests/output*
 !/tests/test/units
+/tests/tstunits/tmp/
+/tests/tstunits/*-*/
+/tests/utils/concat
+/tests/utils/digest
+/tests/utils/dotest
+/tests/utils/fail
+/tests/utils/fptime
+/tests/utils/testfail
 bin/
 fpmake
+packages/fcl-db/tests/database.ini

compiler/Makefile

@@ -451,13 +451,19 @@ endif
 ifndef RTLOPT
 RTLOPT:=$(OPT)
 endif
+SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
+ifndef GIT
+GIT:=$(firstword $(wildcard $(addsuffix /git$(SRCEXEEXT),$(SEARCHPATH))))
+endif
 DATE_FMT = +%Y/%m/%d
 ifdef SOURCE_DATE_EPOCH
     COMPDATESTR ?= $(shell date -u -d "@$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u -r "$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u "$(DATE_FMT)")
 else
    GIT_DIR = $(wildcard ../.git)
    ifneq ($(GIT_DIR),)
-      COMPDATESTR:=$(shell git log -1 --pretty=%cd --date=format:'%Y/%m/%d')
+      ifneq ($(GIT),)
+	COMPDATESTR:=$(shell $(GIT) log -1 --pretty=%cd --date=format:'%Y/%m/%d')
+      endif
    endif
 endif
 ifdef COMPDATESTR
@@ -557,7 +563,6 @@ CPUSUF=wasm32
 endif
 NOCPUDEF=1
 MSGFILE=msg/error$(FPCLANG).msg
-SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
 PPUDUMPPROG:=$(firstword $(strip $(wildcard $(addsuffix /ppudump$(SRCEXEEXT),$(SEARCHPATH)))))
 ifndef PPUDUMP
 ifdef PPUDUMPPROG
@@ -570,6 +575,18 @@ REVINC:=$(wildcard revision.inc)
 ifneq ($(REVINC),)
 override LOCALOPT+=-dREVINC
 ifeq ($(REVSTR),)
+ifneq ($(wildcard ../.git),)
+ifneq ($(GIT),)
+GITDESCRIBE=$(shell $(GIT) describe --dirty)
+REVSTR:=$(word 2,$(subst -, ,$(GITDESCRIBE)))-$(word 3,$(subst -, ,$(GITDESCRIBE)))
+ifneq ($(shell $(GIT) log @{u}..),)
+REVSTR:=$(REVSTR)-unpushed
+endif
+ifneq ($(word 4,$(subst -, ,$(GITDESCRIBE))),)
+REVSTR:=$(REVSTR)-$(word 4,$(subst -, ,$(GITDESCRIBE)))
+endif
+export REVSTR
+else
 ifneq ($(SVNVERSION),)
 REVSTR:=$(subst r,,$(subst r1:,,r$(subst exported,,$(shell $(SVNVERSION) -c .))))
 export REVSTR
@@ -581,6 +598,8 @@ endif
 endif
 endif
 endif
+endif
+endif
 override LOCALOPT+=-d$(CPC_TARGET) -dGDB
 ifdef LLVM
 ifeq ($(findstring $(PPC_TARGET),x86_64 aarch64 arm),)

compiler/Makefile.fpc

@@ -168,6 +168,12 @@ ifndef RTLOPT
 RTLOPT:=$(OPT)
 endif
 
+SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
+
+ifndef GIT
+GIT:=$(firstword $(wildcard $(addsuffix /git$(SRCEXEEXT),$(SEARCHPATH))))
+endif
+
 DATE_FMT = +%Y/%m/%d
 ifdef SOURCE_DATE_EPOCH
     COMPDATESTR ?= $(shell date -u -d "@$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u -r "$(SOURCE_DATE_EPOCH)" "$(DATE_FMT)" 2>/dev/null || date -u "$(DATE_FMT)")
@@ -176,7 +182,9 @@ else
    GIT_DIR = $(wildcard ../.git)
    ifneq ($(GIT_DIR),)
       # ... then take date from head
-      COMPDATESTR:=$(shell git log -1 --pretty=%cd --date=format:'%Y/%m/%d')
+      ifneq ($(GIT),)
+        COMPDATESTR:=$(shell $(GIT) log -1 --pretty=%cd --date=format:'%Y/%m/%d')
+      endif
    endif
 endif
 
@@ -290,8 +298,6 @@ NOCPUDEF=1
 # Default message file
 MSGFILE=msg/error$(FPCLANG).msg
 
-
-SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
 PPUDUMPPROG:=$(firstword $(strip $(wildcard $(addsuffix /ppudump$(SRCEXEEXT),$(SEARCHPATH)))))
 ifndef PPUDUMP
 ifdef PPUDUMPPROG
@@ -310,6 +316,18 @@ override LOCALOPT+=-dREVINC
 # Automatically update revision.inc if
 # svnversion executable is available
 ifeq ($(REVSTR),)
+ifneq ($(wildcard ../.git),)
+ifneq ($(GIT),)
+GITDESCRIBE=$(shell $(GIT) describe --dirty)
+REVSTR:=$(word 2,$(subst -, ,$(GITDESCRIBE)))-$(word 3,$(subst -, ,$(GITDESCRIBE)))
+ifneq ($(shell $(GIT) log @{u}..),)
+REVSTR:=$(REVSTR)-unpushed
+endif
+ifneq ($(word 4,$(subst -, ,$(GITDESCRIBE))),)
+REVSTR:=$(REVSTR)-$(word 4,$(subst -, ,$(GITDESCRIBE)))
+endif
+export REVSTR
+else
 ifneq ($(SVNVERSION),)
 REVSTR:=$(subst r,,$(subst r1:,,r$(subst exported,,$(shell $(SVNVERSION) -c .))))
 export REVSTR
@@ -321,6 +339,8 @@ endif
 endif
 endif
 endif
+endif
+endif
 
 # set correct defines (-d$(CPU_TARGET) is automatically added in makefile.fpc)
 override LOCALOPT+=-d$(CPC_TARGET) -dGDB

compiler/aggas.pas

@@ -74,8 +74,6 @@ interface
 {$endif WASM}
        private
         setcount: longint;
-        procedure WriteDecodedSleb128(a: int64);
-        procedure WriteDecodedUleb128(a: qword);
         procedure WriteCFI(hp: tai_cfi_base);
         function NextSetLabel: string;
        protected
@@ -660,21 +658,6 @@ implementation
       end;
 
 
-    procedure TGNUAssembler.WriteDecodedUleb128(a: qword);
-      var
-        i,len : longint;
-        buf   : array[0..63] of byte;
-      begin
-        len:=EncodeUleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-      end;
-
-
     procedure TGNUAssembler.WriteCFI(hp: tai_cfi_base);
       begin
         writer.AsmWrite(cfi2str[hp.cfityp]);
@@ -708,21 +691,6 @@ implementation
       end;
 
 
-    procedure TGNUAssembler.WriteDecodedSleb128(a: int64);
-      var
-        i,len : longint;
-        buf   : array[0..255] of byte;
-      begin
-        len:=EncodeSleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-      end;
-
-
 {$ifdef WASM}
     procedure TGNUAssembler.WriteFuncType(functype: TWasmFuncType);
       var
@@ -1194,9 +1162,9 @@ implementation
                          writer.AsmWrite(ait_const2str[aitconst_8bit]);
                          case tai_const(hp).consttype of
                            aitconst_uleb128bit:
-                             WriteDecodedUleb128(qword(tai_const(hp).value));
+                             writer.AsmWrite(uleb128tostr(qword(tai_const(hp).value)));
                            aitconst_sleb128bit:
-                             WriteDecodedSleb128(int64(tai_const(hp).value));
+                             writer.AsmWrite(sleb128tostr(tai_const(hp).value));
                            else
                              ;
                          end

compiler/assemble.pas

@@ -157,6 +157,8 @@ interface
         function single2str(d : single) : string; virtual;
         function double2str(d : double) : string; virtual;
         function extended2str(e : extended) : string; virtual;
+        function sleb128tostr(a : int64) : string;
+        function uleb128tostr(a : qword) : string;
         Function DoPipe:boolean; virtual;
 
         function CreateNewAsmWriter: TExternalAssemblerOutputFile; virtual;
@@ -744,6 +746,36 @@ Implementation
          extended2str:='0d'+hs
       end;
 
+    function TExternalAssembler.sleb128tostr(a: int64): string;
+      var
+        i,len : longint;
+        buf   : array[0..31] of byte;
+      begin
+        result:='';
+        len:=EncodeSleb128(a,buf,0);
+        for i:=0 to len-1 do
+          begin
+            if (i > 0) then
+              result:=result+',';
+            result:=result+tostr(buf[i]);
+          end;
+      end;
+
+    function TExternalAssembler.uleb128tostr(a: qword): string;
+    var
+      i,len : longint;
+      buf   : array[0..31] of byte;
+    begin
+      result:='';
+      len:=EncodeUleb128(a,buf,0);
+      for i:=0 to len-1 do
+        begin
+          if (i > 0) then
+            result:=result+',';
+          result:=result+tostr(buf[i]);
+        end;
+    end;
+
 
     Function TExternalAssembler.DoPipe:boolean;
       begin

compiler/i386/i386prop.inc

@@ -666,17 +666,17 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
 (Ch: [Ch_Mop1, Ch_Rop2]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_All]),
+(Ch: [Ch_Wop2, Ch_Rop1]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/i8086/i8086prop.inc

@@ -666,17 +666,17 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
 (Ch: [Ch_Mop1, Ch_Rop2]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_All]),
+(Ch: [Ch_Wop2, Ch_Rop1]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/msg/errord.msg

@@ -3,7 +3,7 @@
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
 #   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 45316
+#   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
@@ -442,6 +442,7 @@ scan_w_setpeosversion_not_support=02103_W_SETPEOSVERSION wird vom Zielbetriebssy
 scan_w_setpesubsysversion_not_support=02104_W_SETPESUBSYSVERSION wird vom Zielbetriebssystem nicht unterst�tzt
 % The \var{\{\$SETPESUBSYSVERSION\}} directive is not supported by the target OS.
 scan_n_changecputype=02105_N_Ge„nderter Prozessortyp muss zum angegebenen Controller passen
+scan_e_emptymacroname=02106_E_Der Name einer macro/compiler-Variablen kann nicht leer sein
 %
 % \end{description}
 # EndOfTeX
@@ -449,7 +450,7 @@ scan_n_changecputype=02105_N_Ge
 #
 # Parser
 #
-# 03355 is the last used one
+# 03360 is the last used one
 #
 # BeginOfTeX
 %
@@ -1091,8 +1092,9 @@ parser_e_paraloc_only_one_para=03197_E_Jedes Argument muss seine eigene "locatio
 parser_e_paraloc_all_paras=03198_E_Jedes Argument muss seine explizite "location" haben
 % If one argument has an explicit argument location, all arguments of a procedure
 % must have one.
-parser_e_illegal_explicit_paraloc=03199_E_"location" des Arguments unbekannt
-% The location specified for an argument isn't recognized by the compiler.
+parser_e_illegal_explicit_paraloc=03199_E_Ung�ltiger expliziter Parameter "location" spezifiziert
+% Syscalls specific: the specified explicit location string for this parameter cannot be parsed, invalid,
+% or the location specified for an argument isn't recognized by the compiler.
 parser_e_32bitint_or_pointer_variable_expected=03200_E_32 Bit-Integer oder Zeiger-Variable erwartet
 % The libbase for MorphOS/AmigaOS can be given only as \var{longint}, \var{dword} or any pointer variable.
 parser_e_goto_outside_proc=03201_E_Goto Statements zwischen verschiedenen Prozeduren sind nicht erlaubt
@@ -1263,7 +1265,8 @@ parser_n_ignore_lower_visibility=03250_N_Die virtuelle Methode "$1" hat eine nie
 % The virtual method overrides an method that is declared with a higher visibility. This might give
 % unexpected results. E.g., in case the new visibility is private then a call to ``inherited'' in a
 % new child class will call the higher-visible method in a parent class and ignores the private method.
-parser_e_field_not_allowed_here=03251_E_Felder sind nach der Definition einer Methode oder Eigenschaft nicht erlaubt. Beginne vorher eine neue Sichtbarkeitssektion
+parser_e_field_not_allowed_here=03251_E_Felder sind nach der Definition einer Methode oder Eigenschaft nicht erlaubt. Beginne vorher eine neue Sichtbarkeits
+
 % Once a method or property has been defined in a class or object, you cannot define any fields afterwards
 % without starting a new visibility section (such as \var{public}, \var{private}, etc.). The reason is
 % that otherwise the source code can appear ambiguous to the compiler, since it is possible to use modifiers
@@ -1569,7 +1572,7 @@ parser_w_ptr_type_ignored=03338_W_Zeigertyp "$1" ignoriert
 % The specified pointer type modifier is ignored, because it is not supported on
 % the current platform. This happens, for example, when a far pointer is
 % declared on a non-x86 platform.
-parser_e_global_generic_references_static=03339_E_Ein globales, generisches Templat referenziert eine statische Symboltabelle
+parser_e_global_generic_references_static=03339_E_Ein generisches Templat im Interface-Bereich referenziert ein Symbol des Implementation-Bereichs
 % A generic declared in the interface section of a unit must not reference symbols that belong
 % solely to the implementation section of that unit.
 parser_u_already_compiled=03340_UL_Die Unit $1 wurde inzwischen bereits kompiliert.
@@ -1628,6 +1631,16 @@ parser_e_method_for_type_in_other_unit=03354_E_Implementierung einer Methods f
 parser_e_generic_constraints_not_allowed_here=03355_E_Eine generische Einschr„nkung ist hier nicht erlaubt
 % At the current location specifying a constraint is not allowed. For example
 % in delphi mode, a constraint might not be specified in the header of the implementation.
+parser_e_location_size_too_small=03356_E_Die explizite "location" ist zu klein f�r den Parameter
+% AmigaOS/MorphOS syscall specific: for int64/qword parameter only a single register location is specified
+parser_e_location_size_too_large=03357_E_Die GrӇe der expliziten "location" ist grӇer als vom Parameter verlangt
+% AmigaOS/MorphOS syscall specific: for a parameter which is smaller than 64bit, a register pair is specified
+parser_e_location_regpair_only_data=03358_E_Nur Daten-Register werden f�r explizite "location" Registerpaare unterst�tzt
+% AmigaOS/MorphOS syscall specific: for 64bit register pairs, only data registers are supported
+parser_e_location_regpair_only_consecutive=03359_E_Nur aufeinander folgende Register werden f�r explizite "location" Registerpaare unterst�tzt
+% MorphOS syscall specific: only consecutive (f.e.: d1-d2) registers are supported for 64bit register pairs
+parser_e_constructurs_cannot_take_type_parameters=03360_E_Konstruktoren k”nnen keine Type-Parameter �bernehmen
+% The use of type parameters in constructors is not allowed.
 %
 % \end{description}
 # EndOfTeX
@@ -1635,7 +1648,7 @@ parser_e_generic_constraints_not_allowed_here=03355_E_Eine generische Einschr
 #
 # Type Checking
 #
-# 04128 is the last used one
+# 04130 is the last used one
 #
 # BeginOfTeX
 %
@@ -2084,6 +2097,11 @@ type_e_forward_interface_type_does_not_match=04127_E_Der Interfacetyp der Vorw
 type_e_generic_const_type_not_allowed=04128_E_Typ ist f�r generische, konstante Parameter nicht erlaubt: $1
 % Only types that can also be used (indirectly) for untyped constants can be used as a
 % type for a generic constant parameter.
+type_e_cant_read_write_type_in_iso_mode=04129_E_Kann Variablen diesen Typs im ISO-Modus nicht lesen oder schreiben
+% You are trying to \var{read} or \var{write} a variable from or to a
+% file of type text, which doesn't support that variable's type in the selected language mode (iso mode).
+type_w_array_size_does_not_match_size_of_constant_string=04130_W_Die L„nge der konstanten Zeichenkette (die L„nge ist $1) muss so groá wie die Anzahl der Array-Elemente sein ($2 Elemente)
+% ISO Pascal requires that string constants have the same length as the array to which them they are assigned.
 %
 % \end{description}
 # EndOfTeX
@@ -2595,7 +2613,7 @@ cg_w_interrupt_does_not_save_registers=06062_W_Der Zielprozessor unterst
 #
 # Assembler reader
 #
-# 07141 is the last used one
+# 07145 is the last used one
 #
 asmr_d_start_reading=07000_DL_Starte $1 Stil Assembler Parsen
 % This informs you that an assembler block is being parsed
@@ -2935,6 +2953,10 @@ asmr_e_multiple_segment_overrides=07139_E_Kann "multiple segment overrides" nich
 asmr_w_multiple_segment_overrides=07140_W_"Multiple segment overrides" (nur das letzte wird beachtet)
 asmr_w_segment_override_ignored_in_64bit_mode=07141_W_Segment-Basis $1 wird erzeugt, aber von der CPU im 64-Bit-Modus ignoriert
 asmr_e_mismatch_broadcasting_elements=07142_E_Broadcasting-Elemente passen nicht (erwartet: {$1} gefunden: {$2})
+asmr_e_invalid_arrangement=07143_E_Ung�ltige Anordnung "$1"
+asmr_e_a64_invalid_regset=07144_E_Register in einem Register-Set m�ssen aufeinander folgen
+asmr_e_unknown_field=07145_E_Unbekannter Feld-Bezeichner
+% The internal assembler read cannot find the passed field identifier.
 %
 % \end{description}
 # EndOfTeX
@@ -2942,7 +2964,7 @@ asmr_e_mismatch_broadcasting_elements=07142_E_Broadcasting-Elemente passen nicht
 #
 # Assembler/binary writers
 #
-# 08035 is the last used one
+# 08036 is the last used one
 #
 asmw_f_too_many_asm_files=08000_F_Zu viele Assembler-Dateien
 % With smartlinking enabled, there are too many assembler
@@ -2999,6 +3021,7 @@ asmw_e_instruction_not_supported_by_cpu=08032_E_Befehl wird vom ausgew
 asmw_e_brxx_out_of_range=08033_E_Asm: Das Ziel des bedingten Zweigs ist auáerhalb des Bereichs
 asmw_e_illegal_use_of_rip=08034_E_Asm: RIP kann nicht als Indexregister oder mit einem anderen Register in einer Referenz verwendet werden
 asmw_e_seh_invalid_data_size=08035_F_Ung�ltige Funktionsgr”áe einer SEH-Funktion
+asmw_e_illegal_use_of_sp=08036_E_Asm: ESP/RSP kann nicht als Indexregister verwendet werden
 %
 % \end{description}
 # EndOfTeX
@@ -3449,7 +3472,7 @@ unit_u_ppu_llvm_mismatch=10067_U_
 #
 # Options
 #
-# 11061 is the last used one
+# 11063 is the last used one
 #
 # BeginOfTeX
 %
@@ -3605,6 +3628,9 @@ option_features_only_for_system_unit=11060_E_Feature-Schalter werden nur beim
 % To selected a certain feature, the system unit must be compiled with this feature enabled. All other units inherited the features set by the
 % system unit through the ppu of the system unit.
 option_debug_info_requires_external_linker=11061_N_Das ausgew„hlte Debug-Format wird vom internen Linker nicht unterst�tzt, schalte um auf externen Linker
+option_valgrind_heaptrc_mismatch=11062_E_Die beiden Optionen ($1) ($2) k”nnen nicht gleichzeitig verwendet werden
+option_unsupported_fpu=11063_F_Der ausgew„hlte FPU-Typ "$1" wird vom ausgew„hlten Befehlssatz "$2" nicht unterst�tzt
+% Not all instruction sets support all FPU types. For example on ARM, Thumb(-1) supports no FPU/VFP instruction set
 %
 % \end{description}
 # EndOfTeX
@@ -3896,6 +3922,7 @@ F*0*_Es werden nur Optionen aufgelistet, die f
 **1A<x>_Ausgabe Format:
 **2Adefault_Benutze den "default" Assembler
 3*2Aas_Assembliere mit Hilfe von GNU AS
+3*2Aas-darwin_Assembliere Darwin Mach-O mit Hilfe von GNU GAS
 3*2Amacho_Mach-O (Darwin, Intel 32 bit) mit Hilfe des internen Schreibers
 8*2Anasm_Assembliere mit Hilfe von Nasm
 8*2Anasmobj_Assembliere mit Hilfe von Nasm
@@ -3916,6 +3943,7 @@ F*0*_Es werden nur Optionen aufgelistet, die f
 4*2Aas_Assembliere mit Hilfe von GNU AS
 4*2Agas_Assembliere mit Hilfe von GNU GAS
 4*2Agas-darwin_Assembliere darwin Mach-O64 mit Hilfe von GNU GAS
+4*2Aas-darwin_Assembliere Darwin Mach-O64 mit Hilfe von GNU GAS
 4*2Amasm_Win64 Objektdatei mit Hilfe von ml64 (Microsoft)
 4*2Apecoff_PE-COFF (Win64) mit Hilfe des internen Schreibers
 4*2Aelf_ELF (Linux-64bit) mit Hilfe des internen Schreibers
@@ -3930,10 +3958,23 @@ F*0*_Es werden nur Optionen aufgelistet, die f
 6*2Amot_Standard Motorola Assembler
 6*2Avasm_Assembliere mit Hilfe von vasm
 A*2Aas_Assembliere mit Hilfe von GNU AS
+A*2Aas-darwin_Assembliere mit Hilfe von GNU AS f�r Darwin Zielsysteme
+A*2Aclang_Assembliere mit Hilfe von clang
+A*2Aelf_Assembliere mit Hilfe des internen ELF-Schreibers
+a*2Aas_Assembliere mit Hilfe von GNU AS
+a*2Aclang_Assembliere mit Hilfe von clang f�r Darwin/iOS Zielsysteme
+a*2Aas-clang_AAssembliere mit Hilfe von clang f�r andere Zielsysteme 
 P*2Aas_Assembliere mit Hilfe von GNU AS
 S*2Aas_Assembliere mit Hilfe von GNU AS
+s*2Aas_Assembliere mit Hilfe von GNU AS
+v*2Aas_Assembliere mit Hilfe von GNU AS
+W*2Abinaryen_Assembliere mit Hilfe von GNU AS f�r wasm32 (wasm-as)
+W*2Allvm-mc_Assembliere mit Hilfe von llvm-mc
+W*2Awabt_Assembliere mit Hilfe von wasa
+x*2Aas_Assembliere mit Hilfe von GNU AS
 Z*2Asdcc-sdasz80_Assembliere mit Hilfe von SDCC-SDASZ80
 Z*2Az80asm_Assembliere mit Hilfe von z80asm
+Z*2Avasm_Assembliere mit Hilfe von Vasm
 # Used only internally by IDE
 **1b_Erzeuge Browser-Info
 **2bl_Erzeuge Info zu lokalen Symbolen
@@ -3994,7 +4035,9 @@ A*2CV<x>_Setze das Section-Threadvar-Modell auf <x>
 **2CX_Benutze Smartlinking
 **1d<x>_Definiere das Symbol <x>
 **1D_Erzeuge eine DEF-Datei
+**2DD<x>_Setze die von %DATE% zur�ck gegebene Datums-Zeichenkette auf x, ohne šberpr�fung auf G�ltigkeit
 **2Dd<x>_Setze Beschreibung zu <x>
+**2DT<x>_Setze die von %TIME% zur�ck gegebene Zeit-Zeichenkette auf x, ohne šberpr�fung auf G�ltigkeit
 **2Dv<x>_Setze DLL Version zu <x>
 *O2Dw_Erzeuge PM-Anwendung
 **1e<x>_Setze Pfad zur ausf�hrbaren Datei
@@ -4007,8 +4050,9 @@ A*2CV<x>_Setze das Section-Threadvar-Modell auf <x>
 **2Fd_Schalte den internen Verzeichnis-Cache des Compilers aus
 **2FD<x>_Setze das Verzeichnis f�r die Compiler-Hilfsprogramme
 **2Fe<x>_Leite die Fehlerausgabe um nach <x>
-**2Ff<x>_Erg„nze <x> zum Framework-Pfad (nur Darwin)
 **2FE<x>_Setze den Pfad f�r Exe/Unit-Dateien auf <x>
+**2Ff<x>_Erg„nze <x> zum Framework-Pfad (nur Darwin), oder setze IDF-Pfad auf <x> (Xtensa-FreeRTOS)
+**2FF_Benutze fpcres als šbersetzer von RC nach RES anstelle von windres oder gorc
 **2Fi<x>_Erg„nze <x> zum Include-Pfad
 **2Fl<x>_Erg„nze <x> zum Bibliotheks-Pfad
 **2FL<x>_Benutze <x> als dynamischen Linker
@@ -4122,6 +4166,7 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 **2SI<x>_Setze den Stil des Interface zu <x>
 **3SIcom_COM kompatibles Interface (Voreinstellung)
 **3SIcorba_CORBA kompatibles Interface
+**2sT_Erzeuge nur Skript, um auf dem Zielsystem zu linken
 **2Sm_Unterst�tze Makros wie in C (global)
 **2So_Sei TP/BP 7.0 kompatibel (wie -Mtp)
 **2Sr_Transparente Dateinamen im ISO-Modus
@@ -4130,8 +4175,8 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 **2Sx_Exception Schl�sselw”rter einschalten (Voreinstellung in Delphi/ObjFPC Moden)
 **2Sy_@<pointer> gibt einen typisierten Zeiger zur�ck, genau wie $T+
 **1s_Rufe weder Assembler noch Linker auf (nur mit -a)
-**2sh_Erzeuge Script um auf dem Host zu linken
-**2st_Erzeuge Script um auf dem Zielsystem zu linken
+**2sh_Erzeuge Skript, um auf dem Host zu linken
+**2st_Erzeuge Skript, um auf dem Zielsystem zu assemblieren und zu linken
 **2sr_šberspringe die Phase der "register allocation" (mit -alr benutzen)
 **1T<x>_Zielbetriebssystem::
 # i386 targets
@@ -4178,7 +4223,9 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 6*2Tlinux_Linux
 6*2Tnetbsd_NetBSD
 6*2Tmacos_Mac OS
+6*2Tmacosclassic_Classic Mac OS
 6*2Tpalmos_PalmOS
+6*2Tsinclairql_Sinclair QL
 # i8086 targets
 8*2Tembedded_Embedded
 8*2Tmsdos_MS-DOS (und kompatible)
@@ -4186,10 +4233,10 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 # arm targets
 A*2Tandroid_Android
 A*2Taros_AROS
-A*2Tdarwin_Darwin/iPhoneOS/iOS
 A*2Tembedded_Embedded
 A*2Tfreertos_FreeRTOS
 A*2Tgba_Game Boy Advance
+A*2Tios_iOS
 A*2Tlinux_Linux
 A*2Tnds_Nintendo DS
 A*2Tnetbsd_NetBSD
@@ -4198,7 +4245,9 @@ A*2Tsymbian_Symbian
 A*2Twince_Windows CE
 # aarch64 targets
 a*2Tandroid_Android
-a*2Tdarwin_Darwin/iOS
+a*2Tdarwin_Darwin/Mac OS X
+a*2Tfreebsd_FreeBSD
+a*2Tios_iOS
 a*2Tlinux_Linux
 a*2Twin64_Windows 64
 # jvm targets
@@ -4218,6 +4267,7 @@ P*2Tdarwin_Darwin und macOS
 P*2Tembedded_Embedded
 P*2Tlinux_Linux
 P*2Tmacos_Mac OS (classic)
+P*2Tmacosclassic_Classic Mac OS
 P*2Tmorphos_MorphOS
 P*2Tnetbsd_NetBSD
 P*2Twii_Wii
@@ -4247,6 +4297,10 @@ x*2Tlinux_Linux
 # z80 targets
 Z*2Tembedded_Embedded
 Z*2Tzxspectrum_ZX Spectrum
+Z*2Tmsxdos_MSX-DOS
+# wasm32 targets
+W*2Tembedded_Embedded
+W*2Twasi_Das WebAssembly System Interface (WASI)
 # end of targets section
 **1u<x>_Entferne die Definition f�r das Symbol <x>
 **1U<x>_Unit-Optionen:
@@ -4281,9 +4335,10 @@ A*2Wb_Erzeuge statt einer Bibliothek ein Bundle (Darwin)
 3*2WB_Erzeuge ein relozierbares Image (Windows, Symbian)
 3*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
 4*2WB_Erzeuge ein relozierbares Image (Windows)
-4*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
+4*2WB<x>_Setze die Imagebasis auf <x> (Windows)
 A*2WB_Erzeuge ein relozierbares Image (Windows, Symbian)
-A*2WB<x>_Setze die Imagebasis auf <x> (Windows)
+A*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
+Z*2WB<x>_Setze die Imagebasis auf <x> (ZX Spectrum)
 3*2WC_Spezifiziere "console type application" (EMX, OS/2, Windows)
 4*2WC_Spezifiziere "console type application" (Windows)
 A*2WC_Spezifiziere "console type application" (Windows)
@@ -4341,10 +4396,14 @@ A*2WR_Erzeuge "relocation code" (Windows)
 8*2Wt<x>_Setze das Format der Ziel-Executable
 8*3Wtexe_Erzeuge eine DOS .EXE Datei (Voreinstellung)
 8*3Wtcom_Erzeuge eine DOS .COM Datei (erfordert das winzige (tiny) Speichermodell)
-P*2WF_Spezifiziere "MPW tool type application" (Classic Mac OS)
+P*2WT_Spezifiziere "MPW tool type application" (Classic Mac OS)
+6*2WQ<x>_Setze das "executable" Metadata-Format (Sinclair QL)
+6*3WQqhdr_Setze Metadata auf QDOS Datei-Header Stil (Voreinstellung)
+6*3WQxtcc_Setze Metadata auf XTcc Stil
 **2WX_Erm”gliche den executable stack (Linux)
 **1X_Programm-Optionen:
 **2X9_Erzeuge Linkerscript f�r GNU Binutils ld „lter als Version 2.19.1 (Linux)
+**2Xa_Erzeuge Code, der auf 64-Bit Zielsystemen mehr als 2 GB statische Daten erlaubt (Linux)
 **2Xc_šbergebe --shared an den Linker (BeOS, Darwin, FreeBSD, Linux)
 **2Xd_Den Standard Bibliotheks-Suchpfad NICHT nutzen (ben”tigt f�r cross compile, wenn nicht -XR verwendet wird)
 **2Xe_Verwende den externen Linker
@@ -4360,12 +4419,13 @@ L*2XlS<x>_Suffix der LLVM-Programme (z. B. -7, wenn clang clang-7 hei
 **2XM<x>_Setze den Namen der 'main' Programm-Routine (Voreinstellung ist 'main')
 **2Xn_Nutze den plattformeigenen Linker des Zielsystem anstelle des GNU ld (Solaris, AIX)
 F*2Xp<x>_Suche nach der Compilerbinary zuerst im Verzeichnis <x>
-**2XP<x>_Stelle dem Namen der Compiler-Hilfsprogramme (binutils) den Prefix <x> voran
+**2XP<x>_Stelle den Namen der Compiler-Hilfsprogramme (binutils) den Prefix <x> voran
 **2Xr<x>_Setze den rlink-Pfad des Linker zu <x> (ben”tigt f�r cross compile, siehe ld-Manual f�r mehr Informationen) (BeOS, Linux)
 **2XR<x>_Stelle allen Linker-Suchpfaden den Namen <x> voran (BeOS, Darwin, FreeBSD, Linux, Mac OS, Solaris)
 **2Xs_Entferne alle Symbole aus der ausf�hrbaren Datei
 **2XS_Versuche Units statisch zu linken (default)    (definiert FPC_LINK_STATIC)
 **2Xt_Linke mit statischen Bibliotheken              (-static wird an den Linker �bergeben)
+**2Xu_Erzeuge ausf�hrbares Program im UF2-Format     (nur embedded-Zielsysteme)
 **2Xv_Erzeuge eine Tabelle mit den virtuellen Entry-Aufrufen
 **2XV_Benutze VLink als externen linker              (Voreinstellung f�r Amiga, MorphOS)
 **2XX_Versuche Units smart zu linken                 (definiert FPC_LINK_SMART)

compiler/msg/errordu.msg

@@ -3,7 +3,7 @@
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
 #   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 45316
+#   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
@@ -442,6 +442,7 @@ scan_w_setpeosversion_not_support=02103_W_SETPEOSVERSION wird vom Zielbetriebssy
 scan_w_setpesubsysversion_not_support=02104_W_SETPESUBSYSVERSION wird vom Zielbetriebssystem nicht unterstützt
 % The \var{\{\$SETPESUBSYSVERSION\}} directive is not supported by the target OS.
 scan_n_changecputype=02105_N_Geänderter Prozessortyp muss zum angegebenen Controller passen
+scan_e_emptymacroname=02106_E_Der Name einer macro/compiler-Variablen kann nicht leer sein
 %
 % \end{description}
 # EndOfTeX
@@ -449,7 +450,7 @@ scan_n_changecputype=02105_N_Geänderter Prozessortyp muss zum angegebenen Contr
 #
 # Parser
 #
-# 03355 is the last used one
+# 03360 is the last used one
 #
 # BeginOfTeX
 %
@@ -1091,8 +1092,9 @@ parser_e_paraloc_only_one_para=03197_E_Jedes Argument muss seine eigene "locatio
 parser_e_paraloc_all_paras=03198_E_Jedes Argument muss seine explizite "location" haben
 % If one argument has an explicit argument location, all arguments of a procedure
 % must have one.
-parser_e_illegal_explicit_paraloc=03199_E_"location" des Arguments unbekannt
-% The location specified for an argument isn't recognized by the compiler.
+parser_e_illegal_explicit_paraloc=03199_E_Ungültiger expliziter Parameter "location" spezifiziert
+% Syscalls specific: the specified explicit location string for this parameter cannot be parsed, invalid,
+% or the location specified for an argument isn't recognized by the compiler.
 parser_e_32bitint_or_pointer_variable_expected=03200_E_32 Bit-Integer oder Zeiger-Variable erwartet
 % The libbase for MorphOS/AmigaOS can be given only as \var{longint}, \var{dword} or any pointer variable.
 parser_e_goto_outside_proc=03201_E_Goto Statements zwischen verschiedenen Prozeduren sind nicht erlaubt
@@ -1569,7 +1571,7 @@ parser_w_ptr_type_ignored=03338_W_Zeigertyp "$1" ignoriert
 % The specified pointer type modifier is ignored, because it is not supported on
 % the current platform. This happens, for example, when a far pointer is
 % declared on a non-x86 platform.
-parser_e_global_generic_references_static=03339_E_Ein globales, generisches Templat referenziert eine statische Symboltabelle
+parser_e_global_generic_references_static=03339_E_Ein generisches Templat im Interface-Bereich referenziert ein Symbol des Implementation-Bereichs
 % A generic declared in the interface section of a unit must not reference symbols that belong
 % solely to the implementation section of that unit.
 parser_u_already_compiled=03340_UL_Die Unit $1 wurde inzwischen bereits kompiliert.
@@ -1628,6 +1630,16 @@ parser_e_method_for_type_in_other_unit=03354_E_Implementierung einer Methods fü
 parser_e_generic_constraints_not_allowed_here=03355_E_Eine generische Einschränkung ist hier nicht erlaubt
 % At the current location specifying a constraint is not allowed. For example
 % in delphi mode, a constraint might not be specified in the header of the implementation.
+parser_e_location_size_too_small=03356_E_Die explizite "location" ist zu klein für den Parameter
+% AmigaOS/MorphOS syscall specific: for int64/qword parameter only a single register location is specified
+parser_e_location_size_too_large=03357_E_Die Größe der expliziten "location" ist größer als vom Parameter verlangt
+% AmigaOS/MorphOS syscall specific: for a parameter which is smaller than 64bit, a register pair is specified
+parser_e_location_regpair_only_data=03358_E_Nur Daten-Register werden für explizite "location" Registerpaare unterstützt
+% AmigaOS/MorphOS syscall specific: for 64bit register pairs, only data registers are supported
+parser_e_location_regpair_only_consecutive=03359_E_Nur aufeinander folgende Register werden für explizite "location" Registerpaare unterstützt
+% MorphOS syscall specific: only consecutive (f.e.: d1-d2) registers are supported for 64bit register pairs
+parser_e_constructurs_cannot_take_type_parameters=03360_E_Konstruktoren können keine Type-Parameter übernehmen
+% The use of type parameters in constructors is not allowed.
 %
 % \end{description}
 # EndOfTeX
@@ -1635,7 +1647,7 @@ parser_e_generic_constraints_not_allowed_here=03355_E_Eine generische Einschrän
 #
 # Type Checking
 #
-# 04128 is the last used one
+# 04130 is the last used one
 #
 # BeginOfTeX
 %
@@ -2084,6 +2096,11 @@ type_e_forward_interface_type_does_not_match=04127_E_Der Interfacetyp der Vorwä
 type_e_generic_const_type_not_allowed=04128_E_Typ ist für generische, konstante Parameter nicht erlaubt: $1
 % Only types that can also be used (indirectly) for untyped constants can be used as a
 % type for a generic constant parameter.
+type_e_cant_read_write_type_in_iso_mode=04129_E_Kann Variablen diesen Typs im ISO-Modus nicht lesen oder schreiben
+% You are trying to \var{read} or \var{write} a variable from or to a
+% file of type text, which doesn't support that variable's type in the selected language mode (iso mode).
+type_w_array_size_does_not_match_size_of_constant_string=04130_W_Die Länge der konstanten Zeichenkette (die Länge ist $1) muss so groß wie die Anzahl der Array-Elemente sein ($2 Elemente)
+% ISO Pascal requires that string constants have the same length as the array to which them they are assigned.
 %
 % \end{description}
 # EndOfTeX
@@ -2595,7 +2612,7 @@ cg_w_interrupt_does_not_save_registers=06062_W_Der Zielprozessor unterstützt es
 #
 # Assembler reader
 #
-# 07141 is the last used one
+# 07145 is the last used one
 #
 asmr_d_start_reading=07000_DL_Starte $1 Stil Assembler Parsen
 % This informs you that an assembler block is being parsed
@@ -2935,6 +2952,10 @@ asmr_e_multiple_segment_overrides=07139_E_Kann "multiple segment overrides" nich
 asmr_w_multiple_segment_overrides=07140_W_"Multiple segment overrides" (nur das letzte wird beachtet)
 asmr_w_segment_override_ignored_in_64bit_mode=07141_W_Segment-Basis $1 wird erzeugt, aber von der CPU im 64-Bit-Modus ignoriert
 asmr_e_mismatch_broadcasting_elements=07142_E_Broadcasting-Elemente passen nicht (erwartet: {$1} gefunden: {$2})
+asmr_e_invalid_arrangement=07143_E_Ungültige Anordnung "$1"
+asmr_e_a64_invalid_regset=07144_E_Register in einem Register-Set müssen aufeinander folgen
+asmr_e_unknown_field=07145_E_Unbekannter Feld-Bezeichner
+% The internal assembler read cannot find the passed field identifier.
 %
 % \end{description}
 # EndOfTeX
@@ -2942,7 +2963,7 @@ asmr_e_mismatch_broadcasting_elements=07142_E_Broadcasting-Elemente passen nicht
 #
 # Assembler/binary writers
 #
-# 08035 is the last used one
+# 08036 is the last used one
 #
 asmw_f_too_many_asm_files=08000_F_Zu viele Assembler-Dateien
 % With smartlinking enabled, there are too many assembler
@@ -2999,6 +3020,7 @@ asmw_e_instruction_not_supported_by_cpu=08032_E_Befehl wird vom ausgewählten Be
 asmw_e_brxx_out_of_range=08033_E_Asm: Das Ziel des bedingten Zweigs ist außerhalb des Bereichs
 asmw_e_illegal_use_of_rip=08034_E_Asm: RIP kann nicht als Indexregister oder mit einem anderen Register in einer Referenz verwendet werden
 asmw_e_seh_invalid_data_size=08035_F_Ungültige Funktionsgröße einer SEH-Funktion
+asmw_e_illegal_use_of_sp=08036_E_Asm: ESP/RSP kann nicht als Indexregister verwendet werden
 %
 % \end{description}
 # EndOfTeX
@@ -3449,7 +3471,7 @@ unit_u_ppu_llvm_mismatch=10067_U_Überspringe die Unit, PPU und Compiler müssen
 #
 # Options
 #
-# 11061 is the last used one
+# 11063 is the last used one
 #
 # BeginOfTeX
 %
@@ -3605,6 +3627,9 @@ option_features_only_for_system_unit=11060_E_Feature-Schalter werden nur beim Ü
 % To selected a certain feature, the system unit must be compiled with this feature enabled. All other units inherited the features set by the
 % system unit through the ppu of the system unit.
 option_debug_info_requires_external_linker=11061_N_Das ausgewählte Debug-Format wird vom internen Linker nicht unterstützt, schalte um auf externen Linker
+option_valgrind_heaptrc_mismatch=11062_E_Die beiden Optionen ($1) ($2) können nicht gleichzeitig verwendet werden
+option_unsupported_fpu=11063_F_Der ausgewählte FPU-Typ "$1" wird vom ausgewählten Befehlssatz "$2" nicht unterstützt
+% Not all instruction sets support all FPU types. For example on ARM, Thumb(-1) supports no FPU/VFP instruction set
 %
 % \end{description}
 # EndOfTeX
@@ -3896,6 +3921,7 @@ F*0*_Es werden nur Optionen aufgelistet, die für die voreingestellte oder ausge
 **1A<x>_Ausgabe Format:
 **2Adefault_Benutze den "default" Assembler
 3*2Aas_Assembliere mit Hilfe von GNU AS
+3*2Aas-darwin_Assembliere Darwin Mach-O mit Hilfe von GNU GAS
 3*2Amacho_Mach-O (Darwin, Intel 32 bit) mit Hilfe des internen Schreibers
 8*2Anasm_Assembliere mit Hilfe von Nasm
 8*2Anasmobj_Assembliere mit Hilfe von Nasm
@@ -3915,7 +3941,8 @@ F*0*_Es werden nur Optionen aufgelistet, die für die voreingestellte oder ausge
 3*2Ayasm_Assembliere mit Hilfe von Yasm (experimentell)
 4*2Aas_Assembliere mit Hilfe von GNU AS
 4*2Agas_Assembliere mit Hilfe von GNU GAS
-4*2Agas-darwin_Assembliere darwin Mach-O64 mit Hilfe von GNU GAS
+4*2Agas-darwin_Assembliere Darwin Mach-O64 mit Hilfe von GNU GAS
+4*2Aas-darwin_Assembliere Darwin Mach-O64 mit Hilfe von GNU GAS
 4*2Amasm_Win64 Objektdatei mit Hilfe von ml64 (Microsoft)
 4*2Apecoff_PE-COFF (Win64) mit Hilfe des internen Schreibers
 4*2Aelf_ELF (Linux-64bit) mit Hilfe des internen Schreibers
@@ -3930,10 +3957,23 @@ F*0*_Es werden nur Optionen aufgelistet, die für die voreingestellte oder ausge
 6*2Amot_Standard Motorola Assembler
 6*2Avasm_Assembliere mit Hilfe von vasm
 A*2Aas_Assembliere mit Hilfe von GNU AS
+A*2Aas-darwin_Assembliere mit Hilfe von GNU AS für Darwin Zielsysteme
+A*2Aclang_Assembliere mit Hilfe von clang
+A*2Aelf_Assembliere mit Hilfe des internen ELF-Schreibers
+a*2Aas_Assembliere mit Hilfe von GNU AS
+a*2Aclang_Assembliere mit Hilfe von clang für Darwin/iOS Zielsysteme
+a*2Aas-clang_AAssembliere mit Hilfe von clang für andere Zielsysteme 
 P*2Aas_Assembliere mit Hilfe von GNU AS
 S*2Aas_Assembliere mit Hilfe von GNU AS
+s*2Aas_Assembliere mit Hilfe von GNU AS
+v*2Aas_Assembliere mit Hilfe von GNU AS
+W*2Abinaryen_Assembliere mit Hilfe von GNU AS für wasm32 (wasm-as)
+W*2Allvm-mc_Assembliere mit Hilfe von llvm-mc
+W*2Awabt_Assembliere mit Hilfe von wasa
+x*2Aas_Assembliere mit Hilfe von GNU AS
 Z*2Asdcc-sdasz80_Assembliere mit Hilfe von SDCC-SDASZ80
 Z*2Az80asm_Assembliere mit Hilfe von z80asm
+Z*2Avasm_Assembliere mit Hilfe von Vasm
 # Used only internally by IDE
 **1b_Erzeuge Browser-Info
 **2bl_Erzeuge Info zu lokalen Symbolen
@@ -3994,7 +4034,9 @@ A*2CV<x>_Setze das Section-Threadvar-Modell auf <x>
 **2CX_Benutze Smartlinking
 **1d<x>_Definiere das Symbol <x>
 **1D_Erzeuge eine DEF-Datei
+**2DD<x>_Setze die von %DATE% zurück gegebene Datums-Zeichenkette auf x, ohne Überprüfung auf Gültigkeit
 **2Dd<x>_Setze Beschreibung zu <x>
+**2DT<x>_Setze die von %TIME% zurück gegebene Zeit-Zeichenkette auf x, ohne Überprüfung auf Gültigkeit
 **2Dv<x>_Setze DLL Version zu <x>
 *O2Dw_Erzeuge PM-Anwendung
 **1e<x>_Setze Pfad zur ausführbaren Datei
@@ -4007,8 +4049,9 @@ A*2CV<x>_Setze das Section-Threadvar-Modell auf <x>
 **2Fd_Schalte den internen Verzeichnis-Cache des Compilers aus
 **2FD<x>_Setze das Verzeichnis für die Compiler-Hilfsprogramme
 **2Fe<x>_Leite die Fehlerausgabe um nach <x>
-**2Ff<x>_Ergänze <x> zum Framework-Pfad (nur Darwin)
 **2FE<x>_Setze den Pfad für Exe/Unit-Dateien auf <x>
+**2Ff<x>_Ergänze <x> zum Framework-Pfad (nur Darwin), oder setze IDF-Pfad auf <x> (Xtensa-FreeRTOS)
+**2FF_Benutze fpcres als Übersetzer von RC nach RES anstelle von windres oder gorc
 **2Fi<x>_Ergänze <x> zum Include-Pfad
 **2Fl<x>_Ergänze <x> zum Bibliotheks-Pfad
 **2FL<x>_Benutze <x> als dynamischen Linker
@@ -4122,6 +4165,7 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 **2SI<x>_Setze den Stil des Interface zu <x>
 **3SIcom_COM kompatibles Interface (Voreinstellung)
 **3SIcorba_CORBA kompatibles Interface
+**2sT_Erzeuge nur Skript, um auf dem Zielsystem zu linken
 **2Sm_Unterstütze Makros wie in C (global)
 **2So_Sei TP/BP 7.0 kompatibel (wie -Mtp)
 **2Sr_Transparente Dateinamen im ISO-Modus
@@ -4130,8 +4174,8 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 **2Sx_Exception Schlüsselwörter einschalten (Voreinstellung in Delphi/ObjFPC Moden)
 **2Sy_@<pointer> gibt einen typisierten Zeiger zurück, genau wie $T+
 **1s_Rufe weder Assembler noch Linker auf (nur mit -a)
-**2sh_Erzeuge Script um auf dem Host zu linken
-**2st_Erzeuge Script um auf dem Zielsystem zu linken
+**2sh_Erzeuge Skript, um auf dem Host zu linken
+**2st_Erzeuge Skript, um auf dem Zielsystem zu assemblieren und zu linken
 **2sr_Überspringe die Phase der "register allocation" (mit -alr benutzen)
 **1T<x>_Zielbetriebssystem::
 # i386 targets
@@ -4178,7 +4222,9 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 6*2Tlinux_Linux
 6*2Tnetbsd_NetBSD
 6*2Tmacos_Mac OS
+6*2Tmacosclassic_Classic Mac OS
 6*2Tpalmos_PalmOS
+6*2Tsinclairql_Sinclair QL
 # i8086 targets
 8*2Tembedded_Embedded
 8*2Tmsdos_MS-DOS (und kompatible)
@@ -4186,10 +4232,10 @@ F*2P<x>_Setze den Zielprozessor (aarch64,arm,avr,i386,i8086,jvm,m68k,mips,mipsel
 # arm targets
 A*2Tandroid_Android
 A*2Taros_AROS
-A*2Tdarwin_Darwin/iPhoneOS/iOS
 A*2Tembedded_Embedded
 A*2Tfreertos_FreeRTOS
 A*2Tgba_Game Boy Advance
+A*2Tios_iOS
 A*2Tlinux_Linux
 A*2Tnds_Nintendo DS
 A*2Tnetbsd_NetBSD
@@ -4198,7 +4244,9 @@ A*2Tsymbian_Symbian
 A*2Twince_Windows CE
 # aarch64 targets
 a*2Tandroid_Android
-a*2Tdarwin_Darwin/iOS
+a*2Tdarwin_Darwin/Mac OS X
+a*2Tfreebsd_FreeBSD
+a*2Tios_iOS
 a*2Tlinux_Linux
 a*2Twin64_Windows 64
 # jvm targets
@@ -4218,6 +4266,7 @@ P*2Tdarwin_Darwin und macOS
 P*2Tembedded_Embedded
 P*2Tlinux_Linux
 P*2Tmacos_Mac OS (classic)
+P*2Tmacosclassic_Classic Mac OS
 P*2Tmorphos_MorphOS
 P*2Tnetbsd_NetBSD
 P*2Twii_Wii
@@ -4247,6 +4296,10 @@ x*2Tlinux_Linux
 # z80 targets
 Z*2Tembedded_Embedded
 Z*2Tzxspectrum_ZX Spectrum
+Z*2Tmsxdos_MSX-DOS
+# wasm32 targets
+W*2Tembedded_Embedded
+W*2Twasi_Das WebAssembly System Interface (WASI)
 # end of targets section
 **1u<x>_Entferne die Definition für das Symbol <x>
 **1U<x>_Unit-Optionen:
@@ -4281,9 +4334,10 @@ A*2Wb_Erzeuge statt einer Bibliothek ein Bundle (Darwin)
 3*2WB_Erzeuge ein relozierbares Image (Windows, Symbian)
 3*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
 4*2WB_Erzeuge ein relozierbares Image (Windows)
-4*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
+4*2WB<x>_Setze die Imagebasis auf <x> (Windows)
 A*2WB_Erzeuge ein relozierbares Image (Windows, Symbian)
-A*2WB<x>_Setze die Imagebasis auf <x> (Windows)
+A*2WB<x>_Setze die Imagebasis auf <x> (Windows, Symbian)
+Z*2WB<x>_Setze die Imagebasis auf <x> (ZX Spectrum)
 3*2WC_Spezifiziere "console type application" (EMX, OS/2, Windows)
 4*2WC_Spezifiziere "console type application" (Windows)
 A*2WC_Spezifiziere "console type application" (Windows)
@@ -4341,10 +4395,14 @@ A*2WR_Erzeuge "relocation code" (Windows)
 8*2Wt<x>_Setze das Format der Ziel-Executable
 8*3Wtexe_Erzeuge eine DOS .EXE Datei (Voreinstellung)
 8*3Wtcom_Erzeuge eine DOS .COM Datei (erfordert das winzige (tiny) Speichermodell)
-P*2WF_Spezifiziere "MPW tool type application" (Classic Mac OS)
+P*2WT_Spezifiziere "MPW tool type application" (Classic Mac OS)
+6*2WQ<x>_Setze das "executable" Metadata-Format (Sinclair QL)
+6*3WQqhdr_Setze Metadata auf QDOS Datei-Header Stil (Voreinstellung)
+6*3WQxtcc_Setze Metadata auf XTcc Stil
 **2WX_Ermögliche den executable stack (Linux)
 **1X_Programm-Optionen:
 **2X9_Erzeuge Linkerscript für GNU Binutils ld älter als Version 2.19.1 (Linux)
+**2Xa_Erzeuge Code, der auf 64-Bit Zielsystemen mehr als 2 GB statische Daten erlaubt (Linux)
 **2Xc_Übergebe --shared an den Linker (BeOS, Darwin, FreeBSD, Linux)
 **2Xd_Den Standard Bibliotheks-Suchpfad NICHT nutzen (benötigt für cross compile, wenn nicht -XR verwendet wird)
 **2Xe_Verwende den externen Linker
@@ -4360,12 +4418,13 @@ L*2XlS<x>_Suffix der LLVM-Programme (z. B. -7, wenn clang clang-7 heißt)
 **2XM<x>_Setze den Namen der 'main' Programm-Routine (Voreinstellung ist 'main')
 **2Xn_Nutze den plattformeigenen Linker des Zielsystem anstelle des GNU ld (Solaris, AIX)
 F*2Xp<x>_Suche nach der Compilerbinary zuerst im Verzeichnis <x>
-**2XP<x>_Stelle dem Namen der Compiler-Hilfsprogramme (binutils) den Prefix <x> voran
+**2XP<x>_Stelle den Namen der Compiler-Hilfsprogramme (binutils) den Prefix <x> voran
 **2Xr<x>_Setze den rlink-Pfad des Linker zu <x> (benötigt für cross compile, siehe ld-Manual für mehr Informationen) (BeOS, Linux)
 **2XR<x>_Stelle allen Linker-Suchpfaden den Namen <x> voran (BeOS, Darwin, FreeBSD, Linux, Mac OS, Solaris)
 **2Xs_Entferne alle Symbole aus der ausführbaren Datei
 **2XS_Versuche Units statisch zu linken (default)    (definiert FPC_LINK_STATIC)
 **2Xt_Linke mit statischen Bibliotheken              (-static wird an den Linker übergeben)
+**2Xu_Erzeuge ausführbares Program im UF2-Format     (nur embedded-Zielsysteme)
 **2Xv_Erzeuge eine Tabelle mit den virtuellen Entry-Aufrufen
 **2XV_Benutze VLink als externen linker              (Voreinstellung für Amiga, MorphOS)
 **2XX_Versuche Units smart zu linken                 (definiert FPC_LINK_SMART)

compiler/ncgbas.pas

@@ -284,6 +284,7 @@ interface
       var
         hp,hp2 : tai;
         i : longint;
+        vs : tabstractnormalvarsym;
       begin
          location_reset(location,LOC_VOID,OS_NO);
 
@@ -403,6 +404,23 @@ interface
                       taicpu(hp).CheckIfValid;
 {$endif x86 or z80}
                      end;
+                  ait_const:
+                    with tai_const(hp) do begin
+                      { Handle references to locals from TP-style INLINE(). }
+                      if assigned(sym) and (sym.bind=AB_NONE) then
+                        begin
+                          vs:=tabstractnormalvarsym(current_procinfo.procdef.parast.Find(sym.Name));
+                          if not assigned(vs) then
+                            vs:=tabstractnormalvarsym(current_procinfo.procdef.localst.Find(sym.Name));
+                          if not assigned(vs) then
+                            Internalerror(2021081401);
+                          if vs.localloc.loc<>LOC_REFERENCE then
+                            Internalerror(2021081402);
+                          value:=vs.localloc.reference.offset+symofs;
+                          sym:=nil;
+                          symofs:=0;
+                        end;
+                    end
                   else
                     ;
                 end;

compiler/ncon.pas

@@ -202,7 +202,10 @@ interface
        cguidconstnode : tguidconstnodeclass = tguidconstnode;
        cnilnode : tnilnodeclass=tnilnode;
 
-    function genintconstnode(const v : TConstExprInt) : tordconstnode;
+    { Creates tordconstnode with the smallest possible int type which can hold v }
+    function genintconstnode(const v : TConstExprInt) : tordconstnode; overload;
+    { Creates tordconstnode with the preferredinttype type or a bigger type which can hold v }
+    function genintconstnode(const v : TConstExprInt; preferredinttype : tdef) : tordconstnode; overload;
     function genenumnode(v : tenumsym) : tordconstnode;
 
     { some helper routines }
@@ -233,6 +236,17 @@ implementation
       end;
 
 
+    function genintconstnode(const v : TConstExprInt; preferredinttype : tdef) : tordconstnode;
+      var
+        htype : tdef;
+      begin
+        int_to_type(v,htype);
+        if htype.size<preferredinttype.size then
+          htype:=preferredinttype;
+        result:=cordconstnode.create(v,htype,true);
+      end;
+
+
     function genenumnode(v : tenumsym) : tordconstnode;
       var
         htype : tdef;

compiler/ninl.pas

@@ -2527,9 +2527,8 @@ implementation
                         else if not is_open_array(left.resultdef) and
                            not is_array_of_const(left.resultdef) and
                            not is_dynamic_array(left.resultdef) then
-                          result:=cordconstnode.create(tarraydef(left.resultdef).highrange-
-                            tarraydef(left.resultdef).lowrange+1,
-                            sinttype,true);
+                          result:=genintconstnode(tarraydef(left.resultdef).highrange-
+                            tarraydef(left.resultdef).lowrange+1,sizesinttype);
                       end;
                     else
                       ;

compiler/nld.pas

@@ -197,7 +197,8 @@ implementation
       cpuinfo,
       htypechk,pass_1,procinfo,paramgr,
       nbas,ncon,nflw,ninl,ncnv,nmem,ncal,nutils,
-      cgbase
+      cgbase,
+      optloadmodifystore
       ;
 
 
@@ -625,6 +626,13 @@ implementation
            is_constrealnode(right) and
            not equal_defs(right.resultdef,left.resultdef) then
           inserttypeconv(right,left.resultdef);
+{$if (cs_opt_use_load_modify_store in supported_optimizerswitches)}
+        { Perform simple optimizations when -O2 and the dedicated
+          cs_opt_use_load_modify_store optimization pass is not enabled. }
+        if (cs_opt_level2 in current_settings.optimizerswitches) and
+           not (cs_opt_use_load_modify_store in current_settings.optimizerswitches) then
+          result:=try_opt_assignmentnode(self);
+{$endif}
       end;
 
 

compiler/optloadmodifystore.pas

@@ -38,16 +38,17 @@ unit optloadmodifystore;
   interface
 
     uses
-      node;
+      node,nld;
 
     procedure do_optloadmodifystore(var rootnode : tnode);
+    function try_opt_assignmentnode(assignmentnode : tassignmentnode): tnode;
 
   implementation
 
     uses
-      globtype,verbose,nutils,compinnr,
+      globtype,globals,verbose,nutils,compinnr,
       defutil,defcmp,htypechk,pass_1,constexp,
-      nadd,ncal,ncon,ncnv,ninl,nld,nmat,
+      nadd,ncal,ncon,ncnv,ninl,nmat,
       symdef;
 
     function try_opt_assignmentnode(assignmentnode: tassignmentnode): tnode;
@@ -57,6 +58,10 @@ unit optloadmodifystore;
         result:=nil;
         with assignmentnode do
           begin
+            { *** Here are simple optimizations which are performed
+              when -O2 (via a call from tassignmentnode.simplify) or
+              when cs_opt_use_load_modify_store is enabled (in a separate pass).
+            }
             { replace i:=succ/pred(i) by inc/dec(i)? }
             if (right.nodetype=inlinen) and
               ((tinlinenode(right).inlinenumber=in_succ_x) or (tinlinenode(right).inlinenumber=in_pred_x)) and
@@ -273,6 +278,71 @@ unit optloadmodifystore;
                 taddnode(ttypeconvnode(right).left).left:=nil;
                 exit;
               end;
+            { replace i:=not i  by in_not_assign_x(i)
+                      i:=-i     by in_neg_assign_x(i)
+
+              this handles the case, where there are no implicit type conversions }
+            if (right.nodetype in [notn,unaryminusn]) and
+              (tunarynode(right).left.isequal(left)) and
+              is_integer(tunarynode(right).left.resultdef) and
+              ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
+              ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
+              valid_for_var(tunarynode(right).left,false) and
+              not(might_have_sideeffects(tunarynode(right).left)) then
+              begin
+                if right.nodetype=notn then
+                  newinlinenodetype:=in_not_assign_x
+                else
+                  newinlinenodetype:=in_neg_assign_x;
+                result:=cinlinenode.createintern(
+                  newinlinenodetype,false,tunarynode(right).left);
+                result.localswitches:=localswitches;
+                result.fileinfo:=fileinfo;
+                result.verbosity:=verbosity;
+                tunarynode(right).left:=nil;
+                exit;
+              end;
+            { replace i:=not i  by in_not_assign_x(i)
+                      i:=-i     by in_neg_assign_x(i)
+
+              this handles the case with type conversions:
+                   outer typeconv: right
+                          neg/not: ttypeconvnode(right).left
+                   inner typeconv: tunarynode(ttypeconvnode(right).left).left
+                   right side 'i': ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left }
+            if (right.nodetype=typeconvn) and
+               (ttypeconvnode(right).convtype=tc_int_2_int) and
+               (ttypeconvnode(right).left.nodetype in [notn,unaryminusn]) and
+               is_integer(ttypeconvnode(right).left.resultdef) and
+               (right.resultdef.size<=ttypeconvnode(right).left.resultdef.size) and
+               (tunarynode(ttypeconvnode(right).left).left.nodetype=typeconvn) and
+               (ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).convtype=tc_int_2_int) and
+               are_equal_ints(right.resultdef,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
+               ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.isequal(left) and
+               is_integer(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
+               ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
+               ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
+               valid_for_var(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left,false) and
+               not(might_have_sideeffects(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left)) then
+              begin
+                if ttypeconvnode(right).left.nodetype=notn then
+                  newinlinenodetype:=in_not_assign_x
+                else
+                  newinlinenodetype:=in_neg_assign_x;
+                result:=cinlinenode.createintern(
+                  newinlinenodetype,false,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left);
+                result.localswitches:=localswitches;
+                result.fileinfo:=fileinfo;
+                result.verbosity:=verbosity;
+                ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left:=nil;
+                exit;
+              end;
+
+            if not (cs_opt_use_load_modify_store in current_settings.optimizerswitches) then
+              exit;
+            { *** Here are more complex optimizations which are performed only
+              when cs_opt_use_load_modify_store is enabled.
+            }
 {$ifdef enable_shl_shr_assign_x_y}
             { replace i:=i shl k by in_shl_assign_x_y(i,k)
                       i:=i shr k by in_shr_assign_x_y(i,k)
@@ -555,65 +625,6 @@ unit optloadmodifystore;
                 exit;
               end;
 {$endif enable_sar_assign_x_y or enable_rox_assign_x_y}
-            { replace i:=not i  by in_not_assign_x(i)
-                      i:=-i     by in_neg_assign_x(i)
-
-              this handles the case, where there are no implicit type conversions }
-            if (right.nodetype in [notn,unaryminusn]) and
-              (tunarynode(right).left.isequal(left)) and
-              is_integer(tunarynode(right).left.resultdef) and
-              ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
-              ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
-              valid_for_var(tunarynode(right).left,false) and
-              not(might_have_sideeffects(tunarynode(right).left)) then
-              begin
-                if right.nodetype=notn then
-                  newinlinenodetype:=in_not_assign_x
-                else
-                  newinlinenodetype:=in_neg_assign_x;
-                result:=cinlinenode.createintern(
-                  newinlinenodetype,false,tunarynode(right).left);
-                result.localswitches:=localswitches;
-                result.fileinfo:=fileinfo;
-                result.verbosity:=verbosity;
-                tunarynode(right).left:=nil;
-                exit;
-              end;
-            { replace i:=not i  by in_not_assign_x(i)
-                      i:=-i     by in_neg_assign_x(i)
-
-              this handles the case with type conversions:
-                   outer typeconv: right
-                          neg/not: ttypeconvnode(right).left
-                   inner typeconv: tunarynode(ttypeconvnode(right).left).left
-                   right side 'i': ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left }
-            if (right.nodetype=typeconvn) and
-               (ttypeconvnode(right).convtype=tc_int_2_int) and
-               (ttypeconvnode(right).left.nodetype in [notn,unaryminusn]) and
-               is_integer(ttypeconvnode(right).left.resultdef) and
-               (right.resultdef.size<=ttypeconvnode(right).left.resultdef.size) and
-               (tunarynode(ttypeconvnode(right).left).left.nodetype=typeconvn) and
-               (ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).convtype=tc_int_2_int) and
-               are_equal_ints(right.resultdef,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
-               ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.isequal(left) and
-               is_integer(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left.resultdef) and
-               ((localswitches*[cs_check_overflow,cs_check_range])=[]) and
-               ((right.localswitches*[cs_check_overflow,cs_check_range])=[]) and
-               valid_for_var(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left,false) and
-               not(might_have_sideeffects(ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left)) then
-              begin
-                if ttypeconvnode(right).left.nodetype=notn then
-                  newinlinenodetype:=in_not_assign_x
-                else
-                  newinlinenodetype:=in_neg_assign_x;
-                result:=cinlinenode.createintern(
-                  newinlinenodetype,false,ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left);
-                result.localswitches:=localswitches;
-                result.fileinfo:=fileinfo;
-                result.verbosity:=verbosity;
-                ttypeconvnode(tunarynode(ttypeconvnode(right).left).left).left:=nil;
-                exit;
-              end;
           end;
       end;
 

compiler/pexpr.pas

@@ -465,12 +465,12 @@ implementation
                      not((p1.nodetype = subscriptn) and
                          is_packed_record_or_object(tsubscriptnode(p1).left.resultdef))) then
                    begin
-                     statement_syssym:=cordconstnode.create(p1.resultdef.size,sizesinttype,true);
+                     statement_syssym:=genintconstnode(p1.resultdef.size,sizesinttype);
                      if (l = in_bitsizeof_x) then
                        statement_syssym:=caddnode.create(muln,statement_syssym,cordconstnode.create(8,sizesinttype,true));
                    end
                  else
-                   statement_syssym:=cordconstnode.create(p1.resultdef.packedbitsize,sizesinttype,true);
+                   statement_syssym:=genintconstnode(p1.resultdef.packedbitsize,sizesinttype);
                  { type def is a struct with generic fields }
                  if df_has_generic_fields in p1.resultdef.defoptions then
                     include(statement_syssym.flags,nf_generic_para);

compiler/pstatmnt.pas

@@ -44,7 +44,7 @@ implementation
        globtype,globals,verbose,constexp,
        systems,
        { aasm }
-       cpubase,aasmtai,aasmdata,
+       cpubase,aasmtai,aasmdata,aasmbase,
        { symtable }
        symconst,symbase,symtype,symdef,symsym,symtable,defutil,defcmp,
        paramgr,
@@ -1085,7 +1085,13 @@ implementation
 
          { Mark procedure that it has assembler blocks }
          include(current_procinfo.flags,pi_has_assembler_block);
-
+{$if defined(cpu8bitalu) or defined(cpu16bitalu)}
+         { We assume the function result is always used in the TP mode }
+         if (m_tp7 in current_settings.modeswitches) and
+            not (po_assembler in current_procinfo.procdef.procoptions) and
+            assigned(current_procinfo.procdef.funcretsym) then
+           current_procinfo.procdef.funcretsym.IncRefCount;
+{$endif}
          { Read first the _ASM statement }
          consume(_ASM);
 
@@ -1136,6 +1142,172 @@ implementation
       end;
 
 
+    { Old Turbo Pascal INLINE(data/data/...) }
+    function tp_inline_statement : tnode;
+      var
+        actype : taiconst_type;
+
+      function eval_intconst: asizeint;
+        var
+          cv : Tconstexprint;
+          def: tdef;
+        begin
+          cv:=get_intconst;
+          case actype of
+            aitconst_8bit:
+              def:=s8inttype;
+            aitconst_16bit:
+              def:=s16inttype;
+            else
+              def:=sizesinttype;
+          end;
+          if cv.uvalue>get_max_value(def).uvalue then
+            def:=get_unsigned_inttype(def);
+          adaptrange(def,cv,rc_implicit);
+          result:=cv.svalue;
+        end;
+
+      var
+        cur_line : longint;
+        w : asizeint;
+        hl : TAsmList;
+        asmstat : tasmnode;
+        sym : tsym;
+        symtable : TSymtable;
+        s : tsymstr;
+        ac : tai_const;
+        nesting : integer;
+        tokenbuf : tdynamicarray;
+      begin
+        consume(_INLINE);
+        consume(_LKLAMMER);
+        hl:=TAsmList.create;
+        asmstat:=casmnode.create(hl);
+        asmstat.fileinfo:=current_filepos;
+        tokenbuf:=tdynamicarray.Create(16);
+        cur_line:=0;
+        { Parse data blocks }
+        repeat
+          { Record one data block for further replaying.
+            This is needed  since / is used as a data block delimiter and cause troubles
+            with constant evaluation which is allowed inside a data block. }
+          tokenbuf.reset;
+          current_scanner.startrecordtokens(tokenbuf);
+          nesting:=0;
+          while token<>_SLASH do
+            begin
+              case token of
+                _LKLAMMER:
+                  inc(nesting);
+                _RKLAMMER:
+                  begin
+                    dec(nesting);
+                    if nesting<0 then
+                      break;
+                  end;
+                _SEMICOLON:
+                  consume(_RKLAMMER); { error }
+                else
+                  ; {no action}
+              end;
+              consume(token);
+            end;
+          current_scanner.stoprecordtokens;
+          { Set the current token to ; to make the constant evaluator happy }
+          token:=_SEMICOLON;
+          { Parse recorded tokens }
+          current_scanner.startreplaytokens(tokenbuf,false);
+
+          if cur_line<>current_filepos.line then
+            begin
+              hl.concat(tai_force_line.Create);
+              cur_line:=current_filepos.line;
+            end;
+
+          { Data size override }
+          if try_to_consume(_GT) then
+            actype:=aitconst_16bit
+          else
+            if try_to_consume(_LT) then
+              actype:=aitconst_8bit
+            else
+              actype:=aitconst_128bit; { default size }
+          sym:=nil;
+          if token=_ID then
+            begin
+              if searchsym(pattern,sym,symtable) then
+                begin
+                  if sym.typ in [staticvarsym,localvarsym,paravarsym] then
+                    begin
+                      { Address of the static symbol or base offset for local symbols }
+                      consume(_ID);
+                      if (sym.typ=staticvarsym) and not (actype in [aitconst_128bit,aitconst_ptr]) then
+                        Message1(type_e_integer_expr_expected,sym.name);
+                      { Additional offset }
+                      if token in [_PLUS,_MINUS] then
+                        w:=eval_intconst
+                      else
+                        w:=0;
+                      if sym.typ=staticvarsym then
+                        s:=sym.mangledname
+                      else
+                        s:=sym.name;
+                      ac:=tai_const.Createname(s,w);
+                      if actype=aitconst_128bit then
+                        ac.consttype:=aitconst_ptr
+                      else
+                        ac.consttype:=actype;
+                      { For a local symbol it is needed to generate a constant with the symbols's stack offset.
+                        The stack offset is unavailable rigth now and will be resolved later in tcgasmnode.pass_generate_code.
+                        Set sym.bind:=AB_NONE to indicate that this is a local symbol. }
+                      if sym.typ<>staticvarsym then
+                        ac.sym.bind:=AB_NONE;
+                      hl.concat(ac);
+                    end
+                  else
+                    if sym.typ=constsym then
+                      sym:=nil
+                    else
+                      begin
+                        consume(_ID);
+                        Message(asmr_e_wrong_sym_type);
+                      end;
+                end;
+            end;
+
+          if sym=nil then
+            begin
+              { Integer constant expression }
+              w:=eval_intconst;
+              case actype of
+                aitconst_8bit:
+                  hl.concat(tai_const.Create_8bit(w));
+                aitconst_16bit:
+                  hl.concat(tai_const.Create_16bit(w));
+                else
+                  if w<$100 then
+                    hl.concat(tai_const.Create_8bit(w))
+                  else
+                    hl.concat(tai_const.Create_sizeint(w));
+              end;
+            end;
+
+          if not try_to_consume(_SEMICOLON) then
+            consume(_RKLAMMER); {error}
+        until nesting<0;
+        tokenbuf.free;
+        { mark boundaries of assembler block, this is necessary for optimizer }
+        hl.insert(tai_marker.create(mark_asmblockstart));
+        hl.concat(tai_marker.create(mark_asmblockend));
+        { Mark procedure that it has assembler blocks }
+        include(current_procinfo.flags,pi_has_assembler_block);
+        { Assume the function result is always used }
+        if assigned(current_procinfo.procdef.funcretsym) then
+          current_procinfo.procdef.funcretsym.IncRefCount;
+        result:=asmstat;
+      end;
+
+
     function statement : tnode;
       var
          p,
@@ -1248,6 +1420,10 @@ implementation
                Message(parser_e_syntax_error);
                consume(_PLUS);
              end;
+           _INLINE:
+             begin
+               code:=tp_inline_statement;
+             end;
            _EOF :
              Message(scan_f_end_of_file);
          else

compiler/tokens.pas

@@ -519,7 +519,7 @@ const
       (str:'EXCEPT'        ;special:false;keyword:[m_except];op:NOTOKEN),
       (str:'EXPORT'        ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'HELPER'        ;special:false;keyword:[m_none];op:NOTOKEN),
-      (str:'INLINE'        ;special:false;keyword:[m_none];op:NOTOKEN),
+      (str:'INLINE'        ;special:false;keyword:[m_tp7];op:NOTOKEN),
       (str:'LEGACY'        ;special:false;keyword:[m_none];op:NOTOKEN),   { Syscall variation on MorphOS }
       (str:'NESTED'        ;special:false;keyword:[m_none];op:NOTOKEN),
       (str:'OBJECT'        ;special:false;keyword:alllanguagemodes-[m_iso,m_extpas];op:NOTOKEN),

compiler/version.pas

@@ -103,7 +103,7 @@ function full_version_string:string;
 begin
   full_version_string := version_nr+'.'+release_nr+'.'+patch_nr+minorpatch
 {$ifdef REVINC}
-  +'-r'+{$i revision.inc}
+  +'-'+{$i revision.inc}
 {$endif REVINC}
   ;
 end;

compiler/x86/agx86nsm.pas

@@ -800,13 +800,13 @@ interface
              begin
                consttype:=tai_const(hp).consttype;
                case consttype of
-                 aitconst_uleb128bit,
-                 aitconst_sleb128bit,
+                 aitconst_uleb128bit:
+                   writer.AsmWriteLn(ait_const2str[aitconst_8bit]+uleb128tostr(qword(tai_const(hp).value)));
+                 aitconst_sleb128bit:
+                   writer.AsmWriteLn(ait_const2str[aitconst_8bit]+sleb128tostr(tai_const(hp).value));
                  aitconst_128bit:
-                    begin
-                      writer.AsmWriteLn(asminfo^.comment+'Unsupported const type '+
-                        ait_const2str[consttype]);
-                    end;
+                   writer.AsmWriteLn(asminfo^.comment+'Unsupported const type '+
+                     ait_const2str[consttype]);
 {$ifdef i8086}
                  aitconst_farptr:
                    begin

compiler/x86/aoptx86.pas

@@ -8618,39 +8618,77 @@ unit aoptx86;
           begin
             if (taicpu(p).oper[0]^.typ = top_const) then
               begin
-                if (taicpu(hp1).opcode = A_AND) and
-                  MatchOpType(taicpu(hp1),top_const,top_reg) and
-                  (getsupreg(taicpu(p).oper[1]^.reg) = getsupreg(taicpu(hp1).oper[1]^.reg)) and
-                  { the second register must contain the first one, so compare their subreg types }
-                  (getsubreg(taicpu(p).oper[1]^.reg)<=getsubreg(taicpu(hp1).oper[1]^.reg)) and
-                  (abs(taicpu(p).oper[0]^.val and taicpu(hp1).oper[0]^.val)<$80000000) then
-                  { change
-                      and const1, reg
-                      and const2, reg
-                    to
-                      and (const1 and const2), reg
-                  }
-                  begin
-                    taicpu(hp1).loadConst(0, taicpu(p).oper[0]^.val and taicpu(hp1).oper[0]^.val);
-                    DebugMsg(SPeepholeOptimization + 'AndAnd2And done',hp1);
-                    RemoveCurrentP(p, hp1);
-                    Result:=true;
-                    exit;
-                  end
-                else if (taicpu(hp1).opcode = A_MOVZX) and
-                  MatchOpType(taicpu(hp1),top_reg,top_reg) and
-                  SuperRegistersEqual(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^.reg) and
-                  (getsupreg(taicpu(hp1).oper[0]^.reg)=getsupreg(taicpu(hp1).oper[1]^.reg)) and
-                   (((taicpu(p).opsize=S_W) and
-                     (taicpu(hp1).opsize=S_BW)) or
-                    ((taicpu(p).opsize=S_L) and
-                     (taicpu(hp1).opsize in [S_WL,S_BL{$ifdef x86_64},S_BQ,S_WQ{$endif x86_64}]))
+                case taicpu(hp1).opcode of
+                  A_AND:
+                    if MatchOpType(taicpu(hp1),top_const,top_reg) and
+                      (getsupreg(taicpu(p).oper[1]^.reg) = getsupreg(taicpu(hp1).oper[1]^.reg)) and
+                      { the second register must contain the first one, so compare their subreg types }
+                      (getsubreg(taicpu(p).oper[1]^.reg)<=getsubreg(taicpu(hp1).oper[1]^.reg)) and
+                      (abs(taicpu(p).oper[0]^.val and taicpu(hp1).oper[0]^.val)<$80000000) then
+                      { change
+                          and const1, reg
+                          and const2, reg
+                        to
+                          and (const1 and const2), reg
+                      }
+                      begin
+                        taicpu(hp1).loadConst(0, taicpu(p).oper[0]^.val and taicpu(hp1).oper[0]^.val);
+                        DebugMsg(SPeepholeOptimization + 'AndAnd2And done',hp1);
+                        RemoveCurrentP(p, hp1);
+                        Result:=true;
+                        exit;
+                      end;
+
+                  A_CMP:
+                    if (PopCnt(DWord(taicpu(p).oper[0]^.val)) = 1) and { Only 1 bit set }
+                      MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.val) and
+                      MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[1]^.reg) and
+                      { Just check that the condition on the next instruction is compatible }
+                      GetNextInstruction(hp1, hp2) and
+                      (hp2.typ = ait_instruction) and
+                      (taicpu(hp2).condition in [C_Z, C_E, C_NZ, C_NE])
+                      then
+                        { change
+                            and  2^n, reg
+                            cmp  2^n, reg
+                            j(c) / set(c) / cmov(c)   (c is equal or not equal)
+                          to
+                            and  2^n, reg
+                            test reg, reg
+                            j(~c) / set(~c) / cmov(~c)
+                        }
+                      begin
+                        { Keep TEST instruction in, rather than remove it, because
+                          it may trigger other optimisations such as MovAndTest2Test }
+                        taicpu(hp1).loadreg(0, taicpu(hp1).oper[1]^.reg);
+                        taicpu(hp1).opcode := A_TEST;
+                        DebugMsg(SPeepholeOptimization + 'AND/CMP/J(c) -> AND/J(~c) with power of 2 constant', p);
+                        taicpu(hp2).condition := inverse_cond(taicpu(hp2).condition);
+                        Result := True;
+                        Exit;
+                      end;
+
+                  A_MOVZX:
+                    if MatchOpType(taicpu(hp1),top_reg,top_reg) and
+                      SuperRegistersEqual(taicpu(p).oper[1]^.reg,taicpu(hp1).oper[1]^.reg) and
+                      (getsupreg(taicpu(hp1).oper[0]^.reg)=getsupreg(taicpu(hp1).oper[1]^.reg)) and
+                      (
+                        (
+                          (taicpu(p).opsize=S_W) and
+                          (taicpu(hp1).opsize=S_BW)
+                        ) or
+                        (
+                          (taicpu(p).opsize=S_L) and
+                          (taicpu(hp1).opsize in [S_WL,S_BL{$ifdef x86_64},S_BQ,S_WQ{$endif x86_64}])
+                        )
 {$ifdef x86_64}
-                      or
-                     ((taicpu(p).opsize=S_Q) and
-                      (taicpu(hp1).opsize in [S_BQ,S_WQ,S_BL,S_WL]))
+                        or
+                        (
+                          (taicpu(p).opsize=S_Q) and
+                          (taicpu(hp1).opsize in [S_BQ,S_WQ,S_BL,S_WL])
+                        )
 {$endif x86_64}
-                    ) then
+                      ) then
                       begin
                         if (((taicpu(hp1).opsize) in [S_BW,S_BL{$ifdef x86_64},S_BQ{$endif x86_64}]) and
                             ((taicpu(p).oper[0]^.val and $ff)=taicpu(p).oper[0]^.val)
@@ -8673,108 +8711,114 @@ unit aoptx86;
                             { See if there are other optimisations possible }
                             Continue;
                           end;
-                      end
-                else if (taicpu(hp1).opcode = A_SHL) and
-                  MatchOpType(taicpu(hp1),top_const,top_reg) and
-                  (getsupreg(taicpu(p).oper[1]^.reg)=getsupreg(taicpu(hp1).oper[1]^.reg)) then
-                  begin
+                      end;
+
+                  A_SHL:
+                    if MatchOpType(taicpu(hp1),top_const,top_reg) and
+                      (getsupreg(taicpu(p).oper[1]^.reg)=getsupreg(taicpu(hp1).oper[1]^.reg)) then
+                      begin
 {$ifopt R+}
 {$define RANGE_WAS_ON}
 {$R-}
 {$endif}
-                    { get length of potential and mask }
-                    MaskLength:=SizeOf(taicpu(p).oper[0]^.val)*8-BsrQWord(taicpu(p).oper[0]^.val)-1;
+                        { get length of potential and mask }
+                        MaskLength:=SizeOf(taicpu(p).oper[0]^.val)*8-BsrQWord(taicpu(p).oper[0]^.val)-1;
 
-                    { really a mask? }
+                        { really a mask? }
 {$ifdef RANGE_WAS_ON}
 {$R+}
 {$endif}
-                    if (((QWord(1) shl MaskLength)-1)=taicpu(p).oper[0]^.val) and
-                      { unmasked part shifted out? }
-                      ((MaskLength+taicpu(hp1).oper[0]^.val)>=topsize2memsize[taicpu(hp1).opsize]) then
-                      begin
-                        DebugMsg(SPeepholeOptimization + 'AndShlToShl done',p);
-                        RemoveCurrentP(p, hp1);
-                        Result:=true;
-                        exit;
+                        if (((QWord(1) shl MaskLength)-1)=taicpu(p).oper[0]^.val) and
+                          { unmasked part shifted out? }
+                          ((MaskLength+taicpu(hp1).oper[0]^.val)>=topsize2memsize[taicpu(hp1).opsize]) then
+                          begin
+                            DebugMsg(SPeepholeOptimization + 'AndShlToShl done',p);
+                            RemoveCurrentP(p, hp1);
+                            Result:=true;
+                            exit;
+                          end;
                       end;
-                  end
-                else if (taicpu(hp1).opcode = A_SHR) and
-                  MatchOpType(taicpu(hp1),top_const,top_reg) and
-                  (taicpu(p).oper[1]^.reg = taicpu(hp1).oper[1]^.reg) and
-                  (taicpu(hp1).oper[0]^.val <= 63) then
-                  begin
-                    { Does SHR combined with the AND cover all the bits?
 
-                      e.g. for "andb $252,%reg; shrb $2,%reg" - the "and" can be removed }
+                  A_SHR:
+                    if MatchOpType(taicpu(hp1),top_const,top_reg) and
+                      (taicpu(p).oper[1]^.reg = taicpu(hp1).oper[1]^.reg) and
+                      (taicpu(hp1).oper[0]^.val <= 63) then
+                      begin
+                        { Does SHR combined with the AND cover all the bits?
 
-                    MaskedBits := taicpu(p).oper[0]^.val or ((TCgInt(1) shl taicpu(hp1).oper[0]^.val) - 1);
+                          e.g. for "andb $252,%reg; shrb $2,%reg" - the "and" can be removed }
 
-                    if ((taicpu(p).opsize = S_B) and ((MaskedBits and $FF) = $FF)) or
-                      ((taicpu(p).opsize = S_W) and ((MaskedBits and $FFFF) = $FFFF)) or
-                      ((taicpu(p).opsize = S_L) and ((MaskedBits and $FFFFFFFF) = $FFFFFFFF)) then
-                      begin
-                        DebugMsg(SPeepholeOptimization + 'AndShrToShr done', p);
-                        RemoveCurrentP(p, hp1);
-                        Result := True;
-                        Exit;
+                        MaskedBits := taicpu(p).oper[0]^.val or ((TCgInt(1) shl taicpu(hp1).oper[0]^.val) - 1);
+
+                        if ((taicpu(p).opsize = S_B) and ((MaskedBits and $FF) = $FF)) or
+                          ((taicpu(p).opsize = S_W) and ((MaskedBits and $FFFF) = $FFFF)) or
+                          ((taicpu(p).opsize = S_L) and ((MaskedBits and $FFFFFFFF) = $FFFFFFFF)) then
+                          begin
+                            DebugMsg(SPeepholeOptimization + 'AndShrToShr done', p);
+                            RemoveCurrentP(p, hp1);
+                            Result := True;
+                            Exit;
+                          end;
                       end;
-                  end
-                else if ((taicpu(hp1).opcode = A_MOVSX){$ifdef x86_64} or (taicpu(hp1).opcode = A_MOVSXD){$endif x86_64}) and
-                  (taicpu(hp1).oper[0]^.typ = top_reg) and
-                  SuperRegistersEqual(taicpu(hp1).oper[0]^.reg, taicpu(hp1).oper[1]^.reg) then
-                    begin
-                      if SuperRegistersEqual(taicpu(p).oper[1]^.reg, taicpu(hp1).oper[1]^.reg) and
-                        (
+
+                  A_MOVSX{$ifdef x86_64}, A_MOVSXD{$endif x86_64}:
+                    if (taicpu(hp1).oper[0]^.typ = top_reg) and
+                      SuperRegistersEqual(taicpu(hp1).oper[0]^.reg, taicpu(hp1).oper[1]^.reg) then
+                      begin
+                        if SuperRegistersEqual(taicpu(p).oper[1]^.reg, taicpu(hp1).oper[1]^.reg) and
                           (
-                            (taicpu(hp1).opsize in [S_BW,S_BL{$ifdef x86_64},S_BQ{$endif x86_64}]) and
-                            ((taicpu(p).oper[0]^.val and $7F) = taicpu(p).oper[0]^.val)
-                          ) or (
-                            (taicpu(hp1).opsize in [S_WL{$ifdef x86_64},S_WQ{$endif x86_64}]) and
-                            ((taicpu(p).oper[0]^.val and $7FFF) = taicpu(p).oper[0]^.val)
+                            (
+                              (taicpu(hp1).opsize in [S_BW,S_BL{$ifdef x86_64},S_BQ{$endif x86_64}]) and
+                              ((taicpu(p).oper[0]^.val and $7F) = taicpu(p).oper[0]^.val)
+                            ) or (
+                              (taicpu(hp1).opsize in [S_WL{$ifdef x86_64},S_WQ{$endif x86_64}]) and
+                              ((taicpu(p).oper[0]^.val and $7FFF) = taicpu(p).oper[0]^.val)
 {$ifdef x86_64}
-                          ) or (
-                            (taicpu(hp1).opsize = S_LQ) and
-                            ((taicpu(p).oper[0]^.val and $7fffffff) = taicpu(p).oper[0]^.val)
+                            ) or (
+                              (taicpu(hp1).opsize = S_LQ) and
+                              ((taicpu(p).oper[0]^.val and $7fffffff) = taicpu(p).oper[0]^.val)
 {$endif x86_64}
-                          )
-                        ) then
-                        begin
-                          if (taicpu(p).oper[1]^.reg = taicpu(hp1).oper[1]^.reg){$ifdef x86_64} or (taicpu(hp1).opsize = S_LQ){$endif x86_64} then
-                            begin
-                              DebugMsg(SPeepholeOptimization + 'AndMovsxToAnd',p);
-                              RemoveInstruction(hp1);
-                              { See if there are other optimisations possible }
-                              Continue;
-                            end;
+                            )
+                          ) then
+                          begin
+                            if (taicpu(p).oper[1]^.reg = taicpu(hp1).oper[1]^.reg){$ifdef x86_64} or (taicpu(hp1).opsize = S_LQ){$endif x86_64} then
+                              begin
+                                DebugMsg(SPeepholeOptimization + 'AndMovsxToAnd',p);
+                                RemoveInstruction(hp1);
+                                { See if there are other optimisations possible }
+                                Continue;
+                              end;
 
-                          { The super-registers are the same though.
+                            { The super-registers are the same though.
 
-                            Note that this change by itself doesn't improve
-                            code speed, but it opens up other optimisations. }
+                              Note that this change by itself doesn't improve
+                              code speed, but it opens up other optimisations. }
 {$ifdef x86_64}
-                          { Convert 64-bit register to 32-bit }
-                          case taicpu(hp1).opsize of
-                            S_BQ:
-                              begin
-                                taicpu(hp1).opsize := S_BL;
-                                taicpu(hp1).oper[1]^.reg := newreg(R_INTREGISTER, getsupreg(taicpu(hp1).oper[1]^.reg), R_SUBD);
-                              end;
-                            S_WQ:
-                              begin
-                                taicpu(hp1).opsize := S_WL;
-                                taicpu(hp1).oper[1]^.reg := newreg(R_INTREGISTER, getsupreg(taicpu(hp1).oper[1]^.reg), R_SUBD);
-                              end
-                            else
-                              ;
-                          end;
+                            { Convert 64-bit register to 32-bit }
+                            case taicpu(hp1).opsize of
+                              S_BQ:
+                                begin
+                                  taicpu(hp1).opsize := S_BL;
+                                  taicpu(hp1).oper[1]^.reg := newreg(R_INTREGISTER, getsupreg(taicpu(hp1).oper[1]^.reg), R_SUBD);
+                                end;
+                              S_WQ:
+                                begin
+                                  taicpu(hp1).opsize := S_WL;
+                                  taicpu(hp1).oper[1]^.reg := newreg(R_INTREGISTER, getsupreg(taicpu(hp1).oper[1]^.reg), R_SUBD);
+                                end
+                              else
+                                ;
+                            end;
 {$endif x86_64}
-                          DebugMsg(SPeepholeOptimization + 'AndMovsxToAndMovzx', hp1);
-                          taicpu(hp1).opcode := A_MOVZX;
-                          { See if there are other optimisations possible }
-                          Continue;
-                        end;
-                    end;
+                            DebugMsg(SPeepholeOptimization + 'AndMovsxToAndMovzx', hp1);
+                            taicpu(hp1).opcode := A_MOVZX;
+                            { See if there are other optimisations possible }
+                            Continue;
+                          end;
+                      end;
+                  else
+                    ;
+                end;
               end;
 
             if (taicpu(hp1).is_jmp) and

compiler/x86/x86ins.dat

@@ -3479,19 +3479,19 @@ xmmreg,xmmrm          \361\3\x0F\x38\x40\110               SSE41,SM
 xmmreg,xmmrm          \361\3\x0F\x38\x17\110               SSE41,SM
 
 [ROUNDPS]
-(Ch_Wop2, Ch_Rop1)
+(Ch_Wop3, Ch_Rop2)
 xmmreg,xmmrm,imm      \361\3\x0F\x3A\x08\110\26            SSE41,SM2,SB,AR2
 
 [ROUNDPD]
-(Ch_Wop2, Ch_Rop1)
+(Ch_Wop3, Ch_Rop2)
 xmmreg,xmmrm,imm      \361\3\x0F\x3A\x09\110\26            SSE41,SM2,SB,AR2
 
 [ROUNDSS]
-(Ch_Wop2, Ch_Rop1)
+(Ch_Wop3, Ch_Rop2)
 xmmreg,xmmrm,imm      \336\361\3\x0F\x3A\x0A\110\26            SSE41,SM2,SB,AR2
 
 [ROUNDSD]
-(Ch_Wop2, Ch_Rop1)
+(Ch_Wop3, Ch_Rop2)
 xmmreg,xmmrm,imm      \337\361\3\x0F\x3A\x0B\110\26            SSE41,SM2,SB,AR2
 
 ;*******************************************************************************
@@ -3526,7 +3526,7 @@ xmmreg,xmmrm,imm       \361\3\x0F\x3A\x62\110\26               SSE42,SM2,SB,AR2
 xmmreg,xmmrm           \361\3\x0F\x38\x37\110                  SSE42,SM
 
 [POPCNT,popcntX]
-(Ch_All)
+(Ch_Wop2, Ch_Rop1)
 reg16,rm16             \333\320\2\x0F\xB8\110              386,SM,SSE4
 reg32,rm32             \333\320\2\x0F\xB8\110              386,SM,SSE4
 reg64,rm64             \333\320\2\x0F\xB8\110              386,SM,SSE4,X86_64

compiler/x86_64/cpupara.pas

@@ -176,15 +176,13 @@ unit cpupara;
            if size<=4 then
              begin
                cl.typ:=X86_64_INTEGERSI_CLASS;
-               { gcc/clang sign/zero-extend all values to 32 bits, except for
-                 _Bool (= Pascal boolean), which is only zero-extended to 8 bits
-                 as per the x86-64 ABI -> do the same
-
-                 some testing showed, that this is not true for 8 bit values:
-                 in case of an 8 bit value, it is not zero/sign extended }
+               { The ABI does not require any sign/zero extension for parameters,
+                 except for _Bool (= Pascal boolean) to 8 bits. However, some
+                 compilers (clang) extend them to 32 bits anyway and rely on it
+                 -> also do it for compatibility when calling such code }
                if not assigned(cl.def) or
-                  not(cl.def.typ=orddef) or
-                  not(torddef(cl.def).ordtype in [uchar,u8bit,s8bit,pasbool1]) then
+                  (cl.def.typ<>orddef) or
+                  (torddef(cl.def).ordtype<>pasbool1) then
                  cl.def:=u32inttype;
              end
            else
@@ -1489,7 +1487,20 @@ unit cpupara;
                         end
                       else if result.intsize in [1,2,4] then
                         begin
-                          paraloc^.size:=def_cgsize(paraloc^.def);
+                          { The ABI does not require sign/zero-extended function
+                            results, but older versions of clang did so and
+                            on Darwin current versions of clang keep doing so
+                            for backward compatibility. On other platforms, it
+                            doesn't and hence we don't either }
+                          if (i=0) and
+                             not(target_info.system in systems_darwin) and
+                             (result.intsize in [1,2]) then
+                            begin
+                              paraloc^.size:=int_cgsize(result.intsize);
+                              paraloc^.def:=cgsize_orddef(paraloc^.size);
+                            end
+                          else
+                            paraloc^.size:=def_cgsize(paraloc^.def);
                         end
                       else
                         begin
@@ -1785,6 +1796,30 @@ unit cpupara;
                             end
                           else
                             begin
+                              { some compilers sign/zero-extend on the callerside,
+                                others don't. To be compatible with both, FPC
+                                extends on the callerside, and assumes no
+                                extension has been performed on the calleeside.
+                                This is less efficient, but the alternative is
+                                occasional crashes when calling code generated
+                                by certain other compilers, or being called from
+                                code generated by other compilers.
+
+                                Exception: Darwin, since everyone there needs to
+                                be compatible with the system compiler clang
+                                (which extends on the caller side).
+
+                                Not for LLVM, since there the zero/signext
+                                attributes by definition only apply to the
+                                caller side }
+{$ifndef LLVM}
+                              if not(target_info.system in systems_darwin) and
+                                 (side=calleeside) and
+                                 (hp.paraloc[side].intsize in [1,2]) then
+                                begin
+                                  paraloc^.def:=hp.paraloc[side].def
+                                end;
+{$endif not LLVM}
                               paraloc^.size:=def_cgsize(paraloc^.def);
                               { s64comp is pushed in an int register }
                               if paraloc^.size=OS_C64 then

compiler/x86_64/x8664pro.inc

@@ -659,17 +659,17 @@
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
-(Ch: [Ch_Wop2, Ch_Rop1]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
+(Ch: [Ch_Wop3, Ch_Rop2]),
 (Ch: [Ch_Mop1, Ch_Rop2]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
-(Ch: [Ch_All]),
+(Ch: [Ch_Wop2, Ch_Rop1]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),
 (Ch: [Ch_All]),

compiler/z80/agsdasz80.pas

@@ -41,8 +41,6 @@ unit agsdasz80;
 
       TSdccSdasZ80Assembler=class(TExternalAssembler)
       private
-        procedure WriteDecodedSleb128(a: int64);
-        procedure WriteDecodedUleb128(a: qword);
         procedure WriteRealConstAsBytes(hp: tai_realconst; const dbdir: string; do_line: boolean);
         function sectionname(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder):string;
         procedure WriteSection(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder;secalign:longint;
@@ -79,38 +77,6 @@ unit agsdasz80;
         #9'.dw'#9,#9'FIXMEDD'#9,#9'FIXMEDQ'#9
       );
 
-    procedure TSdccSdasZ80Assembler.WriteDecodedSleb128(a: int64);
-      var
-        i,len : longint;
-        buf   : array[0..255] of byte;
-      begin
-        writer.AsmWrite(#9'.db'#9);
-        len:=EncodeSleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-        writer.AsmWriteLn(#9'; sleb '+tostr(a));
-      end;
-
-    procedure TSdccSdasZ80Assembler.WriteDecodedUleb128(a: qword);
-      var
-        i,len : longint;
-        buf   : array[0..63] of byte;
-      begin
-        writer.AsmWrite(#9'.db'#9);
-        len:=EncodeUleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-        writer.AsmWriteLn(#9'; uleb '+tostr(a));
-      end;
-
     procedure TSdccSdasZ80Assembler.WriteRealConstAsBytes(hp: tai_realconst; const dbdir: string; do_line: boolean);
       var
         pdata: pbyte;
@@ -652,9 +618,9 @@ unit agsdasz80;
                 consttype:=tai_const(hp).consttype;
                 case consttype of
                   aitconst_uleb128bit:
-                    WriteDecodedUleb128(qword(tai_const(hp).value));
+                    writer.AsmWriteLn(ait_const2str[aitconst_8bit]+uleb128tostr(qword(tai_const(hp).value)));
                   aitconst_sleb128bit:
-                    WriteDecodedSleb128(int64(tai_const(hp).value));
+                    writer.AsmWriteLn(ait_const2str[aitconst_8bit]+sleb128tostr(tai_const(hp).value));
                   aitconst_64bit,
                   aitconst_64bit_unaligned,
                   aitconst_32bit,

compiler/z80/agz80vasm.pas

@@ -41,8 +41,6 @@ unit agz80vasm;
 
       TZ80Vasm=class(TExternalAssembler)
       private
-        procedure WriteDecodedSleb128(a: int64);
-        procedure WriteDecodedUleb128(a: qword);
         procedure WriteRealConstAsBytes(hp: tai_realconst; const dbdir: string; do_line: boolean);
         function sectionattrs(atype:TAsmSectiontype):string;
         function sectionname(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder):string;
@@ -80,38 +78,6 @@ unit agz80vasm;
         #9'.uahalf'#9,#9'FIXMEDD'#9,#9'FIXMEDQ'#9
       );
 
-    procedure TZ80vasm.WriteDecodedSleb128(a: int64);
-      var
-        i,len : longint;
-        buf   : array[0..255] of byte;
-      begin
-        writer.AsmWrite(#9'.byte'#9);
-        len:=EncodeSleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-        writer.AsmWriteLn(#9'; sleb '+tostr(a));
-      end;
-
-    procedure TZ80vasm.WriteDecodedUleb128(a: qword);
-      var
-        i,len : longint;
-        buf   : array[0..63] of byte;
-      begin
-        writer.AsmWrite(#9'.byte'#9);
-        len:=EncodeUleb128(a,buf,0);
-        for i:=0 to len-1 do
-          begin
-            if (i > 0) then
-              writer.AsmWrite(',');
-            writer.AsmWrite(tostr(buf[i]));
-          end;
-        writer.AsmWriteLn(#9'; uleb '+tostr(a));
-      end;
-
     procedure TZ80vasm.WriteRealConstAsBytes(hp: tai_realconst; const dbdir: string; do_line: boolean);
       var
         pdata: pbyte;
@@ -683,9 +649,9 @@ unit agz80vasm;
                 consttype:=tai_const(hp).consttype;
                 case consttype of
                   aitconst_uleb128bit:
-                    WriteDecodedUleb128(qword(tai_const(hp).value));
+                    writer.AsmWriteLn(ait_const2str[aitconst_8bit]+uleb128tostr(qword(tai_const(hp).value)));
                   aitconst_sleb128bit:
-                    WriteDecodedSleb128(int64(tai_const(hp).value));
+                    writer.AsmWriteLn(ait_const2str[aitconst_8bit]+sleb128tostr(tai_const(hp).value));
                   aitconst_64bit,
                   aitconst_64bit_unaligned,
                   aitconst_32bit,

packages/fcl-base/examples/README.txt

@@ -77,4 +77,5 @@ testini.pp   Test/Demo for inifiles, ReadSectionValues.
 contit.pp    Test/Demo for iterators in contnr.pp
 csvbom.pp    Test/Demo for BOM detection in CSV document. (needs databom.txt)
 testappexit.pp Test/Demo for TApplication exit code handling. (ExitCode and ExceptionExitcode)
-demoio.pp    Demo for AssignStream from streamio unit.
+demoio.pp    Demo for AssignStream from streamio unit.
+testthreadpool  Demo for fpthreadpool unit.

packages/fcl-base/examples/testthreadpool.pp

@@ -0,0 +1,100 @@
+{$mode objfpc}
+{$h+}
+
+program testthreadpool;
+
+uses {$ifdef unix}cThreads, {$ENDIF} sysutils, fpthreadpool;
+
+type
+
+  { TMyTask }
+
+  TMyTask = Class(TThreadPoolTask)
+    FID : Integer;
+    destructor destroy; override;
+    procedure DoQueued; override;
+    Procedure DoExecute; override;
+    Constructor Create(aID : Integer);
+    Function ToString : string; override;
+   end;
+
+
+{ TMyTask }
+
+destructor TMyTask.destroy;
+begin
+  Writeln(FID,': Destroy : ',ToString);
+  Flush(Output);
+  inherited destroy;
+end;
+
+procedure TMyTask.DoQueued;
+begin
+  Writeln(FID,': Queued : ',ToString);
+  Flush(Output);
+  inherited DoQueued;
+end;
+
+procedure TMyTask.DoExecute;
+
+Var
+  I,Sec: Integer;
+
+begin
+  Sec:=3+Random(3);
+  Writeln(FID,': Task ',ToString,' waiting ',Sec,' seconds.');
+  Flush(Output);
+  I:=1;
+  While (I<=Sec) and Not Terminated do
+    begin
+    Sleep(Sec);
+    Inc(I);
+    end;
+  Writeln(FID,': Task ',ToString,' done waiting (',Sec,' seconds). ');
+  Flush(Output);
+end;
+
+constructor TMyTask.Create(aID: Integer);
+begin
+  FID:=AID;
+end;
+
+function TMyTask.ToString: string;
+begin
+  Result:=ClassName+' '+HexStr(Self)+' : '+IntToStr(FID);
+end;
+
+procedure RunTest(aPool : TFPCustomSimpleThreadPool);
+
+Var
+  I : Integer;
+  T : TMyTask;
+
+begin
+  For I:=1 to 200 do
+    begin
+    T:=TMyTask.Create(I);
+    if not aPool.AddTask(T) then
+      begin
+      Writeln('Task not accepted, freeing');
+      Flush(Output);
+      T.Free;
+      end;
+    end;
+end;
+
+Var
+  MyPool : TFPSimpleThreadPool;
+
+begin
+  MyPool:=TFPSimpleThreadPool.Create;
+  try
+    MyPool.AddTimeout:=40;
+    MyPool.AutoCheckQueuedTasks:=True;
+    // RunTest(MyPool);
+    RunTest(TFPSimpleThreadPool.Instance);
+  finally
+    MyPool.Free;
+  end;
+end.
+

packages/fcl-base/fpmake.pp

@@ -130,6 +130,9 @@ begin
       T.ResourceStrings:=true;
     T:=P.Targets.addUnit('advancedsingleinstance.pas',AllOSes-[atari]);
       T.ResourceStrings:=true;
+    T:=P.Targets.AddUnit('fpthreadpool.pp',AllOSes-[go32v2,nativent,atari]);
+      T.Dependencies.AddUnit('syncobjs');
+      T.ResourceStrings:=true;
     // Additional sources
     P.Sources.AddSrcFiles('src/win/fclel.*', P.Directory);
     // Install windows resources
@@ -198,6 +201,7 @@ begin
       T:=P.Targets.AddExampleProgram('tstelgtk.pp');
       T:=P.Targets.AddExampleProgram('txmlreg.pp');
       T:=P.Targets.AddExampleProgram('xmldump.pp');
+      T:=P.Targets.AddExampleProgram('testthreadpool.pp');
 
       // example data files.
       // README

packages/fcl-base/src/fpthreadpool.pp

@@ -0,0 +1,886 @@
+unit fpthreadpool;
+
+{$mode ObjFPC}{$H+}
+{ $DEFINE DEBUGTHREADPOOL}
+
+interface
+
+Uses Classes, SysUtils, DateUtils, SyncObjs;
+
+
+Const
+  DefaultAddWaitInterval = 50;
+  DefaultAddTimeOut      = 5000;
+  DefaultQueueTasks      = True;
+
+Type
+  EThreadPool = Class(Exception);
+
+  TFPCustomSimpleThreadPool = Class;
+  TFPCustomSimpleThreadPoolClass = Class of TFPCustomSimpleThreadPool;
+
+  { TThreadPoolTask }
+
+  TExceptionEvent = procedure (Sender : TObject; aException : Exception);
+
+  TThreadPoolTask = class(TObject)
+  private
+    FDoneOnException: Boolean;
+    FOnCancel: TNotifyEvent;
+    FOnDone: TNotifyEvent;
+    FOnException: TExceptionEvent;
+    FOnQueued: TNotifyEvent;
+    FOnTerminate: TNotifyEvent;
+    FTerminated: Boolean;
+  Protected
+    Procedure DoExecute; virtual; abstract;
+    Procedure DoDone; virtual;
+    Procedure DoOnException(E : Exception); virtual;
+    Procedure DoTerminate; virtual;
+    Procedure DoQueued; virtual;
+    Procedure DoCancel; virtual;
+  Public
+    // Call when a task is put on wait queue
+    Procedure Queued;
+    // Call when a task must be executed
+    Procedure Execute;
+    // Call to indicate a running task it should terminate
+    procedure Terminate;
+    // Call when a task is canceled. (i.e. never executed)
+    procedure Cancel;
+    // Called when task is done
+    Property OnDone : TNotifyEvent Read FOnDone Write FOnDone;
+    // Called when an exception is raised during the task
+    Property OnException : TExceptionEvent Read FOnException Write FOnException;
+    // Set to true when the OnDone event should also be executed when the task raised an exception.
+    Property DoneOnException : Boolean Read FDoneOnException Write FDoneOnException;
+    // Called when the Terminate procedure was called.
+    Property OnTerminate : TNotifyEvent Read FOnTerminate Write FOnTerminate;
+    // Called when the task is put on the wait queue.
+    Property OnQueued : TNotifyEvent Read FOnQueued Write FOnQueued;
+    // Called when the task is canceled: removed from the queue.
+    Property OnCancel : TNotifyEvent Read FOnCancel Write FOnCancel;
+    // Set when terminated is called;
+    Property Terminated : Boolean Read FTerminated;
+  end;
+
+  TTaskCallBack = Procedure (aData : TObject);
+
+  { TCallBackThreadPoolTask }
+
+  TCallBackThreadPoolTask = class(TThreadPoolTask)
+  Private
+    FCallback : TTaskCallBack;
+    FData : TObject;
+  Protected
+    Procedure DoExecute; override;
+    Property Callback : TTaskCallBack Read FCallBack;
+    Property Data : TObject Read FData;
+  Public
+    Constructor Create(aCallback : TTaskCallBack; aData : TObject = Nil); virtual;
+  end;
+
+  { TEventThreadPoolTask }
+
+  TEventThreadPoolTask = class(TThreadPoolTask)
+  Private
+    FEvent : TNotifyEvent;
+    FSender : TObject;
+  Protected
+    Procedure DoExecute; override;
+    Property Event : TNotifyEvent Read FEvent;
+    Property Sender : TObject Read FSender;
+  Public
+    Constructor Create(aEvent : TNotifyEvent; aSender : TObject = Nil); virtual;
+  end;
+
+  { TSimpleThreadPoolTask }
+
+  TSimpleThreadPoolTask = class(TThreadPoolTask)
+  Private
+    FProcedure : TProcedure;
+  Protected
+    Procedure DoExecute; override;
+    Property Proc : TProcedure Read FProcedure;
+  Public
+    Constructor Create(aProc : TProcedure); virtual;
+  end;
+
+
+  { TFPCustomSimpleThreadPool }
+
+  TFPCustomSimpleThreadPool = class(TObject)
+  Protected
+    Type
+
+       { TAutoCheckQueueThread }
+
+       TAutoCheckQueueThread = Class(TThread)
+       private
+         FInterval: Integer;
+         FPool: TFPCustomSimpleThreadPool;
+       Public
+         Constructor Create(aPool : TFPCustomSimpleThreadPool; aInterval : Integer);
+         Procedure Execute; override;
+         Property Pool : TFPCustomSimpleThreadPool Read FPool Write FPool;
+         Property Interval : Integer Read FInterval;
+       end;
+       { TAbstractTaskThread }
+
+       TAbstractTaskThread = class(TThread)
+       private
+         FTask: TThreadPoolTask;
+         procedure SetTask(AValue: TThreadPoolTask);
+       protected
+         procedure TerminatedSet; override;
+         procedure DoSetTask(AValue: TThreadPoolTask); virtual;
+       Public
+         Procedure FreeTask;
+         Property Task : TThreadPoolTask Read FTask Write SetTask;
+       end;
+
+       { TAbstractThreadList }
+
+       TAbstractThreadList = class(TObject)
+         Constructor CreateList; virtual; abstract;
+         // Return a thread ready to execute task.
+         Function GetAvailableThread : TAbstractTaskThread; virtual; abstract;
+         // Add thread which must execute task
+         Function AddThread : TAbstractTaskThread; virtual; abstract;
+         // Current thread count
+         Function GetThreadCount : Word; virtual; abstract;
+         // Busy thread count
+         Function GetBusyThreadCount : Word; virtual; abstract;
+         // Idle thread count
+         Function GetIdleThreadCount : Word; virtual; abstract;
+         // Terminate all treads.
+         Procedure TerminateThreads; virtual; abstract;
+       end;
+
+       { TTaskThread }
+
+       TTaskThread = Class(TAbstractTaskThread)
+       Private
+         FTaskEvent : TEventObject;
+         FWaitInterval : Integer;
+       Protected
+         procedure TerminatedSet; override;
+       Public
+         Constructor create(aWaitInterval : Integer; CreateSuspended : Boolean; aOnTerminate : TNotifyEvent); virtual;
+         Destructor Destroy; override;
+         procedure DoSetTask(AValue: TThreadPoolTask); override;
+         procedure Execute; override;
+         Property WaitInterval : Integer Read FWaitInterval;
+       end;
+
+       { TThreadPoolList }
+
+       TThreadPoolList = class (TAbstractThreadList)
+       private
+         FThreadTaskWaitInterval: Integer;
+         FList : TThreadList;
+         Procedure ThreadTerminated(Sender : TObject);
+       public
+         Constructor CreateList; override;
+         Procedure TerminateThreads; override;
+         Function GetAvailableThread : TAbstractTaskThread; override;
+         Function AddThread : TAbstractTaskThread; override;
+         Function GetThreadCount : Word; override;
+         Function GetBusyThreadCount : Word; override;
+         Function GetIdleThreadCount : Word; override;
+         Property ThreadTaskWaitInterval : Integer Read FThreadTaskWaitInterval Write FThreadTaskWaitInterval;
+       end;
+
+  private
+    class var _Instance : TFPCustomSimpleThreadPool;
+    class var _DefaultInstanceClass : TFPCustomSimpleThreadPoolClass;
+  private
+    FAutoCheckQueuedTasks: Boolean;
+    FMaxThreads: Word;
+    FMinThreads: Word;
+    FAddTimeout: Cardinal;
+    FAddWaitInterval: Cardinal;
+    FQueueTasks: Boolean;
+    FWaitQueueLock : TCriticalSection;
+    FTaskQueueLock : TCriticalSection;
+    FTaskList : TAbstractThreadList;
+    FWaitQueue : TThreadList;
+    FAutoCheckQueueThread : TAutoCheckQueueThread;
+    class function GetInstance: TFPCustomSimpleThreadPool; static;
+    procedure SetAutoCheckQueuedTasks(AValue: Boolean);
+    class procedure SetDefaultInstanceClass(AValue: TFPCustomSimpleThreadPoolClass); static;
+    procedure SetMaxThreads(AValue: Word);
+    procedure SetMinThreads(AValue: Word);
+    // Number of busy threads
+    Function GetBusyThreadCount : Word; virtual;
+    // Number of Idle threads
+    Function GetIdleThreadCount : Word;
+    // Number of threads
+    Function GetThreadCount : Word;
+  Protected
+    // Create thread to check queue
+    function CreateAutoCheckQueueThread: TAutoCheckQueueThread;
+    // Check wait list, see if task can be transferred to tasklist
+    Procedure DoCheckQueuedTasks; virtual;
+    // Add task to wait list.
+    Function AddTaskToQueue(aTask: TThreadPoolTask) : Boolean; virtual;
+    // Cancel tasks in the wait queue
+    Procedure DoCancelQueuedTasks;
+    // Terminate running tasks. If DoWait is true, wait till the task queue is empty.
+    Procedure DoTerminateRunningTasks(DoWait : Boolean);
+    // Create the list of threads.
+    function CreateThreadList : TAbstractThreadList; virtual;
+    // Actually add a task.
+    Function DoAddTask (aTask : TThreadPoolTask) : Boolean; virtual;
+    // Min number of threads
+    Property MinThreads : Word Read FMinThreads Write SetMinThreads;
+    // Max number of threads
+    Property MaxThreads : Word Read FMaxThreads Write SetMaxThreads;
+    // Wait interval in milliseconds when adding task and checking for an available thread
+    Property AddWaitInterval : Cardinal Read FAddWaitInterval Write FAddWaitInterval;
+    // Queue timeout in milliseconds when adding task. Set to Zero to wait forever.
+    Property AddTimeout : Cardinal Read FAddTimeout Write FAddTimeout;
+    // Set QueueTasks to add the tasks to a queue if they cannot be executed within the AddTimeout interval
+    Property QueueTasks : Boolean Read FQueueTasks Write FQueueTasks;
+    // Number of busy threads
+    Property BusyThreadCount : Word Read GetBusyThreadCount;
+    // Number of Idle threads
+    Property IdleThreadCount : Word Read GetIdleThreadCount;
+    // Number of threads
+    Property ThreadCount : Word Read GetThreadCount;
+    // Set to true to start a thread that runs the CheckQueuedTasks
+    Property AutoCheckQueuedTasks : Boolean Read FAutoCheckQueuedTasks Write SetAutoCheckQueuedTasks;
+  Public
+    constructor Create; virtual;
+    destructor destroy; override;
+    class constructor InitClass;
+    class destructor DoneClass;
+    // This needs to be called on regular basis to check if queued tasks can be executed.
+    procedure CheckQueuedTasks;
+    // Cancel queued tasks
+    Procedure CancelQueuedTasks;
+    // Terminate running tasks
+    Procedure TerminateRunningTasks;
+    // Will return true if the task was executed or put in queue.
+    // If False is returned, you must free the task. If true is returned, the thread pool will free the task.
+    Function AddTask (aTask : TThreadPoolTask) : Boolean; overload;
+    Function AddTask (aCallBack : TTaskCallBack; aData : TObject = Nil) : Boolean; overload;
+    Function AddTask (aEvent : TNotifyEvent; aData : TObject = Nil): Boolean; overload;
+    class property DefaultInstanceClass : TFPCustomSimpleThreadPoolClass Read _DefaultInstanceClass Write SetDefaultInstanceClass;
+    class property Instance : TFPCustomSimpleThreadPool read GetInstance;
+  end;
+
+  TFPSimpleThreadPool = class(TFPCustomSimpleThreadPool)
+  Public
+    Property MinThreads;
+    Property MaxThreads;
+    Property AddWaitInterval;
+    Property AddTimeout;
+    Property QueueTasks;
+    Property BusyThreadCount;
+    Property IdleThreadCount;
+    Property ThreadCount;
+    Property AutoCheckQueuedTasks;
+  end;
+
+Implementation
+
+Resourcestring
+  SErrMinLargerThanMax = 'MinThreads (%d) must be less than MaxThreads (%d)';
+  SErrMaxLessThanMin = 'MaxThreads (%d) must be greater than MinThreads (%d)';
+  SErrInstanceAlreadyCreated = 'Thread pool instance already created';
+  SErrTaskAlreadySet = 'Cannot set task: task already set';
+
+{$IFDEF DEBUGTHREADPOOL}
+Procedure DoLog(Const Msg : String);
+
+begin
+  Writeln(Output,Msg);
+  Flush(Output);
+end;
+
+Procedure DoLog(Const Fmt : String; Const Args : Array of const);
+begin
+  DoLog(Format(Fmt,Args))
+end;
+{$ENDIF}
+
+{ TFPCustomSimpleThreadPool.TAutoCheckQueueThread }
+
+constructor TFPCustomSimpleThreadPool.TAutoCheckQueueThread.Create(aPool: TFPCustomSimpleThreadPool; aInterval: Integer);
+begin
+  FPool:=aPool;
+  FInterval:=aInterval;
+  FreeOnTerminate:=True;
+  Inherited Create(False);
+end;
+
+procedure TFPCustomSimpleThreadPool.TAutoCheckQueueThread.Execute;
+begin
+  While not Terminated do
+    begin
+    Sleep(FInterval);
+    If Assigned(FPool) then
+      FPool.CheckQueuedTasks;
+    end;
+end;
+
+
+{ TSimpleThreadPoolTask }
+
+procedure TSimpleThreadPoolTask.DoExecute;
+begin
+  FProcedure;
+end;
+
+constructor TSimpleThreadPoolTask.Create(aProc: TProcedure);
+begin
+  FProcedure:=aProc;
+end;
+
+{ TEventThreadPoolTask }
+
+procedure TEventThreadPoolTask.DoExecute;
+
+begin
+  FEvent(FSender);
+end;
+
+constructor TEventThreadPoolTask.Create(aEvent: TNotifyEvent; aSender: TObject = Nil);
+begin
+  FSender:=aSender;
+  FEvent:=aEvent;
+end;
+
+{ TCallBackThreadPoolTask }
+
+procedure TCallBackThreadPoolTask.DoExecute;
+begin
+  FCallBack(FData);
+end;
+
+constructor TCallBackThreadPoolTask.Create(aCallback: TTaskCallBack; aData: TObject);
+begin
+  FCallBack:=aCallBack;
+  FData:=aData;
+end;
+
+{ TFPCustomSimpleThreadPool.TTaskThread }
+
+procedure TFPCustomSimpleThreadPool.TTaskThread.TerminatedSet;
+begin
+  FTaskEvent.SetEvent;
+  inherited TerminatedSet;
+end;
+
+constructor TFPCustomSimpleThreadPool.TTaskThread.create(aWaitInterval : Integer; CreateSuspended: Boolean; aOnTerminate : TNotifyEvent);
+begin
+  FTaskEvent:=TEventObject.Create(Nil,False,False,'');
+  FWaitInterval:=aWaitInterval;
+  OnTerminate:=aOnTerminate;
+  inherited create(CreateSuspended);
+end;
+
+destructor TFPCustomSimpleThreadPool.TTaskThread.Destroy;
+begin
+  FreeAndNil(FTaskEvent);
+  inherited Destroy;
+end;
+
+procedure TFPCustomSimpleThreadPool.TTaskThread.DoSetTask(AValue: TThreadPoolTask);
+begin
+  inherited DoSetTask(AValue);
+  FTaskEvent.SetEvent;
+end;
+
+procedure TFPCustomSimpleThreadPool.TTaskThread.Execute;
+begin
+  While Not Terminated do
+    begin
+    if (FTaskEvent.WaitFor(FWaitInterval)=wrSignaled) then
+      begin
+      FTaskEvent.ResetEvent;
+      // Task can be nil,
+      If Assigned(Task) then
+        try
+          Task.Execute;
+        finally
+          FreeTask;
+        end;
+      end;
+    end;
+end;
+
+{ TFPCustomSimpleThreadPool.TThreadPoolList }
+
+procedure TFPCustomSimpleThreadPool.TThreadPoolList.ThreadTerminated(Sender: TObject);
+begin
+  FList.Remove(Sender);
+end;
+
+constructor TFPCustomSimpleThreadPool.TThreadPoolList.CreateList;
+begin
+  FList:=TThreadList.Create;
+end;
+
+function TFPCustomSimpleThreadPool.TThreadPoolList.GetAvailableThread: TAbstractTaskThread;
+
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  Result:=Nil;
+  L:=FList.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      If TAbstractTaskThread(L[i]).Task=Nil then
+        Result:=TAbstractTaskThread(L[i]);
+  finally
+    FList.UnlockList;
+  end;
+end;
+
+function TFPCustomSimpleThreadPool.TThreadPoolList.AddThread: TAbstractTaskThread;
+begin
+  Result:=TTaskThread.Create(FThreadTaskWaitInterval,False,@ThreadTerminated);
+  FList.Add(Result);
+end;
+
+procedure TFPCustomSimpleThreadPool.TThreadPoolList.TerminateThreads;
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  L:=FList.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      TThread(L[i]).Terminate;
+  finally
+    FList.UnlockList;
+  end;
+end;
+
+function TFPCustomSimpleThreadPool.TThreadPoolList.GetThreadCount: Word;
+
+Var
+  L : TList;
+
+begin
+  L:=FList.LockList;
+  try
+    Result:=L.Count;
+  finally
+    FList.UnlockList;
+  end;
+end;
+
+function TFPCustomSimpleThreadPool.TThreadPoolList.GetBusyThreadCount: Word;
+
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  Result:=0;
+  L:=FList.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      if Assigned(TAbstractTaskThread(L[i]).Task) then
+        Inc(Result);
+  finally
+    FList.UnlockList;
+  end;
+end;
+
+function TFPCustomSimpleThreadPool.TThreadPoolList.GetIdleThreadCount: Word;
+
+Var
+  L : TList;
+  I : Integer;
+
+begin
+  Result:=0;
+  L:=FList.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      if Not Assigned(TAbstractTaskThread(L[i]).Task) then
+        Inc(Result);
+  finally
+    FList.UnlockList;
+  end;
+end;
+
+{ TFPCustomSimpleThreadPool.TAbstractTaskThread }
+
+procedure TFPCustomSimpleThreadPool.TAbstractTaskThread.SetTask(AValue: TThreadPoolTask);
+begin
+  if FTask=AValue then Exit;
+  if (FTask<>Nil) and (aValue=Nil) then
+     Raise EThreadPool.Create(SErrTaskAlreadySet);
+  DoSetTask(aValue);
+end;
+
+procedure TFPCustomSimpleThreadPool.TAbstractTaskThread.DoSetTask(AValue: TThreadPoolTask);
+begin
+  FTask:=AValue;
+end;
+
+procedure TFPCustomSimpleThreadPool.TAbstractTaskThread.FreeTask;
+begin
+  FreeAndNil(FTask);
+end;
+
+procedure TFPCustomSimpleThreadPool.TAbstractTaskThread.TerminatedSet;
+begin
+  if Assigned(FTask) then
+    FTask.Terminate;
+  inherited TerminatedSet;
+end;
+
+{ TThreadPoolTask }
+
+procedure TThreadPoolTask.DoDone;
+begin
+  if Assigned(FonDone) then
+    FOnDone(Self);
+end;
+
+procedure TThreadPoolTask.DoOnException(E: Exception);
+begin
+  if Assigned(FOnException) then
+    FOnException(Self,E);
+end;
+
+procedure TThreadPoolTask.DoTerminate;
+begin
+  if Assigned(FOnTerminate) then
+    FOnTerminate(Self);
+end;
+
+procedure TThreadPoolTask.DoQueued;
+begin
+  If Assigned(FOnQueued) then
+    FOnQueued(Self);
+end;
+
+procedure TThreadPoolTask.DoCancel;
+begin
+  If Assigned(FOnCancel) then
+    FOnCancel(Self);
+end;
+
+procedure TThreadPoolTask.Queued;
+begin
+  DoQueued;
+end;
+
+procedure TThreadPoolTask.Execute;
+
+Var
+  RunOK : Boolean;
+  S : String;
+
+begin
+  RunOK:=False;
+  Try
+    DoExecute;
+    RunOK:=True;
+  Except
+    On E : exception do
+      DoOnException(E);
+  end;
+  {$IFDEF DEBUGTHREADPOOL} DoLog('Done '+Self.ToString);{$ENDIF}
+  if (DoneOnException Or RunOK) then
+    DoDone;
+end;
+
+procedure TThreadPoolTask.Terminate;
+begin
+  FTerminated:=True;
+  DoTerminate;
+end;
+
+procedure TThreadPoolTask.Cancel;
+begin
+  DoCancel;
+end;
+
+{ TFPCustomSimpleThreadPool }
+
+class function TFPCustomSimpleThreadPool.GetInstance: TFPCustomSimpleThreadPool; static;
+begin
+  if _instance=nil then
+    _instance:=_DefaultInstanceClass.Create;
+  Result:=_Instance;
+end;
+
+Function TFPCustomSimpleThreadPool.CreateAutoCheckQueueThread :TAutoCheckQueueThread;
+begin
+  Result:=TAutoCheckQueueThread.Create(Self,AddWaitInterval);
+end;
+
+procedure TFPCustomSimpleThreadPool.SetAutoCheckQueuedTasks(AValue: Boolean);
+begin
+  FWaitQueueLock.Enter;
+  try
+    if FAutoCheckQueuedTasks=AValue then Exit;
+    FAutoCheckQueuedTasks:=AValue;
+    if FAutoCheckQueuedTasks then
+      begin
+      if Assigned(FAutoCheckQueueThread) then
+        begin
+        FAutoCheckQueueThread.Pool:=nil;
+        FAutoCheckQueueThread.Terminate;
+        FAutoCheckQueueThread:=Nil;
+        end;
+      end
+    else
+      begin
+      if Not Assigned(FAutoCheckQueueThread) then
+        FAutoCheckQueueThread:=CreateAutoCheckQueueThread;
+      end;
+  finally
+    FWaitQueueLock.Leave;
+  end;
+end;
+
+class procedure TFPCustomSimpleThreadPool.SetDefaultInstanceClass(AValue: TFPCustomSimpleThreadPoolClass);
+begin
+  if _DefaultInstanceClass=AValue then Exit;
+  if _Instance<>Nil then
+    Raise EThreadPool.Create(SErrInstanceAlreadyCreated);
+  _DefaultInstanceClass:=AValue;
+end;
+
+procedure TFPCustomSimpleThreadPool.SetMaxThreads(AValue: Word);
+begin
+  if FMaxThreads=AValue then Exit;
+  if aValue<FMinThreads then
+      Raise EThreadPool.CreateFmt(SErrMaxLessThanMin,[aValue,MinThreads]);
+    FMaxThreads:=AValue;
+end;
+
+procedure TFPCustomSimpleThreadPool.SetMinThreads(AValue: Word);
+begin
+  if FMinThreads=AValue then Exit;
+  if (FMaxThreads>0) and (aValue>FMaxThreads) then
+      Raise EThreadPool.CreateFmt(SErrMinLargerThanMax,[aValue,MaxThreads]);
+  FMinThreads:=AValue;
+end;
+
+function TFPCustomSimpleThreadPool.GetBusyThreadCount: Word;
+begin
+  Result:=FTaskList.GetBusyThreadCount;
+end;
+
+function TFPCustomSimpleThreadPool.GetIdleThreadCount: Word;
+begin
+  Result:=FTaskList.GetIdleThreadCount;
+end;
+
+function TFPCustomSimpleThreadPool.GetThreadCount: Word;
+begin
+  Result:=FTaskList.GetThreadCount;
+end;
+
+procedure TFPCustomSimpleThreadPool.DoCheckQueuedTasks;
+
+Var
+  L : TList;
+
+begin
+  FWaitQueueLock.Enter;
+  try
+    L:=FWaitQueue.LockList;
+    While (L.Count>0) and DoAddTask(TThreadPoolTask(L[L.Count-1])) do
+      L.Delete(L.Count-1);
+  finally
+    FWaitQueueLock.Leave;
+  end;
+end;
+
+function TFPCustomSimpleThreadPool.AddTaskToQueue(aTask: TThreadPoolTask): Boolean;
+begin
+  {$IFDEF DEBUGTHREADPOOL} DoLog(('Adding task '+aTask.ToString+' to queue');{$ENDIF}
+  FWaitQueueLock.Enter;
+  try
+    FWaitQueue.Add(aTask);
+    aTask.Queued;
+    Result:=True;
+  finally
+    FWaitQueueLock.Leave;
+  end;
+end;
+
+procedure TFPCustomSimpleThreadPool.DoCancelQueuedTasks;
+
+Var
+  L : TList;
+  aTask : TThreadPoolTask;
+begin
+  FWaitQueueLock.Enter;
+  try
+    L:=FWaitQueue.LockList;
+    While (L.Count>0)  do
+      begin
+      aTask:=TThreadPoolTask(L[L.Count-1]);
+      L.Delete(L.Count-1);
+      aTask.Cancel;
+      aTask.Free;
+      end;
+  finally
+    FWaitQueueLock.Leave;
+  end;
+end;
+
+procedure TFPCustomSimpleThreadPool.DoTerminateRunningTasks(DoWait: Boolean);
+begin
+  {$IFDEF DEBUGTHREADPOOL}DoLog('Terminating all threads');{$ENDIF}
+  FTaskList.TerminateThreads;
+  {$IFDEF DEBUGTHREADPOOL}DoLog('Terminated all threads, wait: %s',BoolToStr(DoWait,True);{$ENDIF}
+  if DoWait then
+    begin
+    While FTaskList.GetBusyThreadCount>0 do
+      begin
+      {$IFDEF DEBUGTHREADPOOL}DoLog('Not all threads terminated, wait: %d',[FAddWaitInterval]);{$ENDIF}
+      Sleep(FAddWaitInterval);
+      end;
+    end;
+end;
+
+function TFPCustomSimpleThreadPool.CreateThreadList: TAbstractThreadList;
+begin
+  Result:=TThreadPoolList.CreateList;
+end;
+
+function TFPCustomSimpleThreadPool.DoAddTask(aTask: TThreadPoolTask) : Boolean;
+
+Var
+  T : TAbstractTaskThread;
+  WaitStart : TDateTime;
+  TimeOut : Boolean;
+
+begin
+  WaitStart:=0;
+  Result:=False;
+  TimeOut:=False;
+  Repeat
+    FTaskQueueLock.Enter;
+    try
+      T:=FTaskList.GetAvailableThread;
+      if (T=Nil) and (FTasklist.GetThreadCount<MaxThreads) then
+        T:=FTasklist.AddThread;
+    finally
+      FTaskQueueLock.Leave;
+    end;
+    Result:=T<>Nil;
+    if Result then
+      T.Task:=aTask
+    else
+      begin
+      {$IFDEF DEBUGTHREADPOOL}DoLog('No available thread for task %s waiting %d to %d',[aTask.ToString,FAddWaitIntervalFAddTimeOut]);{$ENDIF}
+      Flush(output);
+      if WaitStart=0 then
+        WaitStart:=Now;
+      Sleep(FAddWaitInterval);
+      TimeOut:=(FAddTimeOut>0) and (MillisecondsBetween(Now,WaitStart)>FAddTimeout);
+      If TimeOut then
+        begin
+        {$IFDEF DEBUGTHREADPOOL}DoLog('TimeOut reached: ',TimeOut);{$ENDIF}
+        Flush(output);
+        end;
+      end;
+  Until Result or TimeOut;
+end;
+
+constructor TFPCustomSimpleThreadPool.Create;
+begin
+  FAddWaitInterval:=DefaultAddWaitInterval;
+  FAddTimeout:=DefaultAddTimeout;
+  FWaitQueueLock:=TCriticalSection.Create;
+  FTaskQueueLock:=TCriticalSection.Create;
+  FWaitQueue:=TThreadList.Create;
+  FTaskList:=CreateThreadList;
+  MaxThreads:=TThread.ProcessorCount;
+  MinThreads:=TThread.ProcessorCount-1;
+  FQueueTasks:=DefaultQueueTasks;
+end;
+
+destructor TFPCustomSimpleThreadPool.destroy;
+begin
+  // Disable the queue
+  AutoCheckQueuedTasks:=False;
+  {$IFDEF DEBUGTHREADPOOL}DoLog('Destroy : Cancelqueuedtasks');{$ENDIF}
+  CancelQueuedTasks;
+  {$IFDEF DEBUGTHREADPOOL}DoLog('Destroy : TerminateRunningTasks');{$ENDIF}
+  TerminateRunningTasks;
+  FreeAndNil(FWaitQueue);
+  FreeAndNil(FTaskList);
+  FreeAndNil(FWaitQueueLock);
+  FreeAndNil(FTaskQueueLock);
+  inherited destroy;
+end;
+
+class constructor TFPCustomSimpleThreadPool.InitClass;
+begin
+  _DefaultInstanceClass:=TFPSimpleThreadPool;
+  _Instance:=Nil;
+end;
+
+class destructor TFPCustomSimpleThreadPool.DoneClass;
+begin
+  FreeAndNil(_Instance);
+end;
+
+procedure TFPCustomSimpleThreadPool.CheckQueuedTasks;
+begin
+  DoCheckQueuedTasks;
+end;
+
+procedure TFPCustomSimpleThreadPool.CancelQueuedTasks;
+begin
+  DoCancelQueuedTasks;
+end;
+
+procedure TFPCustomSimpleThreadPool.TerminateRunningTasks;
+begin
+  DoTerminateRunningTasks(True);
+end;
+
+function TFPCustomSimpleThreadPool.AddTask(aTask: TThreadPoolTask): Boolean;
+begin
+  While ThreadCount<MinThreads do
+    FTaskList.AddThread;
+  CheckQueuedTasks;
+  Result:=DoAddTask(aTask);
+  if (not Result) and QueueTasks then
+    Result:=AddTaskToQueue(aTask);
+end;
+
+function TFPCustomSimpleThreadPool.AddTask(aCallBack: TTaskCallBack; aData: TObject): Boolean;
+
+Var
+  T : TThreadPoolTask;
+
+begin
+  T:=TCallBackThreadPoolTask.Create(aCallBack,aData);
+  Result:=AddTask(T);
+  if not Result then
+    T.Free;
+end;
+
+function TFPCustomSimpleThreadPool.AddTask(aEvent: TNotifyEvent; aData: TObject): Boolean;
+Var
+  T : TThreadPoolTask;
+
+begin
+  T:=TEventThreadPoolTask.Create(aEvent,aData);
+  Result:=AddTask(T);
+  if not Result then
+    T.Free;
+end;
+
+end.
+

packages/fcl-db/src/base/bufdataset.pas

@@ -362,8 +362,8 @@ type
 
   TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny,dfDefault);
 
-  TDatapacketReaderClass = class of TDatapacketReader;
-  TDataPacketReader = class(TObject)
+  TDataPacketHandlerClass = class of TDataPacketHandler;
+  TDataPacketHandler = class(TObject)
     FDataSet: TCustomBufDataset;
     FStream : TStream;
   protected
@@ -398,6 +398,8 @@ type
     // Checks if the provided stream is of the right format for this class
     class function RecognizeStream(AStream : TStream) : boolean; virtual; abstract;
   end;
+  TDataPacketReaderClass = TDataPacketHandlerClass;
+  TDataPacketReader = TDataPacketHandler;
 
   { TFpcBinaryDatapacketReader }
 
@@ -419,7 +421,7 @@ type
                  null fields are not stored (see: null bitmap)
   }
 
-  TFpcBinaryDatapacketReader = class(TDataPacketReader)
+  TFpcBinaryDatapacketHandler = class(TDataPacketHandler)
   private
     const
       FpcBinaryIdent1 = 'BinBufDataset'; // Old version 1; support for transient period;
@@ -446,6 +448,7 @@ type
     procedure FinalizeStoreRecords; override;
     class function RecognizeStream(AStream : TStream) : boolean; override;
   end;
+  TFpcBinaryDatapacketReader = TFpcBinaryDatapacketHandler;
 
   { TCustomBufDataset }
 
@@ -502,7 +505,7 @@ type
     FFileName: TFileName;
     FReadFromFile   : boolean;
     FFileStream     : TFileStream;
-    FDatasetReader  : TDataPacketReader;
+    FPacketHandler  : TDataPacketReader;
     FMaxIndexesCount: integer;
     FDefaultIndex,
     FCurrentIndexDef : TBufDatasetIndex;
@@ -537,8 +540,6 @@ type
     function GetFieldSize(FieldDef : TFieldDef) : longint;
     procedure CalcRecordSize;
     function  IntAllocRecordBuffer: TRecordBuffer;
-    procedure IntLoadFieldDefsFromFile;
-    procedure IntLoadRecordsFromFile;
     function  GetCurrentBuffer: TRecordBuffer;
     procedure CurrentRecordToBuffer(Buffer: TRecordBuffer);
     function LoadBuffer(Buffer : TRecordBuffer): TGetResult;
@@ -548,7 +549,9 @@ type
     function GetActiveRecordUpdateBuffer : boolean;
     procedure CancelRecordUpdateBuffer(AUpdateBufferIndex: integer; var ABookmark: TBufBookmark);
     procedure ParseFilter(const AFilter: string);
-
+    // Packet handling
+    procedure IntLoadFieldDefsFromPacket(aReader : TDataPacketHandler); virtual;
+    procedure IntLoadRecordsFromPacket(aReader : TDataPacketHandler);  virtual;
     function GetBufUniDirectional: boolean;
     // indexes handling
     function GetIndexDefs : TIndexDefs;
@@ -658,8 +661,8 @@ type
       const ACaseInsFields: string = ''); virtual;
     procedure ClearIndexes;
 
-    procedure SetDatasetPacket(AReader : TDataPacketReader);
-    procedure GetDatasetPacket(AWriter : TDataPacketReader);
+    procedure SetDatasetPacket(AReader : TDataPacketHandler);
+    procedure GetDatasetPacket(AWriter : TDataPacketHandler);
     procedure LoadFromStream(AStream : TStream; Format: TDataPacketFormat = dfDefault);
     procedure SaveToStream(AStream : TStream; Format: TDataPacketFormat = dfBinary);
     procedure LoadFromFile(AFileName: string = ''; Format: TDataPacketFormat = dfDefault);
@@ -1372,12 +1375,7 @@ end;
 
 procedure TCustomBufDataset.InternalInitFieldDefs;
 begin
-  if FileName<>'' then
-    begin
-    IntLoadFieldDefsFromFile;
-    FreeAndNil(FDatasetReader);
-    FreeAndNil(FFileStream);
-    end;
+  // Do nothing
 end;
 
 procedure TCustomBufDataset.InitUserIndexes;
@@ -1393,63 +1391,84 @@ end;
 
 procedure TCustomBufDataset.InternalOpen;
 
-var IndexNr : integer;
-    i : integer;
+var
+  IndexNr : integer;
+  i : integer;
+  aPacketReader : TDataPacketReader;
+  aStream : TFileStream;
 
 begin
-  if assigned(FDatasetReader) or (FileName<>'') then
-    IntLoadFieldDefsFromFile;
+  aPacketReader:=Nil;
+  aStream:=Nil;
+  try
+    if assigned(FPacketHandler) or (FileName<>'') then
+      begin
+      aPacketReader:=FPacketHandler;
+      if FileName<>'' then
+        begin
+        aStream := TFileStream.Create(FileName, fmOpenRead);
+        aPacketReader := GetPacketReader(dfDefault, aStream);
+        end;
+      IntLoadFieldDefsFromPacket(aPacketReader);
+      end;
 
-  // This checks if the dataset is actually created (by calling CreateDataset,
-  // or reading from a stream in some other way implemented by a descendent)
-  // If there are less fields than FieldDefs we know for sure that the dataset
-  // is not (correctly) created.
+    // This checks if the dataset is actually created (by calling CreateDataset,
+    // or reading from a stream in some other way implemented by a descendent)
+    // If there are less fields than FieldDefs we know for sure that the dataset
+    // is not (correctly) created.
 
-  // If there are constant expressions in the select statement (for PostgreSQL)
-  // they are of type ftUnknown (in FieldDefs), and are not created (in Fields).
-  // So Fields.Count < FieldDefs.Count in this case
-  // See mantis #22030
+    // If there are constant expressions in the select statement (for PostgreSQL)
+    // they are of type ftUnknown (in FieldDefs), and are not created (in Fields).
+    // So Fields.Count < FieldDefs.Count in this case
+    // See mantis #22030
 
-  //  if Fields.Count<FieldDefs.Count then
-  if (Fields.Count = 0) or (FieldDefs.Count=0) then
-    DatabaseError(SErrNoDataset);
+    //  if Fields.Count<FieldDefs.Count then
+    if (Fields.Count = 0) or (FieldDefs.Count=0) then
+      DatabaseError(SErrNoDataset);
 
-  // search for autoinc field
-  FAutoIncField:=nil;
-  if FAutoIncValue>-1 then
-  begin
-    for i := 0 to Fields.Count-1 do
-      if Fields[i] is TAutoIncField then
-      begin
-        FAutoIncField := TAutoIncField(Fields[i]);
-        Break;
-      end;
-  end;
+    // search for autoinc field
+    FAutoIncField:=nil;
+    if FAutoIncValue>-1 then
+    begin
+      for i := 0 to Fields.Count-1 do
+        if Fields[i] is TAutoIncField then
+        begin
+          FAutoIncField := TAutoIncField(Fields[i]);
+          Break;
+        end;
+    end;
 
-  InitDefaultIndexes;
-  InitUserIndexes;
-  If FIndexName<>'' then
-    FCurrentIndexDef:=TBufDatasetIndex(FIndexes.Find(FIndexName))
-  else if (FIndexFieldNames<>'') then
-    BuildCustomIndex;
+    InitDefaultIndexes;
+    InitUserIndexes;
+    If FIndexName<>'' then
+      FCurrentIndexDef:=TBufDatasetIndex(FIndexes.Find(FIndexName))
+    else if (FIndexFieldNames<>'') then
+      BuildCustomIndex;
 
-  CalcRecordSize;
+    CalcRecordSize;
 
-  FBRecordCount := 0;
+    FBRecordCount := 0;
 
-  for IndexNr:=0 to FIndexes.Count-1 do
-    if Assigned(BufIndexdefs[IndexNr]) then
-      With BufIndexes[IndexNr] do
-        InitialiseSpareRecord(IntAllocRecordBuffer);
+    for IndexNr:=0 to FIndexes.Count-1 do
+      if Assigned(BufIndexdefs[IndexNr]) then
+        With BufIndexes[IndexNr] do
+          InitialiseSpareRecord(IntAllocRecordBuffer);
 
-  FAllPacketsFetched := False;
+    FAllPacketsFetched := False;
 
-  FOpen:=True;
+    FOpen:=True;
 
-  // parse filter expression
-  ParseFilter(Filter);
+    // parse filter expression
+    ParseFilter(Filter);
 
-  if assigned(FDatasetReader) then IntLoadRecordsFromFile;
+    if assigned(aPacketReader) then
+      IntLoadRecordsFromPacket(aPacketReader);
+  finally
+    // We created reader locally here.
+    if assigned(aStream) then
+      FreeAndNil(aPacketReader);
+    FreeAndNil(aStream);
+  end;
 end;
 
 procedure TCustomBufDataset.DoBeforeClose;
@@ -2307,7 +2326,7 @@ end;
 
 class function TCustomBufDataset.DefaultPacketClass: TDataPacketReaderClass;
 begin
-  Result:=TFpcBinaryDatapacketReader;
+  Result:=TFpcBinaryDatapacketHandler;
 end;
 
 function TCustomBufDataset.CreateDefaultPacketReader(aStream : TStream): TDataPacketReader;
@@ -3204,10 +3223,10 @@ begin
     APacketReader := CreateDefaultPacketReader(AStream)
   else if GetRegisterDatapacketReader(AStream, fmt, APacketReaderReg) then
     APacketReader := APacketReaderReg.ReaderClass.Create(Self, AStream)
-  else if TFpcBinaryDatapacketReader.RecognizeStream(AStream) then
+  else if TFpcBinaryDatapacketHandler.RecognizeStream(AStream) then
     begin
     AStream.Seek(0, soFromBeginning);
-    APacketReader := TFpcBinaryDatapacketReader.Create(Self, AStream)
+    APacketReader := TFpcBinaryDatapacketHandler.Create(Self, AStream)
     end
   else
     DatabaseError(SStreamNotRecognised,Self);
@@ -3449,17 +3468,17 @@ begin
   Result := TBufBlobStream.Create(Field as TBlobField, Mode);
 end;
 
-procedure TCustomBufDataset.SetDatasetPacket(AReader: TDataPacketReader);
+procedure TCustomBufDataset.SetDatasetPacket(AReader: TDataPacketHandler);
 begin
-  FDatasetReader := AReader;
+  FPacketHandler := AReader;
   try
     Open;
   finally
-    FDatasetReader := nil;
+    FPacketHandler := nil;
   end;
 end;
 
-procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
+procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketHandler);
 
   procedure StoreUpdateBuffer(AUpdBuffer : TRecUpdateBuffer; var ARowState: TRowState);
   var AThisRowState : TRowState;
@@ -3487,7 +3506,7 @@ procedure TCustomBufDataset.GetDatasetPacket(AWriter: TDataPacketReader);
     FFilterBuffer:=AUpdBuffer.OldValuesBuffer;
     // OldValuesBuffer is nil if the record is either inserted or inserted and then deleted
     if assigned(FFilterBuffer) then
-      FDatasetReader.StoreRecord(AThisRowState,FCurrentUpdateBuffer);
+      aWriter.StoreRecord(AThisRowState,FCurrentUpdateBuffer);
   end;
 
   procedure HandleUpdateBuffersFromRecord(AFindNext : boolean; ARecBookmark : TBufBookmark; var ARowState: TRowState);
@@ -3520,13 +3539,11 @@ var ScrollResult   : TGetResult;
     RowState       : TRowState;
 
 begin
-  FDatasetReader := AWriter;
+  //  CheckActive;
+  ABookMark:=@ATBookmark;
+  aWriter.StoreFieldDefs(FAutoIncValue);
+  SavedState:=SetTempState(dsFilter);
   try
-    //  CheckActive;
-    ABookMark:=@ATBookmark;
-    FDatasetReader.StoreFieldDefs(FAutoIncValue);
-
-    SavedState:=SetTempState(dsFilter);
     ScrollResult:=CurrentIndexBuf.ScrollFirst;
     while ScrollResult=grOK do
       begin
@@ -3537,9 +3554,9 @@ begin
       // now store current record
       FFilterBuffer:=CurrentIndexBuf.CurrentBuffer;
       if RowState=[] then
-        FDatasetReader.StoreRecord([])
+        aWriter.StoreRecord([])
       else
-        FDatasetReader.StoreRecord(RowState,FCurrentUpdateBuffer);
+        aWriter.StoreRecord(RowState,FCurrentUpdateBuffer);
 
       ScrollResult:=CurrentIndexBuf.ScrollForward;
       if ScrollResult<>grOK then
@@ -3551,12 +3568,9 @@ begin
     // There could be an update buffer linked to the last (spare) record
     CurrentIndexBuf.StoreSpareRecIntoBookmark(ABookmark);
     HandleUpdateBuffersFromRecord(False,ABookmark^,RowState);
-
-    RestoreState(SavedState);
-
-    FDatasetReader.FinalizeStoreRecords;
+    aWriter.FinalizeStoreRecords;
   finally
-    FDatasetReader := nil;
+    RestoreState(SavedState);
   end;
 end;
 
@@ -3586,7 +3600,7 @@ begin
   else if GetRegisterDatapacketReader(Nil,fmt,APacketReaderReg) then
     APacketWriter := APacketReaderReg.ReaderClass.Create(Self, AStream)
   else if fmt = dfBinary then
-    APacketWriter := TFpcBinaryDatapacketReader.Create(Self, AStream)
+    APacketWriter := TFpcBinaryDatapacketHandler.Create(Self, AStream)
   else
     DatabaseError(SNoReaderClassRegistered,Self);
   try
@@ -3685,25 +3699,19 @@ begin
     Result := -1;
 end;
 
-procedure TCustomBufDataset.IntLoadFieldDefsFromFile;
+procedure TCustomBufDataset.IntLoadFieldDefsFromPacket(aReader : TDataPacketHandler);
 
 begin
   FReadFromFile := True;
-  if not assigned(FDatasetReader) then
-    begin
-    FFileStream := TFileStream.Create(FileName, fmOpenRead);
-    FDatasetReader := GetPacketReader(dfDefault, FFileStream);
-    end;
-
   FieldDefs.Clear;
-  FDatasetReader.LoadFieldDefs(FAutoIncValue);
+  aReader.LoadFieldDefs(FAutoIncValue);
   if DefaultFields then
     CreateFields
   else
     BindFields(true);
 end;
 
-procedure TCustomBufDataset.IntLoadRecordsFromFile;
+procedure TCustomBufDataset.IntLoadRecordsFromPacket(aReader : TDataPacketHandler);
 
 var
   SavedState      : TDataSetState;
@@ -3715,12 +3723,12 @@ var
 begin
   CheckBiDirectional;
   DefIdx:=DefaultBufferIndex;
-  FDatasetReader.InitLoadRecords;
+  aReader.InitLoadRecords;
   SavedState:=SetTempState(dsFilter);
 
-  while FDatasetReader.GetCurrentRecord do
+  while aReader.GetCurrentRecord do
     begin
-    ARowState := FDatasetReader.GetRecordRowState(AUpdOrder);
+    ARowState := aReader.GetRecordRowState(AUpdOrder);
     if rsvOriginal in ARowState then
       begin
       if length(FUpdateBuffer) < (AUpdOrder+1) then
@@ -3731,12 +3739,12 @@ begin
       FFilterBuffer:=IntAllocRecordBuffer;
       fillchar(FFilterBuffer^,FNullmaskSize,0);
       FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := FFilterBuffer;
-      FDatasetReader.RestoreRecord;
+      aReader.RestoreRecord;
 
-      FDatasetReader.GotoNextRecord;
-      if not FDatasetReader.GetCurrentRecord then
+      aReader.GotoNextRecord;
+      if not aReader.GetCurrentRecord then
         DatabaseError(SStreamNotRecognised,Self);
-      ARowState := FDatasetReader.GetRecordRowState(AUpdOrder);
+      ARowState := aReader.GetRecordRowState(AUpdOrder);
       if rsvUpdated in ARowState then
         FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind:= ukModify
       else
@@ -3746,7 +3754,7 @@ begin
       DefIdx.StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
       fillchar(FFilterBuffer^,FNullmaskSize,0);
 
-      FDatasetReader.RestoreRecord;
+      aReader.RestoreRecord;
       DefIdx.AddRecord;
       inc(FBRecordCount);
       end
@@ -3761,7 +3769,7 @@ begin
       fillchar(FFilterBuffer^,FNullmaskSize,0);
 
       FUpdateBuffer[FCurrentUpdateBuffer].OldValuesBuffer := FFilterBuffer;
-      FDatasetReader.RestoreRecord;
+      aReader.RestoreRecord;
 
       FUpdateBuffer[FCurrentUpdateBuffer].UpdateKind:= ukDelete;
       DefIdx.StoreSpareRecIntoBookmark(@FUpdateBuffer[FCurrentUpdateBuffer].BookmarkData);
@@ -3777,7 +3785,7 @@ begin
       begin
       FFilterBuffer:=DefIdx.SpareBuffer;
       fillchar(FFilterBuffer^,FNullmaskSize,0);
-      FDatasetReader.RestoreRecord;
+      aReader.RestoreRecord;
       if rsvInserted in ARowState then
         begin
         if length(FUpdateBuffer) < (AUpdOrder+1) then
@@ -3791,17 +3799,12 @@ begin
       inc(FBRecordCount);
       end;
 
-    FDatasetReader.GotoNextRecord;
+    aReader.GotoNextRecord;
     end;
 
   RestoreState(SavedState);
   DefIdx.SetToFirstRecord;
   FAllPacketsFetched:=True;
-  if assigned(FFileStream) then
-    begin
-    FreeAndNil(FFileStream);
-    FreeAndNil(FDatasetReader);
-    end;
 
   // rebuild indexes
   BuildIndexes;
@@ -3899,7 +3902,7 @@ end;
 
 function TCustomBufDataset.IsReadFromPacket: Boolean;
 begin
-  Result := (FDatasetReader<>nil) or (FFileName<>'') or FReadFromFile;
+  Result := (FPacketHandler<>nil) or (FFileName<>'') or FReadFromFile;
 end;
 
 procedure TCustomBufDataset.ParseFilter(const AFilter: string);
@@ -4320,15 +4323,15 @@ begin
 end;
 
 
-{ TFpcBinaryDatapacketReader }
+{ TFpcBinaryDatapacketHandler }
 
-constructor TFpcBinaryDatapacketReader.Create(ADataSet: TCustomBufDataset; AStream: TStream);
+constructor TFpcBinaryDatapacketHandler.Create(ADataSet: TCustomBufDataset; AStream: TStream);
 begin
   inherited;
   FVersion := 20; // default version 2.0
 end;
 
-procedure TFpcBinaryDatapacketReader.LoadFieldDefs(var AnAutoIncValue: integer);
+procedure TFpcBinaryDatapacketHandler.LoadFieldDefs(var AnAutoIncValue: integer);
 
 var FldCount : word;
     i        : integer;
@@ -4367,7 +4370,7 @@ begin
   SetLength(FNullBitmap, FNullBitmapSize);
 end;
 
-procedure TFpcBinaryDatapacketReader.StoreFieldDefs(AnAutoIncValue: integer);
+procedure TFpcBinaryDatapacketHandler.StoreFieldDefs(AnAutoIncValue: integer);
 var i : integer;
 begin
   Stream.Write(FpcBinaryIdent2[1], length(FpcBinaryIdent2));
@@ -4393,18 +4396,18 @@ begin
   SetLength(FNullBitmap, FNullBitmapSize);
 end;
 
-procedure TFpcBinaryDatapacketReader.InitLoadRecords;
+procedure TFpcBinaryDatapacketHandler.InitLoadRecords;
 begin
   //  Do nothing
 end;
 
-function TFpcBinaryDatapacketReader.GetCurrentRecord: boolean;
+function TFpcBinaryDatapacketHandler.GetCurrentRecord: boolean;
 var Buf : byte;
 begin
   Result := (Stream.Read(Buf,1)=1) and (Buf=$fe);
 end;
 
-function TFpcBinaryDatapacketReader.GetRecordRowState(out AUpdOrder : Integer) : TRowState;
+function TFpcBinaryDatapacketHandler.GetRecordRowState(out AUpdOrder : Integer) : TRowState;
 var Buf : byte;
 begin
   Stream.Read(Buf,1);
@@ -4415,12 +4418,12 @@ begin
     AUpdOrder := 0;
 end;
 
-procedure TFpcBinaryDatapacketReader.GotoNextRecord;
+procedure TFpcBinaryDatapacketHandler.GotoNextRecord;
 begin
   //  Do Nothing
 end;
 
-procedure TFpcBinaryDatapacketReader.RestoreRecord;
+procedure TFpcBinaryDatapacketHandler.RestoreRecord;
 var
   AField: TField;
   i: integer;
@@ -4463,7 +4466,7 @@ begin
     end;
 end;
 
-procedure TFpcBinaryDatapacketReader.StoreRecord(ARowState: TRowState; AUpdOrder : integer);
+procedure TFpcBinaryDatapacketHandler.StoreRecord(ARowState: TRowState; AUpdOrder : integer);
 var
   AField: TField;
   i: integer;
@@ -4513,12 +4516,12 @@ begin
     end;
 end;
 
-procedure TFpcBinaryDatapacketReader.FinalizeStoreRecords;
+procedure TFpcBinaryDatapacketHandler.FinalizeStoreRecords;
 begin
   //  Do nothing
 end;
 
-class function TFpcBinaryDatapacketReader.RecognizeStream(AStream: TStream): boolean;
+class function TFpcBinaryDatapacketHandler.RecognizeStream(AStream: TStream): boolean;
 var s : string;
 begin
   SetLength(s, 13);

packages/fcl-db/tests/testdbexport.pas

@@ -337,7 +337,7 @@ begin
     ExportSettings.ExportFormat:=AccessCompatible;
     ExportFormat:=efXMLXSDAccess;
     ExportSettings.CreateXSD:=false;
-    ExportSettings.DecimalSeparator:=char(''); //don't override
+    ExportSettings.DecimalSeparator:=#0; //don't override
     Exporter.FileName := FExportTempDir + inttostr(ord(ExportFormat)) +
       lowercase(rightstr(TestName,5)) +
       TDetailedExportExtensions[ExportFormat];
@@ -393,7 +393,7 @@ begin
     ExportSettings.ExportFormat:=AccessCompatible;
     ExportFormat:=efXMLXSDAccess;
     ExportSettings.CreateXSD:=true;
-    ExportSettings.DecimalSeparator:=char(''); //don't override
+    ExportSettings.DecimalSeparator:=char(#0); //don't override
     Exporter.FileName := FExportTempDir + inttostr(ord(ExportFormat)) +
       lowercase(rightstr(TestName,5)) +
       TDetailedExportExtensions[ExportFormat];

packages/fcl-json/tests/testjson.lpi

@@ -1,6 +1,6 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
-  <ProjectOptions BuildModesCount="1">
+  <ProjectOptions>
     <Version Value="12"/>
     <General>
       <Flags>
@@ -13,19 +13,23 @@
       </Flags>
       <SessionStorage Value="InProjectDir"/>
     </General>
-    <BuildModes>
+    <BuildModes Count="1">
       <Item1 Name="default" Default="True"/>
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
     </PublishOptions>
     <RunParams>
+      <local>
+        <CommandLineParams Value="--suite=TTestJSONString.TestJSONStringToString"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
       <FormatVersion Value="2"/>
       <Modes Count="1">
         <Mode0 Name="default">
           <local>
             <CommandLineParams Value="--suite=TTestJSONString.TestJSONStringToString"/>
-            <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+            <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
           </local>
         </Mode0>
       </Modes>
@@ -41,23 +45,23 @@
         <IsPartOfProject Value="True"/>
       </Unit0>
       <Unit1>
-        <Filename Value="testjsonparser.pp"/>
+        <Filename Value="testjsonparser.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit1>
       <Unit2>
-        <Filename Value="testjsondata.pp"/>
+        <Filename Value="testjsondata.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit2>
       <Unit3>
-        <Filename Value="testjsonrtti.pp"/>
+        <Filename Value="testjsonrtti.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit3>
       <Unit4>
-        <Filename Value="../src/fpjsonrtti.pp"/>
+        <Filename Value="testjsonreader.pas"/>
         <IsPartOfProject Value="True"/>
       </Unit4>
       <Unit5>
-        <Filename Value="testjsonreader.pp"/>
+        <Filename Value="../src/fpjsonrtti.pp"/>
         <IsPartOfProject Value="True"/>
       </Unit5>
     </Units>

packages/fcl-json/tests/testjson.pp

@@ -1,3 +1,4 @@
+{ %OPT=-S2 }
 {
     This file is part of the Free Component Library
 

packages/fcl-net/src/ssockets.pp

@@ -879,20 +879,30 @@ begin
 end;
 
 Function  TInetServer.SockToStream (ASocket : Longint) : TSocketStream;
-
 Var
   H : TSocketHandler;
+  A : Boolean;
+
+  procedure ShutDownH;
+  begin
+    H.Shutdown(False);
+    FreeAndNil(Result);
+  end;
 
 begin
   H:=GetClientSocketHandler(aSocket);
   Result:=TInetSocket.Create(ASocket,H);
   (Result as TInetSocket).FHost:='';
   (Result as TInetSocket).FPort:=FPort;
-  if Not H.Accept then
-    begin
-    H.Shutdown(False);
-    FreeAndNil(Result);
-    end;
+
+  try
+    A:=H.Accept;
+  except
+    ShutDownH;
+    raise;
+  end;
+  if Not A then
+    ShutDownH;
 end;
 
 Function TInetServer.Accept : Longint;

packages/fcl-passrc/src/pasresolveeval.pas

@@ -787,7 +787,7 @@ type
     function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
     function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
       LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
-    function LoHiValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
+    function ShiftAndMaskValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
       ErrorEl: TPasElement): TResEvalValue; virtual;
     function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
       Flags: TResEvalFlags): TResEvalEnum; virtual;
@@ -5273,7 +5273,7 @@ begin
   end;
 end;
 
-function TResExprEvaluator.LoHiValue(Value: TResEvalValue; ShiftSize: Integer;
+function TResExprEvaluator.ShiftAndMaskValue(Value: TResEvalValue; ShiftSize: Integer;
   Mask: LongWord; ErrorEl: TPasElement): TResEvalValue;
 var
   uint: LongWord;

packages/fcl-passrc/src/pasresolver.pp

@@ -20088,7 +20088,7 @@ begin
   try
     ComputeElement(Param,ResolvedParam,[]);
     Shift := GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType, Proc.BuiltIn=bfLo, Mask);
-    Evaluated := fExprEvaluator.LoHiValue(Value,Shift,Mask,Params);
+    Evaluated := fExprEvaluator.ShiftAndMaskValue(Value,Shift,Mask,Params);
   finally
     ReleaseEvalValue(Value);
   end;
@@ -27920,7 +27920,7 @@ begin
     writeln('TPasResolver.ComputeElement Unary Kind=',TUnaryExpr(El).Kind,' OpCode=',TUnaryExpr(El).OpCode,' OperandResolved=',GetResolverResultDbg(ResolvedEl),' ',GetElementSourcePosStr(El));
     {$ENDIF}
     case TUnaryExpr(El).OpCode of
-      eopAdd, eopSubtract:
+      eopAdd:
         if ResolvedEl.BaseType in (btAllInteger+btAllFloats) then
           exit
         else if IsGenericTemplType(ResolvedEl) then
@@ -27928,6 +27928,24 @@ begin
         else
           RaiseMsg(20170216152532,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
             [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
+      eopSubtract:
+        if ResolvedEl.BaseType in (btAllSignedInteger+btAllFloats) then
+          exit
+        else if ResolvedEl.BaseType in btAllInteger then
+          begin
+          case ResolvedEl.BaseType of
+          btByte,btWord:
+            ResolvedEl.BaseType:=btLongint;
+          btLongWord,btUIntDouble:
+            ResolvedEl.BaseType:=btIntDouble;
+          end;
+          exit;
+          end
+        else if IsGenericTemplType(ResolvedEl) then
+          exit
+        else
+          RaiseMsg(20210815225815,nIllegalQualifierInFrontOf,sIllegalQualifierInFrontOf,
+            [OpcodeStrings[TUnaryExpr(El).OpCode],GetResolverResultDescription(ResolvedEl)],El);
       eopNot:
         begin
           if ResolvedEl.BaseType in (btAllInteger+btAllBooleans) then

packages/fcl-passrc/tests/testpassrc.pp

@@ -0,0 +1,32 @@
+{ %OPT=-Sc }
+program testpassrc;
+
+{$mode objfpc}{$H+}
+
+uses
+  //MemCheck,
+  Classes, consoletestrunner, tcscanner,  tctypeparser, tcstatements,
+  tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype,
+  tcexprparser, tcprocfunc, tcpassrcutil, tcresolver, tcgenerics,
+  tcuseanalyzer, pasresolveeval, tcresolvegenerics;
+
+type
+
+  { TLazTestRunner }
+
+  TMyTestRunner = class(TTestRunner)
+  protected
+  // override the protected methods of TTestRunner to customize its behavior
+  end;
+
+var
+  Application: TMyTestRunner;
+
+begin
+  Application := TMyTestRunner.Create(nil);
+  DefaultFormat:=fplain;
+  DefaultRunAllTests:=True;
+  Application.Initialize;
+  Application.Run;
+  Application.Free;
+end.

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

@@ -67,11 +67,14 @@ Type
   private
     FDataRead : Int64;
     FContentLength : Int64;
+    FRequestDataWritten : Int64;
+    FRequestContentLength : Int64;
     FAllowRedirect: Boolean;
     FKeepConnection: Boolean;
     FMaxChunkSize: SizeUInt;
     FMaxRedirects: Byte;
     FOnDataReceived: TDataEvent;
+    FOnDataSent: TDataEvent;
     FOnHeaders: TNotifyEvent;
     FOnPassword: TPasswordEvent;
     FOnRedirect: TRedirectEvent;
@@ -130,12 +133,18 @@ Type
     Function CreateProxyData : TProxyData;
     // Called whenever data is read.
     Procedure DoDataRead; virtual;
+    // Called whenever data is written.
+    Procedure DoDataWrite; virtual;
     // Parse response status line. Saves status text and protocol, returns numerical code. Exception if invalid line.
     Function ParseStatusLine(AStatusLine : String) : Integer;
     // Construct server URL for use in request line.
     function GetServerURL(URI: TURI): String;
     // Read 1 line of response. Fills FBuffer
     function ReadString(out S: String): Boolean;
+    // Write string
+    function WriteString(S: String): Boolean;
+    // Write the request body
+    function WriteRequestBody: Boolean;
     // Check if response code is in AllowedResponseCodes. if not, an exception is raised.
     // If AllowRedirect is true, and the result is a Redirect status code, the result is also true
     // If the OnPassword event is set, then a 401 will also result in True.
@@ -336,6 +345,8 @@ Type
     Property OnPassword : TPasswordEvent Read FOnPassword Write FOnPassword;
     // Called whenever data is read from the connection.
     Property OnDataReceived : TDataEvent Read FOnDataReceived Write FOnDataReceived;
+    // Called whenever data is written to the connection.
+    Property OnDataSent : TDataEvent Read FOnDataSent Write FOnDataSent;
     // Called when headers have been processed.
     Property OnHeaders : TNotifyEvent Read FOnHeaders Write FOnHeaders;
     // Called to create socket handler. If not set, or Nil is returned, a standard socket handler is created.
@@ -368,6 +379,7 @@ Type
     Property Password;
     Property OnPassword;
     Property OnDataReceived;
+    Property OnDataSent;
     Property OnHeaders;
     Property OnGetSocketHandler;
     Property Proxy;
@@ -378,6 +390,12 @@ Type
   end;
 
   EHTTPClient = Class(EHTTP);
+  // client socket exceptions
+  EHTTPClientSocket = class(EHTTPClient);
+  // reading from socket
+  EHTTPClientSocketRead = Class(EHTTPClientSocket);
+  // writing to socket
+  EHTTPClientSocketWrite = Class(EHTTPClientSocket);
 
 Function EncodeURLElement(S : String) : String;
 Function DecodeURLElement(Const S : String) : String;
@@ -387,6 +405,7 @@ implementation
 resourcestring
   SErrInvalidProtocol = 'Invalid protocol : "%s"';
   SErrReadingSocket = 'Error reading data from socket';
+  SErrWritingSocket = 'Error writing data to socket';
   SErrInvalidProtocolVersion = 'Invalid protocol version in response: "%s"';
   SErrInvalidStatusCode = 'Invalid response status code: %s';
   SErrUnexpectedResponse = 'Unexpected response status code: %d';
@@ -557,6 +576,12 @@ begin
     FOnDataReceived(Self,FContentLength,FDataRead);
 end;
 
+procedure TFPCustomHTTPClient.DoDataWrite;
+begin
+  If Assigned(FOnDataSent) Then
+    FOnDataSent(Self,FRequestContentLength,FRequestDataWritten);
+end;
+
 function TFPCustomHTTPClient.IndexOfHeader(const AHeader: String): Integer;
 begin
   Result:=IndexOfHeader(RequestHeaders,AHeader);
@@ -736,10 +761,15 @@ begin
   FSentCookies:=FCookies;
   FCookies:=Nil;
   S:=S+CRLF;
-  if not Terminated then
-    FSocket.WriteBuffer(S[1],Length(S));
-  If Assigned(FRequestBody) and not Terminated then
-    FSocket.CopyFrom(FRequestBody,FRequestBody.Size);
+  if Assigned(FRequestBody) then
+    FRequestContentLength:=FRequestBody.Size
+  else
+    FRequestContentLength:=0;
+  FRequestDataWritten:=0;
+  if not Terminated and not WriteString(S) then
+    raise EHTTPClientSocketWrite.Create(SErrWritingSocket);
+  if not Terminated and Assigned(FRequestBody) and not WriteRequestBody then
+    raise EHTTPClientSocketWrite.Create(SErrWritingSocket);
 end;
 
 function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
@@ -757,7 +787,7 @@ function TFPCustomHTTPClient.ReadString(out S: String): Boolean;
     If (r=0) or Terminated Then
       Exit(False);
     If (r<0) then
-      Raise EHTTPClient.Create(SErrReadingSocket);
+      Raise EHTTPClientSocketRead.Create(SErrReadingSocket);
     if (r<ReadBuflen) then
       SetLength(FBuffer,r);
     FDataRead:=FDataRead+R;
@@ -812,6 +842,68 @@ begin
   until Result or Terminated;
 end;
 
+function TFPCustomHTTPClient.WriteString(S: String): Boolean;
+var
+  r,t : Longint;
+
+begin
+  if S='' then
+    Exit(True);
+
+  T:=0;
+  Repeat
+     r:=FSocket.Write(S[t+1],Length(S)-t);
+     inc(t,r);
+     DoDataWrite;
+  Until Terminated or (t=Length(S)) or (r<=0);
+
+  Result := t=Length(S);
+end;
+
+function TFPCustomHTTPClient.WriteRequestBody: Boolean;
+var
+   Buffer: Pointer;
+   BufferSize, i,t,w: LongInt;
+   s, SourceSize: int64;
+
+const
+   MaxSize = $20000;
+begin
+   if not Assigned(FRequestBody) or (FRequestBody.Size=0) then
+    Exit(True);
+
+   FRequestBody.Position:=0;   // This WILL fail for non-seekable streams...
+   BufferSize:=MaxSize;
+   SourceSize:=FRequestBody.Size;
+   if (SourceSize<BufferSize) then
+     BufferSize:=SourceSize;    // do not allocate more than needed
+
+   s:=0;
+   GetMem(Buffer,BufferSize);
+   try
+     repeat
+       i:=FRequestBody.Read(buffer^,BufferSize);
+       if i>0 then
+       begin
+         T:=0;
+         Repeat
+           w:=FSocket.Write(PByte(Buffer)[t],i-t);
+           FRequestDataWritten:=FRequestDataWritten+w;
+           DoDataWrite;
+           inc(t,w);
+         Until Terminated or (t=i) or (w<=0);
+         if t<>i then
+           Exit(False);
+         Inc(s,i);
+       end;
+     until Terminated or (s=SourceSize) or (i<=0);
+   finally
+     FreeMem(Buffer);
+   end;
+
+   Result:=s=SourceSize;
+end;
+
 Function GetNextWord(Var S : String) : string;
 
 Const
@@ -1031,7 +1123,7 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
   begin
     Result:=FSocket.Read(FBuffer[1],LB);
     If Result<0 then
-      Raise EHTTPClient.Create(SErrReadingSocket);
+      Raise EHTTPClientSocketRead.Create(SErrReadingSocket);
     if (Result>0) then
       begin
       FDataRead:=FDataRead+Result;
@@ -1065,7 +1157,7 @@ Function TFPCustomHTTPClient.ReadResponse(Stream: TStream;
       SetLength(FBuffer,ReadBuflen);
       Cnt:=FSocket.Read(FBuffer[1],length(FBuffer));
       If Cnt<0 then
-        Raise EHTTPClient.Create(SErrReadingSocket);
+        Raise EHTTPClientSocketRead.Create(SErrReadingSocket);
       SetLength(FBuffer,Cnt);
       BufPos:=1;
       Result:=Cnt>0;
@@ -1280,14 +1372,23 @@ begin
     If Not IsConnected Then
       ConnectToServer(CHost,CPort,AIsHttps);
     Try
-      if not Terminated then
+      if Terminated then
+        break;
+      try
         SendRequest(AMethod,AURI);
-      if not Terminated then
-        begin
+        if Terminated then
+          break;
         T := ReadResponse(AStream,AAllowedResponseCodes,AHeadersOnly);
-        If Not T Then
-          ReconnectToServer(CHost,CPort,AIsHttps);
+      except
+        on E: EHTTPClientSocket do
+        begin
+          // failed socket operations raise exceptions - e.g. if ReadString() fails
+          // try to reconnect also in this case
+          T:=False;
         end;
+      end;
+      If Not T and Not Terminated Then
+        ReconnectToServer(CHost,CPort,AIsHttps);
     Finally
       // On terminate, we close the request
       If HasConnectionClose or Terminated Then

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

@@ -20,7 +20,7 @@ unit fphttpserver;
 interface
 
 uses
-  Classes, SysUtils, sockets, sslbase, sslsockets, ssockets, resolve, httpdefs;
+  Classes, SysUtils, sockets, sslbase, sslsockets, ssockets, resolve, httpprotocol, httpdefs;
 
 Const
   ReadBufLen = 4096;
@@ -236,7 +236,7 @@ Type
 
   EHTTPServer = Class(EHTTP);
 
-  Function GetStatusCode (ACode: Integer) : String;
+  Function GetStatusCode (ACode: Integer) : String; deprecated 'Use GetHTTPStatusText from unit httpprotocol';
 
 implementation
 
@@ -250,62 +250,7 @@ resourcestring
 Function GetStatusCode (ACode: Integer) : String;
 
 begin
-  Case ACode of
-    100 :  Result:='Continue';
-    101 :  Result:='Switching Protocols';
-    200 :  Result:='OK';
-    201 :  Result:='Created';
-    202 :  Result:='Accepted';
-    203 :  Result:='Non-Authoritative Information';
-    204 :  Result:='No Content';
-    205 :  Result:='Reset Content';
-    206 :  Result:='Partial Content';
-    300 :  Result:='Multiple Choices';
-    301 :  Result:='Moved Permanently';
-    302 :  Result:='Found';
-    303 :  Result:='See Other';
-    304 :  Result:='Not Modified';
-    305 :  Result:='Use Proxy';
-    307 :  Result:='Temporary Redirect';
-    400 :  Result:='Bad Request';
-    401 :  Result:='Unauthorized';
-    402 :  Result:='Payment Required';
-    403 :  Result:='Forbidden';
-    404 :  Result:='Not Found';
-    405 :  Result:='Method Not Allowed';
-    406 :  Result:='Not Acceptable';
-    407 :  Result:='Proxy Authentication Required';
-    408 :  Result:='Request Time-out';
-    409 :  Result:='Conflict';
-    410 :  Result:='Gone';
-    411 :  Result:='Length Required';
-    412 :  Result:='Precondition Failed';
-    413 :  Result:='Request Entity Too Large';
-    414 :  Result:='Request-URI Too Large';
-    415 :  Result:='Unsupported Media Type';
-    416 :  Result:='Requested range not satisfiable';
-    417 :  Result:='Expectation Failed';
-    418 :  Result:='I''m a teapot';
-    421 :  Result:='Misdirected Request';
-    422 :  Result:='Unprocessable Entity';
-    423 :  Result:='Locked';
-    424 :  Result:='Failed Dependency';
-    425 :  Result:='Too Early';
-    426 :  Result:='Upgrade Required';
-    428 :  Result:='Precondition Required';
-    429 :  Result:='Too Many Requests';
-    431 :  Result:='Request Header Fields Too Large';
-    451 :  Result:='Unavailable For Legal Reasons';
-
-    500 :  Result:='Internal Server Error';
-    501 :  Result:='Not Implemented';
-    502 :  Result:='Bad Gateway';
-    503 :  Result:='Service Unavailable';
-    504 :  Result:='Gateway Time-out';
-    505 :  Result:='HTTP Version not supported';
-  else
-    Result:='Unknown status';
-  end;
+  Result := GetHTTPStatusText(ACode);
 end;
 
 Function GetHostNameByAddress(const AnAddress: String): String;
@@ -353,7 +298,7 @@ Var
   S : String;
   I : Integer;
 begin
-  S:=Format('HTTP/1.1 %3d %s'#13#10,[Code,GetStatusCode(Code)]);
+  S:=Format('HTTP/1.1 %3d %s'#13#10,[Code,GetHTTPStatusText(Code)]);
   For I:=0 to Headers.Count-1 do
     S:=S+Headers[i]+#13#10;
   // Last line in headers is empty.
@@ -533,6 +478,7 @@ begin
     if (P>0) then
       begin
       Move(FBuffer[1],S[1],P);
+      FBuffer:='';
       L:=L-P;
       end;
     P:=P+1;

packages/fcl-web/src/base/fphttpstatus.pas

@@ -5,7 +5,7 @@ unit FPHTTPStatus;
 interface
 
 uses
-  SysUtils, fphttpserver, HTTPDefs;
+  SysUtils, fphttpserver, httpprotocol, HTTPDefs;
 
 (* construct and return the default error message for a given
  * HTTP defined error code
@@ -186,8 +186,8 @@ var
   title: string;
   h1: string;
 begin
-  title := Format('%d %s', [status, GetStatusCode(status)]);
-  h1 := GetStatusCode(status);
+  h1 := GetHTTPStatusText(status);
+  title := Format('%d %s', [status, h1]);
 
   Result := '<!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML//EN">' +
     '<html><head><title>' + title +

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

@@ -133,6 +133,7 @@ Function HTTPDecode(const AStr: String): String;
 Function HTTPEncode(const AStr: String): String;
 Function IncludeHTTPPathDelimiter(const AStr: String): String;
 Function ExcludeHTTPPathDelimiter(const AStr: String): String;
+Function GetHTTPStatusText (ACode: Integer) : String;
 
 implementation
 
@@ -268,5 +269,66 @@ begin
     Result:=AStr;
 end;
 
+Function GetHTTPStatusText (ACode: Integer) : String;
+
+begin
+  Case ACode of
+    100 :  Result:='Continue';
+    101 :  Result:='Switching Protocols';
+    200 :  Result:='OK';
+    201 :  Result:='Created';
+    202 :  Result:='Accepted';
+    203 :  Result:='Non-Authoritative Information';
+    204 :  Result:='No Content';
+    205 :  Result:='Reset Content';
+    206 :  Result:='Partial Content';
+    300 :  Result:='Multiple Choices';
+    301 :  Result:='Moved Permanently';
+    302 :  Result:='Found';
+    303 :  Result:='See Other';
+    304 :  Result:='Not Modified';
+    305 :  Result:='Use Proxy';
+    307 :  Result:='Temporary Redirect';
+    400 :  Result:='Bad Request';
+    401 :  Result:='Unauthorized';
+    402 :  Result:='Payment Required';
+    403 :  Result:='Forbidden';
+    404 :  Result:='Not Found';
+    405 :  Result:='Method Not Allowed';
+    406 :  Result:='Not Acceptable';
+    407 :  Result:='Proxy Authentication Required';
+    408 :  Result:='Request Time-out';
+    409 :  Result:='Conflict';
+    410 :  Result:='Gone';
+    411 :  Result:='Length Required';
+    412 :  Result:='Precondition Failed';
+    413 :  Result:='Request Entity Too Large';
+    414 :  Result:='Request-URI Too Large';
+    415 :  Result:='Unsupported Media Type';
+    416 :  Result:='Requested range not satisfiable';
+    417 :  Result:='Expectation Failed';
+    418 :  Result:='I''m a teapot';
+    421 :  Result:='Misdirected Request';
+    422 :  Result:='Unprocessable Entity';
+    423 :  Result:='Locked';
+    424 :  Result:='Failed Dependency';
+    425 :  Result:='Too Early';
+    426 :  Result:='Upgrade Required';
+    428 :  Result:='Precondition Required';
+    429 :  Result:='Too Many Requests';
+    431 :  Result:='Request Header Fields Too Large';
+    451 :  Result:='Unavailable For Legal Reasons';
+
+    500 :  Result:='Internal Server Error';
+    501 :  Result:='Not Implemented';
+    502 :  Result:='Bad Gateway';
+    503 :  Result:='Service Unavailable';
+    504 :  Result:='Gateway Time-out';
+    505 :  Result:='HTTP Version not supported';
+  else
+    Result:='Unknown status';
+  end;
+end;
+
 end.
 

packages/openssl/src/opensslsockets.pp

@@ -22,6 +22,7 @@ Type
     Function FetchErrorInfo: Boolean;
     function CheckSSL(SSLResult: Integer): Boolean;
     function CheckSSL(SSLResult: Pointer): Boolean;
+    function CreateSSLContext(AType: TSSLType): TSSLContext; virtual;
     function InitContext(NeedCertificate: Boolean): Boolean; virtual;
     function DoneContext: Boolean; virtual;
     function InitSslKeys: boolean;virtual;
@@ -49,6 +50,8 @@ implementation
 { TSocketHandler }
 Resourcestring
   SErrNoLibraryInit = 'Could not initialize OpenSSL library';
+  SErrCouldNotCreateSelfSignedCertificate = 'Failed to create self-signed certificate';
+  SErrCouldNotInitSSLKeys = 'Failed to initialize SSL keys';
 
 Procedure MaybeInitSSLInterface;
 
@@ -63,6 +66,11 @@ begin
   Result:=TOpenSSLX509Certificate.Create;
 end;
 
+function TOpenSSLSocketHandler.CreateSSLContext(AType: TSSLType): TSSLContext;
+begin
+  Result := TSSLContext.Create(AType);
+end;
+
 procedure TOpenSSLSocketHandler.SetSSLLastErrorString(AValue: string);
 begin
   if FSSLLastErrorString=AValue then Exit;
@@ -215,11 +223,10 @@ begin
   if Not Result then
     Exit;
   try
-    FCTX:=TSSLContext.Create(SSLType);
+    FCTX:=CreateSSLContext(SSLType);
   Except
     CheckSSL(Nil);
-    Result:=False;
-    Exit;
+    raise;
   end;
   S:=CertificateData.CipherList;
   FCTX.SetCipherList(S);
@@ -230,12 +237,12 @@ begin
     if Not CreateSelfSignedCertificate then
       begin
       DoneContext;
-      Exit(False);
+      raise ESSL.Create(SErrCouldNotCreateSelfSignedCertificate);
       end;
    if Not InitSSLKeys then
      begin
      DoneContext;
-     Exit(False);
+     raise ESSL.Create(SErrCouldNotInitSSLKeys);
      end;
    try
      FSSL:=TSSL.Create(FCTX);
@@ -243,7 +250,7 @@ begin
    Except
      CheckSSL(Nil);
      DoneContext;
-     Result:=False;
+     raise;
    end;
 end;
 

packages/pastojs/src/fppas2js.pp

@@ -462,6 +462,9 @@ unit FPPas2Js;
   {$define HasInt64}
 {$endif}
 
+{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
+{$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
+
 interface
 
 uses
@@ -2076,6 +2079,7 @@ type
       RTLFunc: TPas2JSBuiltInName; PosEl: TPasElement): TJSCallExpression; virtual;
     Function CreateRangeCheckCall_TypeRange(aType: TPasType; GetExpr: TJSElement;
       AContext: TConvertContext; PosEl: TPasElement): TJSCallExpression; virtual;
+    Procedure PrepareAssignDifferentIntegers(El: TPasImplAssign; AssignContext: TAssignContext); virtual;
     // reference
     Function CreateReferencePath(El: TPasElement; AContext: TConvertContext;
       Kind: TRefPathKind; Full: boolean = false; Ref: TResolvedReference = nil): string; virtual;
@@ -13745,7 +13749,6 @@ begin
       end;
     btString:
       begin
-        writeln('AAA1 TPasToJSConverter.ConvertBuiltIn_LowHigh ',IsLow);
       if isLow then
         // low(aString) -> 1
         Result:=CreateLiteralNumber(El,1)
@@ -14262,7 +14265,7 @@ begin
     RaiseInconsistency(20190129102200,El);
   Param := El.Params[0];
   AContext.Resolver.ComputeElement(Param,ResolvedParam,[]);
-  if not (ResolvedParam.BaseType in btAllInteger) then
+  if not (ResolvedParam.BaseType in btAllJSInteger) then
     DoError(20190129121100,nXExpectedButYFound,sXExpectedButYFound,['integer type',
       AContext.Resolver.GetResolverResultDescription(ResolvedParam)],Param);
   Shift := AContext.Resolver.GetShiftAndMaskForLoHiFunc(ResolvedParam.BaseType,IsLoFunc,Mask);
@@ -22301,6 +22304,7 @@ begin
       end;
     if AssignContext.RightSide=nil then
       AssignContext.RightSide:=ConvertExpression(El.right,AContext);
+
     if (AssignContext.RightResolved.BaseType in [btSet,btArrayOrSet])
         and (AssignContext.RightResolved.IdentEl<>nil) then
       begin
@@ -22335,6 +22339,13 @@ begin
       // e.g. double := currency  ->  double := currency/10000
       AssignContext.RightSide:=CreateDivideNumber(El,AssignContext.RightSide,10000);
       end
+    else if (AssignContext.LeftResolved.BaseType<>AssignContext.RightResolved.BaseType)
+        and (AssignContext.LeftResolved.BaseType in btAllJSInteger)
+        and (AssignContext.RightResolved.BaseType in btAllJSInteger) then
+      begin
+      // AnInteger := OtherInteger
+      PrepareAssignDifferentIntegers(El,AssignContext);
+      end
     else if AssignContext.RightResolved.BaseType in btAllStringAndChars then
       begin
       if AssignContext.LeftResolved.BaseType=btContext then
@@ -22539,6 +22550,7 @@ begin
       if (bsRangeChecks in AContext.ScannerBoolSwitches)
           and not (T.Expr is TJSLiteral) then
         begin
+        // range checks
         if AssignContext.LeftResolved.BaseType in btAllJSInteger then
           begin
           if LeftTypeEl is TPasUnresolvedSymbolRef then
@@ -24800,6 +24812,97 @@ begin
   end;
 end;
 
+procedure TPasToJSConverter.PrepareAssignDifferentIntegers(El: TPasImplAssign;
+  AssignContext: TAssignContext);
+
+  function CutToUIntDouble(IntValue: TMaxPrecInt): TMaxPrecInt;
+  begin
+    {$IFDEF pas2js}
+    Result:=((IntValue div $80000000) and $003fffff)*$80000000 +(IntValue and $7FFFFFFF);
+    {$ELSE}
+    Result:=IntValue and MaxSafeIntDouble;
+    {$ENDIF}
+  end;
+
+var
+  aResolver: TPas2JSResolver;
+  LeftBT, RightBT: TResolverBaseType;
+  Value: TResEvalValue;
+  IntValue, LeftMinVal, LeftMaxVal, RightMinVal, RightMaxVal: TMaxPrecInt;
+begin
+  aResolver:=AssignContext.Resolver;
+  LeftBT:=AssignContext.LeftResolved.BaseType;
+  RightBT:=AssignContext.RightResolved.BaseType;
+
+  if not aResolver.GetIntegerRange(LeftBT,LeftMinVal,LeftMaxVal) then
+    RaiseNotSupported(El.left,AssignContext,20210815195159);
+  if not aResolver.GetIntegerRange(RightBT,RightMinVal,RightMaxVal) then
+    RaiseNotSupported(El.right,AssignContext,20210815195228);
+  if (LeftMinVal<=RightMinVal) and (LeftMaxVal>=RightMaxVal) then
+    exit; // right is subset of left
+
+  // right might not fit into left
+
+  Value:=aResolver.Eval(El.right,[]);
+  try
+    if Value<>nil then
+      begin
+      if Value.Kind=revkInt then
+        begin
+        IntValue:=TResEvalInt(Value).Int;
+        if (IntValue>=LeftMinVal) and (IntValue<=LeftMaxVal) then
+          exit;
+        end
+      else if Value.Kind=revkUInt then
+        begin
+        if TResEvalUInt(Value).UInt<=HighIntAsUInt then
+          begin
+          IntValue:=TMaxPrecInt(TResEvalUInt(Value).UInt);
+          if (IntValue>=LeftMinVal) and (IntValue<=LeftMaxVal) then
+            exit;
+          end
+        else
+          {$IFDEF Pas2js}
+          RaiseNotSupported(El.right,AssignContext,20210815214534);
+          {$ELSE}
+          IntValue:=PMaxPrecInt(@TResEvalUInt(Value).UInt)^;
+          {$ENDIF}
+        end
+      else
+        RaiseNotSupported(El.right,AssignContext,20210815204203,'right='+Value.AsDebugString);
+
+      case LeftBT of
+      btByte: IntValue:=IntValue and $FF; // Note: "and" handles negative numbers
+      btShortInt:
+        begin
+        IntValue:=(IntValue and $FF);
+        if IntValue>$7F then IntValue:=IntValue-$100;
+        end;
+      btWord: IntValue:=IntValue and $FFFF;
+      btSmallInt:
+        begin
+        IntValue:=(IntValue and $FFFF);
+        if IntValue>$7FFF then IntValue:=IntValue-$10000;
+        end;
+      btLongWord: IntValue:=IntValue and $FFFFFFFF;
+      btLongint:
+        begin
+        IntValue:=(IntValue and $FFFFFFFF);
+        if IntValue>$7FFFFFFF then IntValue:=IntValue-$100000000;
+        end;
+      btUIntDouble:
+        IntValue:=CutToUIntDouble(IntValue);
+      btIntDouble:
+        IntValue:=CutToUIntDouble(IntValue);
+      end;
+
+      AssignContext.RightSide:=CreateLiteralNumber(El.right,IntValue);
+      end;
+  finally
+    ReleaseEvalValue(Value);
+  end;
+end;
+
 function TPasToJSConverter.CreateReferencePath(El: TPasElement;
   AContext: TConvertContext; Kind: TRefPathKind; Full: boolean;
   Ref: TResolvedReference): string;

packages/pastojs/tests/tcmodules.pas

@@ -277,6 +277,7 @@ type
     Procedure TestInteger_BitwiseShrNativeInt;
     Procedure TestInteger_BitwiseShlNativeInt;
     Procedure TestInteger_SystemFunc;
+    Procedure TestInteger_AssignOutsideConst;
     Procedure TestCurrency;
     Procedure TestForBoolDo;
     Procedure TestForIntDo;
@@ -3159,8 +3160,8 @@ begin
     'this.HiByte2 = (0x1234 >> 8) & 0xFF;',
     'this.LoWord1 = 0x1234CDEF & 0xFFFF;',
     'this.HiWord1 = (0x1234CDEF >> 16) & 0xFFFF;',
-    'this.LoWord2 = -0x1234CDEF & 0xFFFF;',
-    'this.HiWord2 = (-0x1234CDEF >> 16) & 0xFFFF;',
+    'this.LoWord2 = -0x1234CDEF >>> 0;',
+    'this.HiWord2 = Math.floor(-0x1234CDEF / 4294967296) >>> 0;',
     'this.lo4 = 0x34 & 0xF;',
     'this.hi4 = (0x34 >> 4) & 0xF;',
     'this.lo5 = (((-0x34 & 255) << 24) >> 24) & 0xFF;',
@@ -7463,6 +7464,106 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestInteger_AssignOutsideConst;
+begin
+  StartProgram(false);
+  Add([
+  'const',
+  '  MinInt = low(longint);',
+  '  MaxInt = high(longint);',
+  'type',
+  '  {#TMyInt}TMyInt = MinInt..MaxInt;',
+  'var',
+  '  i: TMyInt;',
+  '  aByte: byte;',
+  '  aShortInt: shortint;',
+  '  aWord: word;',
+  '  aSmallInt: smallint;',
+  '  aLongWord: longword;',
+  '  aLongInt: longint;',
+  '  aNativeInt: nativeint;',
+  '  aNativeUInt: nativeuint;',
+  'begin',
+  '  aByte:=$FF;',
+  '  aByte:=$100;',
+  '  aByte:=-1;',
+  '  aByte:=-127;',
+  '  aByte:=-128;',
+  '  aByte:=-254;',
+  '  aByte:=-255;',
+  '  aByte:=-256;',
+  '  aShortInt:=127;',
+  '  aShortInt:=128;',
+  '  aShortInt:=-128;',
+  '  aShortInt:=-129;',
+  '  aWord:=$ffff;',
+  '  aWord:=$10000;',
+  '  aWord:=-1;',
+  '  aWord:=-$ffff;',
+  '  aWord:=-$10000;',
+  '  aWord:=-$10001;',
+  '  aSmallInt:=$7fff;',
+  '  aSmallInt:=$8000;',
+  '  aSmallInt:=-$8000;',
+  '  aSmallInt:=-$8001;',
+  '  aLongWord:=$ffffffff;',
+  '  aLongWord:=$100000000;',
+  '  aLongWord:=-1;',
+  '  aLongWord:=-$ffffffff;',
+  '  aNativeInt:=$1fffffffffffff;',
+  '  aNativeInt:=-$1fffffffffffff;',
+  '  aNativeUInt:=$1fffffffffffff;',
+  '  aNativeUInt:=-$1fffffffffffff;',
+  '']);
+  ConvertProgram;
+  CheckSource('TestInteger_AssignOutsideConst',
+    LinesToStr([
+    'this.MinInt = -2147483648;',
+    'this.MaxInt = 2147483647;',
+    'this.i = 0;',
+    'this.aByte = 0;',
+    'this.aShortInt = 0;',
+    'this.aWord = 0;',
+    'this.aSmallInt = 0;',
+    'this.aLongWord = 0;',
+    'this.aLongInt = 0;',
+    'this.aNativeInt = 0;',
+    'this.aNativeUInt = 0;',
+    '']),
+    LinesToStr([
+    '$mod.aByte = 0xFF;',
+    '$mod.aByte = 0;',
+    '$mod.aByte = 255;',
+    '$mod.aByte = 129;',
+    '$mod.aByte = 128;',
+    '$mod.aByte = 2;',
+    '$mod.aByte = 1;',
+    '$mod.aByte = 0;',
+    '$mod.aShortInt = 127;',
+    '$mod.aShortInt = -128;',
+    '$mod.aShortInt = -128;',
+    '$mod.aShortInt = 127;',
+    '$mod.aWord = 0xffff;',
+    '$mod.aWord = 0;',
+    '$mod.aWord = 65535;',
+    '$mod.aWord = 1;',
+    '$mod.aWord = 0;',
+    '$mod.aWord = 65535;',
+    '$mod.aSmallInt = 0x7fff;',
+    '$mod.aSmallInt = -32768;',
+    '$mod.aSmallInt = -0x8000;',
+    '$mod.aSmallInt = 32767;',
+    '$mod.aLongWord = 0xffffffff;',
+    '$mod.aLongWord = 0;',
+    '$mod.aLongWord = 4294967295;',
+    '$mod.aLongWord = 1;',
+    '$mod.aNativeInt = 0x1fffffffffffff;',
+    '$mod.aNativeInt = -0x1fffffffffffff;',
+    '$mod.aNativeUInt = 0x1fffffffffffff;',
+    '$mod.aNativeUInt = 1;',
+    '']));
+end;
+
 procedure TTestModule.TestCurrency;
 begin
   StartProgram(false);

packages/pastojs/tests/testpas2js.pp

@@ -1,3 +1,4 @@
+{ %OPT=-Sc }
 {
     This file is part of the Free Component Library (FCL)
     Copyright (c) 2014 by Michael Van Canneyt

packages/rtl-objpas/src/inc/strutils.pp

@@ -74,6 +74,7 @@ Function AnsiReverseString(const AText: AnsiString): AnsiString;inline;
 Function StuffString(const AText: string; AStart, ALength: Cardinal;  const ASubText: string): string;
 Function RandomFrom(const AValues: array of string): string; overload;
 Function IfThen(AValue: Boolean; const ATrue: string; const AFalse: string = ''): string; overload;
+Function IfThen(AValue: Boolean; const ATrue: TStringDynArray; const AFalse: TStringDynArray = nil): TStringDynArray; overload;
 function NaturalCompareText (const S1 , S2 : string ): Integer ;
 function NaturalCompareText(const Str1, Str2: string; const ADecSeparator, AThousandSeparator: Char): Integer;
 
@@ -1227,6 +1228,15 @@ begin
     result:=afalse;
 end;
 
+Function IfThen(AValue: Boolean; const ATrue: TStringDynArray; const AFalse: TStringDynArray = nil): TStringDynArray; overload;
+
+begin
+  if avalue then
+    result:=atrue
+  else
+    result:=afalse;
+end;
+
 function NaturalCompareText(const Str1, Str2: string; const ADecSeparator, AThousandSeparator: Char): Integer;
 {
  NaturalCompareBase compares strings in a collated order and

rtl/objpas/classes/classes.inc

@@ -2459,6 +2459,15 @@ end;
 
 { Utility routines }
 
+
+Function IfThen(AValue: Boolean; const ATrue: TStringList; const AFalse: TStringList = nil): TStringList; overload;
+begin
+  if avalue then
+    result:=atrue
+  else
+    result:=afalse;
+end;
+
 function LineStart(Buffer, BufPos: PChar): PChar;
 
 begin

rtl/objpas/classes/classesh.inc

@@ -2469,4 +2469,4 @@ function LineStart(Buffer, BufPos: PChar): PChar;
 procedure BinToHex(BinValue, HexValue: PChar; BinBufSize: Integer); deprecated 'use procedures from unit StrUtils';
 function HexToBin(HexValue, BinValue: PChar; BinBufSize: Integer): Integer;
 function ExtractStrings(Separators, WhiteSpace: TSysCharSet; Content: PChar; Strings: TStrings; AddEmptyStrings : Boolean = False): Integer;
-
+Function IfThen(AValue: Boolean; const ATrue: TStringList; const AFalse: TStringList = nil): TStringList; overload;

rtl/objpas/sysutils/dati.inc

@@ -1089,8 +1089,8 @@ var
           else
             raise EConvertError.Create('Illegal character in format string');
         end ;
-        '/': StoreStr(@FormatSettings.DateSeparator, 1);
-        ':': StoreStr(@FormatSettings.TimeSeparator, 1);
+        '/': if FormatSettings.DateSeparator<>#0 then StoreStr(@FormatSettings.DateSeparator, 1);
+        ':': if FormatSettings.TimeSeparator<>#0 then StoreStr(@FormatSettings.TimeSeparator, 1);
         '[': if (fdoInterval in Options) then isInterval := true else StoreStr(FormatCurrent, 1);
         ']': if (fdoInterval in Options) then isInterval := false else StoreStr(FormatCurrent, 1);
         ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y', 'Z', 'F' {$IFDEF MSWindows}, 'G', 'E'{$ENDIF MSWindows} :

rtl/objpas/types.pp

@@ -174,10 +174,10 @@ type
 
     public
      Type TSingle3Array = array[0..2] of single;
-     var
      constructor Create(const ax,ay,az:single);
      procedure   Offset(const adeltax,adeltay,adeltaz:single); inline;
      procedure   Offset(const adelta:TPoint3D); inline;
+   public  
      case Integer of
       0: (data:TSingle3Array);
       1: (x,y,z : single);

rtl/win/sysutils.pp

@@ -1197,6 +1197,21 @@ begin
 end;
 
 procedure GetLocaleFormatSettings(LCID: Integer; var FormatSettings: TFormatSettings);
+  function FixSeparator(const Format: string; const FromSeparator, ToSeparator: Char): string;
+  var
+    R: PChar;
+  begin
+    if (Format='') or (FromSeparator=ToSeparator) then
+      Exit(Format);
+    Result := Copy(Format, 1);
+    R := PChar(Result);
+    while R^<>#0 do
+      begin
+      if R^=FromSeparator then
+        R^:=ToSeparator;
+      Inc(R);
+      end;
+  end;
 var
   HF  : Shortstring;
   LID : Windows.LCID;
@@ -1218,8 +1233,8 @@ begin
         LongDayNames[I]:=GetLocaleStr(LID,LOCALE_SDAYNAME1+Day,LongDayNames[i]);
         end;
       DateSeparator := GetLocaleChar(LID, LOCALE_SDATE, '/');
-      ShortDateFormat := GetLocaleStr(LID, LOCALE_SSHORTDATE, 'm/d/yy');
-      LongDateFormat := GetLocaleStr(LID, LOCALE_SLONGDATE, 'mmmm d, yyyy');
+      ShortDateFormat := FixSeparator(GetLocaleStr(LID, LOCALE_SSHORTDATE, 'm/d/yy'), DateSeparator, '/');
+      LongDateFormat := FixSeparator(GetLocaleStr(LID, LOCALE_SLONGDATE, 'mmmm d, yyyy'), DateSeparator, '/');
       { Time stuff }
       TimeSeparator := GetLocaleChar(LID, LOCALE_STIME, ':');
       TimeAMString := GetLocaleStr(LID, LOCALE_S1159, 'AM');

rtl/x86_64/math.inc

@@ -295,7 +295,7 @@ const
             fnstcw oldcw
             fldt d
             movw oldcw,%cx
-            orw $0x0c3f,%cx
+            orw $0x0c00,%cx
             movw %cx,newcw
             fldcw newcw
             fld %st
@@ -315,7 +315,7 @@ const
       asm
             fnstcw oldcw
             movw oldcw,%cx
-            orw $0x0c3f,%cx
+            orw $0x0c00,%cx
             movw %cx,newcw
             fldcw newcw
             fldt d
@@ -336,7 +336,7 @@ const
       asm
         fnstcw oldcw
         movw oldcw,%cx
-        orw $0x0c3f,%cx
+        orw $0x0c00,%cx
         movw %cx,newcw
         fldcw newcw
         fldt d

tests/Makefile

@@ -2461,7 +2461,7 @@ TESTDIRECTDIRS=
 TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS))
 TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 fcl-net
 TESTPACKAGESUBDIRS=$(addprefix packages/,$(TESTPACKAGESDIRS))
-TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry
+TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry fcl-passrc fcl-json pastojs
 TESTPACKAGESDIRECTSUBDIRS=$(addprefix ../packages/,$(addsuffix /tests,$(TESTPACKAGESDIRECTDIRS)))
 ifdef QUICKTEST
 export QUICKTEST
@@ -2756,12 +2756,23 @@ distclean: clean fpc_distclean
 digest : utils
 	-$(DIGEST) $(LOG)
 SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
+GIT:=$(firstword $(wildcard $(addsuffix /git$(SRCEXEEXT),$(SEARCHPATH))))
+ifneq ($(wildcard ../.git),)
+ifneq ($(GIT),)
+GIT_GET_HASH=$(GIT) log -1 --format=%h
+SVN_TESTS_REV_STR=$(shell $(GIT_GET_HASH) .)
+SVN_COMPILER_REV_STR=$(shell $(GIT_GET_HASH) ../compiler)
+SVN_RTL_REV_STR=$(shell $(GIT_GET_HASH) ../rtl)
+SVN_PACKAGES_REV_STR=$(shell $(GIT_GET_HASH) ../packages)
+else
 ifneq ($(SVNVERSION),)
 SVN_TESTS_REV_STR=$(shell $(SVNVERSION) -c .)
 SVN_COMPILER_REV_STR=$(shell $(SVNVERSION) -c ../compiler)
 SVN_RTL_REV_STR=$(shell $(SVNVERSION) -c ../rtl)
 SVN_PACKAGES_REV_STR=$(shell $(SVNVERSION) -c ../packages)
 endif
+endif
+endif
 ifeq ($(TEST_COMMENT),)
 TEST_COMMENT=$(TEST_OPT)
 endif
@@ -2785,7 +2796,7 @@ endif
 ifneq ($(TEST_FPC_FULLVERSION),)
 	$(ECHOREDIR) CompilerFullVersion=$(TEST_FPC_FULLVERSION) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
 endif
-ifneq ($(SVNVERSION),)
+ifneq ($(SVN_TESTS_REV_STR),)
 	$(ECHOREDIR) svntestsrevision=$(SVN_TESTS_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
 	$(ECHOREDIR) svncompilerrevision=$(SVN_COMPILER_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
 	$(ECHOREDIR) svnrtlrevision=$(SVN_RTL_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg

tests/Makefile.fpc

@@ -164,7 +164,7 @@ TESTDIRECTDIRS=
 TESTSUBDIRS=cg cg/variants cg/cdecl cpu16 cpu16/i8086 library opt $(addprefix units/,$(TESTUNITDIRS))
 TESTPACKAGESDIRS=win-base webtbs hash fcl-registry fcl-process zlib fcl-db fcl-xml cocoaint bzip2 fcl-net
 TESTPACKAGESUBDIRS=$(addprefix packages/,$(TESTPACKAGESDIRS))
-TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry
+TESTPACKAGESDIRECTDIRS=rtl-objpas rtl-generics hash regexpr fcl-registry fcl-passrc fcl-json pastojs
 TESTPACKAGESDIRECTSUBDIRS=$(addprefix ../packages/,$(addsuffix /tests,$(TESTPACKAGESDIRECTDIRS)))
 
 ifdef QUICKTEST
@@ -620,12 +620,23 @@ digest : utils
 
 
 SVNVERSION:=$(firstword $(wildcard $(addsuffix /svnversion$(SRCEXEEXT),$(SEARCHPATH))))
+GIT:=$(firstword $(wildcard $(addsuffix /git$(SRCEXEEXT),$(SEARCHPATH))))
+ifneq ($(wildcard ../.git),)
+ifneq ($(GIT),)
+GIT_GET_HASH=$(GIT) log -1 --format=%h
+SVN_TESTS_REV_STR=$(shell $(GIT_GET_HASH) .)
+SVN_COMPILER_REV_STR=$(shell $(GIT_GET_HASH) ../compiler)
+SVN_RTL_REV_STR=$(shell $(GIT_GET_HASH) ../rtl)
+SVN_PACKAGES_REV_STR=$(shell $(GIT_GET_HASH) ../packages)
+else
 ifneq ($(SVNVERSION),)
 SVN_TESTS_REV_STR=$(shell $(SVNVERSION) -c .)
 SVN_COMPILER_REV_STR=$(shell $(SVNVERSION) -c ../compiler)
 SVN_RTL_REV_STR=$(shell $(SVNVERSION) -c ../rtl)
 SVN_PACKAGES_REV_STR=$(shell $(SVNVERSION) -c ../packages)
 endif
+endif
+endif
 
 ifeq ($(TEST_COMMENT),)
 TEST_COMMENT=$(TEST_OPT)
@@ -651,7 +662,7 @@ endif
 ifneq ($(TEST_FPC_FULLVERSION),)
         $(ECHOREDIR) CompilerFullVersion=$(TEST_FPC_FULLVERSION) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
 endif
-ifneq ($(SVNVERSION),)
+ifneq ($(SVN_TESTS_REV_STR),)
         $(ECHOREDIR) svntestsrevision=$(SVN_TESTS_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
         $(ECHOREDIR) svncompilerrevision=$(SVN_COMPILER_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg
         $(ECHOREDIR) svnrtlrevision=$(SVN_RTL_REV_STR) >> $(TEST_OUTPUTDIR)/dbdigest.cfg

tests/test/ttpinl.pp

@@ -0,0 +1,43 @@
+{ %cpu=i8086,i386 }
+
+{$ifdef fpc}
+{$mode tp}
+{$endif}
+
+procedure FillWord(var Dest; Count: Word; Data: Word);
+begin
+{$ifdef CPU386}
+  inline(
+    $8b/$7d/<Dest/        (* MOV   EDI,Dest  *)
+    $0f/$b7/$4d/<Count/   (* MOVZX ECX,Count *)
+    $66/$8b/$45/<Data/    (* MOV   AX,Data   *)
+    $fc/                  (* CLD             *)
+    $f3/$66/$ab);         (* REP   STOSW     *)
+{$else}
+  inline(
+    $C4/$7E/<Dest/        (* LES   DI,Dest[BP] *)
+    $8B/$4E/<Count/       (* MOV   CX,Count[BP]*)
+    $8B/$46/<Data/        (* MOV   AX,Data[BP] *)
+    $FC/                  (* CLD               *)
+    $F3/$AB);             (* REP   STOSW       *)
+{$endif}
+end;
+
+var
+  arr: array[1..10] of word;
+  i: integer;
+begin
+{$if sizeof(pointer)<4}
+  writeln('Skipping.');
+  Halt(0);
+{$endif}
+  FillChar(arr,sizeof(arr),$aa);
+  FillWord(arr,sizeof(arr) div 2,$55);
+  for i:=1 to 10 do
+    if arr[i]<>$55 then
+      begin
+        writeln('Wrong value: ', arr[i]);
+        Halt(1);
+      end;
+  writeln('OK.');
+end.

tests/webtbs/tw39296.pp

@@ -0,0 +1,26 @@
+{ %cpu=x86_64 }
+{ %skiptarget=win64 }
+
+function bytepara(b: byte; s: shortint): boolean; assembler; nostackframe;
+asm
+  xorl %eax, %eax
+  cmpl $5, %edi
+  seteb %al
+  cmpl $-3, %esi
+  seteb %dl
+  andb %dl, %al
+end;
+
+var
+  b1: byte;
+  s1: shortint;
+begin
+  b1:=5;
+  s1:=-3;
+  asm
+    movl $0x12345678, %edi
+    movl $0xabcdef01, %esi
+  end ['rsi', 'rdi'];
+  if not bytepara(b1,s1) then
+    halt(1);
+end.

utils/fpdoc/dw_html.pp

@@ -1809,9 +1809,7 @@ begin
   CodeEl := CreateCode(CreatePara(TDEl));
   AppendKw(CodeEl, 'type');
 
-  if not Assigned(AClass.GenericTemplateTypes) then
-      Dolog('ERROR generic init: %s', [AClass.name]);
-  if AClass.GenericTemplateTypes.Count>0 then
+  if Assigned(AClass.GenericTemplateTypes) and (AClass.GenericTemplateTypes.Count>0) then
     AppendGeneric(CodeEl, AClass)
   else
     AppendText(CodeEl, ' ' + UTF8Decode(AClass.Name) + ' ');
@@ -1827,8 +1825,8 @@ begin
     ThisTreeNode := TreeInterface.GetPasElNode(AClass)
   else
     ThisTreeNode := TreeClass.GetPasElNode(AClass);
-  if not Assigned(ThisTreeNode) Then
-    DoLog('ERROR Tree Class information: '+ThisClass.PathName);
+  //if not Assigned(ThisTreeNode) Then
+  //  DoLog('ERROR Tree Class information: '+ThisClass.PathName);
 
   if Assigned(AClass.AncestorType) then
   begin