Merged revisions 1146-1152,1154-1160,1162-1164,1167-1170,1177-1178,1183-1184,1186-1192 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@1202 -

.gitattributes

@@ -688,7 +688,9 @@ fcl/image/fpcanvas.inc svneol=native#text/plain
 fcl/image/fpcanvas.pp svneol=native#text/plain
 fcl/image/fpcdrawh.inc svneol=native#text/plain
 fcl/image/fpcolcnv.inc svneol=native#text/plain
+fcl/image/fpcolhash.pas svneol=native#text/plain
 fcl/image/fpcolors.inc svneol=native#text/plain
+fcl/image/fpditherer.pas svneol=native#text/plain
 fcl/image/fpfont.inc svneol=native#text/plain
 fcl/image/fphandler.inc svneol=native#text/plain
 fcl/image/fphelper.inc svneol=native#text/plain
@@ -699,6 +701,7 @@ fcl/image/fpimgcmn.pp svneol=native#text/plain
 fcl/image/fppalette.inc svneol=native#text/plain
 fcl/image/fppen.inc svneol=native#text/plain
 fcl/image/fppixlcanv.pp svneol=native#text/plain
+fcl/image/fpquantizer.pas svneol=native#text/plain
 fcl/image/fpreadbmp.pp svneol=native#text/plain
 fcl/image/fpreadjpeg.pas svneol=native#text/plain
 fcl/image/fpreadpng.pp svneol=native#text/plain
@@ -3398,7 +3401,7 @@ rtl/linux/arm/syscallh.inc svneol=native#text/plain
 rtl/linux/arm/sysnr.inc svneol=native#text/plain
 rtl/linux/bunxsysc.inc svneol=native#text/plain
 rtl/linux/errno.inc svneol=native#text/plain
-rtl/linux/fpcylix.pp -text
+rtl/linux/fpcylix.pp svneol=native#text/plain
 rtl/linux/gpm.pp svneol=native#text/plain
 rtl/linux/i386/bsyscall.inc svneol=native#text/plain
 rtl/linux/i386/cprt0.as -text
@@ -3732,6 +3735,7 @@ rtl/objpas/sysutils/sysstr.inc svneol=native#text/plain
 rtl/objpas/sysutils/sysstrh.inc svneol=native#text/plain
 rtl/objpas/sysutils/systhrdh.inc svneol=native#text/plain
 rtl/objpas/sysutils/sysuintf.inc svneol=native#text/plain
+rtl/objpas/sysutils/sysuthrd.inc svneol=native#text/plain
 rtl/objpas/sysutils/sysutilh.inc svneol=native#text/plain
 rtl/objpas/sysutils/sysutils.inc svneol=native#text/plain
 rtl/objpas/sysutils/syswide.inc svneol=native#text/plain
@@ -6016,6 +6020,7 @@ tests/webtbs/tw4162.pp svneol=native#text/plain
 tests/webtbs/tw4173.pp svneol=native#text/plain
 tests/webtbs/tw4188.pp svneol=native#text/plain
 tests/webtbs/tw4199.pp svneol=native#text/plain
+tests/webtbs/tw4201.pp svneol=native#text/plain
 tests/webtbs/tw4202.pp svneol=native#text/plain
 tests/webtbs/tw4215.pp svneol=native#text/plain
 tests/webtbs/tw4219.pp svneol=native#text/plain

compiler/ncgcon.pas

@@ -623,7 +623,7 @@ implementation
         if tsetdef(resulttype.def).settype=smallset then
          begin
            location_reset(location,LOC_CONSTANT,OS_32);
-           location.value:=PAInt(value_set)^;
+           location.value:=pLongint(value_set)^;
            exit;
          end;
         location_reset(location,LOC_CREFERENCE,OS_NO);

compiler/ninl.pas

@@ -1441,6 +1441,11 @@ implementation
                   set_varstate(left,vs_used,[vsf_must_be_valid]);
 
                   case left.resulttype.def.deftype of
+                    variantdef:
+                      begin
+                        inserttypeconv(left,cansistringtype);
+                      end;
+
                     stringdef :
                       begin
                         { we don't need string convertions here }

compiler/pmodules.pas

@@ -516,7 +516,10 @@ implementation
            (target_info.system in [system_i386_go32v2,system_i386_watcom]) then
           AddUnit('Profile');
         if (cs_load_fpcylix_unit in aktglobalswitches) then
-          AddUnit('FPCylix');
+          begin
+            AddUnit('FPCylix');
+            AddUnit('DynLibs');
+          end;
         { save default symtablestack }
         defaultsymtablestack:=symtablestack;
         defaultmacrosymtablestack:=macrosymtablestack;

fcl/image/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/08/11]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2005/09/08]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-emx i386-watcom i386-netwlibc i386-wince m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos powerpc-linux powerpc-netbsd powerpc-macos powerpc-darwin powerpc-morphos sparc-linux sparc-netbsd sparc-solaris x86_64-linux x86_64-freebsd x86_64-win64 arm-linux arm-wince
@@ -233,112 +233,112 @@ PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/ext
 override PACKAGE_NAME=fcl
 PACKAGEDIR_MAIN:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /fcl/Makefile.fpc,$(PACKAGESDIR))))))
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),i386-os2)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-netware)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-emx)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-watcom)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-netwlibc)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),m68k-atari)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses  freetypeh freetype ftfont
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer  freetypeh freetype ftfont
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses
+override TARGET_UNITS+=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_RSTS+=pscanvas

fcl/image/Makefile.fpc

@@ -12,7 +12,7 @@ packages=paszlib pasjpeg
 units=fpimgcmn fpimage pngcomn fpreadpng fpwritepng fpreadxpm fpwritexpm \
       clipping fpcanvas pixtools fppixlcanv fpimgcanv pscanvas fpwritebmp \
       fpreadbmp bmpcomn fpreadpnm fpwritepnm fpreadjpeg fpwritejpeg \
-      targacmn fpreadtga fpwritetga ellipses
+      targacmn fpreadtga fpwritetga ellipses fpcolhash fpditherer fpquantizer
 units_win32=freetypeh freetype ftfont
 units_linux=freetypeh freetype ftfont
 units_freebsd=freetypeh freetype ftfont

fcl/image/fpcolhash.pas

@@ -0,0 +1,412 @@
+{*****************************************************************************}
+{
+    This file is part of the Free Pascal's "Free Components Library".
+    Copyright (c) 2005 by Giulio Bernardi
+
+    This file contains a color hash table.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+{*****************************************************************************}
+{$mode objfpc}{$h+}
+unit FPColHash;
+
+interface
+
+uses sysutils, classes, fpimage;
+
+type TFPColorHashException = class(Exception);
+
+type
+  PColHashSubNode = ^TColHashSubNode;
+  TColHashSubNode = packed record
+    index : byte;
+    data : pointer;
+    next : PColHashSubNode;
+  end;
+
+type
+  PColHashMainNode = ^TColHashMainNode;
+  TColHashMainNode = packed record
+    childs : array[0..16] of pointer; { can be either another MainNode or a SubNode }
+  end;
+
+{
+  HashMap configuration:
+  childs[MSN(A)]                                                   level 0
+    |_childs[LSN(A)]                                               level 1
+       |_childs[LSN(R)]                                            level 2
+          |_childs[LSN(G)]                                         level 3
+             |_childs[LSN(B)]                                      level 4
+                |_childs[(MSN(R) MSN(G) MSN (B)) div 256]          level 5
+                   |_element [(MSN(R) MSN(G) MSN (B)) mod 256]
+  Very low accesses to reach an element, not much memory occupation if alpha is rarely used, event with
+  images with 500.000 colors.
+  For extremely colorful images (near 2^24 colors used) using only 5 bits per channel keeps the map
+  small and efficient
+
+}
+
+type
+  TFPPackedColor = record
+    R, G, B, A : byte;
+  end;
+
+type
+  TFPColorWeight = record
+    Col : TFPPackedColor;
+    Num : integer;
+  end;
+  PFPColorWeight = ^TFPColorWeight;
+  TFPColorWeightArray = array of PFPColorWeight;
+
+
+type
+  TFPColorHashTable = class
+  private
+    Root : PColHashMainNode;
+    AllIntegers : boolean;
+    procedure FreeAllData;
+    FCount : longword;
+    function AllocateMainNode : PColHashMainNode;
+    function AllocateSubNode : PColHashSubNode;
+    procedure DeallocateLinkedList(node : PColHashSubNode);
+    procedure DeallocateMainNode(node : PColHashMainNode; level : byte);
+    procedure CalculateIndexes(Col : TFPPackedColor; var ahi, alo, ri, gi, bi, partial, sub : byte);
+    function CalculateColor(const ahi, alo, ri, gi, bi, partial, sub : byte) : TFPPackedColor;
+    function SearchSubNode(start : PColHashSubNode; const index : byte ) : PColHashSubNode;
+    function SearchSubNodeAllocate(var start : PColHashSubNode; const index : byte ) : PColHashSubNode;
+    function Search(const Col : TFPPackedColor) : PColHashSubNode;
+    function SearchAllocate(const Col : TFPPackedColor) : PColHashSubNode;
+  protected
+  public
+    procedure Insert(const Col : TFPColor; const Value : integer);
+    procedure Insert(const Col : TFPColor; const Value : pointer);
+    procedure Add(const Col : TFPColor; const Value : integer);
+    function Get(const Col : TFPColor) : pointer;
+    procedure Clear;
+    function GetArray : TFPColorWeightArray;
+    property Count : longword read FCount;
+    constructor Create;
+    destructor Destroy; override;
+  end;
+
+function FPColor2Packed(Col : TFPColor) : TFPPackedColor;
+function Packed2FPColor(Col : TFPPackedColor) : TFPColor;
+
+implementation
+
+function FPColor2Packed(Col : TFPColor) : TFPPackedColor;
+begin
+  Result.R:=(Col.Red and $FF00) shr 8;
+  Result.G:=(Col.Green and $FF00) shr 8;
+  Result.B:=(Col.Blue and $FF00) shr 8;
+  Result.A:=(Col.Alpha and $FF00) shr 8;
+end;
+
+function Packed2FPColor(Col : TFPPackedColor) : TFPColor;
+begin
+  Result.Red:=(Col.R shl 8) + Col.R;
+  Result.Green:=(Col.G shl 8) + Col.G;
+  Result.Blue:=(Col.B shl 8) + Col.B;
+  Result.Alpha:=(Col.A shl 8) + Col.A;
+end;
+
+constructor TFPColorHashTable.Create;
+begin
+  Fcount:=0;
+  AllIntegers:=true;
+  Root:=nil;
+end;
+
+destructor TFPColorHashTable.Destroy;
+begin
+  FreeAllData;
+  inherited Destroy;
+end;
+
+procedure TFPColorHashTable.CalculateIndexes(Col : TFPPackedColor; var ahi, alo, ri, gi, bi, partial, sub : byte);
+var tmp : longword;
+begin
+  ahi := (Col.A and $F0) shr 4;
+  alo := (Col.A and $F);
+  ri := (Col.R and $F);
+  gi := (Col.G and $F);
+  bi := (Col.B and $F);
+  tmp:=((Col.R and $F0) shl 4) or (Col.G and $F0) or ((Col.B and $F0) shr 4);
+  partial:=tmp div 256;
+  sub:=tmp mod 256;
+end;
+
+function TFPColorHashTable.CalculateColor(const ahi, alo, ri, gi, bi, partial, sub : byte) : TFPPackedColor;
+var tmp : longword;
+    col : TFPPackedColor;
+begin
+  tmp:=(partial shl 8) + sub; //partial*256 + sub;
+  col.A:=(ahi shl 4) or alo;
+  col.R:=((tmp and $F00) shr 4) + ri;
+  col.G:=(tmp and $0F0) + gi;
+  col.B:=((tmp and $00F) shl 4) + bi;
+  Result:=col;
+end;
+
+procedure TFPColorHashTable.FreeAllData;
+begin
+  DeallocateMainNode(Root,0);
+  Root:=nil;
+  FCount:=0;
+  AllIntegers:=true;
+end;
+
+function TFPColorHashTable.AllocateMainNode : PColHashMainNode;
+var tmp : PColHashMainNode;
+    i : byte;
+begin
+  Result:=nil;
+  tmp:=getmem(sizeof(TColHashMainNode));
+  if tmp=nil then raise TFPColorHashException.Create('Out of memory');
+  for i:=0 to high(tmp^.childs) do
+    tmp^.childs[i]:=nil;
+  Result:=tmp;
+end;
+
+function TFPColorHashTable.AllocateSubNode : PColHashSubNode;
+var tmp : PColHashSubNode;
+begin
+  Result:=nil;
+  tmp:=getmem(sizeof(TColHashSubNode));
+  if tmp=nil then raise TFPColorHashException.Create('Out of memory');
+  tmp^.index:=0;
+  tmp^.data:=nil;
+  tmp^.next:=nil;
+  inc(FCount);
+  Result:=tmp;
+end;
+
+procedure TFPColorHashTable.DeallocateLinkedList(node : PColHashSubNode);
+var tmp : PColHashSubNode;
+begin
+  while (node<>nil) do
+  begin
+    tmp:=node^.next;
+    if node^.data<>nil then
+      FreeMem(node^.data);
+    FreeMem(node);
+    node:=tmp;
+  end;
+end;
+
+procedure TFPColorHashTable.DeallocateMainNode(node : PColHashMainNode; level : byte);
+var i : byte;
+begin
+  if node=nil then exit;
+  if level=5 then
+  begin
+    for i:=0 to high(node^.childs) do
+      DeallocateLinkedList(node^.childs[i]);
+  end
+  else
+    for i:=0 to high(node^.childs) do
+      DeallocateMainNode(node^.childs[i],level+1);
+  FreeMem(node);
+end;
+
+function TFPColorHashTable.SearchSubNode(start : PColHashSubNode; const index : byte ) : PColHashSubNode;
+var cur : PColHashSubNode;
+begin
+  Result:=nil;
+  cur:=start;
+  while cur<>nil do
+  begin
+    if cur^.index=index then break
+    else if cur^.index>index then exit; { exit and returns nil}
+    cur:=cur^.next;
+  end;
+  Result:=cur;
+end;
+
+function TFPColorHashTable.SearchSubNodeAllocate(var start : PColHashSubNode; const index : byte ) : PColHashSubNode;
+var tmp, cur, prev : PColHashSubNode;
+begin
+  Result:=nil;
+  prev:=nil;
+  cur:=start;
+  while cur<>nil do
+  begin
+    if cur^.index=index then break
+    else if cur^.index>index then {whoops, we must insert the new node before this one}
+    begin
+      tmp:=AllocateSubNode;
+      tmp^.index:=index;
+      tmp^.next:=cur;
+      if prev<>nil then prev^.next:=tmp
+      else start:=tmp;
+      cur:=tmp;
+      break;
+    end;
+    prev:=cur;
+    cur:=cur^.next;
+  end;
+  if cur=nil then { not found! append to the end }
+  begin
+    cur:=AllocateSubNode;
+    cur^.index:=index;
+    prev^.next:=cur  { start is always <> nil}
+  end;
+  Result:=cur;
+end;
+
+function TFPColorHashTable.Search(const Col : TFPPackedColor) : PColHashSubNode;
+var ahi, alo, ri, gi, bi, partial, sub : byte;
+    tmpmain : PColHashMainNode;
+begin
+  Result:=nil;
+  CalculateIndexes(Col, ahi, alo, ri, gi, bi, partial, sub);
+  if Root=nil then exit;
+  if Root^.childs[ahi]=nil then exit;
+  tmpmain:=Root^.childs[ahi];
+  if tmpmain^.childs[alo]=nil then exit;
+  tmpmain:=tmpmain^.childs[alo];
+  if tmpmain^.childs[ri]=nil then exit;
+  tmpmain:=tmpmain^.childs[ri];
+  if tmpmain^.childs[gi]=nil then exit;
+  tmpmain:=tmpmain^.childs[gi];
+  if tmpmain^.childs[bi]=nil then exit;
+  tmpmain:=tmpmain^.childs[bi];
+
+  if tmpmain^.childs[partial]=nil then exit;
+  Result:=SearchSubNode(tmpmain^.childs[partial],sub);
+end;
+
+{ get the node; if there isn't, build the part of the tree }
+function TFPColorHashTable.SearchAllocate(const Col : TFPPackedColor) : PColHashSubNode;
+var ahi, alo, ri, gi, bi, partial, sub : byte;
+   tmpmain : PColHashMainNode;
+begin
+  Result:=nil;
+  CalculateIndexes(Col, ahi, alo, ri, gi, bi, partial, sub);
+  if Root=nil then Root:=AllocateMainNode;
+  if Root^.childs[ahi]=nil then Root^.childs[ahi]:=AllocateMainNode;
+  tmpmain:=Root^.childs[ahi];
+  if tmpmain^.childs[alo]=nil then tmpmain^.childs[alo]:=AllocateMainNode;
+  tmpmain:=tmpmain^.childs[alo];
+  if tmpmain^.childs[ri]=nil then tmpmain^.childs[ri]:=AllocateMainNode;
+  tmpmain:=tmpmain^.childs[ri];
+  if tmpmain^.childs[gi]=nil then tmpmain^.childs[gi]:=AllocateMainNode;
+  tmpmain:=tmpmain^.childs[gi];
+  if tmpmain^.childs[bi]=nil then tmpmain^.childs[bi]:=AllocateMainNode;
+  tmpmain:=tmpmain^.childs[bi];
+
+  if tmpmain^.childs[partial]=nil then  { newly-created linked list. }
+  begin
+    tmpmain^.childs[partial]:=AllocateSubNode;
+    Result:=tmpmain^.childs[partial];
+    Result^.index:=sub;
+    exit;
+  end;
+  Result:=SearchSubNodeAllocate(tmpmain^.childs[partial],sub)
+end;
+
+procedure TFPColorHashTable.Insert(const Col : TFPColor; const Value : integer);
+var node : PColHashSubNode;
+begin
+  node:=SearchAllocate(FPColor2Packed(col));
+  node^.data:=getmem(sizeof(Value));
+  integer(node^.data^):=value;
+end;
+
+procedure TFPColorHashTable.Insert(const Col : TFPColor; const Value : pointer);
+var node : PColHashSubNode;
+begin
+  node:=SearchAllocate(FPColor2Packed(col));
+  node^.data:=Value;
+  AllIntegers:=false;
+end;
+
+procedure TFPColorHashTable.Add(const Col : TFPColor; const Value : integer);
+var node : PColHashSubNode;
+begin
+  node:=SearchAllocate(FPColor2Packed(col));
+  if node^.data=nil then
+  begin
+    node^.data:=getmem(sizeof(Value));
+    integer(node^.data^):=0;
+  end;
+  inc(integer(node^.data^),value);
+end;
+
+function TFPColorHashTable.Get(const Col : TFPColor) : pointer;
+var node : PColHashSubNode;
+begin
+  node:=Search(FPColor2Packed(col));
+  if node<>nil then
+    Result:=node^.data
+  else
+    Result:=nil;
+end;
+
+procedure TFPColorHashTable.Clear;
+begin
+  FreeAllData;
+end;
+
+function TFPColorHashTable.GetArray : TFPColorWeightArray;
+var ahi, alo, ri, gi, bi, partial : byte;
+    node : PColHashSubNode;
+    i : longword;
+    cw : PFPColorWeight;
+    tmp1,tmp2,tmp3,tmp4,tmp5 : PColHashMainNode;
+begin
+  if not AllIntegers then
+    raise TFPColorHashException.Create('Hashtable data is not made by integers.');
+  SetLength(Result,FCount);
+  if Root=nil then exit;
+  i:=0;
+  for ahi:=0 to 15 do
+  begin
+    if Root^.childs[ahi]=nil then continue;
+    tmp1:=Root^.childs[ahi];
+    for alo:=0 to 15 do
+    begin
+      if tmp1^.childs[alo]=nil then continue;
+      tmp2:=tmp1^.childs[alo];
+      for ri:=0 to 15 do
+      begin
+        if tmp2^.childs[ri]=nil then continue;
+        tmp3:=tmp2^.childs[ri];
+        for gi:=0 to 15 do
+        begin
+          if tmp3^.childs[gi]=nil then continue;
+          tmp4:=tmp3^.childs[gi];
+          for bi:=0 to 15 do
+          begin
+            if tmp4^.childs[bi]=nil then continue;
+            tmp5:=tmp4^.childs[bi];
+            for partial:=0 to 15 do
+            begin
+              node:=tmp5^.childs[partial];
+              while (node<>nil) do
+              begin
+                getmem(cw,sizeof(TFPColorWeight));
+                if cw=nil then
+                  raise TFPColorHashException.Create('Out of memory');
+                cw^.Col:=CalculateColor(ahi,alo,ri,gi,bi,partial,node^.index);
+                cw^.Num:=integer(node^.data^);
+                Result[i]:=cw;
+                inc(i);
+                node:=node^.next;
+              end;
+            end;
+          end;
+        end;
+      end;
+    end;
+  end;
+end;
+
+end.

fcl/image/fpditherer.pas

@@ -0,0 +1,544 @@
+{*****************************************************************************}
+{
+    This file is part of the Free Pascal's "Free Components Library".
+    Copyright (c) 2005 by Giulio Bernardi
+
+    This file contains classes used to dither images.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+{*****************************************************************************}
+
+{$mode objfpc}{$h+}
+unit FPDitherer;
+
+interface
+
+uses sysutils, classes, fpimage, fpcolhash;
+
+type
+  FPDithererException = class (exception);
+
+type
+  TFPDithererProgressEvent = procedure (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte;
+                                         const Msg: AnsiString; var Continue : Boolean) of object;
+
+type
+  TFPBaseDitherer = class
+    private
+      FPalette : TFPPalette;
+      FOnProgress : TFPDithererProgressEvent;
+      procedure QuickSort(const l, r : integer);
+    protected
+      FImage : TFPCustomImage;
+      FHashMap : TFPColorHashTable;
+      FSorted : boolean;
+      FUseHash : boolean;
+      FUseAlpha : boolean;
+      function ColorCompare(const c1, c2 : TFPColor) : shortint;
+      function GetColorDinst(const c1, c2 : TFPColor) : integer;
+      function SubtractColorInt(const c1, c2 : TFPColor) : int64;
+      function SubtractColor(const c1, c2 : TFPColor) : TFPColor;
+      procedure InternalDither(const Source : TFPCustomImage; Dest : TFPCustomImage); virtual;
+      function FindBestColor(OrigColor : TFPColor; var PalIndex : integer) : integer; virtual;
+      procedure Progress (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean); virtual;
+      procedure SetUseHash(Value : boolean); virtual;
+      procedure SetSorted(Value : boolean); virtual;
+    public
+      property OnProgress : TFPDithererProgressEvent read FOnProgress write FOnProgress;
+      property Palette : TFPPalette read FPalette;
+      property PaletteSorted : boolean read FSorted write SetSorted;
+      property UseHashMap : boolean read FUseHash write SetUseHash;
+      property UseAlpha : boolean read FUseAlpha write FUseAlpha;
+      procedure Dither(const Source : TFPCustomImage; Dest : TFPCustomImage);
+      procedure SortPalette; virtual;
+      constructor Create(ThePalette : TFPPalette); virtual;
+      destructor Destroy; override;
+  end;
+
+type
+  PFPPixelReal = ^TFPPixelReal;
+  TFPPixelReal = record   { pixel in real form }
+    a, r, g, b : real;
+  end;
+
+  PFSPixelLine = ^TFSPixelLine;
+  TFSPixelLine = record
+    pixels : PFPPixelReal;             { a line of pixels }
+    Next : PFSPixelLine;               { next line of pixels }
+  end;
+
+type
+  TFPFloydSteinbergDitherer = class(TFPBaseDitherer)
+    private
+      Lines : PFSPixelLine;
+      function Color2Real(const c : TFPColor) : TFPPixelReal;
+      function Real2Color(r : TFPPixelReal) : TFPColor;
+      procedure CreatePixelLine(var line : PFSPixelLine; const row : integer);
+      function GetError(const c1, c2 : TFPColor) : TFPPixelReal;
+      procedure DistributeErrors(var line : PFSPixelLine; const row : integer; Img : TFPCustomImage);
+      procedure DeleteAllPixelLines(var line : PFSPixelLine);
+    protected
+      procedure InternalDither(const Source : TFPCustomImage; Dest : TFPCustomImage); override;
+    public
+      constructor Create(ThePalette : TFPPalette); override;
+  end;
+
+implementation
+
+{ TFPBaseDitherer }
+
+procedure TFPBaseDitherer.Dither(const Source : TFPCustomImage; Dest : TFPCustomImage);
+begin
+  if FPalette.Count=0 then
+    raise FPDithererException.Create('Palette is empty');
+  if Source=Dest then
+    raise FPDithererException.Create('Source and Destination images must be different');
+  InternalDither(Source,Dest);
+  if FUseHash then
+    FHashMap.Clear;
+end;
+
+constructor TFPBaseDitherer.Create(ThePalette : TFPPalette);
+begin
+  FSorted:=false;
+  FUseAlpha:=false;
+  FImage:=nil;
+  FPalette:=ThePalette;
+  FUseHash:=true;
+  FHashMap:=TFPColorHashTable.Create;
+end;
+
+destructor TFPBaseDitherer.Destroy;
+begin
+  if Assigned(FHashMap) then
+    FHashMap.Free;
+end;
+
+procedure TFPBaseDitherer.SetUseHash(Value : boolean);
+begin
+  if Value=FUseHash then exit;
+  if Value then
+    FHashMap:=TFPColorHashTable.Create
+  else
+  begin
+    FHashMap.Free;
+    FHashMap:=nil;
+  end;
+  FUseHash:=Value;
+end;
+
+procedure TFPBaseDitherer.SetSorted(Value : boolean);
+begin
+  FSorted:=Value;
+end;
+
+procedure TFPBaseDitherer.Progress(Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean);
+begin
+  if Assigned(FOnProgress) then
+    FOnProgress(Sender,Stage,PercentDone,Msg,Continue);
+end;
+
+{ rgb triplets are considered like a number having msb in msb(r) and lsb in lsb(b) }
+
+function TFPBaseDitherer.SubtractColorInt(const c1, c2 : TFPColor) : int64;
+var whole1, whole2 : int64;
+begin
+  whole1:= ((c1.Red and $FF00) shl 8) or (c1.Green and $FF00) or ((c1.Blue and $FF00) shr 8);
+  whole2:= ((c2.Red and $FF00) shl 8) or (c2.Green and $FF00) or ((c2.Blue and $FF00) shr 8);
+  if FUseAlpha then
+  begin
+    whole1:=whole1 or ((c1.Alpha and $FF00) shl 16);
+    whole2:=whole2 or ((c2.Alpha and $FF00) shl 16);
+  end;
+  Result:= whole1 - whole2;
+end;
+
+{ this is more efficient than calling subtractcolorint and then extracting r g b values }
+function TFPBaseDitherer.GetColorDinst(const c1, c2 : TFPColor) : integer;
+var dinst : integer;
+begin
+  dinst:=abs(((c1.Red and $FF00) shr 8) - ((c2.Red and $FF00) shr 8));
+  dinst:=dinst+abs(((c1.Green and $FF00) shr 8) - ((c2.Green and $FF00) shr 8));
+  dinst:=dinst+abs(((c1.Blue and $FF00) shr 8) - ((c2.Blue and $FF00) shr 8));
+  if FUseAlpha then
+    dinst:=dinst+abs(((c1.Alpha and $FF00) shr 8) - ((c2.Alpha and $FF00) shr 8));
+  Result:= dinst;
+end;
+
+function TFPBaseDitherer.SubtractColor(const c1, c2 : TFPColor) : TFPColor;
+var whole : int64;
+begin
+  whole:=abs(SubtractColorInt(c1,c2));
+  if FUseALpha then
+    Result.Alpha:=(whole and $FF000000) shr 16
+  else
+    Result.Alpha:=AlphaOpaque;
+  Result.Red:=(whole and $00FF0000) shr 8;
+  Result.Green:=(whole and $0000FF00);
+  Result.Blue:=(whole and $000000FF) shl 8;
+end;
+
+function TFPBaseDitherer.ColorCompare(const c1, c2 : TFPColor) : shortint;
+var whole : int64;
+begin
+  whole:=SubtractColorInt(c1,c2);
+  if whole>0 then Result:=1
+  else if whole<0 then Result:=-1
+  else Result:=0;
+end;
+
+procedure TFPBaseDitherer.QuickSort(const l, r : integer);
+var i, j : integer;
+    pivot, temp : TFPColor;
+begin
+  if l<r then
+  begin
+    pivot:=FPalette[l];
+    i:=l+1;
+    j:=r;
+    repeat
+      while ((i<=r) and (ColorCompare(FPalette[i],pivot)<=0)) do
+        inc(i);
+      while (ColorCompare(FPalette[j],pivot)=1) do
+        dec(j);
+      if i<j then
+      begin
+        temp:=FPalette[i];
+        FPalette[i]:=FPalette[j];
+        FPalette[j]:=temp;
+      end;
+    until i > j;
+    { don't swap if they are equal }
+    if ColorCompare(FPalette[j],pivot)<>0 then
+    begin
+      Fpalette[l]:=Fpalette[j];
+      Fpalette[j]:=pivot;
+    end;
+    Quicksort(l,j-1);
+    Quicksort(i,r);
+  end;
+end;
+
+procedure TFPBaseDitherer.SortPalette;
+begin
+  QuickSort(0,FPalette.Count-1);
+  FSorted:=true;
+end;
+
+type
+  PBestColorData = ^TBestColorData;
+  TBestColorData = record
+    palindex, dinst : integer;
+  end;
+
+function TFPBaseDitherer.FindBestColor(OrigColor : TFPColor; var PalIndex : integer) : integer;
+var i, curr, dinst, tmpdinst, top, bottom : integer;
+    hashval : PBestColorData;
+begin
+  dinst:=$7FFFFFFF;
+  curr:=0;
+
+  if FUseHash then { use the hashmap to improve speed }
+  begin
+    hashval:=FHashMap.Get(OrigColor);
+    if hashval<>nil then
+    begin
+      PalIndex:=hashval^.palindex;
+      Result:=hashval^.dinst;
+      exit;
+    end;
+  end;
+
+  { with a sorted palette, proceed by binary search. this is more efficient with large images or large palettes }
+  if FSorted then 
+  begin
+    top:=0;
+    bottom:=FPalette.Count-1;
+    while top<=bottom do
+    begin
+      i:=(bottom+top) div 2;
+      tmpdinst:=ColorCompare(OrigColor,Fpalette[i]);
+      if tmpdinst<0 then bottom:=i-1
+      else if tmpdinst>0 then top:=i+1
+      else break; { we found it }
+    end;
+    curr:=i;
+    dinst:=GetColorDinst(OrigColor,Fpalette[i]);
+  end
+  else
+    for i:=0 to FPalette.Count-1 do
+    begin
+      tmpdinst:=GetColorDinst(OrigColor,FPalette[i]);
+      if tmpdinst<dinst then
+      begin
+        dinst:=tmpdinst;
+        curr:=i;
+      end;
+      if tmpdinst=0 then break; { There can't be anything better, stop searching }
+    end;
+
+  if FUseHash then { if we are using a hashmap, remember this value}
+  begin
+    hashval:=GetMem(sizeof(TBestColorData));
+    if hashval=nil then
+      raise FPDithererException.Create('Out of memory');
+    hashval^.PalIndex:=curr;
+    hashval^.dinst:=dinst;
+    FHashMap.Insert(OrigColor,hashval);
+  end;
+  PalIndex:=curr;
+  Result:=dinst;
+end;
+
+procedure TFPBaseDitherer.InternalDither(const Source : TFPCustomImage; Dest : TFPCustomImage);
+var i,j, palindex : integer;
+    percent : byte;
+    percentinterval : longword;
+    percentacc : longword;
+    FContinue : boolean;
+begin
+  FImage:=Source;
+  percent:=0;
+  percentinterval:=(FImage.Width*FImage.Height*4) div 100;
+  if percentinterval=0 then percentinterval:=$FFFFFFFF;
+  percentacc:=0;
+  FContinue:=true;
+  Progress (self,psStarting,0,'',FContinue);
+  Dest.SetSize(0,0);
+  Dest.UsePalette:=true;
+  Dest.Palette.Clear;
+  Dest.Palette.Merge(FPalette);
+  Dest.SetSize(FImage.Width,FImage.Height);
+  for j:=0 to FImage.Height-1 do
+    for i:=0 to FImage.Width-1 do
+    begin
+      FindBestColor(FImage[i,j], palindex);
+      Dest.Pixels[i,j]:=palindex;
+      inc(percentacc,4);
+      if percentacc>=percentinterval then
+      begin
+        percent:=percent+(percentacc div percentinterval);
+        percentacc:=percentacc mod percentinterval;
+        Progress (self,psRunning,percent,'',FContinue);
+        if not fcontinue then exit;
+      end;
+    end;
+  Progress (self,psEnding,100,'',FContinue);
+end;
+
+{ TFPFloydSteinbergDitherer }
+
+const FSNullPixel : TFPPixelReal = (a : 0.0; r : 0.0; g : 0.0; b : 0.0);
+
+constructor TFPFloydSteinbergDitherer.Create(ThePalette : TFPPalette);
+begin
+  inherited Create(ThePalette);
+  Lines:=nil;
+end;
+
+function TFPFloydSteinbergDitherer.GetError(const c1, c2 : TFPColor) : TFPPixelReal;
+var temp : TFPPixelReal;
+begin
+  if FUseAlpha then
+    temp.a:=((c1.Alpha and $FF00) shr 8) - ((c2.Alpha and $FF00) shr 8);
+  temp.r:=((c1.Red and $FF00) shr 8) - ((c2.Red and $FF00) shr 8);
+  temp.g:=((c1.Green and $FF00) shr 8) - ((c2.Green and $FF00) shr 8);
+  temp.b:=((c1.Blue and $FF00) shr 8) - ((c2.Blue and $FF00) shr 8);
+  Result:=temp;
+end;
+
+function TFPFloydSteinbergDitherer.Color2Real(const c : TFPColor) : TFPPixelReal;
+var temp : TFPPixelReal;
+begin
+  if FUseAlpha then
+    temp.a:=((c.Alpha and $FF00) shr 8);
+  temp.r:=((c.Red and $FF00) shr 8);
+  temp.g:=((c.Green and $FF00) shr 8);
+  temp.b:=((c.Blue and $FF00) shr 8);
+  Result:=temp;
+end;
+
+function TFPFloydSteinbergDitherer.Real2Color(r : TFPPixelReal) : TFPColor;
+var temp : TFPColor;
+begin
+  { adjust overflows and underflows }
+  if r.r> 255 then r.r:=255; if r.r<0 then r.r:=0;
+  if r.g> 255 then r.g:=255; if r.g<0 then r.g:=0;
+  if r.b> 255 then r.b:=255; if r.b<0 then r.b:=0;
+  if FUseAlpha then
+  begin
+    if r.a> 255 then r.a:=255; if r.a<0 then r.a:=0;
+  end;
+
+  temp.Red:=round(r.r);
+  temp.Red:=(temp.Red shl 8) + temp.Red;
+  temp.Green:=round(r.g);
+  temp.Green:=(temp.Green shl 8) + temp.Green;
+  temp.Blue:=round(r.b);
+  temp.Blue:=(temp.Blue shl 8) + temp.Blue;
+  if FUseAlpha then
+  begin
+    temp.Alpha:=round(r.a);
+    temp.Alpha:=(temp.Alpha shl 8) + temp.Alpha;
+  end
+  else
+    temp.Alpha:=AlphaOpaque;
+  Result:=temp;
+end;
+
+procedure TFPFloydSteinbergDitherer.CreatePixelLine(var line : PFSPixelLine; const row : integer);
+var i : integer;
+begin
+  line:=GetMem(sizeof(TFSPixelLine));
+  if line=nil then
+    raise FPDithererException.Create('Out of memory');
+  line^.next:=nil;
+  { two extra pixels so we don't have to check if the pixel is on start or end of line  }
+  getmem(line^.pixels,sizeof(TFPPixelReal)*(FImage.Width+2));
+  if line^.pixels=nil then
+    raise FPDithererException.Create('Out of memory');
+  if row<FImage.Height-1 then
+  begin
+    line^.pixels[0]:=FSNullPixel;
+    line^.pixels[FImage.Width+1]:=FSNullPixel;
+    for i:=0 to FImage.Width-1 do
+      line^.pixels[i+1]:=Color2Real(FImage[i,row]);
+  end
+  else
+    for i:=0 to FImage.Width+1 do
+      line^.pixels[i]:=FSNullPixel;
+end;
+
+const e716 = 0.4375;
+      e516 = 0.3125;
+      e316 = 0.1875;
+      e116 = 0.0625;
+
+procedure TFPFloydSteinbergDitherer.DistributeErrors(var line : PFSPixelLine; const row : integer; Img : TFPCustomImage);
+var i, width : integer;
+    palindex : integer;
+    OldColor : TFPColor;
+    dir : shortint;
+    nextline : PFSPixelLine;
+begin
+  width:=FImage.Width;
+  if (row mod 2)=0 then
+  begin
+    dir:=1;
+    i:=1;
+  end
+  else
+  begin
+    dir:=-1;
+    i:=width;
+  end;
+  if width<1 then exit;
+
+  repeat
+    OldColor:=Real2Color(line^.pixels[i]);
+    FindBestColor(OldColor, palindex);
+    Img.Pixels[i-1,row]:=palindex; { we use this color for this pixel... }
+    line^.pixels[i]:=GetError(OldColor,Palette[palindex]);
+    { now distribute this error to the other pixels, in this way: }
+    { note: for odd lines this is mirrored and we start from right}
+    {    0      0      0  }
+    {    0      X    7/16 }
+    {  3/16   5/16   1/16 }
+    line^.pixels[i+dir].r:=line^.pixels[i+dir].r+(line^.pixels[i].r*e716);
+    line^.pixels[i+dir].g:=line^.pixels[i+dir].g+(line^.pixels[i].g*e716);
+    line^.pixels[i+dir].b:=line^.pixels[i+dir].b+(line^.pixels[i].b*e716);
+    if FUseAlpha then
+      line^.pixels[i+dir].a:=line^.pixels[i+dir].a+(line^.pixels[i].a*e716);
+    nextline:=line^.next;
+
+    nextline^.pixels[i].r:=nextline^.pixels[i].r+(line^.pixels[i].r*e516);
+    nextline^.pixels[i].g:=nextline^.pixels[i].g+(line^.pixels[i].g*e516);
+    nextline^.pixels[i].b:=nextline^.pixels[i].b+(line^.pixels[i].b*e516);
+    if FUseAlpha then
+      nextline^.pixels[i].a:=nextline^.pixels[i].a+(line^.pixels[i].a*e516);
+
+    nextline^.pixels[i+dir].r:=nextline^.pixels[i+dir].r+(line^.pixels[i].r*e116);
+    nextline^.pixels[i+dir].g:=nextline^.pixels[i+dir].g+(line^.pixels[i].g*e116);
+    nextline^.pixels[i+dir].b:=nextline^.pixels[i+dir].b+(line^.pixels[i].b*e116);
+    if FUseAlpha then
+      nextline^.pixels[i+dir].a:=nextline^.pixels[i+dir].a+(line^.pixels[i].a*e116);
+
+    nextline^.pixels[i-dir].r:=nextline^.pixels[i-dir].r+(line^.pixels[i].r*e316);
+    nextline^.pixels[i-dir].g:=nextline^.pixels[i-dir].g+(line^.pixels[i].g*e316);
+    nextline^.pixels[i-dir].b:=nextline^.pixels[i-dir].b+(line^.pixels[i].b*e316);
+    if FUseAlpha then
+      nextline^.pixels[i-dir].a:=nextline^.pixels[i-dir].a+(line^.pixels[i].a*e316);
+
+    i:=i+dir;
+  until ((i<1) or (i>width));
+end;
+
+procedure TFPFloydSteinbergDitherer.DeleteAllPixelLines(var line : PFSPixelLine);
+var tmp : PFSPixelLine;
+begin
+  while line<>nil do
+  begin
+    tmp:=line^.next;
+    FreeMem(line^.pixels);
+    FreeMem(line);
+    line:=tmp;
+  end;
+end;
+
+procedure TFPFloydSteinbergDitherer.InternalDither(const Source : TFPCustomImage; Dest : TFPCustomImage);
+var i : integer;
+    tmpline : PFSPixelLine;
+    percent : byte;
+    percentinterval : longword;
+    percentacc : longword;
+    FContinue : boolean;
+begin
+  FImage:=Source;
+  if FImage.Height=0 then exit;
+  Dest.SetSize(0,0);
+  try
+    Dest.UsePalette:=true;
+    Dest.Palette.Clear;
+    Dest.Palette.Merge(FPalette);
+    Dest.SetSize(FImage.Width,FImage.Height);
+    percent:=0;
+    percentinterval:=(FImage.Height*4) div 100;
+    if percentinterval=0 then percentinterval:=$FFFFFFFF;
+    percentacc:=0;
+    FContinue:=true;
+    Progress (self,psStarting,0,'',FContinue);
+    if not FContinue then exit;
+    CreatePixelLine(Lines,0);
+    CreatePixelLine(Lines^.next,1);
+
+    for i:=0 to FImage.Height-1 do
+    begin
+      DistributeErrors(Lines, i, Dest);
+      tmpline:=Lines;
+      Lines:=Lines^.next;
+      FreeMem(tmpline^.pixels);
+      FreeMem(tmpline);
+      CreatePixelLine(Lines^.next,i+2);
+      inc(percentacc,4);
+      if percentacc>=percentinterval then
+      begin
+        percent:=percent+(percentacc div percentinterval);
+        percentacc:=percentacc mod percentinterval;
+        Progress (self,psRunning,percent,'',FContinue);
+        if not FContinue then exit;
+      end;
+    end;
+    Progress (self,psEnding,100,'',FContinue);
+  finally
+    DeleteAllPixelLines(lines);
+  end;
+end;
+
+
+end.

fcl/image/fpquantizer.pas

@@ -0,0 +1,787 @@
+{*****************************************************************************}
+{
+    This file is part of the Free Pascal's "Free Components Library".
+    Copyright (c) 2005 by Giulio Bernardi
+
+    This file contains classes used to quantize images.
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+{*****************************************************************************}
+
+{$mode objfpc}{$h+}
+unit FPQuantizer;
+
+interface
+
+uses sysutils, classes, fpimage, fpcolhash;
+
+type
+  FPQuantizerException = class (exception);
+
+type
+  TFPQuantizerProgressEvent = procedure (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte;
+                                         const Msg: AnsiString; var Continue : Boolean) of object;
+
+type
+  TFPColorQuantizer = class
+    private
+      FOnProgress : TFPQuantizerProgressEvent;
+    protected
+      FColNum : longword;
+      FSupportsAlpha : boolean;
+      FImages : array of TFPCustomImage;
+      FCount : integer;
+      function InternalQuantize : TFPPalette; virtual; abstract;
+      procedure SetColNum(AColNum : longword); virtual;
+      procedure Progress (Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean); virtual;
+      function GetImage(Index : integer) : TFPCustomImage;
+      procedure SetImage(Index : integer; const Img : TFPCustomImage);
+      procedure SetCount(Value : integer);
+    public
+      property OnProgress : TFPQuantizerProgressEvent read FOnProgress write FOnProgress;
+      property Images[Index : integer] : TFPCustomImage read GetImage write SetImage;
+      property Count : integer read FCount write SetCount;
+      property ColorNumber : longword read FColNum write SetColNum;
+      property SupportsAlpha : boolean read FSupportsAlpha;
+      procedure Clear;
+      procedure Add(const Img : TFPCustomImage);
+      function Quantize : TFPPalette;
+      constructor Create; virtual;
+      destructor Destroy; override;
+  end;
+
+
+type
+  POctreeQNode = ^TOctreeQNode;
+  TOctreeQChilds = array[0..7] of POctreeQNode;
+  TOctreeQNode = record
+    isleaf : boolean;
+    count : longword;
+    R, G, B : longword;
+    Next : POctreeQNode; //used in the reduction list.
+    Childs : TOctreeQChilds;
+  end;
+
+
+type
+  TFPOctreeQuantizer = class(TFPColorQuantizer)
+    private
+      Root : POctreeQNode;
+      ReductionList : TOctreeQChilds;
+      LeafTot, MaxLeaf : longword;
+      percent : byte;              { these values are used to call OnProgress event }
+      percentinterval : longword;
+      percentacc : longword;
+      FContinue : boolean;
+      procedure DisposeNode(var Node : POctreeQNode);
+      procedure AddColor(var Node : POctreeQNode; const R, G, B, Level : byte);
+      procedure AddToPalette(var Node : POctreeQNode; Palette : TFPPalette; var Current : integer);
+      procedure Reduce;
+      function BuildPalette : TFPPalette;
+    protected
+      function InternalQuantize : TFPPalette; override;
+    public
+  end;
+
+type
+  TMCBox = record
+    total, startindex, endindex : longword;
+  end;
+
+const mcSlow = 0;
+      mcNormal = 1;
+      mcFast = 2;
+
+type
+  TFPMedianCutQuantizer = class(TFPColorQuantizer)
+    private
+      HashTable, palcache : TFPColorHashTable;
+      arr : TFPColorWeightArray;
+      boxes : array of TMCBox;
+      Used : integer;
+      percent : byte;              { these values are used to call OnProgress event }
+      percentinterval : longword;
+      percentacc : longword;
+      FContinue : boolean;
+      FMode : byte;
+      function ColorCompare(const c1, c2 : TFPPackedColor; const Dim : byte) : shortint;
+      function FindLargestDimension(const Box : TMCBox) : byte;
+      procedure QuickSort(const l, r : integer; const Dim : byte);
+      procedure QuickSortBoxes(const l, r : integer);
+      function MeanBox(const box : TMCBox) : TFPColor;
+      function BuildPalette : TFPPalette;
+      procedure SetMode(const Amode : byte);
+      function MaskColor(const col : TFPColor) : TFPColor;
+    protected
+      function InternalQuantize : TFPPalette; override;
+    public
+      constructor Create; override;
+      property Mode : byte read FMode write SetMode;
+  end;
+
+implementation
+
+function RGB2FPColor(const R, G, B : longword) : TFPColor;
+begin
+  Result.Red:=(R shl 8) + R;
+  Result.Green:=(G shl 8) + G;
+  Result.Blue:=(B shl 8) + B;
+  Result.Alpha := AlphaOpaque;
+end;
+
+{ TFPColorQuantizer }
+
+function TFPColorQuantizer.Quantize : TFPPalette;
+begin
+  Result:=InternalQuantize;
+end;
+
+constructor TFPColorQuantizer.Create;
+begin
+  FSupportsAlpha:=false;
+  FColNum:=256; //default setting.
+  FCount:=0;
+  setlength(FImages,0);
+end;
+
+destructor TFPColorQuantizer.Destroy;
+begin
+  Setlength(FImages,0);
+  inherited Destroy;
+end;
+
+procedure TFPColorQuantizer.SetColNum(AColNum : longword);
+begin
+  if AColNum<2 then
+    raise FPQuantizerException.Create('Invalid color depth: '+IntToStr(AColNum));
+  FColNum:=AColNum;
+end;
+
+procedure TFPColorQuantizer.Progress(Sender: TObject; Stage: TFPImgProgressStage; PercentDone: Byte; const Msg: AnsiString; var Continue : Boolean);
+begin
+  if Assigned(FOnProgress) then
+    FOnProgress(Sender,Stage,PercentDone,Msg,Continue);
+end;
+
+function TFPColorQuantizer.GetImage(Index : integer) : TFPCustomImage;
+begin
+  if Index>=FCount then
+    raise FPQuantizerException.Create('Invalid image index: '+IntToStr(Index));
+  Result:=FImages[index];
+end;
+
+procedure TFPColorQuantizer.SetImage(Index : integer; const Img : TFPCustomImage);
+begin
+  if Index>=FCount then
+    raise FPQuantizerException.Create('Invalid image index: '+IntToStr(Index));
+  FImages[Index]:=Img;
+end;
+
+procedure TFPColorQuantizer.SetCount(Value : integer);
+var old, i : integer;
+begin
+  old:=FCount;
+  setlength(FImages,Value);
+  for i:=old to Value-1 do
+    FImages[i]:=nil;
+  FCount:=Value;
+end;
+
+procedure TFPColorQuantizer.Clear;
+begin
+  setlength(FImages,0);
+  FCount:=0;
+end;
+
+procedure TFPColorQuantizer.Add(const Img : TFPCustomImage);
+var i : integer;
+begin
+{ Find first unused slot }
+  for i:=0 to FCount-1 do
+    if FImages[i]=nil then
+    begin
+      Fimages[i]:=Img;
+      exit;
+    end;
+ { If we reached this point there are no unused slot: let's enlarge the array }
+  SetCount(Fcount+1);
+  FImages[FCount-1]:=Img;
+end;
+
+{ TFPOctreeQuantizer }
+
+const Mask : array[0..7] of byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+
+procedure TFPOctreeQuantizer.AddColor(var Node : POctreeQNode; const R, G, B, Level : byte);
+var index, shift : byte;
+begin
+  if Node=nil then
+  begin
+    Node:=getmem(sizeof(TOctreeQNode));
+    if Node=nil then
+      raise FPQuantizerException.Create('Out of memory');
+    FillByte(Node^,sizeof(TOctreeQNode),0);
+    if level=7 then
+    begin
+      Node^.isleaf:=true;
+      inc(LeafTot); { we just created a new leaf }
+    end
+    else
+    begin { we don't put leaves in reduction list since this is unuseful }
+      Node^.isleaf:=false;
+      Node^.Next:=ReductionList[level]; { added on top of the reduction list for its level }
+      ReductionList[level]:=Node;
+    end;
+  end;
+  if Node^.isleaf then
+  begin
+    inc(Node^.R,R);
+    inc(Node^.G,G);
+    inc(Node^.B,B);
+    inc(Node^.count);
+  end
+  else
+  begin
+    shift:=7-level;
+    index:=((R and mask[level]) shr shift) shl 2;
+    index:=index+((G and mask[level]) shr shift) shl 1;
+    index:=index+((B and mask[level]) shr shift);
+    AddColor(Node^.Childs[index],R,G,B,Level+1);
+  end;
+end;
+
+procedure TFPOctreeQuantizer.DisposeNode(var Node : POctreeQNode);
+var i : integer;
+begin
+  if Node=nil then exit;
+  if not (Node^.isleaf) then
+    for i:=0 to 7 do
+      if Node^.childs[i]<>nil then
+        DisposeNode(Node^.childs[i]);
+  FreeMem(Node);
+  Node:=nil;
+end;
+
+procedure TFPOctreeQuantizer.Reduce;
+var i : integer;
+    Node : POctreeQNode;
+begin
+  i:=6; { level 7 nodes don't have childs, start from 6 and go backward }
+  while ((i>0) and (ReductionList[i]=nil)) do
+    dec(i);
+
+  { remove this node from the list}
+  Node:=ReductionList[i];
+  ReductionList[i]:=Node^.Next;
+
+  for i:=0 to 7 do
+    if Node^.childs[i]<>nil then
+    begin
+      inc(Node^.count,Node^.childs[i]^.count);
+      inc(Node^.r,Node^.childs[i]^.r);
+      inc(Node^.g,Node^.childs[i]^.g);
+      inc(Node^.b,Node^.childs[i]^.b);
+      DisposeNode(Node^.childs[i]);
+      dec(LeafTot);
+    end;
+  Node^.isleaf:=true;
+  inc(LeafTot); { this node is now a leaf! }
+end;
+
+procedure TFPOctreeQuantizer.AddToPalette(var Node : POctreeQNode; Palette : TFPPalette; var Current : integer);
+var i : byte;
+begin
+  if not FContinue then exit;
+
+  if Node^.isleaf then
+  begin
+    if (current >= LeafTot) then
+      raise FPQuantizerException.Create('Octree Quantizer internal error: palette index too high.');
+    Node^.r:= Node^.r div Node^.count;
+    Node^.g:= Node^.g div Node^.count;
+    Node^.b:= Node^.b div Node^.count;
+    Palette.Color[Current]:=RGB2FPColor(Node^.r,Node^.g,Node^.b);
+    inc(current);
+
+    { ************************************************ }
+    inc(percentacc);
+    if percentacc>=percentinterval then
+    begin
+      dec(percentacc,percentinterval);
+      inc(percent);
+      Progress(self,psRunning,percent,'',FContinue);
+    end;
+    { ************************************************ }
+
+  end
+  else
+  for i:=0 to 7 do
+    if Node^.childs[i]<>nil then
+      AddToPalette(Node^.childs[i],Palette,Current);
+end;
+
+function TFPOctreeQuantizer.BuildPalette : TFPPalette;
+var pal : TFPPalette;
+    i : integer;
+begin
+  if Root=nil then exit;
+  pal:=TFPPalette.Create(LeafTot);
+  i:=0;
+  try
+    AddToPalette(Root,pal,i);
+  except
+    pal.Free;
+    pal:=nil;
+    raise;
+  end;
+  if not FContinue then
+  begin
+    pal.Free;
+    pal:=nil;
+  end;
+  Result:=pal;
+end;
+
+function TFPOctreeQuantizer.InternalQuantize : TFPPalette;
+var i, j, k : integer;
+    color : TFPColor;
+begin
+  Root:=nil;
+  for i:=0 to high(ReductionList) do
+    ReductionList[i]:=nil;
+  LeafTot:=0;
+  MaxLeaf:=FColNum;
+
+  { ************************************************************** }
+  { set up some values useful when calling OnProgress event        }
+  { number of operations is:                                       }
+  {    width*heigth for population                                 }
+  {    initial palette count - final palette count for reduction   }
+  {    final palette count for building the palette                }
+  { total: width*heigth+initial palette count.                     }
+  { if source image doesn't have a palette assume palette count as }
+  { width*height (worst scenario) if it is < 2^24, or 2^24 else    }
+  percentinterval:=0;
+  percentacc:=0;
+  for i:=0 to FCount-1 do
+    if FImages[i]<>nil then
+    begin
+      percentinterval:=percentinterval+FImages[i].Width*FImages[i].Height;
+      if FImages[i].UsePalette then
+        percentacc:=percentacc+FImages[i].Palette.Count
+      else
+        percentacc:=percentacc+FImages[i].Width*FImages[i].Height;
+    end;
+  if percentacc>$1000000 then percentacc:=$1000000;
+
+  percentinterval:=(percentacc+percentinterval) div 100;  { how many operations for 1% }
+  if percentinterval=0 then percentinterval:=$FFFFFFFF;  { it's quick, call progress only when starting and ending }
+  percent:=0;
+  percentacc:=0;
+  FContinue:=true;
+  Progress (self,psStarting,0,'',FContinue);
+  Result:=nil;
+  if not FContinue then exit;
+  { ************************************************************** }
+
+  { populate the octree with colors }
+  try
+    for k:=0 to FCount-1 do
+      if FImages[k]<>nil then
+        for j:=0 to FImages[k].Height-1 do
+          for i:=0 to FImages[k].Width-1 do
+          begin
+            Color:=FImages[k][i,j];
+            AddColor(Root,(Color.Red and $FF00) shr 8,(Color.Green and $FF00) shr 8,(Color.Blue and $FF00) shr 8,0);
+            { ************************************************* }
+            inc(percentacc);
+            if percentacc>=percentinterval then
+            begin
+              dec(percentacc,percentinterval);
+              inc(percent);
+              Progress(self,psRunning,percent,'',FContinue);
+              if not FContinue then exit;
+            end;
+            { ************************************************* }
+          end;
+    { reduce number of colors until it is <= MaxLeaf }
+    while LeafTot > MaxLeaf do
+    begin
+      Reduce;
+      { ************************************************* }
+      inc(percentacc);
+      if percentacc>=percentinterval then
+      begin
+        dec(percentacc,percentinterval);
+        inc(percent);
+        Progress(self,psRunning,percent,'',FContinue);
+        if not FContinue then exit;
+      end;
+      { ************************************************* }
+    end;
+
+    { build the palette }
+    Result:=BuildPalette;
+    if FContinue then Progress (self,psEnding,100,'',FContinue);
+  finally
+    DisposeNode(Root);
+  end;
+end;
+
+{ TFPMedianCutQuantizer }
+
+const DIM_ALPHA = 0;
+      DIM_RED   = 1;
+      DIM_GREEN = 2;
+      DIM_BLUE  = 3;
+
+constructor TFPMedianCutQuantizer.Create;
+begin
+  inherited Create;
+  FSupportsAlpha:=true;
+  FMode:=mcNormal;
+end;
+
+procedure TFPMedianCutQuantizer.SetMode(const Amode : byte);
+begin
+  if not (Amode in [mcSlow,mcNormal,mcFast]) then
+    raise FPQuantizerException.Create('Invalid quantizer mode: '+IntToStr(Amode));
+  FMode:=Amode;
+end;
+
+function TFPMedianCutQuantizer.FindLargestDimension(const Box : TMCBox) : byte;
+var i : longword;
+    col : TFPPackedColor;
+    maxa, mina, maxr, minr, maxg, ming, maxb, minb : byte;
+begin
+  maxa:=0;   maxr:=0;   maxg:=0;   maxb:=0;
+  mina:=$FF; minr:=$FF; ming:=$FF; minb:=$FF;
+  for i:=box.startindex to box.endindex do
+  begin
+    col:=arr[i]^.Col;
+    if col.A<mina then mina:=col.A;
+    if col.A>maxa then maxa:=col.A;
+    if col.R<minr then minr:=col.R;
+    if col.R>maxr then maxr:=col.R;
+    if col.G<ming then ming:=col.G;
+    if col.G>maxg then maxg:=col.G;
+    if col.B<minb then minb:=col.B;
+    if col.B>maxb then maxb:=col.B;
+  end;
+  maxa:=maxa-mina;
+  maxr:=maxr-minr;
+  maxg:=maxg-ming;
+  maxb:=maxb-minb;
+  if ((maxa>maxr) and (maxa>maxg) and (maxa>maxb)) then Result:=DIM_ALPHA
+  else if ((maxr>maxa) and (maxr>maxg) and (maxr>maxb)) then Result:=DIM_RED
+  else if ((maxg>maxa) and (maxg>maxr) and (maxg>maxb)) then Result:=DIM_GREEN
+  else Result:=DIM_BLUE;
+end;
+
+function TFPMedianCutQuantizer.ColorCompare(const c1, c2 : TFPPackedColor; const Dim : byte) : shortint;
+var tmp : integer;
+begin
+  case Dim of
+    DIM_ALPHA : tmp:=(c1.A-c2.A);
+    DIM_RED   : tmp:=(c1.R-c2.R);
+    DIM_GREEN : tmp:=(c1.G-c2.G);
+    DIM_BLUE  : tmp:=(c1.B-c2.B)
+  else raise FPQuantizerException.Create('Invalid dimension: '+IntToStr(Dim));
+  end;
+  if tmp>0 then Result:=1
+  else if tmp<0 then Result:=-1
+  else Result:=0;
+end;
+
+procedure TFPMedianCutQuantizer.QuickSort(const l, r : integer; const Dim : byte);
+var i, j : integer;
+    pivot, temp : PFPColorWeight;
+begin
+  if l<r then
+  begin
+    pivot:=arr[l];
+    i:=l+1;
+    j:=r;
+    repeat
+      while ((i<=r) and (ColorCompare(arr[i]^.Col,pivot^.Col,dim)<=0)) do
+        inc(i);
+      while (ColorCompare(arr[j]^.Col,pivot^.Col,dim)=1) do
+        dec(j);
+      if i<j then
+      begin
+        temp:=arr[i];
+        arr[i]:=arr[j];
+        arr[j]:=temp;
+      end;
+    until i > j;
+    { don't swap if they are equal }
+    if ColorCompare(arr[j]^.Col,pivot^.Col,dim)<>0 then
+    begin
+      arr[l]:=arr[j];
+      arr[j]:=pivot;
+    end;
+    Quicksort(l,j-1,dim);
+    Quicksort(i,r,dim);
+  end;
+end;
+
+procedure TFPMedianCutQuantizer.QuickSortBoxes(const l, r : integer);
+var i, j : integer;
+    pivot, temp : TMCBox;
+begin
+  if l<r then
+  begin
+    pivot:=boxes[l];
+    i:=l+1;
+    j:=r;
+    repeat
+      while ((i<=r) and (boxes[i].total>=pivot.total)) do
+        inc(i);
+      while (boxes[j].total<pivot.total) do
+        dec(j);
+      if i<j then
+      begin
+        temp:=boxes[i];
+        boxes[i]:=boxes[j];
+        boxes[j]:=temp;
+      end;
+    until i > j;
+    { don't swap if they are equal }
+    if boxes[j].total<>pivot.total then
+    begin
+      boxes[l]:=boxes[j];
+      boxes[j]:=pivot;
+    end;
+    QuicksortBoxes(l,j-1);
+    QuicksortBoxes(i,r);
+  end;
+end;
+
+function TFPMedianCutQuantizer.MeanBox(const box : TMCBox) : TFPColor;
+var tota,totr,totg,totb, pixcount : longword;
+    i : integer;
+    col : TFPPackedColor;
+    fpcol : TFPColor;
+begin
+  tota:=0; totr:=0; totg:=0; totb:=0; pixcount:=0;
+  for i:=box.startindex to box.endindex do
+  begin
+    tota:=tota+(arr[i]^.Col.A*arr[i]^.Num);
+    totr:=totr+(arr[i]^.Col.R*arr[i]^.Num);
+    totg:=totg+(arr[i]^.Col.G*arr[i]^.Num);
+    totb:=totb+(arr[i]^.Col.B*arr[i]^.Num);
+    inc(pixcount,arr[i]^.Num);
+  end;
+  tota:=round(tota / pixcount);
+  totr:=round(totr / pixcount);
+  totg:=round(totg / pixcount);
+  totb:=round(totb / pixcount);
+  if tota>$FF then tota:=$FF;
+  if totr>$FF then totr:=$FF;
+  if totg>$FF then totg:=$FF;
+  if totb>$FF then totb:=$FF;
+  col.a:=tota;
+  col.r:=totr;
+  col.g:=totg;
+  col.b:=totb;
+  fpcol:=Packed2FPColor(col);
+  if palcache.Get(fpcol)<>nil then { already found, try the middle color }
+  begin
+    fpcol:=Packed2FPColor(arr[(box.startindex+box.endindex) div 2]^.Col);
+    if palcache.Get(fpcol)<>nil then { already found, try the first unused color }
+      for i:=box.startindex to box.endindex do
+      begin
+        col.a:=arr[i]^.Col.A;
+        col.r:=arr[i]^.Col.R;
+        col.g:=arr[i]^.Col.G;
+        col.b:=arr[i]^.Col.B;
+        fpcol:=Packed2FPColor(col);
+        if palcache.Get(fpcol)=nil then break;
+      end;
+  end;
+  palcache.Insert(fpcol,nil);
+  Result:=fpcol;
+end;
+
+function TFPMedianCutQuantizer.BuildPalette : TFPPalette;
+var pal : TFPPalette;
+    i : integer;
+begin
+  pal:=TFPPalette.Create(Used);
+  try
+    palcache:=TFPColorHashTable.Create;
+    try
+      for i:=0 to Used-1 do
+      begin
+        pal.Color[i]:=MeanBox(boxes[i]);
+        { ************************************************* }
+        inc(percentacc);
+        if percentacc>=percentinterval then
+        begin
+          percentacc:=percentacc mod percentinterval;
+          inc(percent);
+          Progress(self,psRunning,percent,'',FContinue);
+          if not FContinue then exit;
+        end;
+        { ************************************************* }
+      end
+    finally
+      palcache.Free;
+    end;
+  except
+    pal.Free;
+    raise;
+  end;
+  Result:=pal;
+end;
+
+{ slow   mode: no filtering 
+  normal mode: 8 bit r, 6 bit g, 6 bit b 
+  fast   mode: 5 bit r, 5 bit g, 5 bit b }
+
+const mask_r_normal = $FFFF;
+      mask_g_normal = $FCFC;
+      mask_b_normal = $FCFC;
+      mask_r_fast   = $F8F8;
+      mask_g_fast   = $F8F8;
+      mask_b_fast   = $F8F8;
+
+function TFPMedianCutQuantizer.MaskColor(const col : TFPColor) : TFPColor;
+begin
+  case FMode of
+    mcNormal:
+          begin
+            Result.Red:=Col.Red and mask_r_normal;
+            Result.Green:=Col.Green and mask_g_normal;
+            Result.Blue:=Col.Blue and mask_b_normal;
+          end;
+    mcFast:
+          begin
+            Result.Red:=Col.Red and mask_r_fast;
+            Result.Green:=Col.Green and mask_g_fast;
+            Result.Blue:=Col.Blue and mask_b_fast;
+          end
+    else Result:=Col;
+  end;
+end;
+
+function TFPMedianCutQuantizer.InternalQuantize : TFPPalette;
+var box : ^TMCBox;
+    i, j, k : integer;
+    dim : byte;
+    boxpercent : longword;
+begin
+  HashTable:=TFPColorHashTable.Create;
+  try
+  { *****************************************************************************
+    Operations:
+    width*height of each image (populate the hash table)
+    number of desired colors for the box creation process (this should weight as the previous step)
+    number of desired colors for building the palette.
+  }
+    percentinterval:=0;
+    for k:=0 to FCount-1 do
+      if FImages[k]<>nil then
+        percentinterval:=percentinterval+FImages[k].Height*FImages[k].Width;
+    boxpercent:=percentinterval div FColNum;
+    percentinterval:=percentinterval*2+FColNum;
+
+  percentinterval:=percentinterval div 100;  { how many operations for 1% }
+  if percentinterval=0 then percentinterval:=$FFFFFFFF;  { it's quick, call progress only when starting and ending }
+  percent:=0;
+  percentacc:=0;
+  FContinue:=true;
+  Progress (self,psStarting,0,'',FContinue);
+  if not FContinue then exit;
+  { ***************************************************************************** }
+
+  { For every color in the images, count how many pixels use it}
+    for k:=0 to FCount-1 do
+      if FImages[k]<>nil then
+        for j:=0 to FImages[k].Height-1 do
+          for i:=0 to FImages[k].Width-1 do
+          begin
+            HashTable.Add(MaskColor(FImages[k][i,j]),1);
+            { ************************************************* }
+            inc(percentacc);
+            if percentacc>=percentinterval then
+            begin
+              percentacc:=percentacc mod percentinterval;
+              inc(percent);
+              Progress(self,psRunning,percent,'',FContinue);
+              if not FContinue then exit;
+            end;
+            { ************************************************* }
+          end;
+  { Then let's have the list in array form }
+    setlength(arr,0);
+    arr:=HashTable.GetArray;
+    try
+      HashTable.Clear; { free some resources }
+
+      setlength(boxes,FColNum);
+      boxes[0].startindex:=0;
+      boxes[0].endindex:=length(arr)-1;
+      boxes[0].total:=boxes[0].endindex+1;
+      Used:=1;
+
+      while (used<FColNum) do
+      begin
+        box:=nil;
+        { find a box with at least 2 colors }
+        for i:=0 to Used-1 do
+          if (boxes[i].total)>=2 then
+          begin
+            box:=@boxes[i];
+            break;
+          end;
+        if box=nil then break;
+
+        dim:=FindLargestDimension(box^);
+        { sort the colors of the box along the largest dimension }
+        QuickSort(box^.startindex,box^.endindex,dim);
+
+        { Split the box: half of the colors in the first one, the rest in the second one }
+        j:=(box^.startindex+box^.endindex) div 2;
+        { This is the second box }
+        boxes[Used].startindex:=j+1;
+        boxes[Used].endindex:=box^.endindex;
+        boxes[Used].total:=box^.endindex-j;
+        { And here we update the first box }
+        box^.endindex:=j;
+        box^.total:=box^.endindex-box^.startindex+1;
+        { Sort the boxes so that the first one is the one with higher number of colors }
+        QuickSortBoxes(0,Used);
+        inc(Used);
+
+        { ************************************************* }
+        inc(percentacc,boxpercent);
+        if percentacc>=percentinterval then
+        begin
+          inc(percent,percentacc div percentinterval);
+          percentacc:=percentacc mod percentinterval;
+          Progress(self,psRunning,percent,'',FContinue);
+          if not FContinue then exit;
+        end;
+        { ************************************************* }
+      end;
+      Result:=BuildPalette;
+      if FContinue then Progress (self,psEnding,100,'',FContinue);
+    finally
+      setlength(boxes,0);
+      for i:=0 to length(arr)-1 do
+        FreeMem(arr[i]);
+      setlength(arr,0);
+    end;
+  finally
+    HashTable.Free;
+  end;
+end;
+
+end.

fcl/inc/syncob.inc

@@ -30,35 +30,3 @@ procedure TCriticalSection.Leave;
 begin
   Release;
 end;
-
-constructor TMultiReadExclusiveWriteSynchronizer.Create;
-
-begin
-  Crit:=tcriticalsection.create;
-end;
-
-destructor TMultiReadExclusiveWriteSynchronizer.Destroy;
-begin
-  Crit.free;
-end;
-
-procedure  TMultiReadExclusiveWriteSynchronizer.Beginwrite;
-begin
-  Crit.acquire;
-end;
-
-procedure  TMultiReadExclusiveWriteSynchronizer.Endwrite;
-begin
-  Crit.release;
-end;
-
-procedure  TMultiReadExclusiveWriteSynchronizer.Beginread;
-begin
-  Crit.acquire;
-end;
-
-procedure  TMultiReadExclusiveWriteSynchronizer.Endread;
-begin
-  Crit.acquire;
-end;
-

fcl/inc/syncobh.inc

@@ -62,15 +62,3 @@ type
    TSimpleEvent = class(TEventObject)
       constructor Create;
    end;
-
-   TMultiReadExclusiveWriteSynchronizer = class
-   private
-      crit:TCriticalsection;
-   public
-      constructor Create; virtual;
-      destructor  Destroy; override;
-      procedure Beginwrite;
-      procedure Endwrite;
-      procedure Beginread;
-      procedure Endread;
-   end;

packages/base/libc/crypth.inc

@@ -1,9 +1,9 @@
 
 
 { defined earlier in unistdh.inc...
-function crypt(__key:Pchar; __salt:Pchar):Pchar;cdecl;external clib name 'crypt';
-procedure setkey(__key:Pchar);cdecl;external clib name 'setkey';
-procedure encrypt(__block:Pchar; __edflag:longint);cdecl;external clib name 'encrypt';
+function crypt(__key:Pchar; __salt:Pchar):Pchar;cdecl;external cryptlib name 'crypt';
+procedure setkey(__key:Pchar);cdecl;external cryptlib name 'setkey';
+procedure encrypt(__block:Pchar; __edflag:longint);cdecl;external cryptlib name 'encrypt';
 }
 type
    Pcrypt_data = ^crypt_data;
@@ -20,9 +20,9 @@ type
         initialized : longint;
      end;
 
-function crypt_r(__key:Pchar; __salt:Pchar; __data:Pcrypt_data):Pchar;cdecl;external clib name 'crypt_r';
-procedure setkey_r(__key:Pchar; __data:Pcrypt_data);cdecl;external clib name 'setkey_r';
-procedure encrypt_r(__block:Pchar; __edflag:longint; __data:Pcrypt_data);cdecl;external clib name 'encrypt_r';
+function crypt_r(__key:Pchar; __salt:Pchar; __data:Pcrypt_data):Pchar;cdecl;external cryptlib name 'crypt_r';
+procedure setkey_r(__key:Pchar; __data:Pcrypt_data);cdecl;external cryptlib name 'setkey_r';
+procedure encrypt_r(__block:Pchar; __edflag:longint; __data:Pcrypt_data);cdecl;external cryptlib name 'encrypt_r';
 
 { ---------------------------------------------------------------------
     Borland compatibility types

packages/base/libc/dlfcnh.inc

@@ -3,10 +3,10 @@ Const
   RTLD_NEXT = Pointer(-1);
   RTLD_DEFAULT = nil;
 
-function dlopen(__file:Pchar; __mode:longint):pointer;cdecl;external clib name 'dlopen';
-function dlclose(__handle:pointer):longint;cdecl;external clib name 'dlclose';
-function dlsym(__handle:pointer; __name:Pchar):pointer;cdecl;external clib name 'dlsym';
-function dlvsym(__handle:pointer; __name:Pchar; __version:Pchar):pointer;cdecl;external clib name 'dlvsym';
+function dlopen(__file:Pchar; __mode:longint):pointer;cdecl;external dllib name 'dlopen';
+function dlclose(__handle:pointer):longint;cdecl;external dllib name 'dlclose';
+function dlsym(__handle:pointer; __name:Pchar):pointer;cdecl;external dllib name 'dlsym';
+function dlvsym(__handle:pointer; __name:Pchar; __version:Pchar):pointer;cdecl;external dllib name 'dlvsym';
 function dlerror:Pchar;cdecl;external clib name 'dlerror';
 
 type
@@ -19,7 +19,7 @@ type
         dli_saddr : pointer;
      end;
 
-function dladdr(__address:pointer; __info:PDl_info):longint;cdecl;external clib name 'dladdr';
+function dladdr(__address:pointer; __info:PDl_info):longint;cdecl;external dllib name 'dladdr';
 
 { ---------------------------------------------------------------------
     Borland compatibility types
@@ -29,5 +29,5 @@ Type
   TDLInfo = Dl_info;
   PDLInfo = ^TDLInfo;
 
-function dladdr(__address:pointer; var __info: Dl_info):longint;cdecl;external clib name 'dladdr';
+function dladdr(__address:pointer; var __info: Dl_info):longint;cdecl;external dllib name 'dladdr';
 

packages/base/libc/libc.pp

@@ -9,6 +9,8 @@ uses kerneldefs;
 
 Const
   clib = 'c';
+  dllib = 'dl';
+  cryptlib = 'crypt';
   threadslib = 'pthread';
 
 {$i glue.inc}           // C to Pascal type mappings

packages/base/libc/stdioh.inc

@@ -27,6 +27,7 @@ function tmpfile64:PFILE;cdecl;external clib name 'tmpfile64';
 
 function tmpnam(__s:Pchar):Pchar;cdecl;external clib name 'tmpnam';
 function tmpnam_r(__s:Pchar):Pchar;cdecl;external clib name 'tmpnam_r';
+function tempnam(dir,pfx: PChar): PChar; cdecl; external clib name 'tempnam';
 
 function fclose(__stream:PFILE):longint;cdecl;external clib name 'fclose';
 function fflush(__stream:PFILE):longint;cdecl;external clib name 'fflush';

rtl/freebsd/bsdport.txt

@@ -1,24 +1,15 @@
 $Id: bsdport.txt,v 1.5 2003/11/18 21:47:19 marco Exp $
 
+$Revision$
+
 The Free Pascal *BSD port.
 
 Comments, mistakes and suggestions to [email protected]
 
-Since the last update to this document, I added the Net and OpenBSD ports,
-so now it is a *BSD port. I don't own BSDi or a Mac OS X, or even accounts
-on an intel system so that'll have to wait.  (the Mac OS X/Darwin port
-will definitely take off if the PPC codegenerator is fully working)
-
-In 1.1.x branch, the tree RTLs will be merged into one, for easier
-maintaining, this will hopefully increase the Open and NetBSD ports
-somewhat. 
 
-I'm actively searching for test accounts on Open and NetBSD/i386 (and
-in the future also for other processors).
-Requirements: minimal:   some MBs account, permanent connection, 100 MHz+
-			  (speed not that important)
-	      cool   :   100 MB + 100MB tempspace, low latency connection
-			 fast machine that allows swift cycling.
+In 1.1.x/1.9.x/2.0.x branch, the  BSD RTLs are merged into one, for easier
+maintaining, NetBSD and OpenBSD are dropped due to lack of feedback and
+interest, Darwin has been added.
 
 1 *BSD status and notes. (kept on CVS because I work on several places)
 -----------------------------------------------------------------------------
@@ -29,13 +20,18 @@ Please read these before running a *BSD snapshot/release
 ---
 
    FREEBSD
-            4.x    : Used to develop and maintain port. Should work, all
+	    6.x	   : roughly same as 4.x
+	    5.x    : Used to develop and maintain port. Should work, all
 			 versions. Best *BSD platform.
+            4.x    : Should work mostly. Maybe some updates to prt0.as/cprt0.as
+			needed.
 
             3.x    : _not_ supported,  (3.2, 3.4, 3.6 would probably work
    		     with some very minor changes to the signalhandling. The
    		     syscall numbers changed)
 
+(all these are deprecated in 1.0.x
+
   (NON-ELF) 2.x    : _not_ supported, but it might be doable. (the
    		     OpenBSD port works on a.out)
    
@@ -50,7 +46,7 @@ Please read these before running a *BSD snapshot/release
 		      from the ports tree (devel/binutils) to function
 		      properly. Linker of the ports tree is easier,
 		      but that one doesn't want to make shared files.
-
+)
 The IDE also is starting to work quite nicely on FreeBSD, so it is included
 in the releases since 1.0.6. I didn't check the fixes for *BSD on the other
 two OSes yet.

rtl/inc/elfres32.inc

@@ -1,5 +1,5 @@
 
-const 
+const
   fpcres2elf_version=1;
 
 type
@@ -31,11 +31,11 @@ type
   PFPCResourceInfo = ^TFPCResourceInfo;
 
   TFPCRuntimeResourceInfo = packed record
-    reshash: longint;   // always 32bit, contains an ELF hash of the resource entries name
-    restype: longint;   // always 32bit, contains the resource type ID compatible with Windows RES IDs
-    ptr:     pointer;   // Memory pointer to the reosource
-    name:    string;    // String containing the name of the resource
-    size:    longint;   // The size of the resource entry - 32/64 Bit, depending on platform
+    reshash: longint;    // always 32bit, contains an ELF hash of the resource entries name
+    restype: longint;    // always 32bit, contains the resource type ID compatible with Windows RES IDs
+    ptr:     pointer;    // Memory pointer to the reosource
+    name:    ansistring; // String containing the name of the resource
+    size:    longint;    // The size of the resource entry - 32/64 Bit, depending on platform
   end;
   PFPCRuntimeResourceInfo = ^TFPCRuntimeResourceInfo;
 
@@ -66,31 +66,31 @@ begin
     Result := Result and (not G);
   end;
 end;
-  
+
 procedure InitializeResources;
 
-var 
+var
   i:longint;
   CurrentResource:pFPCResourceInfo;
-  
+
 begin
   If (FPCResourceSectionLocation=Nil) then
     ResInfoCount:=0
-  else  
+  else
     ResInfoCount:=FPCResourceSectionLocation^.resentries;
   If (ResInfoCount<>0) then
     begin
     FPCRuntimeResourceInfoArray:=GetMem(SizeOf(TFPCRuntimeResourceInfo)*ResInfoCount);
     for i:=0 to ResInfoCount-1 do
       begin
-      CurrentResource:=pFPCResourceInfo(pointer(longint(FPCResourceSectionLocation^.reshash.ptr)+i*sizeof(TFPCResourceInfo)));
+      CurrentResource:=pFPCResourceInfo(pointer(FPCResourceSectionLocation^.reshash.ptr+i*sizeof(TFPCResourceInfo)));
       FPCRuntimeResourceInfoArray[i].reshash:=CurrentResource^.reshash;
       FPCRuntimeResourceInfoArray[i].restype:=CurrentResource^.restype;
-      FPCRuntimeResourceInfoArray[i].ptr:=pointer(longint(CurrentResource^.ptr)+longint(FPCResourceSectionLocation^.resdata.ptr));
-      FPCRuntimeResourceInfoArray[i].name:=pchar(pointer(longint(CurrentResource^.name)+longint(FPCResourceSectionLocation^.ressym.ptr)));
+      FPCRuntimeResourceInfoArray[i].ptr:=pointer(CurrentResource^.ptr)+PtrInt(FPCResourceSectionLocation^.resdata.ptr);
+      FPCRuntimeResourceInfoArray[i].name:=pchar(CurrentResource^.name)+PtrInt(FPCResourceSectionLocation^.ressym.ptr);
       FPCRuntimeResourceInfoArray[i].size:=CurrentResource^.size;
       end;
-    end;  
+    end;
   InitRes:=true;
 end;
 
@@ -102,16 +102,16 @@ end;
 
 function FindResource(ModuleHandle: HMODULE; ResourceName: PChar; ResourceType: PChar): TResourceHandle;
 
-var 
+var
   i:longint;
   searchhash:longint;
   n : string;
-  
+
 begin
   Result:=0;
-  if (ResourceName=nil) then 
+  if (ResourceName=nil) then
     Exit;
-  If Not InitRes then 
+  If Not InitRes then
     InitializeResources;
   searchhash:=HashELF(ResourceName);
   n:=strpas(resourcename);
@@ -120,13 +120,13 @@ begin
     begin
     if (FPCRuntimeResourceInfoArray[i].reshash=searchhash) and (FPCRuntimeResourceInfoArray[i].name=n) then
       result:=i+1;
-    Inc(I);  
+    Inc(I);
     end;
 end;
 
 function LoadResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): HGLOBAL;
 begin
-  If Not InitRes then 
+  If Not InitRes then
     InitializeResources;
   if (ResHandle>0) and (ResHandle-1<=ResInfoCount) then
     result:=HGLOBAL(FPCRuntimeResourceInfoArray[ResHandle-1].ptr)
@@ -136,7 +136,7 @@ end;
 
 function SizeofResource(ModuleHandle: HMODULE; ResHandle: TResourceHandle): Integer;
 begin
-  If Not InitRes then 
+  If Not InitRes then
     InitializeResources;
   if (ResHandle>0) and (ResHandle-1<=ResInfoCount) then
     result:=FPCRuntimeResourceInfoArray[ResHandle-1].size

rtl/inc/objpas.inc

@@ -116,10 +116,10 @@
              self.destroy;
         end;
 
-      class function TObject.InstanceSize : LongInt;
+      class function TObject.InstanceSize : SizeInt;
 
         begin
-           InstanceSize:=plongint(pointer(self)+vmtInstanceSize)^;
+           InstanceSize:=pSizeInt(pointer(self)+vmtInstanceSize)^;
         end;
 
       procedure InitInterfacePointers(objclass: tclass;instance : pointer);
@@ -153,7 +153,7 @@
 
         begin
            { the size is saved at offset 0 }
-           fillchar(instance^,plongint(pointer(self)+vmtInstanceSize)^,0);
+           fillchar(instance^, InstanceSize, 0);
            { insert VMT pointer into the new created memory area }
            { (in class methods self contains the VMT!)           }
            ppointer(instance)^:=pointer(self);
@@ -175,7 +175,7 @@
            p : pointer;
 
         begin
-           getmem(p,plongint(pointer(self)+vmtInstanceSize)^);
+           getmem(p, InstanceSize);
            if p <> nil then
               InitInstance(p);
            NewInstance:=TObject(p);

rtl/inc/objpash.inc

@@ -127,12 +127,12 @@
           procedure Free;
           class function InitInstance(instance : pointer) : tobject;
           procedure CleanupInstance;
-          class function ClassType : tclass;
+          class function ClassType : tclass;{$ifdef SYSTEMINLINE}inline;{$endif}
           class function ClassInfo : pointer;
           class function ClassName : shortstring;
           class function ClassNameIs(const name : string) : boolean;
-          class function ClassParent : tclass;
-          class function InstanceSize : longint;
+          class function ClassParent : tclass;{$ifdef SYSTEMINLINE}inline;{$endif}
+          class function InstanceSize : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
           class function InheritsFrom(aclass : tclass) : boolean;
           class function StringMessageTable : pstringmessagetable;
           { message handling routines }

rtl/inc/variant.inc

@@ -16,7 +16,7 @@
 
 var
    variantmanager : tvariantmanager;
-   
+
 procedure printmissingvariantunit;
   begin
     writeln(stderr);
@@ -25,8 +25,8 @@ procedure printmissingvariantunit;
     writeln(stderr,'as one of the first units.');
     writeln(stderr);
   end;
-  
-  
+
+
 procedure invalidvariantop;
   begin
      printmissingvariantunit;
@@ -39,8 +39,8 @@ procedure invalidvariantopnovariants;
     printmissingvariantunit;
     HandleErrorFrame(221,get_frame);
   end;
-  
-  
+
+
 procedure vardisperror;
   begin
     printmissingvariantunit;
@@ -486,8 +486,8 @@ operator :=(const source : olevariant) dest : variant;{$ifdef SYSTEMINLINE}inlin
   begin
     tvardata(result):=tvardata(source);
   end;
-  
-    
+
+
 operator :=(const source : variant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
   begin
     variantmanager.olevarfromvar(dest,source);
@@ -618,6 +618,316 @@ procedure VarCast(var dest : variant;const source : variant;vartype : longint);
   end;
 
 
+{**********************************************************************
+                        from OLEVariant assignments
+ **********************************************************************}
+{ Integer }
+operator :=(const source : olevariant) dest : byte;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    { cast away olevar to var conversion and avoid
+      endless recursion }
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : shortint;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : word;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : smallint;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : dword;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : longint;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : qword;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoint64(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : int64;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoword64(variant(tvardata(source)));
+  end;
+
+
+{ Boolean }
+operator :=(const source : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartobool(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : wordbool;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartobool(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : longbool;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartobool(variant(tvardata(source)));
+  end;
+
+
+{ Chars }
+operator :=(const source : olevariant) dest : char;{$ifdef SYSTEMINLINE}inline;{$endif}
+  var
+    S : String;
+  begin
+    VariantManager.VarToPStr(S,Source);
+    If Length(S)>0 then
+      Dest:=S[1]
+    else
+      Dest:=#0;
+  end;
+
+
+operator :=(const source : olevariant) dest : widechar;{$ifdef SYSTEMINLINE}inline;{$endif}
+  Var
+    WS : WideString;
+  begin
+    VariantManager.VarToWStr(WS,Source);
+    If Length(WS)>0 then
+      Dest:=WS[1]
+    else
+      Dest:=#0;
+  end;
+
+
+{ Strings }
+operator :=(const source : olevariant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.vartopstr(dest,variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.vartolstr(dest,variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.vartowstr(dest,variant(tvardata(source)));
+  end;
+
+
+{ Floats }
+{$ifdef SUPPORT_SINGLE}
+operator :=(const source : olevariant) dest : single;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoreal(variant(tvardata(source)));
+  end;
+{$endif SUPPORT_SINGLE}
+
+
+{$ifdef SUPPORT_DOUBLE}
+operator :=(const source : olevariant) dest : double;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoreal(variant(tvardata(source)));
+  end;
+{$endif SUPPORT_DOUBLE}
+
+
+{$ifdef SUPPORT_EXTENDED}
+operator :=(const source : olevariant) dest : extended;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoreal(variant(tvardata(source)));
+  end;
+{$endif SUPPORT_EXTENDED}
+
+
+{$ifdef SUPPORT_COMP}
+operator :=(const source : olevariant) dest : comp;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartoreal(variant(tvardata(source)));
+  end;
+{$endif SUPPORT_COMP}
+
+
+{ Misc. }
+operator :=(const source : olevariant) dest : currency;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartocurr(variant(tvardata(source)));
+  end;
+
+
+operator :=(const source : olevariant) dest : tdatetime;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    dest:=variantmanager.vartotdatetime(variant(tvardata(source)));
+  end;
+
+
+{**********************************************************************
+                          to OLEVariant assignments
+ **********************************************************************}
+
+operator :=(const source : byte) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : shortint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : word) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : smallint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : dword) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : longint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : qword) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+
+operator :=(const source : int64) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromint(dest,source,1);
+  end;
+
+{ Boolean }
+operator :=(const source : boolean) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromBool(variant(tvardata(dest)),Source);
+   end;
+
+
+operator :=(const source : wordbool) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromBool(variant(tvardata(Dest)),Source);
+   end;
+
+
+operator :=(const source : longbool) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromBool(variant(tvardata(Dest)),Source);
+   end;
+
+
+{ Chars }
+operator :=(const source : char) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfrompstr(dest,source);
+  end;
+
+
+operator :=(const source : widechar) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromwstr(variant(tvardata(dest)),source);
+  end;
+
+
+{ Strings }
+operator :=(const source : shortstring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfrompstr(dest,source);
+  end;
+
+
+operator :=(const source : ansistring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.olevarfromlstr(dest,source);
+  end;
+
+
+operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromwstr(variant(tvardata(dest)),source);
+  end;
+
+
+{ Floats }
+{$ifdef SUPPORT_SINGLE}
+operator :=(const source : single) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromreal(variant(tvardata(dest)),source);
+  end;
+{$endif SUPPORT_SINGLE}
+
+
+{$ifdef SUPPORT_DOUBLE}
+operator :=(const source : double) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromreal(variant(tvardata(dest)),source);
+  end;
+{$endif SUPPORT_DOUBLE}
+
+
+{$ifdef SUPPORT_EXTENDED}
+operator :=(const source : extended) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromreal(variant(tvardata(dest)),source);
+  end;
+{$endif SUPPORT_EXTENDED}
+
+
+{$ifdef SUPPORT_COMP}
+operator :=(const source : comp) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromreal(variant(tvardata(dest)),source);
+  end;
+{$endif SUPPORT_COMP}
+
+
+{ Misc. }
+operator :=(const source : currency) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromcurr(variant(tvardata(dest)),source);
+  end;
+
+
+operator :=(const source : tdatetime) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    variantmanager.varfromtdatetime(variant(tvardata(dest)),source);
+  end;
+
 {**********************************************************************
                       Variant manager functions
  **********************************************************************}

rtl/inc/varianth.inc

@@ -286,7 +286,7 @@ operator :=(const source : variant) dest : double;{$ifdef SYSTEMINLINE}inline;{$
 {$ifdef SUPPORT_EXTENDED}
 operator :=(const source : variant) dest : extended;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$endif SUPPORT_EXTENDED}
-{$ifdef SUPPORT_EXTENDED}
+{$ifdef SUPPORT_COMP}
 operator :=(const source : variant) dest : comp;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$endif SUPPORT_COMP}
 
@@ -325,3 +325,119 @@ operator <=(const op1,op2 : variant) dest : boolean;{$ifdef SYSTEMINLINE}inline;
 procedure VarArrayRedim(var A: Variant; HighBound: SizeInt);
 procedure VarCast(var dest : variant;const source : variant;vartype : longint);
 
+{**********************************************************************
+                        from OLEVariant assignments
+ **********************************************************************}
+
+{ Integer }
+operator :=(const source : olevariant) dest : byte;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : shortint;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : word;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : smallint;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : dword;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : longint;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : qword;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : int64;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Boolean }
+operator :=(const source : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : wordbool;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : longbool;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Chars }
+operator :=(const source : olevariant) dest : char;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : widechar;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Strings }
+operator :=(const source : olevariant) dest : shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : widestring;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Floats }
+{$ifdef SUPPORT_SINGLE}
+operator :=(const source : olevariant) dest : single;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_SINGLE}
+{$ifdef SUPPORT_DOUBLE}
+operator :=(const source : olevariant) dest : double;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_DOUBLE}
+{$ifdef SUPPORT_EXTENDED}
+operator :=(const source : olevariant) dest : extended;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_EXTENDED}
+{$ifdef SUPPORT_COMP}
+operator :=(const source : olevariant) dest : comp;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_COMP}
+
+{ Misc. }
+operator :=(const source : olevariant) dest : currency;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : olevariant) dest : tdatetime;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{**********************************************************************
+                         to OLEVariant assignments
+ **********************************************************************}
+
+{ Integer }
+operator :=(const source : byte) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : shortint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : word) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : smallint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : dword) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : longint) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : qword) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : int64) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Boolean }
+operator :=(const source : boolean) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : wordbool) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : longbool) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Chars }
+operator :=(const source : char) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : widechar) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Strings }
+operator :=(const source : shortstring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : ansistring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : widestring) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{ Floats }
+{$ifdef SUPPORT_SINGLE}
+operator :=(const source : single) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_SINGLE}
+{$ifdef SUPPORT_DOUBLE}
+operator :=(const source : double) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_DOUBLE}
+{$ifdef SUPPORT_EXTENDED}
+operator :=(const source : extended) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_EXTENDED}
+{$ifdef SUPPORT_COMP}
+operator :=(const source : comp) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+{$endif SUPPORT_COMP}
+
+{ Misc. }
+operator :=(const source : currency) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator :=(const source : tdatetime) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+
+{**********************************************************************
+                             OLEVariant Operators
+ **********************************************************************}
+{
+operator or(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator and(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator xor(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator not(const op : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator shl(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator shr(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator +(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator -(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator *(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator /(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator **(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator div(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator mod(const op1,op2 : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator -(const op : olevariant) dest : olevariant;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator =(const op1,op2 : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator <(const op1,op2 : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator >(const op1,op2 : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator >=(const op1,op2 : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+operator <=(const op1,op2 : olevariant) dest : boolean;{$ifdef SYSTEMINLINE}inline;{$endif}
+}

rtl/inc/wstringh.inc

@@ -20,6 +20,9 @@ Function Pos (Const Substr : WideString; Const Source : WideString) : SizeInt;
 Function Pos (c : Char; Const s : WideString) : SizeInt;
 Function Pos (c : WideChar; Const s : WideString) : SizeInt;
 Function Pos (c : WideChar; Const s : AnsiString) : SizeInt;
+Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
 
 Function UpCase(const s : WideString) : WideString;
 

rtl/inc/wstrings.inc

@@ -828,6 +828,22 @@ begin
 end;
 
 
+Function Pos (c : AnsiString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    result:=Pos(WideString(c),s);
+  end;
+
+
+Function Pos (c : ShortString; Const s : WideString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    result:=Pos(WideString(c),s);
+  end;
+
+
+Function Pos (c : WideString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+  begin
+    result:=Pos(c,WideString(s));
+  end;
 
 { Faster version for a char alone. Must be implemented because   }
 { pos(c: char; const s: shortstring) also exists, so otherwise   }

rtl/linux/fpcylix.pp

@@ -21,7 +21,10 @@ unit fpcylix;
   interface
 
     uses
-      cwstring,dynlibs;
+      cthreads,cwstring,dynlibs;
+      
+    const
+      MAX_PATH = 4095;
 
     var
       MainInstance: PtrUInt;

rtl/objpas/classes/streams.inc

@@ -755,30 +755,52 @@ end;
 {*                             TResourceStream                              *}
 {****************************************************************************}
 
-procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
+{$ifdef UNICODE}
+procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar);
   begin
     Res:=FindResource(Instance, Name, ResType);
-    if Res=0 then 
+    if Res=0 then
       raise EResNotFound.CreateFmt(SResNotFound,[Name]);
     Handle:=LoadResource(Instance,Res);
     if Handle=0 then
       raise EResNotFound.CreateFmt(SResNotFound,[Name]);
-    SetPointer(LockResource(Handle),SizeOfResource(Instance,Res));    
+    SetPointer(LockResource(Handle),SizeOfResource(Instance,Res));
   end;
 
+constructor TResourceStream.Create(Instance: THandle; const ResName: WideString; ResType: PWideChar);
+  begin
+    inherited create;
+    Initialize(Instance,PWideChar(ResName),ResType);
+  end;
+constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PWideChar);
+  begin
+    inherited create;
+    Initialize(Instance,PWideChar(ResID),ResType);
+  end;
+{$else UNICODE}
+
+procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
+  begin
+    Res:=FindResource(Instance, Name, ResType);
+    if Res=0 then
+      raise EResNotFound.CreateFmt(SResNotFound,[Name]);
+    Handle:=LoadResource(Instance,Res);
+    if Handle=0 then
+      raise EResNotFound.CreateFmt(SResNotFound,[Name]);
+    SetPointer(LockResource(Handle),SizeOfResource(Instance,Res));
+  end;
 
 constructor TResourceStream.Create(Instance: THandle; const ResName: string; ResType: PChar);
   begin
     inherited create;
     Initialize(Instance,pchar(ResName),ResType);
   end;
-
-
 constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
   begin
     inherited create;
-    Initialize(Instance,pchar(ResID),ResType);
+    Initialize(Instance,pchar(PtrInt(ResID)),ResType);
   end;
+{$endif UNICODE}
 
 
 destructor TResourceStream.Destroy;

rtl/objpas/sysutils/sysstr.inc

@@ -101,6 +101,11 @@ begin
     end;
 end;
 
+function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
+  begin
+    result:=LowerCase(ansistring(V));
+  end;
+
 
 {   CompareStr compares S1 and S2, the result is the based on
     substraction of the ascii values of the characters in S1 and S2

rtl/objpas/sysutils/sysstrh.inc

@@ -65,6 +65,9 @@ procedure AssignStr(var P: PString; const S: string);
 procedure AppendStr(var Dest: String; const S: string);
 function UpperCase(const s: string): string;
 function LowerCase(const s: string): string; overload;
+{ the compiler can't decide else if it should use the char or the ansistring
+  version for a variant } 
+function LowerCase(const V: variant): string; overload;{$ifdef SYSUTILSINLINE}inline;{$endif}
 function CompareStr(const S1, S2: string): Integer;
 function CompareMemRange(P1, P2: Pointer; Length: cardinal): integer;
 function CompareMem(P1, P2: Pointer; Length: cardinal): Boolean;

rtl/objpas/sysutils/systhrdh.inc

@@ -21,6 +21,17 @@ type
      procedure EndWrite;
    end;
 
+   TMultiReadExclusiveWriteSynchronizer = class(TInterfacedObject,IReadWriteSync)
+   private
+      crit : TRtlCriticalSection;
+   public
+      constructor Create; virtual;
+      destructor  Destroy; override;
+      function Beginwrite : boolean;
+      procedure Endwrite;
+      procedure Beginread;
+      procedure Endread;
+   end;
 
 function InterLockedIncrement (var Target: longint) : longint;
 function InterLockedDecrement (var Target: longint) : longint;

rtl/objpas/sysutils/sysuthrd.inc

@@ -0,0 +1,44 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2005 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+
+constructor TMultiReadExclusiveWriteSynchronizer.Create;
+begin
+  System.InitCriticalSection(Crit);
+end;
+
+destructor TMultiReadExclusiveWriteSynchronizer.Destroy;
+begin
+  System.DoneCriticalSection(Crit);
+end;
+
+function  TMultiReadExclusiveWriteSynchronizer.Beginwrite : boolean;
+begin
+  System.EnterCriticalSection(Crit);
+  result:=true;
+end;
+
+procedure  TMultiReadExclusiveWriteSynchronizer.Endwrite;
+begin
+  System.LeaveCriticalSection(Crit);
+end;
+
+procedure  TMultiReadExclusiveWriteSynchronizer.Beginread;
+begin
+  System.EnterCriticalSection(Crit);
+end;
+
+procedure  TMultiReadExclusiveWriteSynchronizer.Endread;
+begin
+  System.LeaveCriticalSection(Crit);
+end;

rtl/objpas/sysutils/sysutils.inc

@@ -91,6 +91,9 @@
   { wide string functions }
   {$i syswide.inc}
 
+  { threading stuff }
+  {$i sysuthrd.inc}
+  
   { CPU Specific code }
   {$i sysutilp.inc}
 

rtl/objpas/typinfo.pp

@@ -308,13 +308,13 @@ type
   ---------------------------------------------------------------------}
 
 function aligntoptr(p : pointer) : pointer;
-  begin
+   begin
 {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
-    if (ptrint(p) mod sizeof(ptrint))<>0 then
-      inc(ptrint(p),sizeof(ptrint)-ptrint(p) mod sizeof(ptrint));
+     if (ptruint(p) and (sizeof(ptruint)-1))<>0 then
+	  ptruint(p) := (ptruint(p) + sizeof(ptruint) - 1) and not (sizeof(ptruint) - 1);
 {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
-    result:=p;
-  end;
+     aligntoptr:=p;
+   end;
 
 
 Function GetEnumName(TypeInfo : PTypeInfo;Value : Integer) : string;

rtl/unix/cthreads.pp

@@ -340,6 +340,11 @@ Type  PINTRTLEvent = ^TINTRTLEvent;
 
     procedure CDoneCriticalSection(var CS);
       begin
+         { unlock as long as unlocking works to unlock it if it is recursive
+           some Delphi code might call this function with a locked mutex      }
+         while pthread_mutex_unlock(@CS)=0 do
+           ;
+
          if pthread_mutex_destroy(@CS) <> 0 then
            runerror(6);
       end;

rtl/unix/cwstring.pp

@@ -152,7 +152,7 @@ procedure Wide2AnsiMove(source:pwidechar;var dest:ansistring;len:SizeInt);
               destpos:=pchar(dest)+outoffset;
             end;
           else
-            raise EConvertError.Create('iconv error');
+            raise EConvertError.Create('iconv error '+IntToStr(fpgetCerrno));
         end;
       end;
     // truncate string
@@ -182,6 +182,16 @@ procedure Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
     while iconv(iconv_ansi2wide,@srcpos,@len,@destpos,@outleft)=size_t(-1) do
       begin
         case fpgetCerrno of
+         ESysEILSEQ:
+            begin
+              { skip and set to '?' }
+              inc(srcpos);
+              pwidechar(destpos)^:='?';
+              inc(destpos,2);
+              dec(outleft,2);
+              { reset }
+              iconv(iconv_wide2ansi,@mynil,@my0,@mynil,@my0);
+            end;
           ESysE2BIG:
             begin
               outoffset:=destpos-pchar(dest);
@@ -193,7 +203,7 @@ procedure Ansi2WideMove(source:pchar;var dest:widestring;len:SizeInt);
               destpos:=pchar(dest)+outoffset;
             end;
           else
-            raise EConvertError.Create('iconv error');
+            raise EConvertError.Create('iconv error '+IntToStr(fpgetCerrno));
         end;
       end;
     // truncate string
@@ -254,7 +264,7 @@ procedure Ansi2UCS4Move(source:pchar;var dest:UCS4String;len:SizeInt);
               destpos:=pchar(dest)+outoffset;
             end;
           else
-            raise EConvertError.Create('iconv error');
+            raise EConvertError.Create('iconv error '+IntToStr(fpgetCerrno));
         end;
       end;
     // truncate string

tests/webtbs/tw4201.pp

@@ -0,0 +1,75 @@
+{ Source provided for Free Pascal Bug Report 4201 }
+{ Submitted by "Gergely Nagy" on  2005-07-19 }
+{ e-mail: [email protected] }
+{ TThread.Synchronize on an abstract virtual method bug demonstration
+  by Gergely Nagy <[email protected]> }
+
+{$mode delphi}
+program fp_thread_bug_test;
+
+uses
+{$ifdef unix}
+  CThreads,
+{$endif unix}
+  Classes;
+
+type
+  TBuggedBaseThread = class;
+
+  TBuggedBaseThread = class (TThread)
+  protected
+    procedure Execute; override;
+    function ExecuteOperation: Boolean; virtual; abstract;
+    procedure EndOperation; virtual; abstract;
+  public
+    constructor Create;
+    procedure StopThread;
+  end;
+
+  TBuggedThread = class (TBuggedBaseThread)
+  protected
+    function ExecuteOperation: Boolean; override;
+    procedure EndOperation; override;
+  end;
+
+constructor TBuggedBaseThread.Create;
+begin
+  inherited Create(True);
+end;
+
+procedure TBuggedBaseThread.StopThread;
+begin
+  Terminate;
+  Suspended:= False;
+  WaitFor;
+  Free;
+end;
+
+procedure TBuggedBaseThread.Execute;
+begin
+  WriteLn ('# Execute...');
+  ExecuteOperation;
+  WriteLn ('# 	...Going to sync...');
+  Synchronize(EndOperation);
+  Terminate;
+end;
+
+procedure TBuggedThread.EndOperation;
+begin
+  WriteLn ('# 	EndOperation');
+end;
+
+function TBuggedThread.ExecuteOperation: Boolean;
+begin
+  WriteLn ('# 	ExecuteOperation');
+  Result:= True;
+end;
+
+var
+  t: TBuggedThread;
+
+begin
+  t:= TBuggedThread.Create;
+
+  t.Execute;
+end.

utils/fpcres/elfres.pas

@@ -467,7 +467,6 @@ begin
   ressym.ptr:=FSectionStream.Position+sizeof(TElf32Header);
   FSymStream.Position:=0;
   FSectionStream.CopyFrom(FSymStream,FSymStream.Size);
-  doalign(4);
 
   // resstr
   resstr.ptr:=FSectionStream.Position+sizeof(TElf32Header);
@@ -555,7 +554,7 @@ begin
   SectionHeader.sh_size:=FSymStream.Size;
   SectionHeader.sh_link:=0;
   SectionHeader.sh_info:=0;
-  SectionHeader.sh_addralign:=4; // alignment
+  SectionHeader.sh_addralign:=1; // DON'T align this, as this section will be merged by ld
   SectionHeader.sh_entsize:=0;
   FSectionStream.Write(SectionHeader,sizeOf(SectionHeader));
 
@@ -578,7 +577,7 @@ begin
   SectionHeader.sh_flags:=2; // A
   SectionHeader.sh_addr:=0;
   SectionHeader.sh_offset:=reshash.ptr;
-  SectionHeader.sh_size:=length(ResourceEntries)*sizeof(TELF32ResourceInfo)+4;
+  SectionHeader.sh_size:=length(ResourceEntries)*sizeof(TELF32ResourceInfo);
   SectionHeader.sh_link:=0;
   SectionHeader.sh_info:=0;
   SectionHeader.sh_addralign:=4; // alignment

utils/fpcres/elfresfix.pas

@@ -130,7 +130,6 @@ end;
 { TElf32ResourceFixer }
 
 procedure TElf32ResourceFixer.DoFixStream(Stream: TStream);
-
 var
   ElfHeader:TElf32header;
   ResourceSectionTable: TElf32ResourceSectionTable;
@@ -143,6 +142,19 @@ var
   strtab:string;
   SectionName: string;
   ResPtrsSection: integer;
+  ResHashSection: integer;
+  ResSymSection: integer;
+
+  ResourceInfo: TELF32ResourceInfo;
+  DataIndex, StringIndex: integer;
+  SymString: string;
+
+  procedure DoAlign(var value:integer; const a: integer);
+  var i: integer;
+  begin
+    i:=(4 - (value MOD a)) MOD a;
+    if (i>0) then inc(value,i);
+  end;
 
 begin
   Fixed:=False;
@@ -184,6 +196,7 @@ begin
   end;
 
   ResPtrsSection:=-1;
+  ResHashSection:=-1;
   ResourceSectionTable.version:=66;
 
   // Next cycle through all sections to gather pointers to all the resource
@@ -205,11 +218,13 @@ begin
         end
       else if sn='ressym' then
         begin
+        ResSymSection:=i;
         ResourceSectionTable.ressym.ptr:=SectionHeaders[i].sh_addr;
         ResourceSectionTable.ressym.size:=SectionHeaders[i].sh_size;
         end
       else if sn='reshash' then
         begin
+        ResHashSection:=i;
         ResourceSectionTable.reshash.ptr:=SectionHeaders[i].sh_addr;
         ResourceSectionTable.reshash.size:=SectionHeaders[i].sh_size;
         ResourceSectionTable.resentries:=SectionHeaders[i].sh_size DIV sizeof(TELF32ResourceInfo);
@@ -235,15 +250,51 @@ begin
   // Ok, we now have pointers to all resource sections and also
   // know the number of resources.
   // Now update the resptrs table
-  if ResPtrsSection>-1 then
-    begin
+  if (ResPtrsSection>-1) and (ResHashSection>-1) and (ResSymSection>-1) then
+  begin
     Doverbose(SUpdatingResPtrs);
     Stream.Position:=SectionHeaders[ResPtrsSection].sh_offset;
     Stream.Write(ResourceSectionTable,sizeof(TELF32ResourceSectionTable));
+
+    // LD might have merged the sections of several linked .or together
+    // Therefore our data and stringtable offsets might be messed up and need to recalculated
+
+    // First get the symbol string
+    Stream.Position:=SectionHeaders[ResSymSection].sh_offset;
+    setlength(SymString, SectionHeaders[ResSymSection].sh_size);
+    Stream.Read(SymString[1], SectionHeaders[ResSymSection].sh_size);
+
+    DataIndex:=0;
+    StringIndex:=0;
+    Stream.Position:=SectionHeaders[ResHashSection].sh_offset;
+
+    for i:=0 to ResourceSectionTable.resentries-1 do
+    begin
+      Stream.Position:=SectionHeaders[ResHashSection].sh_offset+i*sizeof(TELF32ResourceInfo);
+      Stream.Read(ResourceInfo, sizeof(TELF32ResourceInfo));
+      ResourceInfo.ptr:=DataIndex;
+      ResourceInfo.name:=StringIndex;
+
+      // advance for next entry
+      DataIndex:=DataIndex+ResourceInfo.size;
+      DoAlign(DataIndex,4); // The data blocks are 32bit aligned
+
+      // find end of current string
+      while SymString[StringIndex+1]<>#0 do
+        inc(StringIndex,1);
+      inc(StringIndex,1);
+      // this should be the start of the next string
+
+      // write back the entry
+      Stream.Position:=SectionHeaders[ResHashSection].sh_offset+i*sizeof(TELF32ResourceInfo);
+      Stream.Write(ResourceInfo, sizeof(TELF32ResourceInfo));
+    end;
     fixed:=true;
-    end
+  end
   else
     DoError(SErrREsptrsNotFound);
+
+
   if fixed then
     DoVerbose(SFileFixed)
   else