Merged revisions 13218-13347 via svnmerge from

svn+ssh://[email protected]/FPC/svn/fpc/trunk

git-svn-id: branches/objc@13350 -

.gitattributes

@@ -5031,9 +5031,12 @@ packages/winunits-base/src/comconst.pp svneol=native#text/plain
 packages/winunits-base/src/commctrl.pp svneol=native#text/plain
 packages/winunits-base/src/commdlg.pp svneol=native#text/plain
 packages/winunits-base/src/comobj.pp svneol=native#text/plain
+packages/winunits-base/src/dwmapi.pp svneol=native#text/plain
 packages/winunits-base/src/flatsb.pp svneol=native#text/plain
+packages/winunits-base/src/htmlhelp.pp svneol=native#text/plain
 packages/winunits-base/src/imagehlp.pp svneol=native#text/plain
 packages/winunits-base/src/mmsystem.pp svneol=native#text/plain
+packages/winunits-base/src/multimon.pp svneol=native#text/plain
 packages/winunits-base/src/ole2.pp svneol=native#text/plain
 packages/winunits-base/src/oleserver.pp svneol=native#text/plain
 packages/winunits-base/src/richedit.pp svneol=native#text/plain
@@ -5525,6 +5528,7 @@ rtl/darwin/x86_64/sig_cpu.inc svneol=native#text/plain
 rtl/darwin/x86_64/sighnd.inc svneol=native#text/plain
 rtl/embedded/Makefile svneol=native#text/plain
 rtl/embedded/Makefile.fpc svneol=native#text/plain
+rtl/embedded/arm/at91sam7x256.pp svneol=native#text/plain
 rtl/embedded/arm/lpc21x4.pp svneol=native#text/plain
 rtl/embedded/check.inc svneol=native#text/plain
 rtl/embedded/empty.cfg -text
@@ -6017,26 +6021,27 @@ rtl/morphos/varutils.pp svneol=native#text/plain
 rtl/morphos/video.pp svneol=native#text/plain
 rtl/morphos/videodata.inc svneol=native#text/plain
 rtl/nds/Makefile svneol=native#text/plain
-rtl/nds/Makefile.fpc -text
-rtl/nds/classes.pp -text
+rtl/nds/Makefile.fpc svneol=native#text/plain
+rtl/nds/classes.pp svneol=native#text/plain
 rtl/nds/cprt07.as svneol=native#text/plain
 rtl/nds/cprt09.as svneol=native#text/plain
-rtl/nds/dos.pp -text
+rtl/nds/dos.pp svneol=native#text/plain
 rtl/nds/nds.inc svneol=native#text/plain
-rtl/nds/ndsbios.inc -text
-rtl/nds/ndsbiosh.inc -text
+rtl/nds/ndsbios.inc svneol=native#text/plain
+rtl/nds/ndsbiosh.inc svneol=native#text/plain
 rtl/nds/ndsh.inc svneol=native#text/plain
 rtl/nds/prt07.as svneol=native#text/plain
 rtl/nds/prt09.as svneol=native#text/plain
-rtl/nds/sysdir.inc -text
-rtl/nds/sysfile.inc -text
+rtl/nds/sysdir.inc svneol=native#text/plain
+rtl/nds/sysfile.inc svneol=native#text/plain
 rtl/nds/sysheap.inc svneol=native#text/x-pascal
-rtl/nds/sysos.inc -text
-rtl/nds/sysosh.inc -text
+rtl/nds/sysos.inc svneol=native#text/plain
+rtl/nds/sysosh.inc svneol=native#text/plain
+rtl/nds/system.pp svneol=native#text/plain
 rtl/nds/systhrd.inc svneol=native#text/plain
-rtl/nds/sysutils.pp -text
-rtl/nds/tthread.inc -text
-rtl/nds/varutils.pp -text
+rtl/nds/sysutils.pp svneol=native#text/plain
+rtl/nds/tthread.inc svneol=native#text/plain
+rtl/nds/varutils.pp svneol=native#text/plain
 rtl/netbsd/Makefile svneol=native#text/plain
 rtl/netbsd/Makefile.fpc svneol=native#text/plain
 rtl/netbsd/errno.inc svneol=native#text/plain
@@ -6974,12 +6979,14 @@ tests/tbf/tb0211a.pp svneol=native#text/plain
 tests/tbf/tb0212.pp svneol=native#text/plain
 tests/tbf/tb0213.pp svneol=native#text/plain
 tests/tbf/tb0214.pp svneol=native#text/plain
+tests/tbf/tb0214a.pp svneol=native#text/plain
 tests/tbf/tb0215.pp svneol=native#text/plain
 tests/tbf/tb0215a.pp svneol=native#text/plain
 tests/tbf/tb0215b.pp svneol=native#text/plain
 tests/tbf/tb0215c.pp svneol=native#text/plain
 tests/tbf/tb0215d.pp svneol=native#text/plain
 tests/tbf/tb0215e.pp svneol=native#text/plain
+tests/tbf/tb0216.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -7095,7 +7102,6 @@ tests/tbs/tb0110.pp svneol=native#text/plain
 tests/tbs/tb0111.pp svneol=native#text/plain
 tests/tbs/tb0112.pp svneol=native#text/plain
 tests/tbs/tb0113.pp svneol=native#text/plain
-tests/tbs/tb0114.pp svneol=native#text/plain
 tests/tbs/tb0115.pp svneol=native#text/plain
 tests/tbs/tb0116.pp svneol=native#text/plain
 tests/tbs/tb0117.pp svneol=native#text/plain
@@ -8009,6 +8015,8 @@ tests/test/opt/twpo2.pp svneol=native#text/plain
 tests/test/opt/twpo3.pp svneol=native#text/plain
 tests/test/opt/twpo4.pp svneol=native#text/plain
 tests/test/opt/twpo5.pp svneol=native#text/plain
+tests/test/opt/twpo6.pp svneol=native#text/plain
+tests/test/opt/twpo7.pp svneol=native#text/plain
 tests/test/opt/uwpo2.pp svneol=native#text/plain
 tests/test/packages/fcl-base/tascii85.pp svneol=native#text/plain
 tests/test/packages/fcl-base/tgettext1.pp svneol=native#text/plain
@@ -8232,6 +8240,7 @@ tests/test/tparray22.pp svneol=native#text/plain
 tests/test/tparray23.pp svneol=native#text/plain
 tests/test/tparray24.pp svneol=native#text/plain
 tests/test/tparray25.pp svneol=native#text/plain
+tests/test/tparray26.pp svneol=native#text/plain
 tests/test/tparray3.pp svneol=native#text/plain
 tests/test/tparray4.pp svneol=native#text/plain
 tests/test/tparray5.pp svneol=native#text/plain
@@ -8603,6 +8612,8 @@ tests/webtbf/tw13563a.pp svneol=native#text/plain
 tests/webtbf/tw1365.pp svneol=native#text/plain
 tests/webtbf/tw13815.pp svneol=native#text/plain
 tests/webtbf/tw1395.pp svneol=native#text/plain
+tests/webtbf/tw13956.pp svneol=native#text/plain
+tests/webtbf/tw13992.pp svneol=native#text/plain
 tests/webtbf/tw1407.pp svneol=native#text/plain
 tests/webtbf/tw1432.pp svneol=native#text/plain
 tests/webtbf/tw1467.pp svneol=native#text/plain
@@ -8965,6 +8976,7 @@ tests/webtbs/tw1068.pp svneol=native#text/plain
 tests/webtbs/tw10681.pp svneol=native#text/plain
 tests/webtbs/tw10684.pp svneol=native#text/plain
 tests/webtbs/tw1071.pp svneol=native#text/plain
+tests/webtbs/tw10717.pp svneol=native#text/plain
 tests/webtbs/tw10727.pp svneol=native#text/plain
 tests/webtbs/tw1073.pp svneol=native#text/plain
 tests/webtbs/tw10736.pp svneol=native#text/plain
@@ -9157,9 +9169,19 @@ tests/webtbs/tw1374.pp svneol=native#text/plain
 tests/webtbs/tw1375.pp svneol=native#text/plain
 tests/webtbs/tw1376.pp svneol=native#text/plain
 tests/webtbs/tw13763.pp svneol=native#text/plain
+tests/webtbs/tw13813.pp svneol=native#text/plain
 tests/webtbs/tw13820.pp svneol=native#text/plain
+tests/webtbs/tw13872.pp svneol=native#text/plain
+tests/webtbs/tw13890.pp svneol=native#text/plain
+tests/webtbs/tw13948.pp svneol=native#text/plain
 tests/webtbs/tw1398.pp svneol=native#text/plain
+tests/webtbs/tw13984.pp svneol=native#text/plain
+tests/webtbs/tw13992a.pp svneol=native#text/plain
 tests/webtbs/tw1401.pp svneol=native#text/plain
+tests/webtbs/tw14019.pp svneol=native#text/plain
+tests/webtbs/tw14020.pp svneol=native#text/plain
+tests/webtbs/tw14020a.pp svneol=native#text/plain
+tests/webtbs/tw14040.pp svneol=native#text/plain
 tests/webtbs/tw1407.pp svneol=native#text/plain
 tests/webtbs/tw1408.pp svneol=native#text/plain
 tests/webtbs/tw1409.pp svneol=native#text/plain

compiler/aggas.pas

@@ -375,7 +375,7 @@ implementation
           secname:='.tls';
 
         { go32v2 stub only loads .text and .data sections, and allocates space for .bss.
-          Thus, data which normally goes into .rodata and .rodata_norel sections must 
+          Thus, data which normally goes into .rodata and .rodata_norel sections must
           end up in .data section }
         if (atype in [sec_rodata,sec_rodata_norel]) and
           (target_info.system=system_i386_go32v2) then
@@ -387,8 +387,9 @@ implementation
         if not(target_info.system in systems_darwin) and
            create_smartlink_sections and
            (aname<>'') and
-           (atype <> sec_toc) and
-           (atype<>sec_bss) then
+           (atype<>sec_toc) and
+           { on embedded systems every byte counts, so smartlink bss too }
+           ((atype<>sec_bss) or (target_info.system in system_embedded)) then
           begin
             case aorder of
               secorder_begin :

compiler/aoptda.pas

@@ -36,6 +36,10 @@ Unit aoptda;
       TAOptDFA = class
         { uses the same constructor as TAoptCpu = constructor from TAoptObj }
 
+        { How many instructions are between the current instruction and the }
+        { last one that modified the register                               }
+        InstrSinceLastMod: TInstrSinceLastMod;
+
         { gathers the information regarding the contents of every register }
         { at the end of every instruction                                  }
         Procedure DoDFA;
@@ -43,10 +47,6 @@ Unit aoptda;
         { handles the processor dependent dataflow analizing               }
         Procedure CpuDFA(p: PInstr); Virtual; Abstract;
 
-        { How many instructions are between the current instruction and the }
-        { last one that modified the register                               }
-        InstrSinceLastMod: TInstrSinceLastMod;
-
         { convert a TInsChange value into the corresponding register }
         //!!!!!!!!!! Function TCh2Reg(Ch: TInsChange): TRegister; Virtual;
         { returns whether the instruction P reads from register Reg }

compiler/arm/cpuinfo.pas

@@ -49,9 +49,17 @@ Type
 
    tcontrollertype =
      (ct_none,
+
+      { Phillips }
       ct_lpc2114,
       ct_lpc2124,
-      ct_lpc2194
+      ct_lpc2194,
+
+      { ATMEL }
+      ct_at91sam7s256,
+      ct_at91sam7se256,
+      ct_at91sam7x256,
+      ct_at91sam7xc256
      );
 
 Const
@@ -94,17 +102,24 @@ Const
      ('',
       'LPC2114',
       'LPC2124',
-      'LPC2194'
+      'LPC2194',
+      'AT91SAM7S256',
+      'AT91SAM7SE256',
+      'AT91SAM7X256',
+      'AT91SAM7XC256'
      );
 
    controllerunitstr : array[tcontrollertype] of string[20] =
      ('',
       'LPC21x4',
       'LPC21x4',
-      'LPC21x4'
+      'LPC21x4',
+      'AT91SAM7x256',
+      'AT91SAM7x256',
+      'AT91SAM7x256',
+      'AT91SAM7x256'
      );
 
-
    { Supported optimizations, only used for information }
    supported_optimizerswitches = genericlevel1optimizerswitches+
                                  genericlevel2optimizerswitches+

compiler/avr/cgcpu.pas

@@ -181,7 +181,7 @@ unit cgcpu;
                 a_load_ref_reg(list,location^.size,location^.size,tmpref,location^.register);
               LOC_REFERENCE:
                 begin
-                  reference_reset_base(ref,location^.reference.index,location^.reference.offset,araloc.alignment);
+                  reference_reset_base(ref,location^.reference.index,location^.reference.offset,paraloc.alignment);
                   { doubles in softemu mode have a strange order of registers and references }
                   if location^.size=OS_32 then
                     g_concatcopy(list,tmpref,ref,4)

compiler/avr/cpuinfo.pas

@@ -40,6 +40,16 @@ Type
       fp_libgcc
      );
 
+   tcontrollertype =
+     (ct_none,
+
+      ct_atmega16,
+      ct_atmega32,
+      ct_atmega48,
+      ct_atmega64,
+      ct_atmega128
+     );
+
 Const
    {# Size of native extended floating point type }
    extended_size = 12;
@@ -71,6 +81,23 @@ Const
      'LIBGCC'
    );
 
+   controllertypestr : array[tcontrollertype] of string[20] =
+     ('',
+      'ATMEGA16',
+      'ATMEGA32',
+      'ATMEGA48',
+      'ATMEGA64',
+      'ATMEGA128'
+     );
+
+   controllerunitstr : array[tcontrollertype] of string[20] =
+     ('',
+      'ATMEGA16',
+      'ATMEGA32',
+      'ATMEGA48',
+      'ATMEGA64',
+      'ATMEGA128'
+     );
    { Supported optimizations, only used for information }
    supported_optimizerswitches = genericlevel1optimizerswitches+
                                  genericlevel2optimizerswitches+

compiler/avr/navrmat.pas

@@ -123,8 +123,8 @@ implementation
        procedure genOrdConstNodeMod;
          var
              modreg, maskreg, tempreg : tregister;
-{
          begin
+{
              if (tordconstnode(right).value = 0) then begin
                  internalerror(2005061702);
              end

compiler/cclasses.pas

@@ -504,6 +504,35 @@ type
       end;
 
 
+{******************************************************************
+                             tbitset
+*******************************************************************}
+
+       tbitset = class
+       private
+         fdata: pbyte;
+         fdatasize: longint;
+       public
+         constructor create(initsize: longint);
+         constructor create_bytesize(bytesize: longint);
+         destructor destroy; override;
+         procedure clear;
+         procedure grow(nsize: longint);
+         { sets a bit }
+         procedure include(index: longint);
+         { clears a bit }
+         procedure exclude(index: longint);
+         { finds an entry, creates one if not exists }
+         function isset(index: longint): boolean;
+
+         procedure addset(aset: tbitset);
+         procedure subset(aset: tbitset);
+
+         property data: pbyte read fdata;
+         property datasize: longint read fdatasize;
+      end;
+
+
     function FPHash(const s:shortstring):LongWord;
     function FPHash(P: PChar; Len: Integer): LongWord;
 
@@ -2757,4 +2786,98 @@ end;
         Result := False;
       end;
 
+
+{****************************************************************************
+                                tbitset
+****************************************************************************}
+
+    constructor tbitset.create(initsize: longint);
+      begin
+        create_bytesize((initsize+7) div 8);
+      end;
+
+
+    constructor tbitset.create_bytesize(bytesize: longint);
+      begin
+        fdatasize:=bytesize;
+        getmem(fdata,fdataSize);
+        clear;
+      end;
+
+
+    destructor tbitset.destroy;
+      begin
+        freemem(fdata,fdatasize);
+        inherited destroy;
+      end;
+
+
+    procedure tbitset.clear;
+      begin
+        fillchar(fdata^,fdatasize,0);
+      end;
+
+
+    procedure tbitset.grow(nsize: longint);
+      begin
+        reallocmem(fdata,nsize);
+        fillchar(fdata[fdatasize],nsize-fdatasize,0);
+        fdatasize:=nsize;
+      end;
+
+
+    procedure tbitset.include(index: longint);
+      var
+        dataindex: longint;
+      begin
+        { don't use bitpacked array, not endian-safe }
+        dataindex:=index shr 3;
+        if (dataindex>=datasize) then
+          grow(dataindex);
+        fdata[dataindex]:=fdata[dataindex] or (1 shl (index and 7));
+      end;
+
+
+    procedure tbitset.exclude(index: longint);
+      var
+        dataindex: longint;
+      begin
+        dataindex:=index shr 3;
+        if (dataindex>=datasize) then
+          exit;
+        fdata[dataindex]:=fdata[dataindex] and not(1 shl (index and 7));
+      end;
+
+
+    function tbitset.isset(index: longint): boolean;
+      var
+        dataindex: longint;
+      begin
+        dataindex:=index shr 3;
+        result:=
+          (dataindex<datasize) and
+          (((fdata[index shr 3] shr (index and 7)) and 1)<>0);
+      end;
+
+
+    procedure tbitset.addset(aset: tbitset);
+      var
+        i: longint;
+      begin
+        if (aset.datasize>datasize) then
+          grow(aset.datasize);
+        for i:=0 to aset.datasize-1 do
+          fdata[i]:=fdata[i] or aset.data[i];
+      end;
+
+
+    procedure tbitset.subset(aset: tbitset);
+      var
+        i: longint;
+      begin
+        for i:=0 to min(datasize,aset.datasize)-1 do
+          fdata[i]:=fdata[i] and not(aset.data[i]);
+      end;
+
+
 end.

compiler/cfileutl.pas

@@ -46,16 +46,11 @@ interface
       CUtils,CClasses,
       Systems;
 
-    const
-      { On case sensitive file systems, you have 9 lookups per used unit, }
-      { including the system unit, in the current directory               }
-      MinSearchesBeforeCache = 20;
-
     type
       TCachedDirectory = class(TFPHashObject)
       private
         FDirectoryEntries : TFPHashList;
-        FSearchCount: longint;
+        FCached : Boolean;
         procedure FreeDirectoryEntries;
         function GetItemAttr(const AName: TCmdStr): byte;
         function TryUseCache: boolean;
@@ -196,6 +191,7 @@ end;
       begin
         inherited create(AList,AName);
         FDirectoryEntries:=TFPHashList.Create;
+        FCached:=False;
       end;
 
 
@@ -209,25 +205,21 @@ end;
 
     function TCachedDirectory.TryUseCache:boolean;
       begin
-        Result:=true;
-        if (FSearchCount > MinSearchesBeforeCache) then
+        Result:=True;
+        if FCached then
           exit;
-        if (FSearchCount = MinSearchesBeforeCache) then
-          begin
-            inc(FSearchCount);
-            Reload;
-            exit;
-          end;
-        inc(FSearchCount);
-        Result:=false;
+        if not current_settings.disabledircache then
+          ForceUseCache
+        else
+          Result:=False;
       end;
 
 
     procedure TCachedDirectory.ForceUseCache;
       begin
-        if (FSearchCount<=MinSearchesBeforeCache) then
+        if not FCached then
           begin
-            FSearchCount:=MinSearchesBeforeCache+1;
+            FCached:=True;
             Reload;
           end;
       end;

compiler/dbgdwarf.pas

@@ -137,7 +137,7 @@ interface
 
         { DWARF 3 values.   }
         DW_AT_allocated := $4e,DW_AT_associated := $4f,
-        DW_AT_data_location := $50,DW_AT_stride := $51,
+        DW_AT_data_location := $50,DW_AT_byte_stride := $51,
         DW_AT_entry_pc := $52,DW_AT_use_UTF8 := $53,
         DW_AT_extension := $54,DW_AT_ranges := $55,
         DW_AT_trampoline := $56,DW_AT_call_column := $57,
@@ -308,6 +308,8 @@ interface
       TDebugInfoDwarf2 = class(TDebugInfoDwarf)
       private
       protected
+        procedure appenddef_set_intern(list:TAsmList;def:tsetdef; force_tag_set: boolean);
+
         procedure appenddef_file(list:TAsmList;def:tfiledef); override;
         procedure appenddef_formal(list:TAsmList;def:tformaldef); override;
         procedure appenddef_object(list:TAsmList;def:tobjectdef); override;
@@ -320,7 +322,7 @@ interface
 
       { TDebugInfoDwarf3 }
 
-      TDebugInfoDwarf3 = class(TDebugInfoDwarf)
+      TDebugInfoDwarf3 = class(TDebugInfoDwarf2)
       private
       protected
         procedure appenddef_array(list:TAsmList;def:tarraydef); override;
@@ -1327,6 +1329,7 @@ implementation
       var
         size : aint;
         elesize : aint;
+        elestrideattr : tdwarf_attribute;
         labsym: tasmlabel;
       begin
         if is_dynamic_array(def) then
@@ -1340,9 +1343,15 @@ implementation
           end;
 
         if not is_packed_array(def) then
-          elesize := def.elesize*8
+          begin
+          elestrideattr := DW_AT_byte_stride;
+          elesize := def.elesize;
+          end
         else
+          begin
+          elestrideattr := DW_AT_stride_size;
           elesize := def.elepackedbitsize;
+          end;
 
         if is_special_array(def) then
           begin
@@ -1350,11 +1359,11 @@ implementation
             if assigned(def.typesym) then
               append_entry(DW_TAG_array_type,true,[
                 DW_AT_name,DW_FORM_string,symname(def.typesym)+#0,
-                DW_AT_stride_size,DW_FORM_udata,elesize
+                elestrideattr,DW_FORM_udata,elesize
                 ])
             else
               append_entry(DW_TAG_array_type,true,[
-                DW_AT_stride_size,DW_FORM_udata,elesize
+                elestrideattr,DW_FORM_udata,elesize
                 ]);
             append_labelentry_ref(DW_AT_type,def_dwarf_lab(def.elementdef));
             finish_entry;
@@ -1370,12 +1379,12 @@ implementation
               append_entry(DW_TAG_array_type,true,[
                 DW_AT_name,DW_FORM_string,symname(def.typesym)+#0,
                 DW_AT_byte_size,DW_FORM_udata,size,
-                DW_AT_stride_size,DW_FORM_udata,elesize
+                elestrideattr,DW_FORM_udata,elesize
                 ])
             else
               append_entry(DW_TAG_array_type,true,[
                 DW_AT_byte_size,DW_FORM_udata,size,
-                DW_AT_stride_size,DW_FORM_udata,elesize
+                elestrideattr,DW_FORM_udata,elesize
                 ]);
             append_labelentry_ref(DW_AT_type,def_dwarf_lab(def.elementdef));
             finish_entry;
@@ -1467,7 +1476,7 @@ implementation
           current_asmdata.asmlists[al_dwarf_info].concat(tai_symbol.create(arr,0));
           append_entry(DW_TAG_array_type,true,[
             DW_AT_byte_size,DW_FORM_udata,def.size,
-            DW_AT_stride_size,DW_FORM_udata,1*8
+            DW_AT_byte_stride,DW_FORM_udata,1
             ]);
           append_labelentry_ref(DW_AT_type,def_dwarf_lab(cchartype));
           finish_entry;
@@ -3026,11 +3035,12 @@ implementation
         end;
       end;
 
-    procedure TDebugInfoDwarf2.appenddef_set(list:TAsmList;def: tsetdef);
+    procedure TDebugInfoDwarf2.appenddef_set_intern(list:TAsmList;def: tsetdef; force_tag_set: boolean);
       var
         lab: tasmlabel;
       begin
-        if (ds_dwarf_sets in current_settings.debugswitches) then
+        if force_tag_set or
+           (ds_dwarf_sets in current_settings.debugswitches) then
           begin
             { current (20070704 -- patch was committed on 20060513) gdb cvs supports set types }
 
@@ -3045,21 +3055,21 @@ implementation
                 ]);
             if assigned(def.elementdef) then
               begin
-                if (def.elementdef.typ=enumdef) then
-                  begin
-                    { gdb 6.7 - 6.8 is broken for regular enum sets }
-                    if not(tf_dwarf_only_local_labels in target_info.flags) then
-                      current_asmdata.getdatalabel(lab)
-                    else
-                      current_asmdata.getaddrlabel(lab);
-                    append_labelentry_ref(DW_AT_type,lab);
-                    finish_entry;
-                    current_asmdata.asmlists[al_dwarf_info].concat(tai_symbol.create(lab,0));
-                    append_entry(DW_TAG_subrange_type,false,[
-                      DW_AT_lower_bound,DW_FORM_sdata,tenumdef(def.elementdef).minval,
-                      DW_AT_upper_bound,DW_FORM_sdata,tenumdef(def.elementdef).maxval
-                      ]);
-                  end;
+                if not(tf_dwarf_only_local_labels in target_info.flags) then
+                  current_asmdata.getdatalabel(lab)
+                else
+                  current_asmdata.getaddrlabel(lab);
+                append_labelentry_ref(DW_AT_type,lab);
+                finish_entry;
+                current_asmdata.asmlists[al_dwarf_info].concat(tai_symbol.create(lab,0));
+                { Sets of e.g. [1..5] are actually stored as a set of [0..7],
+                  so write the exact boundaries of the set here. Let's hope no
+                  debugger ever rejects this because this "subrange" type can
+                  actually have a larger range than the original one.  }
+                append_entry(DW_TAG_subrange_type,false,[
+                  DW_AT_lower_bound,DW_FORM_sdata,def.setbase,
+                  DW_AT_upper_bound,DW_FORM_sdata,get_max_value(def.elementdef).svalue
+                  ]);
                 append_labelentry_ref(DW_AT_type,def_dwarf_lab(def.elementdef))
               end
           end
@@ -3082,6 +3092,11 @@ implementation
         finish_entry;
       end;
 
+    procedure TDebugInfoDwarf2.appenddef_set(list:TAsmList;def: tsetdef);
+      begin
+        appenddef_set_intern(list,def,false);
+      end;
+
     procedure TDebugInfoDwarf2.appenddef_undefined(list:TAsmList;def: tundefineddef);
       begin
         { gdb 6.4 doesn't support DW_TAG_unspecified_type so we
@@ -3137,6 +3152,7 @@ implementation
         finish_entry;
         { to simplify things, we don't write a multidimensional array here }
         append_entry(DW_TAG_subrange_type,false,[
+          DW_AT_byte_stride,DW_FORM_udata,def.elesize,
           DW_AT_lower_bound,DW_FORM_udata,0,
           DW_AT_upper_bound,DW_FORM_block1,5
           ]);
@@ -3400,18 +3416,7 @@ implementation
 
     procedure TDebugInfoDwarf3.appenddef_set(list:TAsmList;def: tsetdef);
       begin
-        if assigned(def.typesym) then
-          append_entry(DW_TAG_set_type,false,[
-            DW_AT_name,DW_FORM_string,symname(def.typesym)+#0,
-            DW_AT_byte_size,DW_FORM_data2,def.size
-            ])
-        else
-          append_entry(DW_TAG_set_type,false,[
-            DW_AT_byte_size,DW_FORM_data2,def.size
-            ]);
-        if assigned(tsetdef(def).elementdef) then
-          append_labelentry_ref(DW_AT_type,def_dwarf_lab(tsetdef(def).elementdef));
-        finish_entry;
+        appenddef_set_intern(list,def,true);
       end;
 
     procedure TDebugInfoDwarf3.appenddef_undefined(list:TAsmList;def: tundefineddef);

compiler/dbgstabs.pas

@@ -73,6 +73,7 @@ interface
         procedure field_add_stabstr(p:TObject;arg:pointer);
         procedure method_add_stabstr(p:TObject;arg:pointer);
         procedure field_write_defs(p:TObject;arg:pointer);
+        function  get_enum_defstr(def: tenumdef; lowerbound: longint): ansistring;
       protected
         procedure appendsym_staticvar(list:TAsmList;sym:tstaticvarsym);override;
         procedure appendsym_paravar(list:TAsmList;sym:tparavarsym);override;
@@ -561,25 +562,36 @@ implementation
       end;
 
 
-    procedure TDebugInfoStabs.appenddef_enum(list:TAsmList;def:tenumdef);
+    function TDebugInfoStabs.get_enum_defstr(def: tenumdef; lowerbound: longint): ansistring;
       var
-        st : ansistring;
-        p  : Tenumsym;
+        i: longint;
+        p: tenumsym;
       begin
         { we can specify the size with @s<size>; prefix PM }
         if def.size <> std_param_align then
-          st:='@s'+tostr(def.size*8)+';e'
+          result:='@s'+tostr(def.size*8)+';e'
         else
-          st:='e';
+          result:='e';
         p := tenumsym(def.firstenum);
+        { the if-test is required because pred(def.minval) might overflow;
+          the longint() typecast should be safe because stabs is not
+          supported for 64 bit targets }
+        if (def.minval<>lowerbound) then
+          for i:=lowerbound to pred(longint(def.minval)) do
+            result:=result+'<invalid>:'+tostr(i)+',';
+
         while assigned(p) do
           begin
-            st:=st+GetSymName(p)+':'+tostr(p.value)+',';
+            result:=result+GetSymName(p)+':'+tostr(p.value)+',';
             p:=p.nextenum;
           end;
         { the final ',' is required to have a valid stabs }
-        st:=st+';';
-        write_def_stabstr(list,def,st);
+        result:=result+';';
+      end;
+
+    procedure TDebugInfoStabs.appenddef_enum(list:TAsmList;def:tenumdef);
+      begin
+        write_def_stabstr(list,def,get_enum_defstr(def,def.minval));
       end;
 
 
@@ -787,9 +799,34 @@ implementation
 
     procedure TDebugInfoStabs.appenddef_set(list:TAsmList;def:tsetdef);
       var
+        st,
         ss : ansistring;
+        p: pchar;
+        elementdefstabnr: string;
       begin
-        ss:=def_stabstr_evaluate(def,'@s$1;S$2',[tostr(def.size*8),def_stab_number(tsetdef(def).elementdef)]);
+        { ugly hack: create a temporary subrange type if the lower bound of
+          the set's element type is not a multiple of 8 (because we store them
+          as if the lower bound is a multiple of 8) }
+        if (def.setbase<>get_min_value(def.elementdef)) then
+          begin
+            { allocate a def number }
+            inc(global_stab_number);
+            elementdefstabnr:=tostr(global_stab_number);
+            { anonymous subrange def }
+            st:='":t'+elementdefstabnr+'=';
+            if (def.elementdef.typ = enumdef) then
+              st:=st+get_enum_defstr(tenumdef(def.elementdef),def.setbase)
+            else
+              st:=st+def_stabstr_evaluate(def.elementdef,'r'+elementdefstabnr+';$1;$2;',[tostr(longint(def.setbase)),tostr(longint(get_max_value(def.elementdef).svalue))]);
+            st:=st+'",'+tostr(N_LSYM)+',0,0,0';
+            { add to list }
+            getmem(p,length(st)+1);
+            move(pchar(st)^,p^,length(st)+1);
+            list.concat(Tai_stab.create(stab_stabs,p));
+          end
+        else
+          elementdefstabnr:=def_stab_number(def.elementdef);
+        ss:=def_stabstr_evaluate(def,'@s$1;S$2',[tostr(def.size*8),elementdefstabnr]);
         write_def_stabstr(list,def,ss);
       end;
 

compiler/fpcdefs.inc

@@ -126,6 +126,6 @@
 
 {$define SUPPORT_UNALIGNED}
 
-{$if not defined(cpui386) and defined(i386)}
-{$error Cross-compiling from non-i386 to i386 is not yet supported at this time }
+{$if not defined(FPC_HAS_TYPE_EXTENDED) and defined(i386)}
+{$error Cross-compiling from systems without support for an 80 bit extended floating point type to i386 is not yet supported at this time }
 {$endif}

compiler/globals.pas

@@ -104,7 +104,9 @@ interface
     type
        tcodepagestring = string[20];
 
-       tsettings = record
+       { this is written to ppus during token recording for generics so it must be packed }
+       tsettings = packed record
+         alignment       : talignmentinfo;
          globalswitches  : tglobalswitches;
          moduleswitches  : tmoduleswitches;
          localswitches   : tlocalswitches;
@@ -119,7 +121,10 @@ interface
            >0: round to this size }
          setalloc,
          packenum        : shortint;
-         alignment       : talignmentinfo;
+
+         packrecords     : shortint;
+         maxfpuregisters : shortint;
+
          cputype,
          optimizecputype : tcputype;
          fputype         : tfputype;
@@ -128,15 +133,14 @@ interface
          defproccall     : tproccalloption;
          sourcecodepage  : tcodepagestring;
 
-         packrecords     : shortint;
-         maxfpuregisters : shortint;
-
          minfpconstprec  : tfloattype;
 
+         disabledircache : boolean;
+
         { CPU targets with microcontroller support can add a controller specific unit }
-{$if defined(ARM)}
+{$if defined(ARM) or defined(AVR)}
         controllertype   : tcontrollertype;
-{$endif defined(ARM)}
+{$endif defined(ARM) or defined(AVR)}
        end;
 
     const
@@ -328,16 +332,6 @@ interface
 
     const
       default_settings : TSettings = (
-        globalswitches : [cs_check_unit_name,cs_link_static];
-        moduleswitches : [cs_extsyntax,cs_implicit_exceptions];
-        localswitches : [cs_check_io,cs_typed_const_writable];
-        modeswitches : fpcmodeswitches;
-        optimizerswitches : [];
-        genwpoptimizerswitches : [];
-        dowpoptimizerswitches : [];
-        debugswitches : [];
-        setalloc : 0;
-        packenum : 4;
         alignment : (
           procalign : 0;
           loopalign : 0;
@@ -352,6 +346,21 @@ interface
           recordalignmax : 0;
           maxCrecordalign : 0;
         );
+        globalswitches : [cs_check_unit_name,cs_link_static];
+        moduleswitches : [cs_extsyntax,cs_implicit_exceptions];
+        localswitches : [cs_check_io,cs_typed_const_writable];
+        modeswitches : fpcmodeswitches;
+        optimizerswitches : [];
+        genwpoptimizerswitches : [];
+        dowpoptimizerswitches : [];
+        debugswitches : [];
+
+        setalloc : 0;
+        packenum : 4;
+
+        packrecords     : 0;
+        maxfpuregisters : 0;
+
 {$ifdef i386}
         cputype : cpu_Pentium;
         optimizecputype : cpu_Pentium3;
@@ -396,9 +405,9 @@ interface
         interfacetype : it_interfacecom;
         defproccall : pocall_default;
         sourcecodepage : '8859-1';
-        packrecords     : 0;
-        maxfpuregisters : 0;
         minfpconstprec : s32real;
+
+        disabledircache : false;
 {$if defined(ARM)}
         controllertype : ct_none;
 {$endif defined(ARM)}

compiler/htypechk.pas

@@ -68,10 +68,10 @@ interface
         FAllowVariant : boolean;
         procedure collect_overloads_in_class(ProcdefOverloadList:TFPObjectList);
         procedure collect_overloads_in_units(ProcdefOverloadList:TFPObjectList);
-        procedure create_candidate_list(ignorevisibility:boolean);
+        procedure create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
         function  proc_add(ps:tprocsym;pd:tprocdef):pcandidate;
       public
-        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility:boolean);
+        constructor create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
         constructor create_operator(op:ttoken;ppn:tnode);
         destructor destroy;override;
         procedure list(all:boolean);
@@ -955,7 +955,8 @@ implementation
         gotvec,
         gotclass,
         gotdynarray,
-        gotderef : boolean;
+        gotderef,
+        gottypeconv : boolean;
         fromdef,
         todef    : tdef;
         errmsg,
@@ -976,6 +977,7 @@ implementation
         gotpointer:=false;
         gotdynarray:=false;
         gotstring:=false;
+        gottypeconv:=false;
         hp:=p;
         if not(valid_void in opts) and
            is_void(hp.resultdef) then
@@ -1013,6 +1015,17 @@ implementation
                       { same when we got a class and subscript (= deref) }
                       (gotclass and gotsubscript) or
                       (
+                       { allowing assignments to typecasted properties
+                           a) is Delphi-incompatible
+                           b) causes problems in case the getter is a function
+                              (because then the result of the getter is
+                               typecasted to this type, and then we "assign" to
+                               this typecasted function result) -> always
+                               disallow, since property accessors should be
+                               transparantly changeable to functions at all
+                               times
+                       }
+                       not(gottypeconv) and
                        not(gotsubscript and gotrecord) and
                        not(gotstring and gotvec)
                       ) then
@@ -1059,6 +1072,7 @@ implementation
                end;
              typeconvn :
                begin
+                 gottypeconv:=true;
                  { typecast sizes must match, exceptions:
                    - implicit typecast made by absolute
                    - from formaldef
@@ -1599,7 +1613,7 @@ implementation
                            TCallCandidates
 ****************************************************************************}
 
-    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility:boolean);
+    constructor tcallcandidates.create(sym:tprocsym;st:TSymtable;ppn:tnode;ignorevisibility,allowdefaultparas:boolean);
       begin
         if not assigned(sym) then
           internalerror(200411015);
@@ -1607,7 +1621,7 @@ implementation
         FProcsym:=sym;
         FProcsymtable:=st;
         FParanode:=ppn;
-        create_candidate_list(ignorevisibility);
+        create_candidate_list(ignorevisibility,allowdefaultparas);
       end;
 
 
@@ -1617,7 +1631,7 @@ implementation
         FProcsym:=nil;
         FProcsymtable:=nil;
         FParanode:=ppn;
-        create_candidate_list(false);
+        create_candidate_list(false,false);
       end;
 
 
@@ -1730,7 +1744,7 @@ implementation
       end;
 
 
-    procedure tcallcandidates.create_candidate_list(ignorevisibility:boolean);
+    procedure tcallcandidates.create_candidate_list(ignorevisibility,allowdefaultparas:boolean);
       var
         j     : integer;
         pd    : tprocdef;
@@ -1789,8 +1803,17 @@ implementation
               it is visible }
             if (FParalength>=pd.minparacount) and
                (
-                (FParalength<=pd.maxparacount) or
-                (po_varargs in pd.procoptions)
+                (
+                 allowdefaultparas and
+                 (
+                  (FParalength<=pd.maxparacount) or
+                  (po_varargs in pd.procoptions)
+                 )
+                ) or
+                (
+                 not allowdefaultparas and
+                 (FParalength=pd.maxparacount)
+                )
                ) and
                (
                 ignorevisibility or

compiler/i386/daopt386.pas

@@ -218,13 +218,6 @@ type
     function getlabelwithsym(sym: tasmlabel): tai;
 
    private
-    { Walks through the list to find the lowest and highest label number, inits the }
-    { labeltable and fixes/optimizes some regallocs                                 }
-     procedure initlabeltable;
-
-    function initdfapass2: boolean;
-    procedure dodfapass2;
-
     { asm list we're working on }
     list: TAsmList;
 
@@ -240,6 +233,13 @@ type
     { all labels in the current block: their value mapped to their location }
     lolab, hilab, labdif: longint;
     labeltable: plabeltable;
+
+    { Walks through the list to find the lowest and highest label number, inits the }
+    { labeltable and fixes/optimizes some regallocs                                 }
+     procedure initlabeltable;
+
+    function initdfapass2: boolean;
+    procedure dodfapass2;
   end;
 
 

compiler/link.pas

@@ -100,12 +100,12 @@ interface
          procedure PrintLinkerScript;
          function  RunLinkScript(const outputname:TCmdStr):boolean;
       protected
+         linkscript : TCmdStrList;
          property CObjInput:TObjInputClass read FCObjInput write FCObjInput;
          property CExeOutput:TExeOutputClass read FCExeOutput write FCExeOutput;
          property StaticLibraryList:TFPHashObjectList read FStaticLibraryList;
          property ImportLibraryList:TFPHashObjectList read FImportLibraryList;
          procedure DefaultLinkScript;virtual;abstract;
-         linkscript : TCmdStrList;
       public
          IsSharedLibrary : boolean;
          Constructor Create;override;

compiler/msg/errord.msg

@@ -1,9 +1,9 @@
 #
 #   German (alternative, LATIN-US DOS) Language File for Free Pascal
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
-#   <karl-michael.schindler at physik.uni-halle.de>
+#   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 12528
+#   Based on errore.msg of SVN revision 13257 + one
 #
 #   This file is part of the Free Pascal Compiler
 #   Copyright (c) 1998-2009 by the Free Pascal Development team
@@ -1185,7 +1185,7 @@ parser_n_ignore_lower_visibility=03250_N_Die virtuelle Methode "$1" hat eine nie
 #
 # Type Checking
 #
-# 04083 is the last used one
+# 04087 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1469,6 +1469,20 @@ type_w_pointer_to_signed=04082_W_Die Konvertierung von Pointern in einen Integer
 type_interface_has_no_guid=04083_E_Interface Typ $1 hat keine g�ltige GUID
 % When applying the as-operator to an interface or class, the desired interface (i.e. the right operand of the
 % as-operator) must have a valid GUID.
+type_e_invalid_objc_selector_name=04084_E_Ung�ltiger Objective-C-Selector-Name
+% An Objective-C selector cannot be empty, must be a valid identifier or a single colon,
+% and if it contains at least one colon it must also end in one.
+type_e_expected_objc_method_but_got=04085_E_Erwartete eine Objective-C-Methode, erhielt aber $1
+% A selector can only be created for Objective-C methods, not for any other kind
+% of procedure/function/method.
+type_e_expected_objc_method=04086_E_Erwartete eine Objective-C-Methode, oder den Namen einer konstanten Methode
+% A selector can only be created for Objective-C methods, either by specifying
+% the name using a string constant, or by using an Objective-C method identifier
+% that is visible in the current scope.
+type_e_no_type_info=04087_E_F�r diesen Typ steht keine Typ-Information zu Verf�gung
+% Type information is not generated for some types, such as enumerations with gaps
+% in their value range (this includes enumerations whose lower bound is different
+% from zero).
 % \end{description}
 #
 # Symtable
@@ -1574,12 +1588,12 @@ sym_w_uninitialized_local_variable=05036_W_Lokale Variable "$1" wird verwendet,
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_w_uninitialized_variable=05037_W_Variable "$1" scheint nicht initialisiert worden zu sein
 % These messages are displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % wasn't initialized first (i.e. appeared in the left-hand side of an
-% assigment).
+% assignassignmentment).
 sym_e_id_no_member=05038_E_Bezeichener verweist nicht auf ein Element: $1
 % This error is generated when an identifier of a record,
 % field or method is accessed while it is not defined.
@@ -1614,22 +1628,22 @@ sym_h_uninitialized_local_variable=05057_H_Die Variable "$1" scheint nicht initi
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. it did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_uninitialized_variable=05058_H_Die Variable "$1" scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. t did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_w_function_result_uninitialized=05059_W_Die Ergebnisvariable der Funktion scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. before it appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_function_result_uninitialized=05060_H_Die Ergebnisvariable der Funktion scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. it appears in the left-hand side of an
-% assigment)
+% assignment)
 sym_w_identifier_only_read=05061_W_Die Variable "$1" wird gelesen, obwohl ihr aber noch kein Wert zugewiesen wurde
 % You have read the value of a variable, but nowhere assigned a value to
 % it.
@@ -2192,6 +2206,10 @@ execinfo_x_stackcommit=09134_X_Stack Bereich "committed": $1 Bytes
 % \begin{description}
 link_f_executable_too_big=09200_F_Das Programm - Image ist f�r das Target $1 zu groá
 % Fatal error when resulting executable is too big.
+link_w_32bit_absolute_reloc=09201_W_Object Daei "$1" enth„lt eine 32-bit absolute Relocation auf Symbol "$2".
+% Warning when 64-bit object file contains 32-bit absolute relocations.
+% In such case an executable image can be loaded into lower 4Gb of
+% address space only.
 %\end{description}
 # EndOfTeX
 
@@ -2401,7 +2419,7 @@ unit_e_different_wpo_file=10061_E_Unit $1 wurde mit einer anderen Feedback-Einga
 #
 #  Options
 #
-# 11044 is the last used one
+# 11046 is the last used one
 #
 option_usage=11000_O_$1 [Optionen] <Eingabedatei> [Optionen]
 # BeginOfTeX
@@ -2516,6 +2534,13 @@ option_unsupported_target=11044_F_Die Option "$1" wird auf der Zielplattform nic
 % Not all options are supported or implemented for all target platforms. This message informs you that a chosen
 % option is incompatible with the currently selected target platform.
 %\end{description}
+option_unsupported_target_for_feature=11045_F_Das Feature "$1" wird f�r die ausgew„hlte Zielplattform nicht oder noch nicht unterst�tzt
+% Not all features are supported or implemented for all target platforms. This message informs you that a chosen
+% feature is incompatible with the currently selected target platform.
+option_dwarf_smart_linking=11046_N_DWARF Debug-Information kann auf dieser Zielplattform nicht zusammen mit Smartlinking benutzt werden, es wird auf statisches Linken umgeschaltet
+% Smart linking is currently incompatble with DWARF debug information on most
+% platforms, so smart linking is disabled in such cases.
+
 # EndOfTeX
 
 #
@@ -2529,11 +2554,11 @@ option_unsupported_target=11044_F_Die Option "$1" wird auf der Zielplattform nic
 % This section lists errors that occur when the compiler is performing
 % whole program optimization.
 % \begin{description}
-wpo_cant_find_file=12000_F_Feedback-Datei $1 f�r die Gesamtprogramm-Optimierung kann nicht ge”ffnet werden
+wpo_cant_find_file=12000_F_Feedback-Datei "$1" f�r die Gesamtprogramm-Optimierung kann nicht ge”ffnet werden
 % The compiler cannot open the specified feedback file with whole program optimization information.
-wpo_begin_processing=12001_D_Bearbeite die Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei $1
+wpo_begin_processing=12001_D_Bearbeite die Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei "$1"
 % The compiler starts processing whole program optimization information found in the named file.
-wpo_end_processing=12002_D_Bearbeitung der Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei $1 beendet
+wpo_end_processing=12002_D_Bearbeitung der Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei "$1" beendet
 % The compiler has finished processing the whole program optimization information found in the named file.
 wpo_expected_section=12003_E_Erwarte einen Sektions-Header, statt dessen "$2" in Zeile $1 der wpo-Feedback-Datei erhalten
 % The compiler expected a section header in the whole program optimization file (starting with \%),
@@ -2631,6 +2656,9 @@ Unterst
   All
   $WPOPTIMIZATIONS
 
+Unterst�tzte Microcontroller:
+  $CONTROLLERTYPES
+
 Dieses Programm unterliegt der GNU General Public Licence
 Weitere Informationen sind in COPYING.FPC zu finden
 
@@ -2850,19 +2878,20 @@ S*2Tlinux_Linux
 **1u<x>_Entferne die Definition f�r das Symbol <x>
 **1U<x>_Unit-Optionen:
 **2Un_Pr�fe den Unitnamen nicht
-**2Ur_Erzeuge release unit Dateien
+**2Ur_Erzeuge "release unit"-Dateien
 **2Us_Erzeuge eine Systemunit
 **1v<x>_Meldungen, <x> ist eine Kombination der folgenden Zeichen:
 **2*_e : Fehler (Standard)             0 : Nichts (ausser Fehlern)
 **2*_w : Warnungen                     u : Unit Informationen
 **2*_n : Anmerkungen                   t : Angesprochene/benutzte Dateien
-**2*_h : Hinweise                      c : Preprozessordirektive
+**2*_h : Hinweise                      c : Preprozessordirektiven
 **2*_i : Allgemeine Informationen      d : Debug Informationen
 **2*_l : Zeilennummern                 r : Rhide/GCC kompatibler Modus
+**2*_s : Zeitstempel                   q : Nummer der Meldung
 **2*_a : Alles                         x : Exe-Datei Informationen (nur Win32)
-**2*_b : Schreibe bei Meldungen mit Dateinamen den vollst„ndigem Pfad
-**2*_v : Schreibe fpcdebug.txt mit     p : Schreibe tree.log mit Analysenbaum (parse tree)
-**2*_   ganz viel Information          q : Zeige die Nummer der Meldung
+**2*_b : Schreibe bei Meldungen mit    p : Schreibe tree.log mit Analysenbaum (parse tree)
+**2*_    Dateinamen den vollst„ndigen  v : Schreibe fpcdebug.txt mit 
+**2*_    Pfad                              ganz viel Information
 **2*_m<x>,<y> : Zeige die Meldungen mit den Nummern <x> und <y> nicht
 3*1W<x>_Ziel-spezifische Optionen (Ziele)
 A*1W<x>_Ziel-spezifische Optionen (Ziele)
@@ -2909,7 +2938,7 @@ P*2WX_Erm
 **2XP<x>_Stelle den Namen der Compiler-Hilfsprogrammen den Prefix <x> voran
 **2Xr<x>_Setze den Bibliotheks-Suchpfad zu <x>       (ben”tigt f�r cross compile)
 **2XR<x>_Stelle allen Linker-Suchpfaden den Namen <x> voran (BeOS, Darwin, FreeBSD, Linux, Mac OS, Solaris)
-**2Xs_Entferne alle Symbole von ausf�hrbarer Datei
+**2Xs_Entferne alle Symbole aus der ausf�hrbaren Datei
 **2XS_Versuche Units statisch zu linken (default)    (definiert FPC_LINK_STATIC)
 **2Xt_Linke mit statischen Bibliotheken              (-static wird an den Linker �bergeben)
 **2XX_Versuche Units smart zu linken                 (definiert FPC_LINK_SMART)

compiler/msg/errordu.msg

@@ -1,9 +1,9 @@
-#
+#
 #   German (UTF-8) Language File for Free Pascal
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
-#   <karl-michael.schindler at physik.uni-halle.de>
+#   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 12528
+#   Based on errore.msg of SVN revision 13257 + one
 #
 #   This file is part of the Free Pascal Compiler
 #   Copyright (c) 1998-2009 by the Free Pascal Development team
@@ -1184,7 +1184,7 @@ parser_n_ignore_lower_visibility=03250_N_Die virtuelle Methode "$1" hat eine nie
 #
 # Type Checking
 #
-# 04083 is the last used one
+# 04087 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1468,6 +1468,20 @@ type_w_pointer_to_signed=04082_W_Die Konvertierung von Pointern in einen Integer
 type_interface_has_no_guid=04083_E_Interface Typ $1 hat keine gültige GUID
 % When applying the as-operator to an interface or class, the desired interface (i.e. the right operand of the
 % as-operator) must have a valid GUID.
+type_e_invalid_objc_selector_name=04084_E_Ungültiger Objective-C-Selector-Name
+% An Objective-C selector cannot be empty, must be a valid identifier or a single colon,
+% and if it contains at least one colon it must also end in one.
+type_e_expected_objc_method_but_got=04085_E_Erwartete eine Objective-C-Methode, erhielt aber $1
+% A selector can only be created for Objective-C methods, not for any other kind
+% of procedure/function/method.
+type_e_expected_objc_method=04086_E_Erwartete eine Objective-C-Methode, oder den Namen einer konstanten Methode
+% A selector can only be created for Objective-C methods, either by specifying
+% the name using a string constant, or by using an Objective-C method identifier
+% that is visible in the current scope.
+type_e_no_type_info=04087_E_Für diesen Typ steht keine Typ-Information zu Verfügung
+% Type information is not generated for some types, such as enumerations with gaps
+% in their value range (this includes enumerations whose lower bound is different
+% from zero).
 % \end{description}
 #
 # Symtable
@@ -1573,12 +1587,12 @@ sym_w_uninitialized_local_variable=05036_W_Lokale Variable "$1" wird verwendet,
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_w_uninitialized_variable=05037_W_Variable "$1" scheint nicht initialisiert worden zu sein
 % These messages are displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % wasn't initialized first (i.e. appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_e_id_no_member=05038_E_Bezeichener verweist nicht auf ein Element: $1
 % This error is generated when an identifier of a record,
 % field or method is accessed while it is not defined.
@@ -1613,22 +1627,22 @@ sym_h_uninitialized_local_variable=05057_H_Die Variable "$1" scheint nicht initi
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. it did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_uninitialized_variable=05058_H_Die Variable "$1" scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. t did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_w_function_result_uninitialized=05059_W_Die Ergebnisvariable der Funktion scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. before it appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_function_result_uninitialized=05060_H_Die Ergebnisvariable der Funktion scheint nicht initialisiert zu sein
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. it appears in the left-hand side of an
-% assigment)
+% assignment)
 sym_w_identifier_only_read=05061_W_Die Variable "$1" wird gelesen, obwohl ihr aber noch kein Wert zugewiesen wurde
 % You have read the value of a variable, but nowhere assigned a value to
 % it.
@@ -2191,6 +2205,10 @@ execinfo_x_stackcommit=09134_X_Stack Bereich "committed": $1 Bytes
 % \begin{description}
 link_f_executable_too_big=09200_F_Das Programm - Image ist für das Target $1 zu groß
 % Fatal error when resulting executable is too big.
+link_w_32bit_absolute_reloc=09201_W_Object Daei "$1" enthält eine 32-bit absolute Relocation auf Symbol "$2".
+% Warning when 64-bit object file contains 32-bit absolute relocations.
+% In such case an executable image can be loaded into lower 4Gb of
+% address space only.
 %\end{description}
 # EndOfTeX
 
@@ -2400,7 +2418,7 @@ unit_e_different_wpo_file=10061_E_Unit $1 wurde mit einer anderen Feedback-Einga
 #
 #  Options
 #
-# 11044 is the last used one
+# 11046 is the last used one
 #
 option_usage=11000_O_$1 [Optionen] <Eingabedatei> [Optionen]
 # BeginOfTeX
@@ -2514,6 +2532,13 @@ option_else_without_if=11043_F_Zur \var{\#ELSE} Direktive in Zeile $2 der Option
 option_unsupported_target=11044_F_Die Option "$1" wird auf der Zielplattform nicht oder noch nicht unterstützt
 % Not all options are supported or implemented for all target platforms. This message informs you that a chosen
 % option is incompatible with the currently selected target platform.
+option_unsupported_target_for_feature=11045_F_Das Feature "$1" wird für die ausgewählte Zielplattform nicht oder noch nicht unterstützt
+% Not all features are supported or implemented for all target platforms. This message informs you that a chosen
+% feature is incompatible with the currently selected target platform.
+option_dwarf_smart_linking=11046_N_DWARF Debug-Information kann auf dieser Zielplattform nicht zusammen mit Smartlinking benutzt werden, es wird auf statisches Linken umgeschaltet
+% Smart linking is currently incompatble with DWARF debug information on most
+% platforms, so smart linking is disabled in such cases.
+
 %\end{description}
 # EndOfTeX
 
@@ -2528,11 +2553,11 @@ option_unsupported_target=11044_F_Die Option "$1" wird auf der Zielplattform nic
 % This section lists errors that occur when the compiler is performing
 % whole program optimization.
 % \begin{description}
-wpo_cant_find_file=12000_F_Feedback-Datei $1 für die Gesamtprogramm-Optimierung kann nicht geöffnet werden
+wpo_cant_find_file=12000_F_Feedback-Datei "$1" für die Gesamtprogramm-Optimierung kann nicht geöffnet werden
 % The compiler cannot open the specified feedback file with whole program optimization information.
-wpo_begin_processing=12001_D_Bearbeite die Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei $1
+wpo_begin_processing=12001_D_Bearbeite die Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei "$1"
 % The compiler starts processing whole program optimization information found in the named file.
-wpo_end_processing=12002_D_Bearbeitung der Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei $1 beendet
+wpo_end_processing=12002_D_Bearbeitung der Informationen zur Gesamtprogramm-Optimierung aus der wpo-Feedback-Datei "$1" beendet
 % The compiler has finished processing the whole program optimization information found in the named file.
 wpo_expected_section=12003_E_Erwarte einen Sektions-Header, statt dessen "$2" in Zeile $1 der wpo-Feedback-Datei erhalten
 % The compiler expected a section header in the whole program optimization file (starting with \%),
@@ -2630,6 +2655,9 @@ Unterstützte Gesamtprogramm-Optimierungen:
   All
   $WPOPTIMIZATIONS
 
+Unterstützte Microcontroller:
+  $CONTROLLERTYPES
+
 Dieses Programm unterliegt der GNU General Public Licence
 Weitere Informationen sind in COPYING.FPC zu finden
 
@@ -2849,19 +2877,20 @@ S*2Tlinux_Linux
 **1u<x>_Entferne die Definition für das Symbol <x>
 **1U<x>_Unit-Optionen:
 **2Un_Prüfe den Unitnamen nicht
-**2Ur_Erzeuge release unit Dateien
+**2Ur_Erzeuge "release unit"-Dateien
 **2Us_Erzeuge eine Systemunit
 **1v<x>_Meldungen, <x> ist eine Kombination der folgenden Zeichen:
 **2*_e : Fehler (Standard)             0 : Nichts (ausser Fehlern)
 **2*_w : Warnungen                     u : Unit Informationen
 **2*_n : Anmerkungen                   t : Angesprochene/benutzte Dateien
-**2*_h : Hinweise                      c : Preprozessordirektive
+**2*_h : Hinweise                      c : Preprozessordirektiven
 **2*_i : Allgemeine Informationen      d : Debug Informationen
 **2*_l : Zeilennummern                 r : Rhide/GCC kompatibler Modus
+**2*_s : Zeitstempel                   q : Nummer der Meldung
 **2*_a : Alles                         x : Exe-Datei Informationen (nur Win32)
-**2*_b : Schreibe bei Meldungen mit Dateinamen den vollständigem Pfad
-**2*_v : Schreibe fpcdebug.txt mit     p : Schreibe tree.log mit Analysenbaum (parse tree)
-**2*_   ganz viel Information          q : Zeige die Nummer der Meldung
+**2*_b : Schreibe bei Meldungen mit    p : Schreibe tree.log mit Analysenbaum (parse tree)
+**2*_    Dateinamen den vollständigen  v : Schreibe fpcdebug.txt mit 
+**2*_    Pfad                              ganz viel Information
 **2*_m<x>,<y> : Zeige die Meldungen mit den Nummern <x> und <y> nicht
 3*1W<x>_Ziel-spezifische Optionen (Ziele)
 A*1W<x>_Ziel-spezifische Optionen (Ziele)
@@ -2908,7 +2937,7 @@ P*2WX_Ermögliche den executable stack (Linux)
 **2XP<x>_Stelle den Namen der Compiler-Hilfsprogrammen den Prefix <x> voran
 **2Xr<x>_Setze den Bibliotheks-Suchpfad zu <x>       (benötigt für cross compile)
 **2XR<x>_Stelle allen Linker-Suchpfaden den Namen <x> voran (BeOS, Darwin, FreeBSD, Linux, Mac OS, Solaris)
-**2Xs_Entferne alle Symbole von ausführbarer Datei
+**2Xs_Entferne alle Symbole aus der ausführbaren Datei
 **2XS_Versuche Units statisch zu linken (default)    (definiert FPC_LINK_STATIC)
 **2Xt_Linke mit statischen Bibliotheken              (-static wird an den Linker übergeben)
 **2XX_Versuche Units smart zu linken                 (definiert FPC_LINK_SMART)

compiler/msg/errore.msg

@@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
 #
 # Parser
 #
-# 03255 is the last used one
+# 03256 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1176,23 +1176,28 @@ parser_n_ignore_lower_visibility=03250_N_Virtual method "$1" has a lower visibil
 % The virtual method overrides an method that is declared with a higher visibility. This might give
 % unexpected results. In case the new visibility is private than it might be that a call to inherited in a
 % new child class will call the higher visible method in a parent class and ignores the private method.
-parser_e_objc_requires_msgstr=03251_E_Objective-C messages require their Objective-C selector name to be specified using the "message" directive.
+parser_e_field_not_allowed_here=03251_E_Fields cannot appear after a method or property definition, start a new visibility section first
+% Once a method or property has been defined in a class or object, you cannot define any fields afterwards
+% without starting a new visibility section (such as \var{public}, \var{private}, etc.). The reason is
+% that otherwise the source code can appear ambiguous to the compiler, since it is possible to use modifiers
+% such as \var{default} and \var{register} also as field names.
+parser_e_objc_requires_msgstr=03252_E_Objective-C messages require their Objective-C selector name to be specified using the "message" directive.
 % Objective-C messages require their Objective-C name (selector name) to be specified using the \var{message `someName:'} procedure directive.
 % While bindings to other languages automatically generate such names based on the identifier you use (by replacing
 % all underscores with colons), this is unsafe since nothing prevents an Objective-C method name to contain actual
 % colons.
-parser_e_objc_no_constructor_destructor=03252_E_Objective-C does not have formal constructors nor destructors. Use the alloc, initXXX and dealloc messages.
+parser_e_objc_no_constructor_destructor=03253_E_Objective-C does not have formal constructors nor destructors. Use the alloc, initXXX and dealloc messages.
 % The Objective-C language does not have any constructors or destructors. While there are some messages with a similar
 % purpose (such as \var{init} and \var{dealloc}), these cannot be identified using automatic parsers and do not
 % guarantee anything like Pascal constructors/destructors (e.g., you have to take care of only calling ``designated''
 % inherited ``constructors''). For these reasons, we have opted to follow the standard Objective-C patterns for
 % instance creation/destruction.
-parser_e_message_string_too_long=03253_E_Message name is too long (max. 255 characters)
+parser_e_message_string_too_long=03254_E_Message name is too long (max. 255 characters)
 % Due to compiler implementation reasons, message names are currently limited to 255 characters.
-parser_e_objc_message_name_too_long=03254_E_Objective-C message symbol name for "$1" is too long
+parser_e_objc_message_name_too_long=03255_E_Objective-C message symbol name for "$1" is too long
 % Due to compiler implementation reasons, mangled message names (i.e., the symbol names used in the assembler
 % code) are currently limited to 255 characters.
-parser_h_no_objc_parent=03255_H_Defining a new Objective-C root class. To derive from another root class (e.g., NSObject), specify it as the parent class.
+parser_h_no_objc_parent=03256_H_Defining a new Objective-C root class. To derive from another root class (e.g., NSObject), specify it as the parent class.
 % If no parent class is specified for an Object Pascal class, then it automatically derives from TObject.
 % Objective-C classes however do not automatically derive from NSObject, because one can have multiple
 % root classes in Objective-C. For example, in the Cocoa framework both NSObject and NSProxy are root classes.
@@ -1611,7 +1616,7 @@ sym_w_uninitialized_variable=05037_W_Variable "$1" does not seem to be initializ
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_e_id_no_member=05038_E_identifier idents no member "$1"
 % This error is generated when an identifier of a record,
 % field or method is accessed while it is not defined.
@@ -1646,22 +1651,22 @@ sym_h_uninitialized_local_variable=05057_H_Local variable "$1" does not seem to
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. it did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_uninitialized_variable=05058_H_Variable "$1" does not seem to be initialized
 % This message is displayed if the compiler thinks that a variable will
 % be used (i.e. it appears in the right-hand side of an expression) when it
 % was not initialized first (i.e. t did not appear in the left-hand side of an
-% assigment).
+% assignment).
 sym_w_function_result_uninitialized=05059_W_Function result variable does not seem to initialized
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. before it appeared in the left-hand side of an
-% assigment).
+% assignment).
 sym_h_function_result_uninitialized=05060_H_Function result variable does not seem to be initialized
 % This message is displayed if the compiler thinks that the function result
 % variable will be used (i.e. it appears in the right-hand side of an expression)
 % before it is initialized (i.e. it appears in the left-hand side of an
-% assigment)
+% assignment)
 sym_w_identifier_only_read=05061_W_Variable "$1" read but nowhere assigned
 % You have read the value of a variable, but nowhere assigned a value to
 % it.
@@ -2231,7 +2236,7 @@ link_f_executable_too_big=09200_F_Executable image size is too big for $1 target
 % Fatal error when resulting executable is too big.
 link_w_32bit_absolute_reloc=09201_W_Object file "$1" contains 32-bit absolute relocation to symbol "$2".
 % Warning when 64-bit object file contains 32-bit absolute relocations.
-% In such case an executable image can be loaded into lower 4Gb of 
+% In such case an executable image can be loaded into lower 4Gb of
 % address space only.
 %\end{description}
 # EndOfTeX
@@ -2577,11 +2582,11 @@ option_dwarf_smart_linking=11046_N_DWARF debug information cannot be used with s
 % This section lists errors that occur when the compiler is performing
 % whole program optimization.
 % \begin{description}
-wpo_cant_find_file=12000_F_Cannot open whole program optimization feedback file $1
+wpo_cant_find_file=12000_F_Cannot open whole program optimization feedback file "$1"
 % The compiler cannot open the specified feedback file with whole program optimization information.
-wpo_begin_processing=12001_D_Processing whole program optimization information in wpo feedback file $1
+wpo_begin_processing=12001_D_Processing whole program optimization information in wpo feedback file "$1"
 % The compiler starts processing whole program optimization information found in the named file.
-wpo_end_processing=12002_D_Finished processing the whole program optimization information in wpo feedback file $1
+wpo_end_processing=12002_D_Finished processing the whole program optimization information in wpo feedback file "$1"
 % The compiler has finished processing the whole program optimization information found in the named file.
 wpo_expected_section=12003_E_Expected section header, but got "$2" at line $1 of wpo feedback file
 % The compiler expected a section header in the whole program optimization file (starting with \%),
@@ -2778,6 +2783,7 @@ S*2Aas_Assemble using GNU AS
 **2Fa<x>[,y]_(for a program) load units <x> and [y] before uses is parsed
 **2Fc<x>_Set input codepage to <x>
 **2FC<x>_Set RC compiler binary name to <x>
+**2Fd_Disable the compiler's internal directory cache
 **2FD<x>_Set the directory where to search for compiler utilities
 **2Fe<x>_Redirect error output to <x>
 **2Ff<x>_Add <x> to framework path (Darwin only)
@@ -2798,14 +2804,15 @@ S*2Aas_Assemble using GNU AS
 *g2gh_Use heaptrace unit (for memory leak/corruption debugging)
 *g2gl_Use line info unit (show more info with backtraces)
 *g2go<x>_Set debug information options
-*g3godwarfsets_ Enable Dwarf set debug information (breaks gdb < 6.5)
+*g3godwarfsets_ Enable DWARF set debug information (breaks gdb < 6.5)
+*g3gostabsabsincludes_ Store absolute/full include file paths in Stabs
 *g2gp_Preserve case in stabs symbol names
-*g2gs_Generate stabs debug information
+*g2gs_Generate Stabs debug information
 *g2gt_Trash local variables (to detect uninitialized uses)
-*g2gv_Generates programs traceable with valgrind
-*g2gw_Generate dwarf-2 debug information (same as -gw2)
-*g2gw2_Generate dwarf-2 debug information
-*g2gw3_Generate dwarf-3 debug information
+*g2gv_Generates programs traceable with Valgrind
+*g2gw_Generate DWARFv2 debug information (same as -gw2)
+*g2gw2_Generate DWARFv2 debug information
+*g2gw3_Generate DWARFv3 debug information
 **1i_Information
 **2iD_Return compiler date
 **2iV_Return short compiler version
@@ -2912,10 +2919,11 @@ S*2Tlinux_Linux
 **2*_h : Show hints                  c : Show conditionals
 **2*_i : Show general info           d : Show debug info
 **2*_l : Show linenumbers            r : Rhide/GCC compatibility mode
+**2*_s : Show time stamps            q : Show message numbers
 **2*_a : Show everything             x : Executable info (Win32 only)
-**2*_b : Write file names messages with full path
-**2*_v : Write fpcdebug.txt with     p : Write tree.log with parse tree
-**2*_    lots of debugging info      q : Show message numbers
+**2*_b : Write file names messages   p : Write tree.log with parse tree
+**2*_    with full path              v : Write fpcdebug.txt with
+**2*_                                    lots of debugging info
 **2*_m<x>,<y> : Don't show messages numbered <x> and <y>
 3*1W<x>_Target-specific options (targets)
 A*1W<x>_Target-specific options (targets)

compiler/msgidx.inc

@@ -338,11 +338,12 @@ const
   parser_e_weak_external_not_supported=03248;
   parser_e_forward_mismatch=03249;
   parser_n_ignore_lower_visibility=03250;
-  parser_e_objc_requires_msgstr=03251;
-  parser_e_objc_no_constructor_destructor=03252;
-  parser_e_message_string_too_long=03253;
-  parser_e_objc_message_name_too_long=03254;
-  parser_h_no_objc_parent=03255;
+  parser_e_field_not_allowed_here=03251;
+  parser_e_objc_requires_msgstr=03252;
+  parser_e_objc_no_constructor_destructor=03253;
+  parser_e_message_string_too_long=03254;
+  parser_e_objc_message_name_too_long=03255;
+  parser_h_no_objc_parent=03256;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -793,9 +794,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 51640;
+  MsgTxtSize = 51955;
 
   MsgIdxMax : array[1..20] of longint=(
-    24,87,256,88,65,51,108,22,202,62,
+    24,87,257,88,65,51,108,22,202,62,
     47,20,1,1,1,1,1,1,1,1
   );

compiler/ncal.pas

@@ -75,6 +75,7 @@ interface
           procedure register_created_object_types;
 
 
+       private
           { inlining support }
           inlinelocals            : TFPObjectList;
           inlineinitstatement,
@@ -1276,7 +1277,6 @@ implementation
         hdef : tdef;
         ptemp : ttempcreatenode;
         usederef : boolean;
-        usevoidpointer : boolean;
       begin
         { Load all complex loads into a temp to prevent
           double calls to a function. We can't simply check for a hp.nodetype=calln }
@@ -1287,33 +1287,22 @@ implementation
             usederef:=(p.resultdef.typ in [arraydef,recorddef]) or
                       is_shortstring(p.resultdef) or
                       is_object(p.resultdef);
-            { avoid refcount increase }
-            usevoidpointer:=is_interface(p.resultdef);
 
             if usederef then
               hdef:=tpointerdef.create(p.resultdef)
             else
               hdef:=p.resultdef;
 
-            if usevoidpointer then
+            ptemp:=ctempcreatenode.create(hdef,hdef.size,tt_persistent,true);
+            if usederef then
               begin
-                ptemp:=ctempcreatenode.create(voidpointertype,voidpointertype.size,tt_persistent,true);
-                loadp:=ctypeconvnode.create_internal(p,voidpointertype);
-                refp:=ctypeconvnode.create_internal(ctemprefnode.create(ptemp),hdef);
+                loadp:=caddrnode.create_internal(p);
+                refp:=cderefnode.create(ctemprefnode.create(ptemp));
               end
             else
               begin
-                ptemp:=ctempcreatenode.create(hdef,hdef.size,tt_persistent,true);
-                if usederef then
-                  begin
-                    loadp:=caddrnode.create_internal(p);
-                    refp:=cderefnode.create(ctemprefnode.create(ptemp));
-                  end
-                else
-                  begin
-                    loadp:=p;
-                    refp:=ctemprefnode.create(ptemp)
-                  end
+                loadp:=p;
+                refp:=ctemprefnode.create(ptemp)
               end;
             add_init_statement(ptemp);
             add_init_statement(cassignmentnode.create(
@@ -2372,7 +2361,7 @@ implementation
                   { ignore possible private for properties or in delphi mode for anon. inherited (FK) }
                   ignorevisibility:=(nf_isproperty in flags) or
                                     ((m_delphi in current_settings.modeswitches) and (cnf_anon_inherited in callnodeflags));
-                  candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility);
+                  candidates:=tcallcandidates.create(symtableprocentry,symtableproc,left,ignorevisibility,not(nf_isproperty in flags));
 
                    { no procedures found? then there is something wrong
                      with the parameter size or the procedures are
@@ -2411,9 +2400,7 @@ implementation
                             end
                           else
                             begin
-                              if assigned(left) then
-                               current_filepos:=left.fileinfo;
-                              CGMessage1(parser_e_wrong_parameter_size,symtableprocentry.realname);
+                              CGMessagePos1(fileinfo,parser_e_wrong_parameter_size,symtableprocentry.realname);
                               symtableprocentry.write_parameter_lists(nil);
                             end;
                         end;

compiler/ncgcal.pas

@@ -974,6 +974,23 @@ implementation
          { procedure variable or normal function call ? }
          if (right=nil) then
            begin
+             { register call for WPO (must be done before wpo test below,
+               otherwise optimised called methods are no longer registered)
+             }
+             if (po_virtualmethod in procdefinition.procoptions) and
+                assigned(methodpointer) and
+                (methodpointer.nodetype<>typen) and
+                (not assigned(current_procinfo) or
+                 wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
+               tprocdef(procdefinition)._class.register_vmt_call(tprocdef(procdefinition).extnumber);
+{$ifdef vtentry}
+             if not is_interface(tprocdef(procdefinition)._class) then
+               begin
+                 inc(current_asmdata.NextVTEntryNr);
+                 current_asmdata.CurrAsmList.Concat(tai_symbol.CreateName('VTREF'+tostr(current_asmdata.NextVTEntryNr)+'_'+tprocdef(procdefinition)._class.vmt_mangledname+'$$'+tostr(vmtoffset div sizeof(pint)),AT_FUNCTION,0));
+               end;
+{$endif vtentry}
+
              name_to_call:='';
              { When methodpointer is typen we don't need (and can't) load
                a pointer. We can directly call the correct procdef (PFV) }
@@ -1005,14 +1022,10 @@ implementation
 
                  { Call through VMT, generate a VTREF symbol to notify the linker }
                  vmtoffset:=tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber);
-{$ifdef vtentry}
-                 if not is_interface(tprocdef(procdefinition)._class) then
-                   begin
-                     inc(current_asmdata.NextVTEntryNr);
-                     current_asmdata.CurrAsmList.Concat(tai_symbol.CreateName('VTREF'+tostr(current_asmdata.NextVTEntryNr)+'_'+tprocdef(procdefinition)._class.vmt_mangledname+'$$'+tostr(vmtoffset div sizeof(pint)),AT_FUNCTION,0));
-                   end;
-{$endif vtentry}
-
+                 { register call for WPO }
+                 if (not assigned(current_procinfo) or
+                     wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
+                   tprocdef(procdefinition)._class.register_vmt_call(tprocdef(procdefinition).extnumber);
 {$ifndef x86}
                  pvreg:=cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
 {$endif not x86}

compiler/ncgflw.pas

@@ -31,10 +31,10 @@ interface
 
     type
        tcgwhilerepeatnode = class(twhilerepeatnode)
+          usedregvars: tusedregvars;
+
           procedure pass_generate_code;override;
           procedure sync_regvars(checkusedregvars: boolean);
-
-          usedregvars: tusedregvars;
        end;
 
        tcgifnode = class(tifnode)
@@ -42,10 +42,10 @@ interface
        end;
 
        tcgfornode = class(tfornode)
+          usedregvars: tusedregvars;
+
           procedure pass_generate_code;override;
           procedure sync_regvars(checkusedregvars: boolean);
-
-          usedregvars: tusedregvars;
        end;
 
        tcgexitnode = class(texitnode)

compiler/ncgld.pas

@@ -64,7 +64,8 @@ implementation
       cpubase,parabase,
       tgobj,ncgutil,
       cgobj,
-      ncgbas,ncgflw;
+      ncgbas,ncgflw,
+      wpobase;
 
 {*****************************************************************************
                    SSA (for memory temps) support
@@ -115,6 +116,14 @@ implementation
                   result := fen_norecurse_true;
                 end;
             end;
+          { Subscriptn must be rejected, otherwise we may replace an
+            an entire record with a temp for its first field, mantis #13948)
+            Exception: the field's size is the same as the entire record
+          }
+          subscriptn:
+            if not(tsubscriptnode(n).left.resultdef.typ in [recorddef,objectdef]) or
+               (tsubscriptnode(n).left.resultdef.size <> tsubscriptnode(n).resultdef.size) then
+              result := fen_norecurse_false;
           { optimize the searching a bit }
           derefn,addrn,
           calln,inlinen,casen,
@@ -481,6 +490,16 @@ implementation
                      if (po_virtualmethod in procdef.procoptions) and
                         not(nf_inherited in flags) then
                        begin
+                         if (not assigned(current_procinfo) or
+                             wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
+                           procdef._class.register_vmt_call(procdef.extnumber);
+            {$ifdef vtentry}
+                         if not is_interface(procdef._class) then
+                           begin
+                             inc(current_asmdata.NextVTEntryNr);
+                             current_asmdata.CurrAsmList.Concat(tai_symbol.CreateName('VTREF'+tostr(current_asmdata.NextVTEntryNr)+'_'+procdef._class.vmt_mangledname+'$$'+tostr(vmtoffset div sizeof(pint)),AT_FUNCTION,0));
+                           end;
+            {$endif vtentry}
                          { a classrefdef already points to the VMT }
                          if (left.resultdef.typ<>classrefdef) then
                            begin

compiler/ncgrtti.pas

@@ -67,7 +67,8 @@ implementation
        fmodule,
        symsym,
        aasmtai,aasmdata,
-       defutil
+       defutil,
+       wpobase
        ;
 
 
@@ -311,6 +312,12 @@ implementation
                      { virtual method, write vmt offset }
                      current_asmdata.asmlists[al_rtti].concat(Tai_const.create(aitconst_ptr,
                        tprocdef(propaccesslist.procdef)._class.vmtmethodoffset(tprocdef(propaccesslist.procdef).extnumber)));
+                     { register for wpo }
+                     tprocdef(propaccesslist.procdef)._class.register_vmt_call(tprocdef(propaccesslist.procdef).extnumber);
+                     {$ifdef vtentry}
+                     { not sure if we can insert those vtentry symbols safely here }
+                     {$error register methods used for published properties}
+                     {$endif vtentry}
                      typvalue:=2;
                   end;
              end;

compiler/ncnv.pas

@@ -189,13 +189,13 @@ interface
        ttypeconvnodeclass = class of ttypeconvnode;
 
        tasnode = class(tbinarynode)
+          call: tnode;
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function dogetcopy: tnode;override;
           function docompare(p: tnode): boolean; override;
           destructor destroy; override;
-          call: tnode;
        end;
        tasnodeclass = class of tasnode;
 
@@ -3202,6 +3202,11 @@ implementation
          if codegenerror then
            exit;
 
+         { Passing a class type to an "is" expression cannot result in a class
+           of that type to be constructed.
+         }
+         include(right.flags,nf_ignore_for_wpo);
+
          if (right.resultdef.typ=classrefdef) then
           begin
             { left must be a class }
@@ -3399,6 +3404,10 @@ implementation
         procname: string;
       begin
         result:=nil;
+        { Passing a class type to an "as" expression cannot result in a class
+          of that type to be constructed.
+        }
+        include(right.flags,nf_ignore_for_wpo);
         if not assigned(call) then
           begin
             if is_class(left.resultdef) and

compiler/nmem.pas

@@ -175,9 +175,10 @@ implementation
          else if not is_objcclass(left.resultdef) and
                  not is_objcclassref(left.resultdef) then
            begin
-             if not assigned(current_procinfo) or
-               (po_inline in current_procinfo.procdef.procoptions) or
-               wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
+             if not(nf_ignore_for_wpo in flags) and
+                (not assigned(current_procinfo) or
+                 (po_inline in current_procinfo.procdef.procoptions) or
+                  wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
              begin
                { keep track of which classes might be instantiated via a classrefdef }
                if (left.resultdef.typ=classrefdef) then

compiler/node.pas

@@ -257,7 +257,16 @@ interface
          nf_get_asm_position,
 
          { tblocknode }
-         nf_block_with_exit
+         nf_block_with_exit,
+
+         { tloadvmtaddrnode }
+         nf_ignore_for_wpo  { we know that this loadvmtaddrnode cannot be used to construct a class instance }
+
+         { WARNING: there are now 32 elements in this type, and a set of this
+             type is written to the PPU. So before adding any more elements,
+             either move some flags to specific nodes, or stream a normalset
+             to the ppu
+         }
 
        );
 

compiler/options.pas

@@ -852,6 +852,11 @@ begin
                    end;
                  'C' :
                    RCCompiler := More;
+                 'd' :
+                   if UnsetBool(more, 0) then
+                     init_settings.disabledircache:=false
+                   else
+                     init_settings.disabledircache:=true;
                  'D' :
                    utilsdirectory:=FixPath(More,true);
                  'e' :

compiler/optvirt.pas

@@ -40,6 +40,7 @@ unit optvirt;
         fdef: tobjectdef;
         fparent: tinheritancetreenode;
         fchilds: tfpobjectlist;
+        fcalledvmtmethods: tbitset;
         finstantiated: boolean;
 
         function getchild(index: longint): tinheritancetreenode;
@@ -57,6 +58,7 @@ unit optvirt;
           this def (either new or existing one
         }
         function  maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
+        function  findchild(_def: tobjectdef): tinheritancetreenode;
       end;
 
 
@@ -73,6 +75,9 @@ unit optvirt;
         function registerinstantiatedobjectdefrecursive(def: tobjectdef; instantiated: boolean): tinheritancetreenode;
         procedure markvmethods(node: tinheritancetreenode; p: pointer);
         procedure printobjectvmtinfo(node: tinheritancetreenode; arg: pointer);
+        procedure addcalledvmtentries(node: tinheritancetreenode; arg: pointer);
+
+        function  getnodefordef(def: tobjectdef): tinheritancetreenode;
        public
         constructor create;
         destructor destroy; override;
@@ -81,6 +86,7 @@ unit optvirt;
         }
         procedure registerinstantiatedobjdef(def: tdef);
         procedure registerinstantiatedclassrefdef(def: tdef);
+        procedure registercalledvmtentries(entries: tcalledvmtentries);
         procedure checkforclassrefinheritance(def: tdef);
         procedure foreachnode(proctocall: tinheritancetreecallback; arg: pointer);
         procedure foreachleafnode(proctocall: tinheritancetreecallback; arg: pointer);
@@ -178,6 +184,8 @@ unit optvirt;
         fparent:=_parent;
         fdef:=_def;
         finstantiated:=_instantiated;
+        if assigned(_def) then
+          fcalledvmtmethods:=tbitset.create(_def.vmtentries.count);
       end;
 
 
@@ -185,6 +193,7 @@ unit optvirt;
       begin
         { fchilds owns its members, so it will free them too }
         fchilds.free;
+        fcalledvmtmethods.free;
         inherited destroy;
       end;
 
@@ -211,8 +220,6 @@ unit optvirt;
 
 
     function tinheritancetreenode.maybeaddchild(_def: tobjectdef; _instantiated: boolean): tinheritancetreenode;
-      var
-        i: longint;
       begin
         { sanity check }
         if assigned(_def.childof) then 
@@ -226,19 +233,32 @@ unit optvirt;
         if not assigned(fchilds) then
           fchilds:=tfpobjectlist.create(true);
         { def already a child -> return }
-        for i := 0 to fchilds.count-1 do
-          if (tinheritancetreenode(fchilds[i]).def=_def) then
-            begin
-              result:=tinheritancetreenode(fchilds[i]);
-              result.finstantiated:=result.finstantiated or _instantiated;
-              exit;
-            end;
-        { not found, add new child }
-        result:=tinheritancetreenode.create(self,_def,_instantiated);
-        fchilds.add(result);
+        result:=findchild(_def);
+        if assigned(result) then
+          result.finstantiated:=result.finstantiated or _instantiated
+        else
+          begin
+            { not found, add new child }
+            result:=tinheritancetreenode.create(self,_def,_instantiated);
+            fchilds.add(result);
+          end;
       end;
 
 
+    function tinheritancetreenode.findchild(_def: tobjectdef): tinheritancetreenode;
+      var
+        i: longint;
+      begin
+        result:=nil;
+        if assigned(fchilds) then
+          for i := 0 to fchilds.count-1 do
+            if (tinheritancetreenode(fchilds[i]).def=_def) then
+              begin
+                result:=tinheritancetreenode(fchilds[i]);
+                break;
+              end;
+      end;
+
     { *************************** tinheritancetree ************************* }
 
     constructor tinheritancetree.create;
@@ -296,6 +316,37 @@ unit optvirt;
       end;
 
 
+    function tinheritancetree.getnodefordef(def: tobjectdef): tinheritancetreenode;
+      begin
+        if assigned(def.childof) then
+          begin
+            result:=getnodefordef(def.childof);
+            if assigned(result) then
+              result:=result.findchild(def);
+          end
+        else
+          result:=froots.findchild(def);
+      end;
+
+
+    procedure tinheritancetree.registercalledvmtentries(entries: tcalledvmtentries);
+      var
+        node: tinheritancetreenode;
+      begin
+        node:=getnodefordef(tobjectdef(entries.objdef));
+        { it's possible that no instance of this class or its descendants are
+          instantiated
+        }
+        if not assigned(node) then
+          exit;
+        { now mark these methods as (potentially) called for this type and for
+          all of its descendants
+        }
+        addcalledvmtentries(node,entries.calledentries);
+        foreachnodefromroot(node,@addcalledvmtentries,entries.calledentries);
+      end;
+
+
    procedure tinheritancetree.checkforclassrefinheritance(def: tdef);
      var
        i: longint;
@@ -408,8 +459,19 @@ unit optvirt;
               
               if not assigned(currnode.def.vmcallstaticinfo) then
                 currnode.def.vmcallstaticinfo:=allocmem(currnode.def.vmtentries.count*sizeof(tvmcallstatic));
+              { if this method cannot be called, we can just mark it as
+                unreachable. This will cause its static name to be set to
+                FPC_ABSTRACTERROR later on. Exception: published methods are
+                always reachable (via RTTI).
+              }
+              if (pd.visibility<>vis_published) and
+                 not(currnode.fcalledvmtmethods.isset(i)) then
+                begin
+                  currnode.def.vmcallstaticinfo^[i]:=vmcs_unreachable;
+                  currnode:=currnode.parent;
+                end
               { same procdef as in all instantiated childs? (yes or don't know) }
-              if (currnode.def.vmcallstaticinfo^[i] in [vmcs_default,vmcs_yes]) then
+              else if (currnode.def.vmcallstaticinfo^[i] in [vmcs_default,vmcs_yes]) then
                 begin
                   { methods in uninstantiated classes can be made static if
                     they are the same in all instantiated derived classes
@@ -439,14 +501,16 @@ unit optvirt;
                     end;
                   currnode:=currnode.parent;
                 end
-              else
+              else if (currnode.def.vmcallstaticinfo^[i]=vmcs_no) then
                 begin
                   {$IFDEF DEBUG_DEVIRT}
                   writeln('    not processing parents, already non-static for ',currnode.def.typename);
                   {$ENDIF}
                   { parents are already set to vmcs_no, so no need to continue }
                   currnode:=nil;
-                end;
+                end
+              else
+                currnode:=currnode.parent;
             until not assigned(currnode) or
                   not assigned(currnode.def);
           end;
@@ -463,10 +527,12 @@ unit optvirt;
       var
         i,
         totaldevirtualised,
-        totalvirtual: ptrint;
+        totalvirtual,
+        totalunreachable: ptrint;
       begin
         totaldevirtualised:=0;
         totalvirtual:=0;
+        totalunreachable:=0;
         writeln(node.def.typename);
         if (node.def.vmtentries.count=0) then
           begin
@@ -481,13 +547,26 @@ unit optvirt;
                 begin
                   inc(totaldevirtualised);
                   writeln('  Devirtualised: ',pvmtentry(node.def.vmtentries[i])^.procdef.typename);
+                end
+              else if (node.def.vmcallstaticinfo^[i]=vmcs_unreachable) then
+                begin
+                  inc(totalunreachable);
+                  writeln('   Unreachable: ',pvmtentry(node.def.vmtentries[i])^.procdef.typename);
                 end;
             end;
-        writeln('Total devirtualised: ',totaldevirtualised,'/',totalvirtual);
+        writeln('Total devirtualised/unreachable/all: ',totaldevirtualised,'/',totalunreachable,'/',totalvirtual);
         writeln;
       end;
 
 
+    procedure tinheritancetree.addcalledvmtentries(node: tinheritancetreenode; arg: pointer);
+      var
+        vmtentries: tbitset absolute arg;
+      begin
+        node.fcalledvmtmethods.addset(vmtentries);
+      end;
+
+
     procedure tinheritancetree.printvmtinfo;
       begin
         foreachnode(@printobjectvmtinfo,nil);
@@ -622,11 +701,18 @@ unit optvirt;
         if (node.def.vmtentries.count=0) then
           exit;
         for i:=0 to node.def.vmtentries.count-1 do
-          if (po_virtualmethod in pvmtentry(node.def.vmtentries[i])^.procdef.procoptions) and
-             (node.def.vmcallstaticinfo^[i]=vmcs_yes) then
-            begin
-              { add info about devirtualised vmt entry }
-              classdevirtinfo.addstaticmethod(i,pvmtentry(node.def.vmtentries[i])^.procdef.mangledname);
+          if (po_virtualmethod in pvmtentry(node.def.vmtentries[i])^.procdef.procoptions) then
+            case node.def.vmcallstaticinfo^[i] of
+              vmcs_yes:
+                begin
+                  { add info about devirtualised vmt entry }
+                  classdevirtinfo.addstaticmethod(i,pvmtentry(node.def.vmtentries[i])^.procdef.mangledname);
+                end;
+              vmcs_unreachable:
+                begin
+                  { static reference to FPC_ABSTRACTERROR }
+                  classdevirtinfo.addstaticmethod(i,'FPC_ABSTRACTERROR');
+                end;
             end;
       end;
 
@@ -809,6 +895,17 @@ unit optvirt;
              end;
            end;
 
+         { add info about called virtual methods }
+         hp:=tmodule(loaded_units.first);
+         while assigned(hp) do
+          begin
+            if assigned(hp.wpoinfo.calledvmtentries) then
+              for i:=0 to hp.wpoinfo.calledvmtentries.count-1 do
+                inheritancetree.registercalledvmtentries(tcalledvmtentries(hp.wpoinfo.calledvmtentries[i]));
+            hp:=tmodule(hp.next);
+          end;
+
+
          inheritancetree.optimizevirtualmethods;
 {$ifdef DEBUG_DEVIRT}
          inheritancetree.printvmtinfo;
@@ -1054,34 +1151,51 @@ unit optvirt;
              exit;
            end;
 
+         { if it's for a vmtentry of an objdef and the objdef is
+           not instantiated, then we can fill the vmt with pointers
+           to FPC_ABSTRACTERROR, except for published methods
+           (these can be called via rtti, so always have to point
+            to the original method)
+         }
+         if forvmtentry and
+            (tprocdef(procdef).visibility=vis_published) then
+           begin
+             result:=false;
+             exit;
+           end;
+
          { get the component names for the class/procdef combo }
          defsdecompose(realobjdef,tprocdef(procdef),unitid,classid,vmtentry);
 
+         { If we don't have information about a particular unit/class/method,
+           it means that such class cannot be instantiated. So if we are
+           looking up information for a vmt entry, we can always safely return
+           FPC_ABSTRACTERROR if we do not find anything, unless it's a
+           published method (but those are handled already above) or a
+           class method (can be called even if the class is not instantiated).
+         }
+         result:=
+           forvmtentry and
+           not(po_classmethod in tprocdef(procdef).procoptions);
+         staticname:='FPC_ABSTRACTERROR';
+
          { do we have any info for this unit? }
          unitdevirtinfo:=findunit(unitid^);
-         result:=false;
          if not assigned(unitdevirtinfo) then
            exit;
          { and for this class? }
          classdevirtinfo:=unitdevirtinfo.findclass(classid^);
          if not assigned(classdevirtinfo) then
            exit;
-         { if it's for a vmtentry of an objdef and the objdef is
-           not instantiated, then we can fill the vmt with pointers
-           to FPC_ABSTRACTERROR, except for published methods
-           (these can be called via rtti, so always have to point
-            to the original method)
-         }
-         if forvmtentry and
-            (tprocdef(procdef).procsym.visibility=vis_published) then
-           exit;
          if forvmtentry and
             (objdef.typ=objectdef) and
             not classdevirtinfo.instantiated and
             { virtual class methods can be called even if the class is not instantiated }
             not(po_classmethod in tprocdef(procdef).procoptions) then
            begin
-             staticname:='FPC_ABSTRACTERROR';
+             { already set above
+               staticname:='FPC_ABSTRACTERROR';
+             }
              result:=true;
            end
          else

compiler/parser.pas

@@ -86,6 +86,7 @@ implementation
          pattern:='';
          orgpattern:='';
          current_scanner:=nil;
+         switchesstatestackpos:=0;
 
          { register all nodes and tais }
          registernodes;
@@ -280,6 +281,8 @@ implementation
           oldcurrent_procinfo : tprocinfo;
           old_settings : tsettings;
           oldsourcecodepage : tcodepagestring;
+          old_switchesstatestack : tswitchesstatestack;
+          old_switchesstatestackpos : Integer;
         end;
 
       var
@@ -300,11 +303,13 @@ implementation
          with olddata^ do
           begin
             old_current_module:=current_module;
-          { save symtable state }
+
+            { save symtable state }
             oldsymtablestack:=symtablestack;
             oldmacrosymtablestack:=macrosymtablestack;
             oldcurrent_procinfo:=current_procinfo;
-          { save scanner state }
+
+            { save scanner state }
             oldc:=c;
             oldpattern:=pattern;
             oldorgpattern:=orgpattern;
@@ -312,14 +317,19 @@ implementation
             oldidtoken:=idtoken;
             old_block_type:=block_type;
             oldtokenpos:=current_tokenpos;
-          { save cg }
+            old_switchesstatestack:=switchesstatestack;
+            old_switchesstatestackpos:=switchesstatestackpos;
+
+            { save cg }
             oldparse_only:=parse_only;
-          { save akt... state }
-          { handle the postponed case first }
+
+            { save akt... state }
+            { handle the postponed case first }
             flushpendingswitchesstate;
             oldcurrent_filepos:=current_filepos;
             old_settings:=current_settings;
           end;
+
        { reset parser, a previous fatal error could have left these variables in an unreliable state, this is
          important for the IDE }
          afterassignment:=false;
@@ -457,8 +467,12 @@ implementation
                 idtoken:=oldidtoken;
                 current_tokenpos:=oldtokenpos;
                 block_type:=old_block_type;
+                switchesstatestack:=old_switchesstatestack;
+                switchesstatestackpos:=old_switchesstatestackpos;
+
                 { restore cg }
                 parse_only:=oldparse_only;
+
                 { restore symtable state }
                 symtablestack:=oldsymtablestack;
                 macrosymtablestack:=oldmacrosymtablestack;

compiler/pdecobj.pas

@@ -101,6 +101,11 @@ implementation
             include(p.propoptions,ppo_defaultproperty);
             if not(ppo_hasparameters in p.propoptions) then
               message(parser_e_property_need_paras);
+            if (token=_COLON) then
+              begin
+                Message(parser_e_field_not_allowed_here);
+                consume_all_until(_SEMICOLON);
+              end;
             consume(_SEMICOLON);
           end;
         { hint directives, these can be separated by semicolons here,
@@ -408,6 +413,7 @@ implementation
         oldparse_only,
         old_parse_generic : boolean;
         object_member_blocktype : tblock_type;
+        fields_allowed: boolean;
       begin
         { empty class declaration ? }
         if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and
@@ -424,6 +430,7 @@ implementation
           current_objectdef.symtable.currentvisibility:=vis_public;
         testcurobject:=1;
         has_destructor:=false;
+        fields_allowed:=true;
         object_member_blocktype:=bt_general;
         repeat
           case token of
@@ -451,6 +458,7 @@ implementation
                        consume(_PRIVATE);
                        current_objectdef.symtable.currentvisibility:=vis_private;
                        include(current_objectdef.objectoptions,oo_has_private);
+                       fields_allowed:=true;
                      end;
                    _PROTECTED :
                      begin
@@ -459,6 +467,7 @@ implementation
                        consume(_PROTECTED);
                        current_objectdef.symtable.currentvisibility:=vis_protected;
                        include(current_objectdef.objectoptions,oo_has_protected);
+                       fields_allowed:=true;
                      end;
                    _PUBLIC :
                      begin
@@ -466,6 +475,7 @@ implementation
                          Message(parser_e_no_access_specifier_in_interfaces);
                        consume(_PUBLIC);
                        current_objectdef.symtable.currentvisibility:=vis_public;
+                       fields_allowed:=true;
                      end;
                    _PUBLISHED :
                      begin
@@ -476,6 +486,7 @@ implementation
                          Message(parser_e_no_access_specifier_in_interfaces);
                        consume(_PUBLISHED);
                        current_objectdef.symtable.currentvisibility:=vis_published;
+                       fields_allowed:=true;
                      end;
                    _STRICT :
                      begin
@@ -503,6 +514,7 @@ implementation
                           end
                         else
                           message(parser_e_protected_or_private_expected);
+                        fields_allowed:=true;
                       end;
                     else
                       begin
@@ -514,6 +526,8 @@ implementation
                             if (current_objectdef.symtable.currentvisibility=vis_published) and
                                not(oo_can_have_published in current_objectdef.objectoptions) then
                               Message(parser_e_cant_have_published);
+                            if (not fields_allowed) then
+                              Message(parser_e_field_not_allowed_here);
 
                             read_record_fields([vd_object])
                           end
@@ -525,6 +539,7 @@ implementation
             _PROPERTY :
               begin
                 property_dec;
+                fields_allowed:=false;
               end;
             _PROCEDURE,
             _FUNCTION,
@@ -571,6 +586,7 @@ implementation
                 maybe_parse_hint_directives(pd);
 
                 parse_only:=oldparse_only;
+                fields_allowed:=false;
               end;
             _CONSTRUCTOR :
               begin
@@ -604,6 +620,7 @@ implementation
                 maybe_parse_hint_directives(pd);
 
                 parse_only:=oldparse_only;
+                fields_allowed:=false;
               end;
             _DESTRUCTOR :
               begin
@@ -642,6 +659,7 @@ implementation
                 maybe_parse_hint_directives(pd);
 
                 parse_only:=oldparse_only;
+                fields_allowed:=false;
               end;
             _END :
               begin

compiler/pdecsub.pas

@@ -1128,7 +1128,14 @@ implementation
           message(parser_e_illegal_function_result);
         { support procedure proc stdcall export; }
         if not(check_proc_directive(false)) then
-          consume(_SEMICOLON);
+          begin
+            if (token=_COLON) then
+              begin
+                message(parser_e_field_not_allowed_here);
+                consume_all_until(_SEMICOLON);
+              end;
+            consume(_SEMICOLON);
+          end;
         result:=pd;
 
         if locationstr<>'' then
@@ -2487,7 +2494,14 @@ const
                      (token in [_END,_RKLAMMER,_EQUAL]) then
                     break
                   else
-                    consume(_SEMICOLON);
+                    begin
+                      if (token=_COLON) then
+                        begin
+                          Message(parser_e_field_not_allowed_here);
+                          consume_all_until(_SEMICOLON);
+                        end;
+                      consume(_SEMICOLON)
+                    end;
                 end;
             end
            else

compiler/pinline.pas

@@ -79,7 +79,10 @@ implementation
         p:=comp_expr(true);
         { calc return type }
         if is_new then
-          set_varstate(p,vs_written,[])
+          begin
+            set_varstate(p,vs_written,[]);
+            valid_for_var(p,true);
+          end
         else
           set_varstate(p,vs_readwritten,[vsf_must_be_valid]);
         if (m_mac in current_settings.modeswitches) and

compiler/pmodules.pas

@@ -1042,6 +1042,9 @@ implementation
            needs to be added implicitly }
          current_module.updatemaps;
 
+         { create whole program optimisation information }
+         current_module.wpoinfo:=tunitwpoinfo.create;
+
          { ... parse the declarations }
          Message1(parser_u_parsing_interface,current_module.realmodulename^);
          symtablestack.push(current_module.globalsymtable);
@@ -1120,9 +1123,6 @@ implementation
          symtablestack.push(current_module.globalsymtable);
          symtablestack.push(current_module.localsymtable);
 
-         { create whole program optimisation information }
-         current_module.wpoinfo:=tunitwpoinfo.create;
-
          if not current_module.interface_only then
            begin
              Message1(parser_u_parsing_implementation,current_module.modulename^);

compiler/powerpc/agppcmpw.pas

@@ -41,11 +41,12 @@ interface
         procedure WriteExternals;
         procedure WriteAsmFileHeader;
       private
+        cur_CSECT_name: String;
+        cur_CSECT_class: String;
+
         procedure WriteInstruction(hp : tai);
         procedure WriteProcedureHeader(var hp:tai);
         procedure WriteDataHeader(var s:string; isExported, isConst:boolean);
-        cur_CSECT_name: String;
-        cur_CSECT_class: String;
       end;
 
 

compiler/powerpc/cpupi.pas

@@ -47,10 +47,11 @@ unit cpupi;
          private
           first_save_int_reg, first_save_fpu_reg: tsuperregister;
          public
+          needs_frame_pointer: boolean;
+
           property get_first_save_int_reg: tsuperregister read first_save_int_reg;
           property get_first_save_fpu_reg: tsuperregister read first_save_fpu_reg;
 
-          needs_frame_pointer: boolean;
        end;
 
 

compiler/powerpc64/cpupi.pas

@@ -37,13 +37,14 @@ type
 
     { offset where the frame pointer from the outer procedure is stored. }
     parent_framepointer_offset: longint;
+
+    needs_frame_pointer : boolean;
+
     constructor create(aparent: tprocinfo); override;
     procedure set_first_temp_offset; override;
     function calc_stackframe_size: longint; override;
     function calc_stackframe_size(numgpr, numfpr : longint): longint;
 
-    needs_frame_pointer : boolean;
-
     procedure allocate_got_register(list: TAsmList); override;
   end;
 

compiler/ppu.pas

@@ -43,7 +43,7 @@ type
 {$endif Test_Double_checksum}
 
 const
-  CurrentPPUVersion = 97;
+  CurrentPPUVersion = 100;
 
 { buffer sizes }
   maxentrysize = 1024;

compiler/ptconst.pas

@@ -44,7 +44,8 @@ implementation
        { parser specific stuff }
        pbase,pexpr,pdecvar,
        { codegen }
-       cpuinfo,cgbase,dbgbase
+       cpuinfo,cgbase,dbgbase,
+       wpobase
        ;
 
 {$maxfpuregisters 0}
@@ -329,6 +330,11 @@ implementation
                 if not Tobjectdef(tclassrefdef(n.resultdef).pointeddef).is_related(tobjectdef(def.pointeddef)) then
                   IncompatibleTypes(n.resultdef, def);
                 list.concat(Tai_const.Create_sym(current_asmdata.RefAsmSymbol(Tobjectdef(tclassrefdef(n.resultdef).pointeddef).vmt_mangledname)));
+                { update wpo info }
+                if not assigned(current_procinfo) or
+                   (po_inline in current_procinfo.procdef.procoptions) or
+                   wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname) then
+                  tobjectdef(tclassrefdef(n.resultdef).pointeddef).register_maybe_created_object_type;
               end;
              niln:
                list.concat(Tai_const.Create_sym(nil));

compiler/scandir.pas

@@ -23,22 +23,10 @@ unit scandir;
 
 {$i fpcdefs.inc}
 
-interface
-
-
-    procedure InitScannerDirectives;
-
-implementation
+  interface
 
     uses
-      SysUtils,
-      cutils,cfileutl,
-      globtype,globals,systems,widestr,cpuinfo,
-      verbose,comphook,ppu,
-      scanner,switches,
-      fmodule,
-      symconst,symtable,
-      rabase;
+      globtype;
 
     const
       switchesstatestackmax = 20;
@@ -49,10 +37,27 @@ implementation
         verbosity: longint;
       end;
 
+    type
+      tswitchesstatestack = array[0..switchesstatestackmax] of tsavedswitchesstate;
+
     var
-      switchesstatestack: array[0..switchesstatestackmax] of tsavedswitchesstate;
+      switchesstatestack:tswitchesstatestack;
       switchesstatestackpos: Integer;
 
+    procedure InitScannerDirectives;
+
+  implementation
+
+    uses
+      SysUtils,
+      cutils,cfileutl,
+      globals,systems,widestr,cpuinfo,
+      verbose,comphook,ppu,
+      scanner,switches,
+      fmodule,
+      symconst,symtable,
+      rabase;
+
 {*****************************************************************************
                                     Helpers
 *****************************************************************************}
@@ -1405,6 +1410,4 @@ implementation
         AddDirective('Z4',directive_all, @dir_z4);
       end;
 
-begin
-  switchesstatestackpos:= 0;
 end.

compiler/symdef.pas

@@ -231,7 +231,7 @@ interface
 
        { tobjectdef }
 
-       tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no);
+       tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable);
        pmvcallstaticinfo = ^tmvcallstaticinfo;
        tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic;
        tobjectdef = class(tabstractrecorddef)
@@ -296,9 +296,11 @@ interface
           function FindDestructor : tprocdef;
           function implements_any_interfaces: boolean;
           procedure reset; override;
+          { WPO }
           procedure register_created_object_type;override;
           procedure register_maybe_created_object_type;
           procedure register_created_classref_type;
+          procedure register_vmt_call(index:longint);
           procedure make_all_methods_external;
        end;
 
@@ -2385,10 +2387,10 @@ implementation
             exit;
           end;
 
+        result:=cachedelesize*aint(cachedelecount);
         if (ado_IsBitPacked in arrayoptions) then
-          size:=(cachedelesize * aint(cachedelecount) + 7) div 8
-        else
-          result:=cachedelesize*aint(cachedelecount);
+          { can't just add 7 and divide by 8, because that may overflow }
+          result:=result div 8 + ord((result mod 8)<>0);
       end;
 
 
@@ -4319,6 +4321,13 @@ implementation
       end;
 
 
+    procedure tobjectdef.register_vmt_call(index: longint);
+      begin
+        if (is_object(self) or is_class(self)) then
+          current_module.wpoinfo.addcalledvmtentry(self,index);
+      end;
+
+
     procedure make_procdef_external(data: tobject; arg: pointer);
       var
         def: tdef absolute data;

compiler/symsym.pas

@@ -137,9 +137,10 @@ interface
                                          callback:Tnotification_callback):cardinal;
           procedure unregister_notification(id:cardinal);
         private
-          procedure setvardef(def:tdef);
           _vardef     : tdef;
           vardefderef : tderef;
+
+          procedure setvardef(def:tdef);
         public
           property vardef: tdef read _vardef write setvardef;
       end;

compiler/symtable.pas

@@ -91,12 +91,11 @@ interface
           procedure insertdef(def:TDefEntry);override;
           function is_packed: boolean;
         protected
-          procedure setdatasize(val: aint);
           _datasize       : aint;
           { size in bits of the data in case of bitpacked record. Only important during construction, }
           { no need to save in/restore from ppu file. datasize is always (databitsize+7) div 8.       }
           databitsize    : aint;
-          { bitpacked? -> all fieldvarsym offsets are in bits instead of bytes }
+          procedure setdatasize(val: aint);
         public
           property datasize : aint read _datasize write setdatasize;
        end;

compiler/systems.pas

@@ -236,7 +236,8 @@ interface
 
 
        palignmentinfo = ^talignmentinfo;
-       talignmentinfo = record
+       { this is written to ppus during token recording for generics so it must be packed }
+       talignmentinfo = packed record
          procalign,
          loopalign,
          jumpalign,

compiler/systems/i_embed.pas

@@ -33,8 +33,8 @@ unit i_embed;
             system       : system_arm_embedded;
             name         : 'Embedded';
             shortname    : 'embedded';
-            flags        : [tf_needs_symbol_size,tf_files_case_sensitive,tf_use_function_relative_addresses
-	                          ,tf_smartlink_sections];
+            flags        : [tf_needs_symbol_size,tf_files_case_sensitive,
+                            tf_use_function_relative_addresses,tf_smartlink_sections];
             cpu          : cpu_arm;
             unit_env     : '';
             extradefines : '';

compiler/systems/i_gba.pas

@@ -57,6 +57,8 @@ unit i_gba;
             staticClibext : '.a';
             staticClibprefix : 'lib';
             sharedClibprefix : 'lib';
+            importlibprefix : 'libimp';
+            importlibext : '.a';
             Cprefix      : '';
             newline      : #10;
             dirsep       : '/';

compiler/systems/i_nds.pas

@@ -57,6 +57,8 @@ unit i_nds;
             staticClibext : '.a';
             staticClibprefix : 'lib';
             sharedClibprefix : 'lib';
+            importlibprefix : 'libimp';
+            importlibext : '.a';
             Cprefix      : '';
             newline      : #10;
             dirsep       : '/';

compiler/systems/t_embed.pas

@@ -224,32 +224,63 @@ begin
       with linkres do
         begin
           Add('ENTRY(_START)');
-          Add('SECTIONS');
+          Add('MEMORY');
           Add('{');
-          Add('     . = 0x0;  /* start of flash */');
-          Add('    /* code and constants */');
-          Add('    .text :');
-          Add('    {');
-          Add('    *(.init, .init.*)');
-          Add('    *(.text, .text.*)');
-          Add('    *(.strings)');
-          Add('    *(.rodata.*)');
-          Add('    *(.comment)');
-          Add('    }');
-          Add('    /* uninitialized data */');
-          Add('    . = 0x40000000;  /* start of ram */');
-          Add('    .bss :');
-          Add('    {');
-          Add('    *(.bss, .bss.*)');
-          Add('    *(COMMON)');
-          Add('    *(.data, .data.*)');
-          Add('    KEEP (*(.fpc .fpc.n_version .fpc.n_links))');
-          Add('    }');
+          Add('    flash : ORIGIN = 0, LENGTH = 256K');
+          Add('    ram : ORIGIN = 0x40000000, LENGTH = 16K');
           Add('}');
+          Add('_stack_top = 0x40003FFC;');
         end;
+      ct_at91sam7s256,
+      ct_at91sam7se256,
+      ct_at91sam7x256,
+      ct_at91sam7xc256:
+      with linkres do
+        begin
+          Add('ENTRY(_START)');
+          Add('MEMORY');
+          Add('{');
+          Add('    flash : ORIGIN = 0, LENGTH = 256K');
+          Add('    ram : ORIGIN = 0x200000, LENGTH = 64K');
+          Add('}');
+          Add('_stack_top = 0x20FFFC;');
+        end;
+
     else
       internalerror(200902011);
   end;
+
+  with linkres do
+    begin
+      Add('SECTIONS');
+      Add('{');
+      Add('     .text :');
+      Add('    {');
+      Add('    *(.init, .init.*)');
+      Add('    *(.text, .text.*)');
+      Add('    *(.strings)');
+      Add('    *(.rodata, .rodata.*)');
+      Add('    *(.comment)');
+      Add('    _etext = .;');
+      Add('    } >flash');
+      Add('    .data :');
+      Add('    {');
+      Add('    _data = .;');
+      Add('    *(.data, .data.*)');
+      Add('    KEEP (*(.fpc .fpc.n_version .fpc.n_links))');
+      Add('    _edata = .;');
+      Add('    } >ram AT >flash');
+      Add('    .bss :');
+      Add('    {');
+      Add('    _bss_start = .;');
+      Add('    *(.bss, .bss.*)');
+      Add('    *(COMMON)');
+      Add('    } >ram');
+      Add('. = ALIGN(4);');
+      Add('_bss_end = . ;');
+      Add('}');
+      Add('_end = .;');
+    end;
 {$endif ARM}
 
   { Write and Close response }
@@ -308,17 +339,16 @@ begin
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 
 { Remove ReponseFile }
-  if (success) and not(cs_link_nolink in current_settings.globalswitches) then
+  if success and not(cs_link_nolink in current_settings.globalswitches) then
    DeleteFile(outputexedir+Info.ResName);
 
-{ Post process
+{ Post process }
   if success then
     begin
-      success:=DoExec(FindUtil(utilsprefix+'objcopy'),'-O binary '+
+      success:=DoExec(FindUtil(utilsprefix+'objcopy'),'-O ihex '+
         ChangeFileExt(current_module.exefilename^,'.elf')+' '+
-        current_module.exefilename^,true,false);
+        ChangeFileExt(current_module.exefilename^,'.hex'),true,false);
     end;
-}
 
   MakeExecutable:=success;   { otherwise a recursive call to link method }
 end;

compiler/systems/t_gba.pas

@@ -31,7 +31,7 @@ implementation
 
     uses
        SysUtils,
-       cutils,cfileutils,cclasses,
+       cutils,cfileutl,cclasses,
        globtype,globals,systems,verbose,script,fmodule,i_gba,link;
 
     type

compiler/systems/t_nds.pas

@@ -31,7 +31,7 @@ implementation
 
     uses
        SysUtils,
-       cutils,cfileutils,cclasses,
+       cutils,cfileutl,cclasses,
        globtype,globals,systems,verbose,script,fmodule,i_nds,link;
 
     type

compiler/wpobase.pas

@@ -110,6 +110,31 @@ type
   { ** Information created per unit for use during subsequent compilation *** }
   { ************************************************************************* }
 
+  { information about called vmt entries for a class }
+  tcalledvmtentries = class
+   protected
+    { the class }
+    fobjdef: tdef;
+    fobjdefderef: tderef;
+    { the vmt entries }
+    fcalledentries: tbitset;
+   public
+    constructor create(_objdef: tdef; nentries: longint);
+    constructor ppuload(ppufile: tcompilerppufile);
+    destructor destroy; override;
+    procedure ppuwrite(ppufile: tcompilerppufile);
+
+    procedure buildderef;
+    procedure buildderefimpl;
+    procedure deref;
+    procedure derefimpl;
+
+    property objdef: tdef read fobjdef write fobjdef;
+    property objdefderef: tderef read fobjdefderef write fobjdefderef;
+    property calledentries: tbitset read fcalledentries write fcalledentries;
+  end;
+
+
   { base class of information collected per unit. Still needs to be
     generalised for different kinds of wpo information, currently specific
     to devirtualization.
@@ -127,6 +152,12 @@ type
        so they can end up in a classrefdef var and be instantiated)
     }
     fmaybecreatedbyclassrefdeftypes: tfpobjectlist;
+
+    { called virtual methods for all classes (hashed by mangled classname,
+      entries bitmaps indicating which vmt entries per class are called --
+      tcalledvmtentries)
+    }
+    fcalledvmtentries: tfphashlist;
    public
     constructor create; reintroduce; virtual;
     destructor destroy; override;
@@ -134,10 +165,12 @@ type
     property createdobjtypes: tfpobjectlist read fcreatedobjtypes;
     property createdclassrefobjtypes: tfpobjectlist read fcreatedclassrefobjtypes;
     property maybecreatedbyclassrefdeftypes: tfpobjectlist read fmaybecreatedbyclassrefdeftypes;
+    property calledvmtentries: tfphashlist read fcalledvmtentries;
 
     procedure addcreatedobjtype(def: tdef);
     procedure addcreatedobjtypeforclassref(def: tdef);
     procedure addmaybecreatedbyclassref(def: tdef);
+    procedure addcalledvmtentry(def: tdef; index: longint);
   end;
 
   { ************************************************************************* }
@@ -321,10 +354,13 @@ implementation
       fcreatedobjtypes:=tfpobjectlist.create(false);
       fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
       fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
+      fcalledvmtentries:=tfphashlist.create;
     end;
 
 
   destructor tunitwpoinfobase.destroy;
+    var
+      i: longint;
     begin
       fcreatedobjtypes.free;
       fcreatedobjtypes:=nil;
@@ -332,6 +368,18 @@ implementation
       fcreatedclassrefobjtypes:=nil;
       fmaybecreatedbyclassrefdeftypes.free;
       fmaybecreatedbyclassrefdeftypes:=nil;
+
+      { may not be assigned in case the info was loaded from a ppu and we
+        are not generating a wpo feedback file (see tunitwpoinfo.ppuload)
+      }
+      if assigned(fcalledvmtentries) then
+        begin
+          for i:=0 to fcalledvmtentries.count-1 do
+            tcalledvmtentries(fcalledvmtentries[i]).free;
+          fcalledvmtentries.free;
+          fcalledvmtentries:=nil;
+        end;
+
       inherited destroy;
     end;
     
@@ -341,16 +389,35 @@ implementation
       fcreatedobjtypes.add(def);
     end;
 
+
   procedure tunitwpoinfobase.addcreatedobjtypeforclassref(def: tdef);
     begin
       fcreatedclassrefobjtypes.add(def);
     end;
 
+
   procedure tunitwpoinfobase.addmaybecreatedbyclassref(def: tdef);
     begin
       fmaybecreatedbyclassrefdeftypes.add(def);
     end;
 
+
+  procedure tunitwpoinfobase.addcalledvmtentry(def: tdef; index: longint);
+    var
+      entries: tcalledvmtentries;
+      key: shortstring;
+    begin
+      key:=tobjectdef(def).vmt_mangledname;
+      entries:=tcalledvmtentries(fcalledvmtentries.find(key));
+      if not assigned(entries) then
+        begin
+          entries:=tcalledvmtentries.create(def,tobjectdef(def).vmtentries.count);
+          fcalledvmtentries.add(key,entries);
+        end;
+      entries.calledentries.include(index);
+    end;
+
+
   { twpofilereader }
 
   function twpofilereader.getnextnoncommentline(out s: string):
@@ -379,7 +446,9 @@ implementation
 
   constructor twpofilereader.create(const fn: tcmdstr; dest: twpoinfomanagerbase);
     begin
-      if not FileExists(fn) then
+      if not FileExists(fn) or
+         { FileExists also returns true for directories }
+         DirectoryExists(fn) then
         begin
           cgmessage1(wpo_cant_find_file,fn);
           exit;
@@ -677,4 +746,62 @@ implementation
       inherited destroy;
     end;
 
+  { tcalledvmtentries }
+
+  constructor tcalledvmtentries.create(_objdef: tdef; nentries: longint);
+    begin
+      objdef:=_objdef;
+      calledentries:=tbitset.create(nentries);
+    end;
+
+
+  constructor tcalledvmtentries.ppuload(ppufile: tcompilerppufile);
+    var
+      len: longint;
+    begin
+      ppufile.getderef(fobjdefderef);
+      len:=ppufile.getlongint;
+      calledentries:=tbitset.create_bytesize(len);
+      if (len <> calledentries.datasize) then
+        internalerror(2009060301);
+      ppufile.readdata(calledentries.data^,len);
+    end;
+
+
+  destructor tcalledvmtentries.destroy;
+    begin
+      fcalledentries.free;
+      inherited destroy;
+    end;
+
+
+  procedure tcalledvmtentries.ppuwrite(ppufile: tcompilerppufile);
+    begin
+      ppufile.putderef(objdefderef);
+      ppufile.putlongint(calledentries.datasize);
+      ppufile.putdata(calledentries.data^,calledentries.datasize);
+    end;
+
+
+  procedure tcalledvmtentries.buildderef;
+    begin
+      objdefderef.build(objdef);
+    end;
+
+
+  procedure tcalledvmtentries.buildderefimpl;
+    begin
+    end;
+
+
+  procedure tcalledvmtentries.deref;
+    begin
+      objdef:=tdef(objdefderef.resolve);
+    end;
+
+
+  procedure tcalledvmtentries.derefimpl;
+    begin
+    end;
+
 end.

compiler/wpoinfo.pas

@@ -41,6 +41,7 @@ type
     fcreatedobjtypesderefs: pderefarray;
     fcreatedclassrefobjtypesderefs: pderefarray;
     fmaybecreatedbyclassrefdeftypesderefs: pderefarray;
+    fcalledvmtentriestemplist: tfpobjectlist;
    { devirtualisation information -- end }
 
    public
@@ -92,6 +93,13 @@ implementation
           freemem(fmaybecreatedbyclassrefdeftypesderefs);
           fmaybecreatedbyclassrefdeftypesderefs:=nil;
         end;
+
+      if assigned(fcalledvmtentriestemplist) then
+        begin
+          fcalledvmtentriestemplist.free;
+          fcalledvmtentriestemplist:=nil;
+        end;
+
       inherited destroy;
     end;
     
@@ -113,6 +121,10 @@ implementation
       for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
         ppufile.putderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
 
+      ppufile.putlongint(fcalledvmtentries.count);
+      for i:=0 to fcalledvmtentries.count-1 do
+        tcalledvmtentries(fcalledvmtentries[i]).ppuwrite(ppufile);
+
       ppufile.writeentry(ibcreatedobjtypes);
 
       { don't free deref arrays immediately after use, as the types may need
@@ -129,26 +141,41 @@ implementation
       if ppufile.readentry<>ibcreatedobjtypes then
         cgmessage(unit_f_ppu_read_error);
 
-      len:=ppufile.getlongint;
-      fcreatedobjtypes:=tfpobjectlist.create(false);
-      fcreatedobjtypes.count:=len;
-      getmem(fcreatedobjtypesderefs,len*sizeof(tderef));
-      for i:=0 to len-1 do
-        ppufile.getderef(fcreatedobjtypesderefs^[i]);
-
-      len:=ppufile.getlongint;
-      fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
-      fcreatedclassrefobjtypes.count:=len;
-      getmem(fcreatedclassrefobjtypesderefs,len*sizeof(tderef));
-      for i:=0 to len-1 do
-        ppufile.getderef(fcreatedclassrefobjtypesderefs^[i]);
-
-      len:=ppufile.getlongint;
-      fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
-      fmaybecreatedbyclassrefdeftypes.count:=len;
-      getmem(fmaybecreatedbyclassrefdeftypesderefs,len*sizeof(tderef));
-      for i:=0 to len-1 do
-        ppufile.getderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
+      { don't load the wpo info from the units if we are not generating
+        a wpo feedback file (that would just take time and memory)
+      }
+      if (init_settings.genwpoptimizerswitches=[]) then
+        ppufile.skipdata(ppufile.entrysize)
+      else
+        begin
+          len:=ppufile.getlongint;
+          fcreatedobjtypes:=tfpobjectlist.create(false);
+          fcreatedobjtypes.count:=len;
+          getmem(fcreatedobjtypesderefs,len*sizeof(tderef));
+          for i:=0 to len-1 do
+            ppufile.getderef(fcreatedobjtypesderefs^[i]);
+
+          len:=ppufile.getlongint;
+          fcreatedclassrefobjtypes:=tfpobjectlist.create(false);
+          fcreatedclassrefobjtypes.count:=len;
+          getmem(fcreatedclassrefobjtypesderefs,len*sizeof(tderef));
+          for i:=0 to len-1 do
+            ppufile.getderef(fcreatedclassrefobjtypesderefs^[i]);
+
+          len:=ppufile.getlongint;
+          fmaybecreatedbyclassrefdeftypes:=tfpobjectlist.create(false);
+          fmaybecreatedbyclassrefdeftypes.count:=len;
+          getmem(fmaybecreatedbyclassrefdeftypesderefs,len*sizeof(tderef));
+          for i:=0 to len-1 do
+            ppufile.getderef(fmaybecreatedbyclassrefdeftypesderefs^[i]);
+
+          len:=ppufile.getlongint;
+          fcalledvmtentriestemplist:=tfpobjectlist.create(false);
+          fcalledvmtentriestemplist.count:=len;
+          fcalledvmtentries:=tfphashlist.create;
+          for i:=0 to len-1 do
+            fcalledvmtentriestemplist[i]:=tcalledvmtentries.ppuload(ppufile);
+        end;
     end;
 
 
@@ -167,6 +194,9 @@ implementation
       getmem(fmaybecreatedbyclassrefdeftypesderefs,fmaybecreatedbyclassrefdeftypes.count*sizeof(tderef));
       for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
         fmaybecreatedbyclassrefdeftypesderefs^[i].build(fmaybecreatedbyclassrefdeftypes[i]);
+
+      for i:=0 to fcalledvmtentries.count-1 do
+        tcalledvmtentries(fcalledvmtentries[i]).objdefderef.build(tcalledvmtentries(fcalledvmtentries[i]).objdef);
     end;
 
 
@@ -178,7 +208,12 @@ implementation
   procedure tunitwpoinfo.deref;
     var
       i: longint;
+      len: longint;
+
     begin
+      if (init_settings.genwpoptimizerswitches=[]) then
+        exit;
+
       { don't free deref arrays immediately after use, as the types may need
         re-resolving in case a unit needs to be reloaded
       }
@@ -190,6 +225,23 @@ implementation
 
       for i:=0 to fmaybecreatedbyclassrefdeftypes.count-1 do
         fmaybecreatedbyclassrefdeftypes[i]:=fmaybecreatedbyclassrefdeftypesderefs^[i].resolve;
+
+      { in case we are re-resolving, free previous batch }
+      if (fcalledvmtentries.count<>0) then
+        { don't just re-deref, in case the name might have changed (?) }
+        fcalledvmtentries.clear;
+      { allocate enough internal memory in one go }
+      fcalledvmtentries.capacity:=fcalledvmtentriestemplist.count;
+      { now resolve all items in the list and add them to the hash table }
+      for i:=0 to fcalledvmtentriestemplist.count-1 do
+        begin
+          with tcalledvmtentries(fcalledvmtentriestemplist[i]) do
+            begin
+              objdef:=tdef(objdefderef.resolve);
+              fcalledvmtentries.add(tobjectdef(objdef).vmt_mangledname,
+                fcalledvmtentriestemplist[i]);
+            end;
+        end;
     end;
 
 

ide/fpdebug.pas

@@ -201,6 +201,8 @@ type
 
     PWatch = ^TWatch;
     TWatch =  Object(TObject)
+      expr : pstring;
+      last_value,current_value : pchar;
       constructor Init(s : string);
       constructor Load(var S: TStream);
       procedure   Store(var S: TStream);
@@ -208,8 +210,6 @@ type
       procedure Get_new_value;
       procedure Force_new_value;
       destructor done;virtual;
-      expr : pstring;
-      last_value,current_value : pchar;
     private
       GDBRunCount : longint;
     end;

ide/fpkeys.pas

@@ -36,13 +36,13 @@ Const
 type
    PKeyDialog = ^TKeyDialog;
    TKeyDialog = object(TCenterDialog)
-     Constructor Init(Const ATitle : String);
-     {Procedure HandleEvent(var E : TEvent);virtual;}
-     function Execute : Word;Virtual;
       PSTL : Array [1..NumWantedKeys] of PLabel;
       PL : Array [1..NumWantedKeys] of PInputLine;
       KeyOK : Array [1..NumWantedKeys] of boolean;
       PST,PST2 : PAdvancedStaticText;
+      Constructor Init(Const ATitle : String);
+     {Procedure HandleEvent(var E : TEvent);virtual;}
+     function Execute : Word;Virtual;
    end;
 
 Procedure LoadKeys(var S : TStream);

ide/fpmingw.pas

@@ -34,7 +34,7 @@ uses gdbint; // force dependancies that hopefully make it execute at the right m
 Type
   TAtexitFunction = function(p:TCFUnction):longint cdecl;
 
-var _imp__atexit : TAtExitFunction; Cvar;  // "true" atexit in mingw libs.
+var _imp__atexit : TAtExitFunction; Cvar; external;  // "true" atexit in mingw libs.
 
 function atexit(p:TCFunction):longint;cdecl; [public, alias : '_atexit'];
 

ide/fpviews.pas

@@ -124,10 +124,10 @@ type
 
     PSourceEditor = ^TSourceEditor;
     TSourceEditor = object(TFileEditor)
-      constructor Init(var Bounds: TRect; AHScrollBar, AVScrollBar:
-          PScrollBar; AIndicator: PIndicator;const AFileName: string);
       CompileStamp : longint;
       CodeCompleteTip: PFPToolTip;
+      constructor Init(var Bounds: TRect; AHScrollBar, AVScrollBar:
+          PScrollBar; AIndicator: PIndicator;const AFileName: string);
 {$ifndef NODEBUG}
     private
       ShouldHandleBreakpoints : boolean;

packages/chm/src/chmreader.pas

@@ -241,6 +241,7 @@ begin
   {$IFDEF CHM_DEBUG}
   WriteLn('PMGI depth = ', fDirectoryHeader.IndexTreeDepth);
   WriteLn('PMGI Root =  ', fDirectoryHeader.IndexOfRootChunk);
+  Writeln('DirCount  =  ', fDirectoryHeader.DirectoryChunkCount);
   {$ENDIF}
   fDirectoryEntriesStartPos := fStream.Position;
   fDirectoryHeaderLength := LEtoN(fHeaderEntries[1].Length);

packages/fcl-base/src/daemonapp.pp

@@ -236,6 +236,7 @@ Type
   Published
     Property DaemonClassName : String Read FDaemonClassName Write FDaemonClassName;
     Property Name : String Read FName Write SetName;
+    Property Description : String Read FDescription Write FDescription;
     Property DisplayName : String Read FDisplayName Write FDisplayName;
     Property RunArguments : String Read FRunArgs Write FRunArgs;
     Property Options : TDaemonOptions Read FOptions Write FOptions;
@@ -1141,6 +1142,11 @@ begin
         CheckControlMessage(True);
       CheckControlMessage(False);
       end;
+    end
+  else
+    begin
+    FDaemon.Status:=csStopped;
+    Application.Terminate;
     end;
 end;
 

packages/fcl-base/src/win/daemonapp.inc

@@ -185,12 +185,13 @@ Procedure TCustomDaemonApplication.SysInstallDaemon(Daemon : TCustomDaemon);
 
 Var
   SM,SV: SC_HANDLE;
-  N,DN,E,LG,UN,UP : String;
+  SD,N,DN,E,LG,UN,UP : String;
   DD : TDaemonDef;
   ST,STT,ES: Integer;
   IDTag : DWord;
   PIDTag : LPDWord;
   PDeps,PN,PP : PChar;
+  D : TServiceDescriptionA;
   
 begin
   SM:=TSMData(FSysData).FHandle;
@@ -243,6 +244,9 @@ begin
     If (SV=0) then
       RaiseLastOSError;
     Try
+      SD:=DD.Description;
+      D.lpDescription:=Pchar(SD);
+      ChangeServiceConfig2(SV,SERVICE_CONFIG_DESCRIPTION,@D);
       If (PIDTag<>Nil) then
         DD.WinBindings.IDTag:=IDTag;
     finally

packages/fcl-db/src/codegen/fpcgtiopf.pp

@@ -23,10 +23,12 @@ uses
   Classes, SysUtils, db, fpddcodegen;
   
 TYpe
-  TClassOption = (caCreateClass,caConstructor,caDestructor,caCreateList,caListAddMethod,caListItemsProperty);
+  TClassOption = (caCreateClass,caConstructor,caDestructor,caCreateList,
+                  caListAddMethod,caListItemsProperty,caOverrideRead,
+                  caOverrideReadThis,caOverrideSave);
   TClassOptions = Set of TClassOption;
   TVisitorOption = (voRead,voReadList,voCreate,voDelete,voUpdate,
-                    voCommonSetupParams,voSingleSaveVisitor);
+                    voCommonSetupParams,voSingleSaveVisitor,voRegisterVisitors);
   TVisitorOptions = set of TVisitorOption;
   
   { TTiOPFCodeOptions }
@@ -76,6 +78,9 @@ TYpe
     // Auxiliary routines
     procedure WriteFieldAssign(Strings: TStrings; F: TFieldPropDef);
     procedure WriteAssignToParam(Strings: TStrings; F: TFieldPropDef);
+    procedure WriteReadWriteOverride(Strings: TStrings; const AAMethod, AVisitorGroup: String);
+    procedure WriteRegisterVisitorLine(Strings: TStrings;
+      const V: TVisitorOption; const ObjectClassName: String);
     procedure WriteSetSQL(Strings: TStrings; const ASQL: String);
     procedure WriteSQLConstants(Strings: TStrings);
     Procedure WriteTerminateVisitor(Strings : TStrings; V : TVisitorOption; const ObjectClassName: String);
@@ -90,14 +95,17 @@ TYpe
     procedure WriteReadVisitor(Strings: TStrings; const ObjectClassName: String );
     procedure WriteVisitorDeclaration(Strings: TStrings; V: TVisitorOption; const ObjectClassName: String);
     procedure WriteVisitorImplementation(Strings: TStrings; V: TVisitorOption; const ObjectClassName: String);
+    procedure WriteVisitorRegistration(Strings: TStrings; const ObjectClassName: String);
   Protected
     // Not to be overridden.
     procedure WriteListAddObject(Strings: TStrings; const ListClassName, ObjectClassName: String);
     // Overrides of parent objects
     function AllowPropertyDeclaration(F: TFieldPropDef; AVisibility: TVisibilities): Boolean; override;
     Function GetInterfaceUsesClause : string; override;
+    procedure WriteVisibilityStart(V: TVisibility; Strings: TStrings); override;
     Procedure DoGenerateInterface(Strings: TStrings); override;
     Procedure DoGenerateImplementation(Strings: TStrings); override;
+    procedure CreateImplementation(Strings: TStrings); override;
     Function NeedsConstructor : Boolean; override;
     Function NeedsDestructor : Boolean; override;
     Class Function NeedsFieldDefs : Boolean; override;
@@ -370,8 +378,12 @@ begin
   If (Result<>'') then
     Result:=Result+', ';
   Result:=Result+'tiVisitor, tiVisitorDB, tiObject';
+  If (voRegisterVisitors in tiOPFoptions.VisitorOptions)
+     or ([caOverrideRead,caOverrideReadThis,caOverrideSave]*tiOPFOptions.ClassOptions<>[]) then
+    Result:=Result+', tiOPFManager';
 end;
 
+
 procedure TTiOPFCodeGenerator.DoGenerateInterface(Strings: TStrings);
 
 Var
@@ -400,6 +412,12 @@ begin
       DecIndent;
     end;
     end;
+  If voRegisterVisitors in tiOPFoptions.VisitorOptions then
+    begin
+    AddLn(Strings);
+    AddLn(Strings,'Procedure Register'+tiOPFoptions.ObjectClassName+'Visitors;');
+    AddLn(Strings);
+    end;
 end;
 
 
@@ -526,7 +544,7 @@ procedure TTiOPFCodeGenerator.WriteSQLConstants(Strings : TStrings);
 
 Const
   VisSQL : Array [TVisitorOption] of string
-         = ('Read','ReadList','Create','Delete','Update','','');
+         = ('Read','ReadList','Create','Delete','Update','','','');
 
 Var
   OCN,S : String;
@@ -596,9 +614,62 @@ begin
     For V:=Low(TVisitorOption) to High(TVisitorOption) do
       If V in VisitorOptions then
         WriteVisitorImplementation(Strings,V,ObjectClassName);
+    If (voRegisterVisitors in TiOPFOptions.VisitorOptions) then
+      WriteVisitorRegistration(Strings,ObjectClassName);
     end;
 end;
 
+{ ---------------------------------------------------------------------
+  Override read/write/readthis
+  ---------------------------------------------------------------------}
+
+procedure TTiOPFCodeGenerator.WriteVisibilityStart(V: TVisibility;
+  Strings: TStrings);
+begin
+  Inherited;
+  If (V=vPublic) then
+    begin
+    if (caOverrideSave in TiOPFOptions.ClassOptions) then
+      AddLn(Strings,'Procedure Save; override;');
+    If (caOverrideRead in TiOPFOptions.ClassOptions) then
+      AddLn(Strings,'Procedure Read; override;');
+    If (caOverrideReadThis in TiOPFOptions.ClassOptions) then
+      AddLn(Strings,'Procedure ReadThis; override;');
+    end;
+end;
+
+procedure TTiOPFCodeGenerator.CreateImplementation(Strings: TStrings);
+
+begin
+  inherited CreateImplementation(Strings);
+  if (caOverrideSave in TiOPFOptions.ClassOptions) then
+    WriteReadWriteOverride(Strings,'Save','Save');
+  If (caOverrideRead in TiOPFOptions.ClassOptions) then
+    WriteReadWriteOverride(Strings,'Read','Read');
+  If (caOverrideReadThis in TiOPFOptions.ClassOptions) then
+    WriteReadWriteOverride(Strings,'ReadThis','Read');
+end;
+
+procedure TTiOPFCodeGenerator.WriteReadWriteOverride(Strings : TStrings; Const AAMethod,AVisitorGroup : String);
+
+Const
+  SExecVisitor = 'GTIOPFManager.VisitorManager.Execute(''%s_%s'',Self);';
+
+Var
+  OCN,S: String;
+
+begin
+  OCN:=TiOPFOptions.ObjectClassName;
+  S:=Format('Procedure %s.%s;',[OCN,AAMethod]);
+  BeginMethod(Strings,S);
+  AddLn(Strings,'begin');
+  IncIndent;
+  S:=Format(SExecVisitor,[OCN,AVisitorGroup]);
+  AddLn(Strings,S);
+  DecIndent;
+  EndMethod(Strings,S);
+end;
+
 { ---------------------------------------------------------------------
   Visitor helper routines
   ---------------------------------------------------------------------}
@@ -619,6 +690,7 @@ begin
     WriteTerminateVisitor(Strings,V,ObjectClassName);
 end;
 
+
 Function TTiOPFCodeGenerator.BeginInit(Strings : TStrings; const AClass : String) : String;
 
 begin
@@ -674,6 +746,54 @@ begin
   IncIndent;
 end;
 
+{ ---------------------------------------------------------------------
+  Visitor registration
+  ---------------------------------------------------------------------}
+
+procedure TTiOPFCodeGenerator.WriteRegisterVisitorLine(Strings : TStrings; Const V: TVisitorOption; Const ObjectClassName : String);
+
+Var
+  C : String;
+  S : String;
+
+begin
+  C:=VisitorClassName(v,ObjectClassName);
+  Case V of
+    voRead        : S:='Read';
+    voReadList    : S:='ReadList';
+    voCreate      : S:='Save';
+    voDelete      : S:='Save';
+    voUpdate      : S:='Save';
+  end;
+  S:=ObjectClassName+'_'+S;
+  S:=Format('GTIOPFManager.RegisterVisitor(''%s'',%s);',[S,C]);
+  AddLn(Strings,S);
+end;
+
+procedure TTiOPFCodeGenerator.WriteVisitorRegistration(Strings : TStrings; Const ObjectClassName : String);
+
+Const
+  RealVis = [voRead,voReadList,voCreate,voDelete,voUpdate];
+
+Var
+  v : TVisitorOption;
+  S : String;
+
+begin
+  Addln(Strings);
+  S:='Procedure Register'+ObjectClassName+'Visitors;';
+  BeginMethod(Strings,S);
+  AddLn(Strings,'begin');
+  IncIndent;
+  For v:=Low(TVisitorOption) to High(TVisitorOption) do
+    begin
+    If (V in RealVis) and (V in TiOPFOptions.VisitorOptions) then
+      WriteRegisterVisitorLine(Strings,V,ObjectClassName);
+    end;
+  DecIndent;
+  EndMethod(Strings,S);
+end;
+
 { ---------------------------------------------------------------------
   Read Visitor
   ---------------------------------------------------------------------}

packages/fcl-db/src/datadict/fpdatadict.pp

@@ -24,8 +24,15 @@ uses
 
 Type
   // Supported objects in this data dictionary
-  TObjectType = (otUnknown,otDictionary,otTables,otTable,otFields,otField,
-                 otConnection,otTableData,otIndexDefs,otIndexDef);
+  TObjectType = (otUnknown,otDictionary,
+                 otTables,otTable,
+                 otFields,otField,
+                 otConnection,otTableData,
+                 otIndexDefs,otIndexDef,
+                 otSequenceDefs,otSequenceDef,
+                 otForeignKeyDefs,otForeignKeyDef,
+                 otDomainDefs,otDomainDef);
+
   TDDProgressEvent = Procedure(Sender : TObject; Const Msg : String) of Object;
 
   TFPDDFieldList = Class;
@@ -450,7 +457,9 @@ Type
   end;
 
   { TFPDDSQLEngine }
-  TSQLEngineOption = (eoLineFeedAfterField,eoUseOldInWhereParams,eoAndTermsInBrackets,eoQuoteFieldNames,eoLineFeedAfterAndTerm,eoAddTerminator);
+  TSQLEngineOption = (eoLineFeedAfterField,eoUseOldInWhereParams,eoAndTermsInBrackets,
+                      eoQuoteFieldNames,eoLineFeedAfterAndTerm,eoAddTerminator,
+                      eoSkipForeignkeys);
   TSQLEngineOptions = Set of TSQLEngineOption;
   
 
@@ -470,7 +479,8 @@ Type
     Procedure ResetLine;
     Procedure AddToStringLN(Var Res : String; S : String);
     Procedure AddToString(Var Res : String; S : String);
-    Procedure FixUpStatement(var Res : String);
+    Procedure FixUpStatement(var Res : String; ForceTerminator : Boolean = False);
+    Procedure FixUpStatement(SQL : TStrings; ForceTerminator : Boolean = False);
     Procedure AddWhereClause(Var Res : String; FieldList: TFPDDFieldList; UseOldParam:Boolean);
     Function CreateAndTerm(FD : TDDFieldDef; UseOldParam : Boolean): string;
     // Primitives. Override for engine-specifics
@@ -488,6 +498,7 @@ Type
   Public
     Constructor Create; virtual;
     function  CreateWhereSQL(Var Res : String; FieldList: TFPDDFieldList; UseOldParam:Boolean): String;
+    // Methods that fill a stringlist
     Procedure CreateSelectSQLStrings(FieldList,KeyFields : TFPDDFieldList; SQL : TStrings);
     Procedure CreateInsertSQLStrings(FieldList : TFPDDFieldList; SQL : TStrings);
     Procedure CreateUpdateSQLStrings(FieldList,KeyFields : TFPDDFieldList; SQL : TStrings);
@@ -495,23 +506,29 @@ Type
     Procedure CreateCreateSQLStrings(Fields,KeyFields : TFPDDFieldList; SQL : TStrings);
     Procedure CreateCreateSQLStrings(KeyFields : TFPDDFieldList; SQL : TStrings);
     Procedure CreateIndexesSQLStrings(Indexes : TFPDDIndexList; SQL : TStrings);
+    Procedure CreateForeignKeysSQLStrings(ForeignKeys: TDDForeignKeyDefs; SQL : TStrings);
     Procedure CreateSequencesSQLStrings(Sequences : TFPDDSequenceList; SQL : TStrings);
     Procedure CreateDomainsSQLStrings(Domains : TFPDDDomainList; SQL : TStrings);
+    // Insert/Update/Delete statements.
     Function  CreateSelectSQL(FieldList,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateInsertSQL(FieldList : TFPDDFieldList) : String; virtual;
     Function  CreateUpdateSQL(FieldList,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateDeleteSQL(KeyFields : TFPDDFieldList) : String; virtual;
+    // CREATE TABLE statement
     Function  CreateCreateSQL(Fields,KeyFields : TFPDDFieldList) : String; virtual;
     Function  CreateCreateSQL(KeyFields : TFPDDFieldList) : String; virtual;
-    // Indexes
+    // CREATE INDEX
     Function  CreateIndexSQL(Index : TDDIndexDef) : String; virtual;
     Function  CreateIndexesSQL(Indexes : TFPDDIndexList) : String;
     Function  CreateIndexesSQL(Indexes : TDDIndexDefs) : String;
-    // Sequences
+    // CONSTRAINT: Foreign keys
+    Function  CreateForeignKeySQL(ForeignKey: TDDForeignKeyDef) : String;virtual;
+    Function  CreateForeignKeysSQL(ForeignKeys: TDDForeignKeyDefs) : String;
+    // CREATE SEQUENCE
     Function  CreateSequenceSQL(Sequence : TDDSequenceDef) : String; virtual;
     Function  CreateSequencesSQL(Sequences : TFPDDSequenceList) : String;
     Function  CreateSequencesSQL(Sequences : TDDSequenceDefs) : String;
-    // Domains
+    // CREATE DOMAIN
     Function  CreateDomainSQL(Domain : TDDDomainDef) : String; virtual;
     Function  CreateDomainsSQL(Domains : TFPDDDomainList) : String;
     Function  CreateDomainsSQL(Domains : TDDDomainDefs) : String;
@@ -1317,6 +1334,7 @@ begin
   FTableName:=AValue;
   FFieldDefs.TableName:=AValue;
   FIndexDefs.TableName:=AValue;
+  FKeyDefs.TableName:=AValue;
 end;
 
 function TDDTableDef.GetPrimaryKeyName: String;
@@ -1461,6 +1479,7 @@ begin
     OnProgress(Self,Format(SSavingFieldsFrom,[TableName]));
   FFieldDefs.SaveToIni(Ini,ASection+SFieldSuffix);
   FIndexDefs.SaveToIni(Ini,ASection+SIndexSuffix);
+  FKeyDefs.SaveToIni(Ini,ASection+SKeySuffix);
 end;
 
 procedure TDDTableDef.LoadFromIni(Ini: TCustomInifile; ASection: String);
@@ -1474,6 +1493,7 @@ begin
     OnProgress(Self,Format(SLoadingFieldsFrom,[TableName]));
   FFieldDefs.LoadFromIni(Ini,ASection+SFieldSuffix);
   FIndexDefs.LoadFromIni(Ini,ASection+SIndexSuffix);
+  FKeyDefs.LoadFromIni(Ini,ASection+SKeySuffix);
 end;
 
 procedure TDDTableDef.PrimaryIndexToFields;
@@ -1935,7 +1955,6 @@ end;
 function TFPDDEngine.ImportDomains(Domains: TDDDomainDefs; List : TStrings; UpdateExisting : boolean) : Integer;
 begin
   result := 0;
-  writeln ('importing no domains');
 end;
 
 function TFPDDEngine.GetSequenceList(List: TStrings): integer;
@@ -1947,7 +1966,6 @@ end;
 function TFPDDEngine.ImportSequences(Sequences: TDDSequenceDefs; List : TStrings; UpdateExisting : boolean) : Integer;
 begin
   result := 0;
-  writeln ('importing no sequences');
 end;
 
 procedure TFPDDEngine.CreateTable(Table: TDDTableDef);
@@ -2015,11 +2033,33 @@ begin
   NoIndent;
 end;
 
-procedure TFPDDSQLEngine.FixUpStatement(var Res: String);
+procedure TFPDDSQLEngine.FixUpStatement(var Res: String; ForceTerminator : Boolean = False);
+
+Var
+  L : Integer;
+
 begin
   Res:=Trim(Res);
-  if (eoAddTerminator in Options) then
-    Res:=Res+FTerminatorChar;
+  if (eoAddTerminator in Options) or ForceTerminator then
+    begin
+    L:=Length(Res);
+    If (L=0) or (Res[L]<>FTerminatorChar) then
+      Res:=Res+FTerminatorChar;
+    end;
+end;
+
+procedure TFPDDSQLEngine.FixUpStatement(SQL: TStrings; ForceTerminator: Boolean = False);
+
+Var
+  S : String;
+
+begin
+  If (SQL.Count>0) then
+    begin
+    S:=SQL[SQL.Count-1];
+    FixupStatement(S,ForceTerminator);
+    SQL[SQL.Count-1]:=S;
+    end;
 end;
 
 Procedure TFPDDSQLEngine.AddToStringLN(Var Res : String;S : String);
@@ -2428,6 +2468,31 @@ begin
   end;
 end;
 
+function TFPDDSQLEngine.CreateForeignKeySQL(ForeignKey: TDDForeignKeyDef
+  ): String;
+
+begin
+  Result:=Format('ALTER TABLE %s ADD CONSTRAINT %s',[TableDef.TableName,ForeignKey.KeyName]);
+  Result:=Result+Format(' FOREIGN KEY (%s)',[ForeignKey.KeyFields]);
+  Result:=Result+Format(' REFERENCES %s(%s)',[ForeignKey.ReferencesTable,ForeignKey.ReferencedFields])
+end;
+
+function TFPDDSQLEngine.CreateForeignKeysSQL(ForeignKeys: TDDForeignKeyDefs
+  ): String;
+
+Var
+  SQL : TStrings;
+
+begin
+  SQL:=TStringList.Create;
+  try
+    CreateForeignKeysSQLStrings(ForeignKeys,SQL);
+    Result:=SQL.Text;
+  finally
+    SQL.Free;
+  end;
+end;
+
 function TFPDDSQLEngine.CreateSequenceSQL(Sequence: TDDSequenceDef): String;
 begin
   Result:='CREATE SEQUENCE '+Sequence.SequenceName;
@@ -2529,7 +2594,8 @@ Var
   KF : TFPDDFieldlist;
   ID : TDDIndexDef;
   FD : TDDFieldDef;
-  
+  S : String;
+
 begin
   CheckTableDef;
   L:=TStringList.Create;
@@ -2547,7 +2613,16 @@ begin
             KF.Add(FD);
           end;
       CreateCreateSQLStrings(KF,SQL);
+      FixupStatement(SQL,True);
       L.Text:=CreateIndexesSQL(TableDef.Indexes);
+      If (L.Count>0) then
+        begin
+        SQL.AddStrings(L);
+        FixupStatement(SQL,True);
+        end;
+      L.Clear;
+      If Not (eoSkipForeignKeys in Options) then
+        L.Text:=CreateForeignKeysSQL(TableDef.ForeignKeys);
       SQL.AddStrings(L);
     finally
       KF.Free;
@@ -2605,6 +2680,17 @@ begin
       SQL.Add(CreateIndexSQL(Indexes[i])+TerminatorChar);
 end;
 
+procedure TFPDDSQLEngine.CreateForeignKeysSQLStrings(
+  ForeignKeys: TDDForeignKeyDefs; SQL: TStrings);
+
+Var
+  I : integer;
+
+begin
+  For I:=0 to ForeignKeys.Count-1 do
+    SQL.Add(CreateForeignKeySQL(ForeignKeys[i])+TerminatorChar);
+end;
+
 procedure TFPDDSQLEngine.CreateSequencesSQLStrings(Sequences: TFPDDSequenceList;
   SQL: TStrings);
 

packages/fcl-db/src/datadict/fpddsqldb.pp

@@ -57,6 +57,7 @@ Const
   KeyUserName     = 'User';
   KeyPassword     = 'Password';
   KeyEncode       = 'Trivial';
+  KeyCharset      = 'Charset';
 
 implementation
 
@@ -105,6 +106,7 @@ begin
     FConn.Password:=XorDecode(KeyEncode,L.Values[KeyPassword]);
     FConn.LoginPrompt:=False;
     FConn.Connected:=True;
+    FConn.CharSet:=L.Values[KeyCharset];
     FConnected:=True;
     FConnectString:=AConnectString;
     Result:=True;

packages/fcl-db/src/sqldb/sqldb.pp

@@ -1214,7 +1214,14 @@ var tel, fieldc : integer;
     ReadFromFile: Boolean;
 begin
   ReadFromFile:=IsReadFromPacket;
-  Prepare;
+  if ReadFromFile then
+    begin
+    FCursor:=TSQLCursor.Create;
+    FCursor.FStatementType:=stSelect;
+    FUpdateable:=True;
+    end
+  else
+    Prepare;
   if FCursor.FStatementType in [stSelect,stExecProcedure] then
     begin
     if not ReadFromFile then

packages/fcl-db/src/sqlite/customsqliteds.pas

@@ -45,6 +45,8 @@ const
   DefaultStringSize = 255;
 
 type
+  TCustomSqliteDataset = class;
+
   PDataRecord = ^DataRecord;
   PPDataRecord = ^PDataRecord;
   DataRecord = record
@@ -57,12 +59,14 @@ type
   TDSStream = class(TStream)
   private
     FActiveItem: PDataRecord;
+    FDataset: TCustomSqliteDataset;
     FFieldRow: PChar;
-    FFieldIndex: Integer;
+    FField: TField;
+    FFieldOffset: Integer;
     FRowSize: Integer;
     FPosition: LongInt;
   public
-    constructor Create(const ActiveItem: PDataRecord; FieldIndex: Integer);
+    constructor Create(Dataset: TCustomSqliteDataset; Field: TField);
     function Write(const Buffer; Count: LongInt): LongInt; override;
     function Read(var Buffer; Count: LongInt): LongInt; override;
     function Seek(Offset: LongInt; Origin: Word): LongInt; override;
@@ -202,6 +206,7 @@ type
     function Lookup(const KeyFields: String; const KeyValues: Variant; const ResultFields: String): Variant; override;
     // Additional procedures
     function ApplyUpdates: Boolean;
+    procedure ClearUpdates(RecordStates: TRecordStateSet = [rsAdded, rsDeleted, rsUpdated]);
     function CreateTable: Boolean;
     function CreateTable(const ATableName: String): Boolean;
     procedure ExecCallback(const ASql: String; UserData: Pointer = nil);
@@ -209,6 +214,7 @@ type
     procedure ExecSQL(const ASql: String);
     procedure ExecSQLList;
     procedure ExecuteDirect(const ASql: String); virtual; abstract;
+    function GetSQLValue(Values: PPChar; FieldIndex: Integer): String;
     procedure QueryUpdates(RecordStates: TRecordStateSet; Callback: TQueryUpdatesCallback; UserData: Pointer = nil);
     function QuickQuery(const ASql: String):String;overload;
     function QuickQuery(const ASql: String; const AStrList: TStrings): String; overload;
@@ -323,13 +329,18 @@ end;
 
 // TDSStream
 
-constructor TDSStream.Create(const ActiveItem: PDataRecord; FieldIndex: Integer);
+constructor TDSStream.Create(Dataset: TCustomSqliteDataset; Field: TField);
 begin
   inherited Create;
   //FPosition := 0;
-  FActiveItem := ActiveItem;
-  FFieldIndex := FieldIndex;
-  FFieldRow := ActiveItem^.Row[FieldIndex];
+  FDataset := Dataset;
+  FField := Field;
+  if Field.FieldNo >= 0 then
+    FFieldOffset := Field.FieldNo - 1
+  else
+    FFieldOffset := Dataset.FieldDefs.Count + Dataset.FCalcFieldList.IndexOf(Field);
+  FActiveItem := PPDataRecord(Dataset.ActiveBuffer)^;
+  FFieldRow := FActiveItem^.Row[FFieldOffset];
   if FFieldRow <> nil then
     FRowSize := StrLen(FFieldRow);
   //else
@@ -360,7 +371,7 @@ begin
   if FRowSize > 0 then
     Move(FFieldRow^, NewRow^, FRowSize);
   Move(Buffer, (NewRow + FRowSize)^, Count);
-  FActiveItem^.Row[FFieldIndex] := NewRow;
+  FActiveItem^.Row[FFieldOffset] := NewRow;
   StrDispose(FFieldRow);
   {$ifdef DEBUG_SQLITEDS}
   WriteLn('##TDSStream.Write##');
@@ -373,6 +384,8 @@ begin
   FFieldRow := NewRow;
   FRowSize := StrLen(NewRow);
   Inc(FPosition, Count);
+  if not (FDataset.State in [dsCalcFields, dsFilter, dsNewValue]) then
+    FDataset.DataEvent(deFieldChange, PtrInt(FField));
 end; 
  
 function TDSStream.Read(var Buffer; Count: Longint): LongInt;
@@ -454,7 +467,7 @@ begin
     StrDispose(FCacheItem^.Row[Field.FieldNo - 1]);
     FCacheItem^.Row[Field.FieldNo - 1] := nil;
   end;
-  Result:= TDSStream.Create(PPDataRecord(ActiveBuffer)^, Field.FieldNo - 1);
+  Result := TDSStream.Create(Self, Field);
 end;
 
 procedure TCustomSqliteDataset.DoBeforeClose;
@@ -1446,6 +1459,14 @@ begin
     DatabaseError(ReturnString, Self);
 end;
 
+function TCustomSqliteDataset.GetSQLValue(Values: PPChar; FieldIndex: Integer
+  ): String;
+begin
+  if (State = dsInactive) or (FieldIndex < 0) or (FieldIndex >= FieldDefs.Count) then
+    DatabaseError('Error retrieving SQL value: dataset inactive or field out of range', Self);
+  Result := FGetSqlStr[FieldIndex](Values[FieldIndex]);
+end;
+
 procedure TCustomSqliteDataset.ExecSQL;
 begin
   ExecSQL(FSQL);
@@ -1590,7 +1611,17 @@ begin
   {$ifdef DEBUG_SQLITEDS}
   WriteLn('  Result: ', Result);
   {$endif}   
-end;    
+end;
+
+procedure TCustomSqliteDataset.ClearUpdates(RecordStates: TRecordStateSet);
+begin
+  if rsUpdated in RecordStates then
+    FUpdatedItems.Clear;
+  if rsDeleted in RecordStates then
+    FDeletedItems.Clear;
+  if rsAdded in RecordStates then
+    FAddedItems.Clear;
+end;
 
 function TCustomSqliteDataset.CreateTable: Boolean;
 begin

packages/fcl-image/src/fpcolhash.pas

@@ -71,8 +71,8 @@ type
   private
     Root : PColHashMainNode;
     AllIntegers : boolean;
-    procedure FreeAllData;
     FCount : longword;
+    procedure FreeAllData;
     function AllocateMainNode : PColHashMainNode;
     function AllocateSubNode : PColHashSubNode;
     procedure DeallocateLinkedList(node : PColHashSubNode);
@@ -409,4 +409,4 @@ begin
   end;
 end;
 
-end.
+end.

packages/fcl-image/src/fpreadbmp.pp

@@ -32,7 +32,6 @@ uses FPImage, classes, sysutils, BMPcomn;
 type
   TFPReaderBMP = class (TFPCustomImageReader)
     Private
-      Procedure FreeBufs;       // Free (and nil) buffers.
       DeltaX, DeltaY : integer; // Used for the never-used delta option in RLE
       TopDown : boolean;        // If set, bitmap is stored top down instead of bottom up
       continue : boolean;       // needed for onprogress event
@@ -40,6 +39,7 @@ type
       percentinterval : longword;
       percentacc : longword;
       Rect : TRect;
+      Procedure FreeBufs;       // Free (and nil) buffers.
     protected
       ReadSize : Integer;       // Size (in bytes) of 1 scanline.
       BFI : TBitMapInfoHeader;  // The header as read from the stream.

packages/fcl-json/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2008/10/22]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/03/15]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@@ -1179,6 +1179,7 @@ endif
 ifeq ($(OS_TARGET),go32v2)
 STATICLIBPREFIX=
 SHORTSUFFIX=dos
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),watcom)
 STATICLIBPREFIX=
@@ -1186,6 +1187,7 @@ OEXT=.obj
 ASMEXT=.asm
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=wat
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),linux)
 BATCHEXT=.sh
@@ -1222,6 +1224,7 @@ STATICLIBPREFIX=
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=os2
 ECHO=echo
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),emx)
 BATCHEXT=.cmd
@@ -1230,6 +1233,7 @@ STATICLIBPREFIX=
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=emx
 ECHO=echo
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),amiga)
 EXEEXT=
@@ -1269,17 +1273,20 @@ ifeq ($(OS_TARGET),netware)
 EXEEXT=.nlm
 STATICLIBPREFIX=
 SHORTSUFFIX=nw
+IMPORTLIBPREFIX=imp
 endif
 ifeq ($(OS_TARGET),netwlibc)
 EXEEXT=.nlm
 STATICLIBPREFIX=
 SHORTSUFFIX=nwl
+IMPORTLIBPREFIX=imp
 endif
 ifeq ($(OS_TARGET),macos)
 BATCHEXT=
 EXEEXT=
 DEBUGSYMEXT=.xcoff
 SHORTSUFFIX=mac
+IMPORTLIBPREFIX=imp
 endif
 ifeq ($(OS_TARGET),darwin)
 BATCHEXT=.sh
@@ -1306,14 +1313,17 @@ STATICLIBEXT=.a1
 SHAREDLIBEXT=.so1
 STATICLIBPREFIX=
 SHORTSUFFIX=v1
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),go32v2)
 STATICLIBPREFIX=
 SHORTSUFFIX=dos
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),watcom)
 STATICLIBPREFIX=
 SHORTSUFFIX=wat
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),linux)
 BATCHEXT=.sh
@@ -1360,6 +1370,7 @@ STATICLIBEXT=.ao2
 SHAREDLIBEXT=.dll
 SHORTSUFFIX=os2
 ECHO=echo
+IMPORTLIBPREFIX=
 endif
 ifeq ($(OS_TARGET),amiga)
 EXEEXT=
@@ -1420,6 +1431,7 @@ STATICLIBEXT=.a
 SHAREDLIBEXT=.nlm
 EXEEXT=.nlm
 SHORTSUFFIX=nw
+IMPORTLIBPREFIX=imp
 endif
 ifeq ($(OS_TARGET),netwlibc)
 STATICLIBPREFIX=
@@ -1431,6 +1443,7 @@ STATICLIBEXT=.a
 SHAREDLIBEXT=.nlm
 EXEEXT=.nlm
 SHORTSUFFIX=nwl
+IMPORTLIBPREFIX=imp
 endif
 ifeq ($(OS_TARGET),macos)
 BATCHEXT=
@@ -1442,6 +1455,7 @@ STATICLIBEXT=.a
 EXEEXT=
 DEBUGSYMEXT=.xcoff
 SHORTSUFFIX=mac
+IMPORTLIBPREFIX=imp
 endif
 endif
 ifneq ($(findstring $(OS_SOURCE),$(LIMIT83fs)),)
@@ -1770,6 +1784,7 @@ REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),i386-darwin)
 REQUIRE_PACKAGES_RTL=1
+REQUIRE_PACKAGES_UNIVINT=1
 REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),i386-emx)
@@ -1846,6 +1861,7 @@ REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
 REQUIRE_PACKAGES_RTL=1
+REQUIRE_PACKAGES_UNIVINT=1
 REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
@@ -1882,6 +1898,7 @@ REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),x86_64-darwin)
 REQUIRE_PACKAGES_RTL=1
+REQUIRE_PACKAGES_UNIVINT=1
 REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
@@ -1904,6 +1921,7 @@ REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),arm-darwin)
 REQUIRE_PACKAGES_RTL=1
+REQUIRE_PACKAGES_UNIVINT=1
 REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),arm-wince)
@@ -1932,6 +1950,7 @@ REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),powerpc64-darwin)
 REQUIRE_PACKAGES_RTL=1
+REQUIRE_PACKAGES_UNIVINT=1
 REQUIRE_PACKAGES_FCL-BASE=1
 endif
 ifeq ($(FULL_TARGET),powerpc64-embedded)
@@ -2054,6 +2073,32 @@ ifdef UNITDIR_WINUNITS-JEDI
 override COMPILER_UNITDIR+=$(UNITDIR_WINUNITS-JEDI)
 endif
 endif
+ifdef REQUIRE_PACKAGES_UNIVINT
+PACKAGEDIR_UNIVINT:=$(firstword $(subst /Makefile.fpc,,$(strip $(wildcard $(addsuffix /univint/Makefile.fpc,$(PACKAGESDIR))))))
+ifneq ($(PACKAGEDIR_UNIVINT),)
+ifneq ($(wildcard $(PACKAGEDIR_UNIVINT)/units/$(TARGETSUFFIX)),)
+UNITDIR_UNIVINT=$(PACKAGEDIR_UNIVINT)/units/$(TARGETSUFFIX)
+else
+UNITDIR_UNIVINT=$(PACKAGEDIR_UNIVINT)
+endif
+ifdef CHECKDEPEND
+$(PACKAGEDIR_UNIVINT)/$(FPCMADE):
+	$(MAKE) -C $(PACKAGEDIR_UNIVINT) $(FPCMADE)
+override ALLDEPENDENCIES+=$(PACKAGEDIR_UNIVINT)/$(FPCMADE)
+endif
+else
+PACKAGEDIR_UNIVINT=
+UNITDIR_UNIVINT:=$(subst /Package.fpc,,$(strip $(wildcard $(addsuffix /univint/Package.fpc,$(UNITSDIR)))))
+ifneq ($(UNITDIR_UNIVINT),)
+UNITDIR_UNIVINT:=$(firstword $(UNITDIR_UNIVINT))
+else
+UNITDIR_UNIVINT=
+endif
+endif
+ifdef UNITDIR_UNIVINT
+override COMPILER_UNITDIR+=$(UNITDIR_UNIVINT)
+endif
+endif
 ifndef NOCPUDEF
 override FPCOPTDEF=$(ARCH)
 endif

packages/fcl-net/src/mkxmlrpc.pp

@@ -47,11 +47,11 @@ type
   end;
 
   TRPCList = class
+    ServerClasses: TList;
+    UsedModules: TStringList;
     constructor Create;
     destructor Destroy; override;
     procedure AddServerClass(const AClassName: String);
-    ServerClasses: TList;
-    UsedModules: TStringList;
   end;
 
 var

packages/fcl-net/src/ssockets.pp

@@ -109,10 +109,10 @@ type
   TInetServer = Class(TSocketServer)
   Protected
     FAddr : TINetSockAddr;
-    Function  SockToStream (ASocket : Longint) : TSocketStream;Override;
-    Function Accept : Longint;override;
     FPort : Word;
     FHost: string;
+    Function  SockToStream (ASocket : Longint) : TSocketStream;Override;
+    Function Accept : Longint;override;
   Public
     Procedure Bind; Override;
     Constructor Create(APort: Word);

packages/fcl-web/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/03/29]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/06/23]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@@ -271,25 +271,25 @@ ifeq ($(FULL_TARGET),i386-go32v2)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-os2)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-haiku)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -298,7 +298,7 @@ ifeq ($(FULL_TARGET),i386-netware)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -316,7 +316,7 @@ ifeq ($(FULL_TARGET),i386-netwlibc)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),i386-embedded)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -328,10 +328,10 @@ ifeq ($(FULL_TARGET),m68k-linux)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -340,7 +340,7 @@ ifeq ($(FULL_TARGET),m68k-atari)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -352,7 +352,7 @@ ifeq ($(FULL_TARGET),powerpc-linux)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),powerpc-amiga)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -373,10 +373,10 @@ ifeq ($(FULL_TARGET),sparc-linux)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),sparc-embedded)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -385,13 +385,13 @@ ifeq ($(FULL_TARGET),x86_64-linux)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),x86_64-darwin)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),x86_64-embedded)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
@@ -406,7 +406,7 @@ ifeq ($(FULL_TARGET),arm-darwin)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache
+override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache  fastcgi custfcgi fpfcgi
 endif
 ifeq ($(FULL_TARGET),arm-gba)
 override TARGET_UNITS+=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb webutil fpdatasetform cgiapp ezcgi fpapache

packages/fcl-web/Makefile.fpc

@@ -8,10 +8,22 @@ version=2.2.2
 
 [target]
 units=httpdefs fphttp custweb custcgi fpcgi fptemplate fphtml websession fpweb \
-      webutil fpdatasetform cgiapp ezcgi fpapache 
-units_linux=fastcgi custfcgi fpfcgi
+      webutil fpdatasetform cgiapp ezcgi fpapache
 rsts=fpcgi fphtml fpweb websession cgiapp
 
+# these units are listed separately because they don't work for
+# darwin (which does support the rest of fcl-web)
+units_beos=fastcgi custfcgi fpfcgi
+units_haiku=fastcgi custfcgi fpfcgi
+units_freebsd=fastcgi custfcgi fpfcgi
+units_solaris=fastcgi custfcgi fpfcgi
+units_netbsd=fastcgi custfcgi fpfcgi
+units_openbsd=fastcgi custfcgi fpfcgi
+units_linux=fastcgi custfcgi fpfcgi
+units_win32=fastcgi custfcgi fpfcgi
+units_win64=fastcgi custfcgi fpfcgi
+units_wince=fastcgi custfcgi fpfcgi
+
 [require]
 packages=fcl-base fcl-xml fcl-db fcl-process httpd22
 packages_darwin=univint

packages/fcl-web/src/custfcgi.pp

@@ -85,7 +85,16 @@ uses
 {$ifdef CGIDEBUG}
   dbugintf,
 {$endif}
-  BaseUnix, Sockets;
+  Sockets;
+
+{$undef nosignal}
+
+{$if defined(FreeBSD) or defined(Linux)}
+  {$define nosignal}
+{$ifend}
+
+Const 
+   NoSignalAttr =  {$ifdef nosignal} MSG_NOSIGNAL{$else}0{$endif};
 
 { TFCGIHTTPRequest }
 
@@ -243,7 +252,7 @@ var BytesToWrite : word;
     BytesWritten  : Integer;
 begin
   BytesToWrite := BEtoN(ARecord^.contentLength) + ARecord^.paddingLength+sizeof(FCGI_Header);
-  BytesWritten := sockets.fpsend(TFCGIRequest(Request).Handle, ARecord, BytesToWrite, MSG_NOSIGNAL);
+  BytesWritten := sockets.fpsend(TFCGIRequest(Request).Handle, ARecord, BytesToWrite, NoSignalAttr);
   Assert(BytesWritten=BytesToWrite);
 end;
 
@@ -336,7 +345,7 @@ begin
     if not TFCGIRequest(ARequest).KeepConnectionAfterRequest then
       begin
       fpshutdown(FHandle,SHUT_RDWR);
-      FpClose(FHandle);
+      CloseSocket(FHandle);
       FHandle := -1;
       end;
     Request := Nil;
@@ -359,7 +368,7 @@ var Header : FCGI_Header;
    result := False;
     if ByteAmount>0 then
       begin
-      BytesRead := sockets.fpRecv(FHandle, ReadBuf, ByteAmount, MSG_NOSIGNAL);
+      BytesRead := sockets.fpRecv(FHandle, ReadBuf, ByteAmount, NoSignalAttr);
       if BytesRead<>ByteAmount then
         begin
 //        SendDebug('FCGIRecord incomplete');

packages/fcl-web/src/fpweb.pp

@@ -38,10 +38,10 @@ Type
     Procedure DoHandleRequest(ARequest : TRequest; AResponse : TResponse; Var Handled : Boolean); override;
     Procedure DoGetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean); virtual;
     Procedure GetContent(ARequest : TRequest; Content : TStream; Var Handled : Boolean);
-    Procedure Assign(Source : TPersistent); override;
   Public
     Constructor create(ACollection : TCollection); override;
     Destructor destroy; override;
+    Procedure Assign(Source : TPersistent); override;
   published
     Property Content : String Read GetStringContent Write SetContent;
     Property Contents : TStrings Read GetContents Write SetContents;
@@ -332,7 +332,7 @@ end;
 
 procedure TCustomFPWebModule.SetActions(const AValue: TFPWebActions);
 begin
-  if (FActions<>AValue) then;
+  if (FActions<>AValue) then
     FActions.Assign(AValue);
 end;
 

packages/fcl-web/src/httpdefs.pp

@@ -1113,6 +1113,9 @@ var
   R : String;
 
 begin
+{$ifdef CGIDEBUG}
+  SendMethodEnter('TRequest.InitRequestVars');
+{$endif}
   R:=Method;
   if (R='') then
     Raise Exception.Create(SErrNoRequestMethod);
@@ -1126,6 +1129,9 @@ begin
     InitGetVars
   else
     Raise Exception.CreateFmt(SErrInvalidRequestMethod,[R]);
+{$ifdef CGIDEBUG}
+  SendMethodExit('TRequest.InitRequestVars');
+{$endif}
 end;
 
 Type
@@ -1158,7 +1164,7 @@ begin
     CT:=ContentType;
     if Pos('MULTIPART/FORM-DATA',Uppercase(CT))<>0 then
       ProcessMultiPart(M,CT, ContentFields)
-    else if CompareText('APPLICATION/X-WWW-FORM-URLENCODED',CT)=0 then
+    else if Pos('APPLICATION/X-WWW-FORM-URLENCODED',Uppercase(CT))<>0 then
       ProcessUrlEncoded(M, ContentFields)
     else
       begin

packages/fcl-xml/src/dom.pp

@@ -251,6 +251,7 @@ type
     property Prefix: DOMString read GetPrefix write SetPrefix;
     // DOM level 3
     property TextContent: DOMString read GetTextContent write SetTextContent;
+    function LookupNamespaceURI(const APrefix: DOMString): DOMString;
     // Extensions to DOM interface:
     function CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode; overload; virtual;
     function FindNode(const ANodeName: DOMString): TDOMNode; virtual;
@@ -290,6 +291,8 @@ type
 //   NodeList
 // -------------------------------------------------------
 
+  TFilterResult = (frFalse, frNorecurseFalse, frTrue, frNorecurseTrue);
+
   TDOMNodeList = class(TObject)
   protected
     FNode: TDOMNode;
@@ -297,6 +300,8 @@ type
     FList: TFPList;
     function GetCount: LongWord;
     function GetItem(index: LongWord): TDOMNode;
+    function NodeFilter(aNode: TDOMNode): TFilterResult; virtual;
+    // now deprecated in favor of NodeFilter
     procedure BuildList; virtual;
   public
     constructor Create(ANode: TDOMNode);
@@ -311,9 +316,12 @@ type
   TDOMElementList = class(TDOMNodeList)
   protected
     filter: DOMString;
-    FNamespaceFilter: DOMString;
+    FNSIndexFilter: Integer;
+    localNameFilter: DOMString;
+    FMatchNS: Boolean;
+    FMatchAnyNS: Boolean;
     UseFilter: Boolean;
-    procedure BuildList; override;
+    function NodeFilter(aNode: TDOMNode): TFilterResult; override;
   public
     constructor Create(ANode: TDOMNode; const AFilter: DOMString); overload;
     constructor Create(ANode: TDOMNode; const nsURI, localName: DOMString); overload;
@@ -344,11 +352,10 @@ type
     function SetNamedItem(arg: TDOMNode): TDOMNode;
     function RemoveNamedItem(const name: DOMString): TDOMNode;
     // Introduced in DOM Level 2:
-    function getNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode;
-    function setNamedItemNS(arg: TDOMNode): TDOMNode;
-    function removeNamedItemNS(const namespaceURI,localName: DOMString): TDOMNode;
+    function getNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode; virtual;
+    function setNamedItemNS(arg: TDOMNode): TDOMNode; virtual;
+    function removeNamedItemNS(const namespaceURI,localName: DOMString): TDOMNode; virtual;
 
-    // FIX: made readonly. Reason: Anyone was allowed to insert any node without any checking.
     property Item[index: LongWord]: TDOMNode read GetItem; default;
     property Length: LongWord read GetLength;
   end;
@@ -424,6 +431,7 @@ type
     FNodeLists: THashTable;
     FMaxPoolSize: Integer;
     FPools: PNodePool;
+    FDocumentURI: DOMString;
     function GetDocumentElement: TDOMElement;
     function GetDocType: TDOMDocumentType;
     function GetNodeType: Integer; override;
@@ -466,6 +474,8 @@ type
     function CreateAttributeNS(const nsURI, QualifiedName: DOMString): TDOMAttr;
     function GetElementsByTagNameNS(const nsURI, alocalName: DOMString): TDOMNodeList;
     function GetElementById(const ElementID: DOMString): TDOMElement;
+    // DOM level 3:
+    property documentURI: DOMString read FDocumentURI write FDocumentURI;
     // Extensions to DOM interface:
     constructor Create;
     destructor Destroy; override;
@@ -535,6 +545,7 @@ type
     function  GetNodeValue: DOMString; override;
     function GetNodeType: Integer; override;
     function GetSpecified: Boolean;
+    function GetIsID: Boolean;
     procedure SetNodeValue(const AValue: DOMString); override;
   public
     destructor Destroy; override;
@@ -543,6 +554,7 @@ type
     property Specified: Boolean read GetSpecified;
     property Value: DOMString read GetNodeValue write SetNodeValue;
     property OwnerElement: TDOMElement read FOwnerElement;
+    property IsID: Boolean read GetIsID;
     // extensions
     // TODO: this is to be replaced with DOM 3 TypeInfo
     property DataType: TAttrDataType read FDataType write FDataType;
@@ -788,6 +800,19 @@ const
 
 implementation
 
+{ a namespace-enabled NamedNodeMap }
+type
+  TAttributeMap = class(TDOMNamedNodeMap)
+  private
+    function FindNS(nsIndex: Integer; const aLocalName: DOMString;
+      out Index: LongWord): Boolean;
+    function InternalRemoveNS(const nsURI, aLocalName: DOMString): TDOMNode;
+  public
+    function getNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode; override;
+    function setNamedItemNS(arg: TDOMNode): TDOMNode; override;
+    function removeNamedItemNS(const namespaceURI,localName: DOMString): TDOMNode; override;
+  end;
+
 // -------------------------------------------------------
 //   DOM Exception
 // -------------------------------------------------------
@@ -1072,9 +1097,9 @@ begin
     child.SetReadOnly(Value);
     child := child.NextSibling;
   end;
-  attrs := Attributes;
-  if Assigned(attrs) then
+  if HasAttributes then
   begin
+    attrs := Attributes;
     for I := 0 to attrs.Length-1 do
       attrs[I].SetReadOnly(Value);
   end;
@@ -1106,6 +1131,64 @@ begin
   Result := CompareDOMStrings(DOMPChar(name), DOMPChar(SelfName), Length(name), Length(SelfName));
 end;
 
+// This will return nil for Entity, Notation, DocType and DocFragment's
+function GetAncestorElement(n: TDOMNode): TDOMElement;
+var
+  parent: TDOMNode;
+begin
+  parent := n.ParentNode;
+  while Assigned(parent) and (parent.NodeType <> ELEMENT_NODE) do
+    parent := parent.ParentNode;
+  Result := TDOMElement(parent);
+end;
+
+// TODO: specs prescribe to return default namespace if APrefix=null,
+// but we aren't able to distinguish null from an empty string.
+// This breaks level3/nodelookupnamespaceuri08 which passes an empty string.
+function TDOMNode.LookupNamespaceURI(const APrefix: DOMString): DOMString;
+var
+  Attr: TDOMAttr;
+  Map: TDOMNamedNodeMap;
+  I: Integer;
+begin
+  Result := '';
+  if Self = nil then
+    Exit;
+  case NodeType of
+    ELEMENT_NODE:
+    begin
+      if (nfLevel2 in FFlags) and (TDOMElement(Self).Prefix = APrefix) then
+      begin
+        result := Self.NamespaceURI;
+        Exit;
+      end;
+      if HasAttributes then
+      begin
+        Map := Attributes;
+        for I := 0 to Map.Length-1 do
+        begin
+          Attr := TDOMAttr(Map[I]);
+          // should ignore level 1 atts here
+          if ((Attr.Prefix = 'xmlns') and (Attr.localName = APrefix)) or
+             ((Attr.localName = 'xmlns') and (APrefix = '')) then
+          begin
+            result := Attr.NodeValue;
+            Exit;
+          end;
+        end
+      end;
+      result := GetAncestorElement(Self).LookupNamespaceURI(APrefix);
+    end;
+    DOCUMENT_NODE:
+      result := TDOMDocument(Self).documentElement.LookupNamespaceURI(APrefix);
+
+    ATTRIBUTE_NODE:
+      result := TDOMAttr(Self).OwnerElement.LookupNamespaceURI(APrefix);
+
+  else
+    Result := GetAncestorElement(Self).LookupNamespaceURI(APrefix);
+  end;
+end;
 
 //------------------------------------------------------------------------------
 
@@ -1400,18 +1483,43 @@ begin
   inherited Destroy;
 end;
 
+function TDOMNodeList.NodeFilter(aNode: TDOMNode): TFilterResult;
+begin
+// accept all nodes but don't allow recursion
+  Result := frNorecurseTrue;
+end;
+
 procedure TDOMNodeList.BuildList;
 var
-  Child: TDOMNode;
+  current, next: TDOMNode;
+  res: TFilterResult;
 begin
   FList.Clear;
   FRevision := FNode.GetRevision; // refresh
 
-  Child := FNode.FirstChild;
-  while Assigned(Child) do
+  current := FNode.FirstChild;
+
+  while Assigned(current) do
   begin
-    FList.Add(Child);
-    Child := Child.NextSibling;
+    res := NodeFilter(current);
+    if res in [frTrue, frNorecurseTrue] then
+      FList.Add(current);
+
+    next := nil;
+    if res in [frTrue, frFalse] then
+      next := current.FirstChild;
+
+    if next = nil then
+    begin
+      while current <> FNode do
+      begin
+        next := current.NextSibling;
+        if Assigned(next) then
+          Break;
+        current := current.ParentNode;
+      end;
+    end;
+    current := next;
   end;
 end;
 
@@ -1446,38 +1554,34 @@ end;
 constructor TDOMElementList.Create(ANode: TDOMNode; const nsURI, localName: DOMString);
 begin
   inherited Create(ANode);
-  filter := localName;
-  FNamespaceFilter := nsURI;
-  UseFilter := (filter <> '*') and (FNamespaceFilter <> '*');
+  localNameFilter := localName;
+  FMatchNS := True;
+  FMatchAnyNS := (nsURI = '*');
+  if not FMatchAnyNS then
+    FNSIndexFilter := ANode.FOwnerDocument.IndexOfNS(nsURI);
+  UseFilter := (localName <> '*');
 end;
 
-// TODO: namespace support here
-procedure TDOMElementList.BuildList;
+function TDOMElementList.NodeFilter(aNode: TDOMNode): TFilterResult;
 var
-  Child: TDOMNode;
+  I, L: Integer;
 begin
-  FList.Clear;
-  FRevision := FNode.GetRevision; // refresh
-
-  Child := FNode.FirstChild;
-  while Assigned(Child) and (Child <> FNode) do
+  Result := frFalse;
+  if aNode.NodeType = ELEMENT_NODE then with TDOMElement(aNode) do
   begin
-    if (Child.NodeType = ELEMENT_NODE) and (not UseFilter or (TDOMElement(Child).TagName = filter)) then
-          FList.Add(Child);
-    // recursive track node hierarchy  
-    if Assigned(Child.FirstChild) then
-      Child := Child.FirstChild
-    else
-      if Assigned(Child.NextSibling) then
-        Child := Child.NextSibling
-      else
+    if FMatchNS then
+    begin
+      if (FMatchAnyNS or (FNSI.NSIndex = Word(FNSIndexFilter))) then
       begin
-         Child := Child.ParentNode;
-         while Assigned(Child) and (Child <> FNode) and not Assigned(Child.NextSibling) do
-           Child := Child.ParentNode;
-         if Assigned(Child) and (Child <> FNode) then
-            Child := Child.NextSibling;
+        I := FNSI.PrefixLen;
+        L := system.Length(FNSI.QName^.Key);
+        if (not UseFilter or ((L-I = system.Length(localNameFilter)) and
+          CompareMem(@FNSI.QName^.Key[I+1], DOMPChar(localNameFilter), system.Length(localNameFilter)*sizeof(WideChar)))) then
+          Result := frTrue;
       end;
+    end
+    else if (not UseFilter or (TagName = Filter)) then
+      Result := frTrue;
   end;
 end;
 
@@ -1551,11 +1655,11 @@ begin
     Result := nil;
 end;
 
+// Note: this *may* raise NOT_SUPPORTED_ERR if the document is e.g. HTML.
+// This isn't checked now.
 function TDOMNamedNodeMap.GetNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode;
 begin
-  // TODO: implement TDOMNamedNodeMap.GetNamedItemNS
-  raise EDOMNotSupported.Create('TDOMNamedNodeMap.GetNamedItemNS');
-    Result := nil;
+  Result := nil;
 end;
 
 function TDOMNamedNodeMap.ValidateInsert(arg: TDOMNode): Integer;
@@ -1608,15 +1712,13 @@ begin
 end;
 
 function TDOMNamedNodeMap.SetNamedItemNS(arg: TDOMNode): TDOMNode;
-var
-  res: Integer;
 begin
-  // TODO: implement TDOMNamedNodeMap.SetNamedItemNS
-  res := ValidateInsert(arg);
-  if res <> 0 then
-    raise EDOMError.Create(res, 'NamedNodeMap.SetNamedItemNS');
-
-    Result := nil;
+{ Since the map contains only namespaceless nodes (all having empty
+  localName and namespaceURI properties), a namespaced arg won't match
+  any of them. Therefore, add it using nodeName as key.
+  Note: a namespaceless arg is another story, as it will match *any* node
+  in the map. This can be considered as a flaw in specs. }
+  Result := SetNamedItem(arg);
 end;
 
 function TDOMNamedNodeMap.Delete(index: LongWord): TDOMNode;
@@ -1670,12 +1772,112 @@ end;
 
 function TDOMNamedNodeMap.RemoveNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode;
 begin
-  if nfReadOnly in FOwner.FFlags then
-    raise EDOMError.Create(NO_MODIFICATION_ALLOWED_ERR, 'NamedNodeMap.RemoveNamedItemNS');
-  // TODO: Implement TDOMNamedNodeMap.RemoveNamedItemNS
+// see comments to SetNamedItemNS. Related tests are written clever enough
+// in the sense they don't expect NO_MODIFICATION_ERR in first place.
+  raise EDOMNotFound.Create('NamedNodeMap.RemoveNamedItemNS');
+  Result := nil;
+end;
+
+{ TAttributeMap }
+
+// Since list is kept sorted by nodeName, we must use linear search here.
+// This routine is not called while parsing, so parsing speed is not lowered.
+function TAttributeMap.FindNS(nsIndex: Integer; const aLocalName: DOMString;
+  out Index: LongWord): Boolean;
+var
+  I: Integer;
+  P: DOMPChar;
+begin
+  for I := 0 to FList.Count-1 do
+  begin
+    with TDOMAttr(FList.List^[I]) do
+    begin
+      if nsIndex = FNSI.NSIndex then
+      begin
+        P := DOMPChar(FNSI.QName^.Key);
+        if FNSI.PrefixLen > 1 then
+          Inc(P, FNSI.PrefixLen);
+        if CompareDOMStrings(DOMPChar(aLocalName), P, System.Length(aLocalName), System.Length(FNSI.QName^.Key) - FNSI.PrefixLen) = 0 then
+        begin
+          Index := I;
+          Result := True;
+          Exit;
+        end;
+      end;
+    end;
+  end;
+  Result := False;
+end;
+
+function TAttributeMap.InternalRemoveNS(const nsURI, aLocalName: DOMString): TDOMNode;
+var
+  i: Cardinal;
+  nsIndex: Integer;
+begin
   Result := nil;
+  nsIndex := FOwner.FOwnerDocument.IndexOfNS(nsURI);
+  if (nsIndex >= 0) and FindNS(nsIndex, aLocalName, i) then
+  begin
+    Result := Delete(I);
+    RestoreDefault(TDOMAttr(Result).FNSI.QName^.Key);
+  end;
 end;
 
+function TAttributeMap.getNamedItemNS(const namespaceURI, localName: DOMString): TDOMNode;
+var
+  nsIndex: Integer;
+  i: LongWord;
+begin
+  nsIndex := FOwner.FOwnerDocument.IndexOfNS(namespaceURI);
+  if (nsIndex >= 0) and FindNS(nsIndex, localName, i) then
+    Result := TDOMNode(FList.List^[i])
+  else
+    Result := nil;
+end;
+
+function TAttributeMap.setNamedItemNS(arg: TDOMNode): TDOMNode;
+var
+  i: LongWord;
+  res: Integer;
+  Exists: Boolean;
+begin
+  res := ValidateInsert(arg);
+  if res <> 0 then
+    raise EDOMError.Create(res, 'NamedNodeMap.SetNamedItemNS');
+
+  Result := nil;
+  with TDOMAttr(arg) do
+  begin
+    // calling LocalName is no good... but it is done once
+    if FindNS(FNSI.NSIndex, localName, i) then
+    begin
+      Result := TDOMNode(FList.List^[i]);
+      FList.Delete(i);
+    end;
+    // Do a non-namespace search in order to keep the list sorted on nodeName
+    Exists := Find(FNSI.QName^.Key, i);
+    if Exists and (Result = nil) then  // case when arg has no namespace
+    begin
+      Result := TDOMNode(FList.List^[i]);
+      FList.List^[i] := arg;
+    end
+    else
+      FList.Insert(i, arg);
+  end;
+  if Assigned(Result) then
+    TDOMAttr(Result).FOwnerElement := nil;
+  TDOMAttr(arg).FOwnerElement := TDOMElement(FOwner);
+end;
+
+function TAttributeMap.removeNamedItemNS(const namespaceURI,
+  localName: DOMString): TDOMNode;
+begin
+  if nfReadOnly in FOwner.FFlags then
+    raise EDOMError.Create(NO_MODIFICATION_ALLOWED_ERR, 'NamedNodeMap.RemoveNamedItemNS');
+  Result := InternalRemoveNS(namespaceURI, localName);
+  if Result = nil then
+     raise EDOMNotFound.Create('NamedNodeMap.RemoveNamedItemNS');
+end;
 
 // -------------------------------------------------------
 //   CharacterData
@@ -1805,7 +2007,9 @@ var
   s: string;
 begin
   s := feature;   // force Ansi, features do not contain non-ASCII chars
-  Result := SameText(s, 'XML') and ((version = '') or (version = '1.0'));
+  Result := (SameText(s, 'XML') and ((version = '') or (version = '1.0') or (version = '2.0'))) or
+            (SameText(s, 'Core') and ((version = '') or (version = '2.0')));
+
 end;
 
 function TDOMImplementation.CreateDocumentType(const QualifiedName, PublicID,
@@ -2353,7 +2557,10 @@ end;
 function TDOMAttr.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode;
 begin
   // Cloned attribute is always specified and carries its children
-  Result := ACloneOwner.CreateAttribute(NodeName);
+  if nfLevel2 in FFlags then
+    Result := ACloneOwner.CreateAttributeNS(namespaceURI, NodeName)
+  else
+    Result := ACloneOwner.CreateAttribute(NodeName);
   TDOMAttr(Result).FDataType := FDataType;
   CloneChildren(Result, ACloneOwner);
 end;
@@ -2376,6 +2583,11 @@ begin
   Result := nfSpecified in FFlags;
 end;
 
+function TDOMAttr.GetIsID: Boolean;
+begin
+  Result := FDataType = dtID;
+end;
+
 // -------------------------------------------------------
 //   Element
 // -------------------------------------------------------
@@ -2390,7 +2602,6 @@ begin
   Include(FFlags, nfDestroying);
   if Assigned(FOwnerDocument.FIDList) then
     FOwnerDocument.RemoveID(Self);
-  // FIX: Attribute nodes are now freed by TDOMNamedNodeMap.Destroy
   FreeAndNil(FAttributes);
   inherited Destroy;
 end;
@@ -2398,12 +2609,45 @@ end;
 function TDOMElement.CloneNode(deep: Boolean; ACloneOwner: TDOMDocument): TDOMNode;
 var
   i: Integer;
+  Attr, AttrClone: TDOMAttr;
 begin
-  Result := ACloneOwner.CreateElement(NodeName);
-  if Assigned(FAttributes) then
+  if ACloneOwner <> FOwnerDocument then
   begin
-    for i := 0 to FAttributes.Length - 1 do
-      TDOMElement(Result).SetAttributeNode(TDOMAttr(FAttributes[i].CloneNode(True, ACloneOwner)));
+    // Importing has to go the hard way...
+    if nfLevel2 in FFlags then
+      Result := ACloneOwner.CreateElementNS(NamespaceURI, NodeName)
+    else
+      Result := ACloneOwner.CreateElement(NodeName);
+    if Assigned(FAttributes) then
+    begin
+      for i := 0 to FAttributes.Length - 1 do
+      begin
+        Attr := TDOMAttr(FAttributes[i]);
+        // destroy defaulted attributes (if any), it is safe because caller had not seen them yet
+        if Attr.Specified then
+          TDOMElement(Result).SetAttributeNode(TDOMAttr(Attr.CloneNode(True, ACloneOwner))).Free;
+      end;
+    end;
+  end
+  else   // Cloning may cheat a little bit.
+  begin
+    Result := FOwnerDocument.Alloc(TDOMElement);
+    TDOMElement(Result).Create(FOwnerDocument);
+    TDOMElement(Result).FNSI := FNSI;
+    if nfLevel2 in FFlags then
+      Include(Result.FFlags, nfLevel2);
+    if Assigned(FAttributes) then
+    begin
+      // clone all attributes, but preserve nfSpecified flag
+      for i := 0 to FAttributes.Length - 1 do
+      begin
+        Attr := TDOMAttr(FAttributes[i]);
+        AttrClone := TDOMAttr(Attr.CloneNode(True, ACloneOwner));
+        if not Attr.Specified then
+          Exclude(AttrClone.FFlags, nfSpecified);
+        TDOMElement(Result).SetAttributeNode(AttrClone);
+      end;
+    end;
   end;
   if deep then
     CloneChildren(Result, ACloneOwner);
@@ -2432,8 +2676,33 @@ end;
 procedure TDOMElement.RestoreDefaultAttr(AttrDef: TDOMAttr);
 var
   Attr: TDOMAttr;
+  ColonPos: Integer;
+  AttrName, nsuri: DOMString;
 begin
   Attr := TDOMAttr(AttrDef.CloneNode(True));
+  AttrName := Attr.Name;
+  ColonPos := Pos(WideChar(':'), AttrName);
+  if Pos(DOMString('xmlns'), AttrName) = 1 then
+  begin
+    if (Length(AttrName) = 5) or (ColonPos = 6) then
+      Attr.SetNSI(stduri_xmlns, ColonPos);
+  end
+  else if ColonPos > 0 then
+  begin
+    if (ColonPos = 4) and (Pos(DOMString('xml'), AttrName) = 1) then
+      Attr.SetNSI(stduri_xml, 4)
+    else
+    begin
+      nsuri := LookupNamespaceURI(Copy(AttrName, 1, ColonPos-1));
+      // TODO: what if prefix isn't defined?
+      Attr.SetNSI(nsuri, ColonPos);
+    end
+  end;
+  // TODO: this is cheat, should look at config['namespaces'] instead.
+  // revisit when it is implemented.
+  if nfLevel2 in FFlags then
+    Include(Attr.FFlags, nfLevel2);
+  // There should be no matching attribute at this point, so non-namespace method is ok
   SetAttributeNode(Attr);
 end;
 
@@ -2450,7 +2719,7 @@ end;
 function TDOMElement.GetAttributes: TDOMNamedNodeMap;
 begin
   if FAttributes=nil then
-    FAttributes := TDOMNamedNodeMap.Create(Self, ATTRIBUTE_NODE);
+    FAttributes := TAttributeMap.Create(Self, ATTRIBUTE_NODE);
   Result := FAttributes;
 end;
 
@@ -2509,13 +2778,14 @@ procedure TDOMElement.RemoveAttributeNS(const nsURI,
   aLocalName: DOMString);
 begin
   Changing;
-  // TODO: Implement TDOMElement.RemoveAttributeNS
-  raise EDOMNotSupported.Create('TDOMElement.RemoveAttributeNS');
+  if Assigned(FAttributes) then
+    TAttributeMap(FAttributes).InternalRemoveNS(nsURI, aLocalName).Free;
 end;
 
 procedure TDOMElement.SetAttributeNS(const nsURI, qualifiedName,
   value: DOMString);
 var
+  I: Cardinal;
   Attr: TDOMAttr;
   idx, prefIdx: Integer;
 begin
@@ -2524,14 +2794,27 @@ begin
   prefIdx := CheckQName(qualifiedName, idx, FOwnerDocument.FXml11);
   if prefIdx < 0 then
     raise EDOMError.Create(-prefIdx, 'Element.SetAttributeNS');
-    
-  Attr := Attributes.GetNamedItemNS(nsURI, qualifiedName) as TDOMAttr;
-  if attr = nil then
+
+  if TAttributeMap(Attributes).FindNS(idx, Copy(qualifiedName, prefIdx+1, MaxInt), I) then
   begin
-    attr := FOwnerDocument.CreateAttributeNS(nsURI, qualifiedName);
-    // TODO 5: keep sorted!
-    FAttributes.FList.Add(attr);
-  end;
+    Attr := TDOMAttr(FAttributes[I]);
+    // need to reinsert because the nodeName may change
+    FAttributes.FList.Delete(I);
+  end
+  else
+  begin
+    TDOMNode(Attr) := FOwnerDocument.Alloc(TDOMAttr);
+    Attr.Create(FOwnerDocument);
+    Attr.FOwnerElement := Self;
+    Attr.FNSI.NSIndex := Word(idx);
+    Include(Attr.FFlags, nfLevel2);
+  end;
+  // keep list sorted by DOM Level 1 name
+  FAttributes.Find(qualifiedName, I);
+  FAttributes.FList.Insert(I, Attr);
+  // TODO: rehash properly, same issue as with Node.SetPrefix()
+  Attr.FNSI.QName := FOwnerDocument.FNames.FindOrAdd(DOMPChar(qualifiedName), Length(qualifiedName));
+  Attr.FNSI.PrefixLen := Word(prefIdx);
   attr.NodeValue := value;
 end;
 

packages/fcl-xml/src/htmwrite.pp

@@ -180,8 +180,13 @@ begin
     wc := Cardinal(Src^);  Inc(Src);
     case wc of
       $0A: pb := StrECopy(pb, PChar(FLineBreak));
+      $0D: begin
+        pb := StrECopy(pb, PChar(FLineBreak));
+        if (Src < SrcEnd) and (Src^ = #$0A) then
+          Inc(Src);
+      end;
 
-      0..$09, $0B..$7F:  begin
+      0..$09, $0B, $0C, $0E..$7F:  begin
         pb^ := char(wc); Inc(pb);
       end;
 

packages/fcl-xml/src/sax_html.pp

@@ -505,14 +505,20 @@ var
   Element: TDOMElement;
   i: Integer;
 begin
-  // WriteLn('Start: ', LocalName, '. Node buffer before: ', FNodeBuffer.Count, ' elements');
+  {$ifdef SAX_HTML_DEBUG}
+  WriteLn('Start: ', LocalName, '. Node buffer before: ', FNodeBuffer.Count, ' elements');
+  {$endif}
   Element := FDocument.CreateElement(LocalName);
   if Assigned(Attr) then
   begin
-    // WriteLn('Attribute: ', Attr.GetLength);
+    {$ifdef SAX_HTML_DEBUG}
+     WriteLn('Attribute: ', Attr.GetLength);
+    {$endif}
     for i := 0 to Attr.GetLength - 1 do
     begin
-      // WriteLn('#', i, ': LocalName = ', Attr.GetLocalName(i), ', Value = ', Attr.GetValue(i));
+      {$ifdef SAX_HTML_DEBUG}
+       WriteLn('#', i, ': LocalName = ', Attr.GetLocalName(i), ', Value = ', Attr.GetValue(i));
+      {$endif}
       Element[Attr.GetLocalName(i)] := Attr.GetValue(i);
     end;
   end;
@@ -531,7 +537,9 @@ begin
     if not Assigned(FDocument.DocumentElement) then
       FDocument.AppendChild(Element);
   FNodeBuffer.Add(NodeInfo);
-  // WriteLn('Start: ', LocalName, '. Node buffer after: ', FNodeBuffer.Count, ' elements');
+  {$ifdef SAX_HTML_DEBUG}
+    WriteLn('Start: ', LocalName, '. Node buffer after: ', FNodeBuffer.Count, ' elements');
+  {$endif}
 end;
 
 procedure THTMLToDOMConverter.ReaderEndElement(Sender: TObject;
@@ -543,7 +551,9 @@ var
   TagInfo: PHTMLElementProps;
 
 begin
-  // WriteLn('End: ', LocalName, '. Node buffer: ', FNodeBuffer.Count, ' elements');
+  {$ifdef SAX_HTML_DEBUG}
+    WriteLn('End: ', LocalName, '. Node buffer: ', FNodeBuffer.Count, ' elements');
+  {$endif}
   // Find the matching start tag
   i := FNodeBuffer.Count - 1;
   while i >= 0 do

packages/fcl-xml/src/xmlread.pp

@@ -66,6 +66,8 @@ type
     FCDSectionsAsText: Boolean;
     FResolveExternals: Boolean;
     FNamespaces: Boolean;
+    FDisallowDoctype: Boolean;
+    FMaxChars: Cardinal;
   public
     property Validate: Boolean read FValidate write FValidate;
     property PreserveWhitespace: Boolean read FPreserveWhitespace write FPreserveWhitespace;
@@ -74,6 +76,8 @@ type
     property CDSectionsAsText: Boolean read FCDSectionsAsText write FCDSectionsAsText;
     property ResolveExternals: Boolean read FResolveExternals write FResolveExternals;
     property Namespaces: Boolean read FNamespaces write FNamespaces;
+    property DisallowDoctype: Boolean read FDisallowDoctype write FDisallowDoctype;
+    property MaxChars: Cardinal read FMaxChars write FMaxChars;
   end;
 
   // NOTE: DOM 3 LS ACTION_TYPE enumeration starts at 1
@@ -162,7 +166,9 @@ type
     FOnStack: Boolean;
     FBetweenDecls: Boolean;
     FReplacementText: DOMString;
+    FURI: DOMString;
     FStartLocation: TLocation;
+    FCharCount: Cardinal;
   end;
 
   PWideCharBuf = ^TWideCharBuf;
@@ -186,6 +192,7 @@ type
     FXML11Rules: Boolean;
     FSystemID: WideString;
     FPublicID: WideString;
+    FCharCount: Cardinal;
     function GetSystemID: WideString;
     function GetPublicID: WideString;
   protected
@@ -233,6 +240,7 @@ type
     FStream: TStream;
     FCapacity: Integer;
     FOwnStream: Boolean;
+    FEof: Boolean;
   public
     constructor Create(AStream: TStream; AOwnStream: Boolean);
     destructor Destroy; override;
@@ -279,6 +287,7 @@ type
   end;
 
   TElementValidator = object
+    FElement: TDOMElement;
     FElementDef: TDOMElementDef;
     FCurCP: TContentParticle;
     FFailed: Boolean;
@@ -289,6 +298,7 @@ type
   TXMLReadState = (rsProlog, rsDTD, rsRoot, rsEpilog);
 
   TElementContentType = (
+    ctUndeclared,
     ctAny,
     ctEmpty,
     ctMixed,
@@ -353,12 +363,12 @@ type
     FCDSectionsAsText: Boolean;
     FResolveExternals: Boolean;
     FNamespaces: Boolean;
+    FDisallowDoctype: Boolean;
+    FMaxChars: Cardinal;
 
     procedure RaiseExpectedQmark;
-    procedure GetChar;
     procedure Initialize(ASource: TXMLCharSource);
     function DoParseAttValue(Delim: WideChar): Boolean;
-    procedure DoParseFragment;
     function ContextPush(AEntity: TDOMEntityEx): Boolean;
     function ContextPop: Boolean;
     procedure XML11_BuildTables;
@@ -373,6 +383,7 @@ type
     procedure CallErrorHandler(E: EXMLReadError);
     function  FindOrCreateElDef: TDOMElementDef;
     function  SkipUntilSeq(const Delim: TSetOfChar; const More: array of WideChar): Boolean;
+    procedure CheckMaxChars;
   protected
     FCursor: TDOMNode_WithChildren;
     FNesting: Integer;
@@ -406,6 +417,8 @@ type
     procedure ParseDoctypeDecl;                                         // [28]
     procedure ParseMarkupDecl;                                          // [29]
     procedure ParseElement;                                             // [39]
+    procedure ParseEndTag;                                              // [42]
+    procedure DoEndElement(ErrOffset: Integer);
     procedure ParseAttribute(Elem: TDOMElement; ElDef: TDOMElementDef);
     procedure ParseContent;                                             // [43]
     function  ResolvePredefined: Boolean;
@@ -422,13 +435,13 @@ type
     procedure ExpectChoiceOrSeq(CP: TContentParticle);
     procedure ParseElementDecl;
     procedure ParseNotationDecl;
-    function ResolveEntity(const SystemID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
+    function ResolveEntity(const AbsSysID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
     procedure ProcessDefaultAttributes(Element: TDOMElement; Map: TDOMNamedNodeMap);
     procedure ProcessNamespaceAtts(Element: TDOMElement);
     procedure AddBinding(Attr: TDOMAttr; Prefix: PHashItem; var Chain: TBinding);
     procedure EndNamespaceScope(var Chain: TBinding);
 
-    procedure PushVC(aElDef: TDOMElementDef);
+    procedure PushVC(aElement: TDOMElement; aElDef: TDOMElementDef);
     procedure PopVC;
     procedure UpdateConstraints;
     procedure ValidateDTD;
@@ -458,7 +471,6 @@ type
   public
     FExternallyDeclared: Boolean;
     ContentType: TElementContentType;
-    HasElementDecl: Boolean;
     IDAttr: TDOMAttrDef;
     NotationAttr: TDOMAttrDef;
     RootCP: TContentParticle;
@@ -795,6 +807,7 @@ begin
   FBuf := PWideChar(AData);
   FBufEnd := FBuf + Length(AData);
   LFPos := FBuf-1;
+  FCharCount := Length(AData);
 end;
 
 procedure TXMLCharSource.Initialize;
@@ -947,7 +960,12 @@ begin
     if rslt = 0 then
       Break
     else if rslt < 0 then
-      DecodingError('Invalid character in input stream');
+      DecodingError('Invalid character in input stream')
+    else
+    begin
+      Inc(FCharCount, rslt);
+      FReader.CheckMaxChars;
+    end;
   until False;
 
   FBufEnd^ := #0;
@@ -1082,7 +1100,8 @@ var
   OldBuf: PChar;
 begin
   Assert(FCharBufEnd - FCharBuf < Slack-4);
-
+  if FEof then
+    Exit;
   OldBuf := FCharBuf;
   Remainder := FCharBufEnd - FCharBuf;
   if Remainder < 0 then
@@ -1091,6 +1110,8 @@ begin
   if Remainder > 0 then
     Move(OldBuf^, FCharBuf^, Remainder);
   BytesRead := FStream.Read(FAllocated[Slack-4], FCapacity);
+  if BytesRead < FCapacity then
+    FEof := True;
   FCharBufEnd := FAllocated + (Slack-4) + BytesRead;
   PWideChar(FCharBufEnd)^ := #0;
 end;
@@ -1152,20 +1173,14 @@ begin
   Loc.LinePos := FSource.FBuf-FSource.LFPos;
 end;
 
-function TXMLReader.ResolveEntity(const SystemID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
+function TXMLReader.ResolveEntity(const AbsSysID, PublicID: WideString; out Source: TXMLCharSource): Boolean;
 var
-  AbsSysID: WideString;
   Filename: string;
   Stream: TStream;
   fd: THandle;
 begin
   Source := nil;
   Result := False;
-  if not Assigned(FSource) then
-    AbsSysID := SystemID
-  else
-    if not ResolveRelativeURI(FSource.SystemID, SystemID, AbsSysID) then
-      Exit;
   { TODO: alternative resolvers
     These may be 'internal' resolvers or a handler set by application.
     Internal resolvers should probably produce a TStream
@@ -1195,11 +1210,6 @@ begin
   FSource.Initialize;
 end;
 
-procedure TXMLReader.GetChar;
-begin
-  FSource.NextChar;
-end;
-
 procedure TXMLReader.RaiseExpectedQmark;
 begin
   FatalError('Expected single or double quote');
@@ -1260,6 +1270,23 @@ begin
   E.Free;
 end;
 
+procedure TXMLReader.CheckMaxChars;
+var
+  src: TXMLCharSource;
+  total: Cardinal;
+begin
+  if FMaxChars = 0 then
+    Exit;
+  src := FSource;
+  total := 0;
+  repeat
+    Inc(total, src.FCharCount);
+    if total > FMaxChars then
+      FatalError('Exceeded character count limit');
+    src := src.FParent;
+  until src = nil;
+end;
+
 procedure TXMLReader.CallErrorHandler(E: EXMLReadError);
 begin
   try
@@ -1406,6 +1433,8 @@ begin
   FIgnoreComments := FCtrl.Options.IgnoreComments;
   FResolveExternals := FCtrl.Options.ResolveExternals;
   FNamespaces := FCtrl.Options.Namespaces;
+  FDisallowDoctype := FCtrl.Options.DisallowDoctype;
+  FMaxChars := FCtrl.Options.MaxChars;
 end;
 
 destructor TXMLReader.Destroy;
@@ -1442,11 +1471,12 @@ end;
 procedure TXMLReader.ProcessXML(ASource: TXMLCharSource);
 begin
   doc := TXMLDocument.Create;
+  doc.documentURI := ASource.SystemID;  // TODO: to be changed to URI or BaseURI  
   FCursor := doc;
   FState := rsProlog;
   FNesting := 0;
   Initialize(ASource);
-  DoParseFragment;
+  ParseContent;
 
   if FState < rsRoot then
     FatalError('Root element is missing');
@@ -1462,7 +1492,7 @@ begin
   FState := rsRoot;
   Initialize(ASource);
   FXML11 := doc.InheritsFrom(TXMLDocument) and (TXMLDocument(doc).XMLVersion = '1.1');
-  DoParseFragment;
+  ParseContent;
 end;
 
 function TXMLReader.CheckName(aFlags: TCheckNameFlags): Boolean;
@@ -1526,6 +1556,7 @@ begin
     end;
 
     BufAppendChunk(FName, FSource.FBuf, p);
+    Result := (FName.Length > 0);
 
     FSource.FBuf := p;
     if (p^ <> #0) or not FSource.Reload then
@@ -1533,7 +1564,6 @@ begin
 
     p := FSource.FBuf;
   until False;
-  Result := (FName.Length > 0);
   if not (Result or (cnOptional in aFlags)) then
     RaiseNameNotFound;
 end;
@@ -1615,7 +1645,7 @@ begin
       else
         Break;
       end;
-      GetChar;
+      FSource.NextChar;
     until Value > $10FFFF
     else
     repeat
@@ -1624,7 +1654,7 @@ begin
       else
         Break;
       end;
-      GetChar;
+      FSource.NextChar;
     until Value > $10FFFF;
 
     case Value of
@@ -1693,22 +1723,13 @@ begin
   Result := wc <> #0;
 end;
 
-procedure TXMLReader.DoParseFragment;
-begin
-  // SAX: ContentHandler.StartDocument() - here?
-  ParseContent;
-  if FSource.FBuf^ <> #0 then
-    FatalError('End-tag is not allowed here');
-  // SAX: ContentHandler.EndDocument() - here? or somewhere in destructor?  
-end;
-
 function TXMLReader.ContextPush(AEntity: TDOMEntityEx): Boolean;
 var
   Src: TXMLCharSource;
 begin
-  if AEntity.SystemID <> '' then
+  if (AEntity.SystemID <> '') and not AEntity.FResolved then
   begin
-    Result := ResolveEntity(AEntity.SystemID, AEntity.PublicID, Src);
+    Result := ResolveEntity(AEntity.FURI, AEntity.PublicID, Src);
     if not Result then
     begin
       // TODO: a detailed message like SysErrorMessage(GetLastError) would be great here 
@@ -1719,6 +1740,8 @@ begin
   else
   begin
     Src := TXMLCharSource.Create(AEntity.FReplacementText);
+    // needed in case of prefetched external PE
+    Src.SystemID := AEntity.FURI;
     Src.FLineNo := AEntity.FStartLocation.Line;
     Src.LFPos := Src.FBuf - AEntity.FStartLocation.LinePos;
   end;
@@ -1743,6 +1766,7 @@ begin
     if Assigned(FSource.FEntity) then
     begin
       TDOMEntityEx(FSource.FEntity).FOnStack := False;
+      TDOMEntityEx(FSource.FEntity).FCharCount := FSource.FCharCount;
 // [28a] PE that was started between MarkupDecls may not end inside MarkupDecl
       Error := TDOMEntityEx(FSource.FEntity).FBetweenDecls and FInsideDecl;
     end;
@@ -1760,9 +1784,11 @@ var
   RefName: WideString;
   Child: TDOMNode;
   SaveCursor: TDOMNode_WithChildren;
+  cnt: Cardinal;
 begin
   AEntity := nil;
   SetString(RefName, FName.Buffer, FName.Length);
+  cnt := FName.Length+2;
 
   if Assigned(FDocType) then
     AEntity := FDocType.Entities.GetNamedItem(RefName) as TDOMEntityEx;
@@ -1770,19 +1796,19 @@ begin
   if AEntity = nil then
   begin
     if FStandalone or (FDocType = nil) or not (FHavePERefs or (FDocType.SystemID <> '')) then
-      FatalError('Reference to undefined entity ''%s''', [RefName], FName.Length+2)
+      FatalError('Reference to undefined entity ''%s''', [RefName], cnt)
     else
-      ValidationError('Undefined entity ''%s'' referenced', [RefName], FName.Length+2);
+      ValidationError('Undefined entity ''%s'' referenced', [RefName], cnt);
     FCursor.AppendChild(doc.CreateEntityReference(RefName));
     Exit;
   end;
 
   if InAttr and (AEntity.SystemID <> '') then
-    FatalError('External entity reference is not allowed in attribute value', FName.Length+2);
+    FatalError('External entity reference is not allowed in attribute value', cnt);
   if FStandalone and AEntity.FExternallyDeclared then
-    FatalError('Standalone constraint violation', FName.Length+2);
+    FatalError('Standalone constraint violation', cnt);
   if AEntity.NotationName <> '' then
-    FatalError('Reference to unparsed entity ''%s''', [RefName], FName.Length+2);
+    FatalError('Reference to unparsed entity ''%s''', [RefName], cnt);
 
   if not AEntity.FResolved then
   begin
@@ -1798,7 +1824,7 @@ begin
         if InAttr then
           DoParseAttValue(#0)
         else
-          DoParseFragment;
+          ParseContent;
         AEntity.FResolved := True;
       finally
         AEntity.SetReadOnly(True);
@@ -1808,6 +1834,9 @@ begin
       end;
     end;
   end;
+  // charcount of the entity included is known at this point
+  Inc(FSource.FCharCount, AEntity.FCharCount - cnt);
+  CheckMaxChars;
   if (not FExpandEntities) or (not AEntity.FResolved) then
   begin
     // This will clone Entity children
@@ -1841,6 +1870,27 @@ begin
   if PEnt.FOnStack then
     FatalError('Entity ''%%%s'' recursively references itself', [PEnt.NodeName]);
 
+  { cache an external PE so it's only fetched once }
+  if (PEnt.SystemID <> '') and not PEnt.FResolved then
+  begin
+    if ContextPush(PEnt) then
+    try
+      FValue.Length := 0;
+      FSource.SkipUntil(FValue, [#0]);
+      SetString(PEnt.FReplacementText, FValue.Buffer, FValue.Length);
+      PEnt.FCharCount := FValue.Length;
+      PEnt.FStartLocation.Line := 1;
+      PEnt.FStartLocation.LinePos := 1;
+    finally
+      ContextPop;
+      PEnt.FResolved := True;
+      FValue.Length := 0;
+    end;
+  end;
+
+  Inc(FSource.FCharCount, PEnt.FCharCount);
+  CheckMaxChars;
+
   PEnt.FBetweenDecls := not FInsideDecl;
   ContextPush(PEnt);
   FHavePERefs := True;
@@ -1853,7 +1903,7 @@ begin
   if (FSource.FBuf^ <> '''') and (FSource.FBuf^ <> '"') then
     RaiseExpectedQmark;
   Delim := FSource.FBuf^;
-  GetChar;  // skip quote
+  FSource.NextChar;  // skip quote
   StoreLocation(FTokenStart);
   if not DoParseAttValue(Delim) then
     FatalError('Literal has no closing quote',-1);
@@ -1866,7 +1916,7 @@ begin
   if (FSource.FBuf^ = '''') or (FSource.FBuf^ = '"') then
   begin
     Delim := FSource.FBuf^;
-    GetChar;  // skip quote
+    FSource.NextChar;  // skip quote
     StoreLocation(FTokenStart);
     FValue.Length := 0;
     if Delim = '''' then
@@ -1955,7 +2005,7 @@ var
   Name, Value: WideString;
   PINode: TDOMProcessingInstruction;
 begin
-  GetChar;      // skip '?'
+  FSource.NextChar;      // skip '?'
   Name := ExpectName;
   CheckNCName;
   with FName do
@@ -2083,9 +2133,12 @@ end;
 procedure TXMLReader.ParseDoctypeDecl;    // [28]
 var
   Src: TXMLCharSource;
+  DoctypeURI: WideString;
 begin
   if FState >= rsDTD then
     FatalError('Markup declaration is not allowed here');
+  if FDisallowDoctype then
+    FatalError('Document type is prohibited by parser settings');
 
   ExpectString('DOCTYPE');
   SkipS(True);
@@ -2123,7 +2176,8 @@ begin
 
   if (FDocType.SystemID <> '') then
   begin
-    if ResolveEntity(FDocType.SystemID, FDocType.PublicID, Src) then
+    ResolveRelativeURI(FSource.SystemID, FDocType.SystemID, DoctypeURI);
+    if ResolveEntity(DocTypeURI, FDocType.PublicID, Src) then
     begin
       Initialize(Src);
       try
@@ -2148,7 +2202,7 @@ begin
     SkipS;
   if FSource.FBuf^ <> '=' then
     FatalError('Expected "="');
-  GetChar;
+  FSource.NextChar;
   SkipS;
 end;
 
@@ -2209,7 +2263,7 @@ begin
       ExpectChoiceOrSeq(CurrentCP);
       if CurrentEntity <> FSource.FEntity then
         BadPENesting;
-      GetChar;
+      FSource.NextChar;
     end
     else
       CurrentCP.Def := FindOrCreateElDef;
@@ -2228,7 +2282,7 @@ begin
     else
       if FSource.FBuf^ <> Delim then
         FatalError(Delim);
-    GetChar; // skip delimiter
+    FSource.NextChar; // skip delimiter
   until False;
   if Delim = '|' then
     CP.CPType := ctChoice
@@ -2246,10 +2300,10 @@ var
   ExtDecl: Boolean;
 begin
   CP := nil;
-  Typ := ctAny;         // satisfy compiler
+  Typ := ctUndeclared;         // satisfy compiler
   ExpectWhitespace;
   ElDef := FindOrCreateElDef;
-  if ElDef.HasElementDecl then
+  if ElDef.ContentType <> ctUndeclared then
     ValidationError('Duplicate declaration of element ''%s''', [ElDef.TagName], FName.Length);
 
   ExtDecl := FSource.DTDSubsetType <> dsInternal;
@@ -2285,7 +2339,7 @@ begin
         end;
         if CurrentEntity <> FSource.FEntity then
           BadPENesting;
-        GetChar;
+        FSource.NextChar;
         if (not CheckForChar('*')) and (CP.ChildCount > 0) then
           FatalError(WideChar('*'));
       end
@@ -2295,7 +2349,7 @@ begin
         ExpectChoiceOrSeq(CP);
         if CurrentEntity <> FSource.FEntity then
           BadPENesting;
-        GetChar;
+        FSource.NextChar;
         ParseQuantity(CP);
       end;
     except
@@ -2306,9 +2360,8 @@ begin
   else
     FatalError('Invalid content specification');
   // SAX: DeclHandler.ElementDecl(name, model);
-  if not ElDef.HasElementDecl then
+  if ElDef.ContentType = ctUndeclared then
   begin
-    ElDef.HasElementDecl := True;
     ElDef.FExternallyDeclared := ExtDecl;
     ElDef.ContentType := Typ;
     ElDef.RootCP := CP;
@@ -2414,6 +2467,7 @@ begin
             ExpectChar('(');
             repeat
               SkipWhitespace;
+              StoreLocation(FTokenStart);
               CheckName;
               CheckNCName;
               if not AttDef.AddEnumToken(FName.Buffer, FName.Length) then
@@ -2463,8 +2517,7 @@ begin
       if DiscardIt then
         AttDef.Free;
     except
-      if AttDef.OwnerElement = nil then
-        AttDef.Free;
+      AttDef.Free;
       raise;
     end;
     SkipWhitespace;
@@ -2547,15 +2600,21 @@ begin
     begin
       NDataAllowed := False;
       Delim := FSource.FBuf^;
-      GetChar;
+      FSource.NextChar;
       StoreLocation(Entity.FStartLocation);
       if not ParseEntityDeclValue(Delim) then
         DoErrorPos(esFatal, 'Literal has no closing quote', Entity.FStartLocation);
       SetString(Entity.FReplacementText, FEntityValue.Buffer, FEntityValue.Length);
+      Entity.FCharCount := FEntityValue.Length;
     end
     else
+    begin
       if not ParseExternalID(Entity.FSystemID, Entity.FPublicID, False) then
         FatalError('Expected entity value or external ID');
+      { need to resolve entity's SystemID relative to the current source,
+        which may differ from the source at the point of inclusion }
+      ResolveRelativeURI(FSource.SystemID, Entity.SystemID, Entity.FURI);
+    end;
 
     if NDataAllowed then                // [76]
     begin
@@ -2564,6 +2623,7 @@ begin
       if FSource.Matches('NDATA') then
       begin
         ExpectWhitespace;
+        StoreLocation(FTokenStart);
         Entity.FNotationName := ExpectName;
         AddForwardRef(FNotationRefs, FName.Buffer, FName.Length);
         // SAX: DTDHandler.UnparsedEntityDecl(...);
@@ -2771,16 +2831,24 @@ procedure TXMLReader.ParseContent;
 var
   nonWs: Boolean;
   wc: WideChar;
+  StartNesting: Integer;
 begin
+  StartNesting := FNesting;
   with FSource do
   repeat
     if FBuf^ = '<' then
     begin
-      if FBufEnd < FBuf + 3 then
-        Reload;
       Inc(FBuf);
-      if FBuf^ = '/' then Break;     // end tag case is as frequent as start tag
-      if CheckName([cnOptional]) then
+      if FBufEnd < FBuf + 2 then
+        Reload;
+      if FBuf^ = '/' then
+      begin
+        if FNesting <= StartNesting then
+          FatalError('End-tag is not allowed here');
+        Inc(FBuf);
+        ParseEndTag;
+      end
+      else if CheckName([cnOptional]) then
         ParseElement
       else if FBuf^ = '!' then
       begin
@@ -2849,6 +2917,8 @@ begin
         FatalError('Illegal at document level', -1);
     end;
   until FBuf^ = #0;
+  if FNesting > StartNesting then
+    FatalError('End-tag is missing for ''%s''', [FValidator[FNesting].FElement.NSI.QName^.Key]);
 end;
 
 procedure TXMLCharSource.NextChar;
@@ -2872,7 +2942,6 @@ var
   NewElem: TDOMElement;
   ElDef: TDOMElementDef;
   IsEmpty: Boolean;
-  ErrOffset: Integer;
   ElName: PHashItem;
 begin
   if FState > rsRoot then
@@ -2894,7 +2963,7 @@ begin
 
   // Find declaration for this element
   ElDef := TDOMElementDef(ElName^.Data);
-  if (ElDef = nil) or (not ElDef.HasElementDecl) then
+  if (ElDef = nil) or (ElDef.ContentType = ctUndeclared) then
     ValidationError('Using undeclared element ''%s''',[ElName^.Key], FName.Length);
 
   // Check if new element is allowed in current context
@@ -2913,65 +2982,69 @@ begin
   if FSource.FBuf^ = '/' then
   begin
     IsEmpty := True;
-    GetChar;
+    FSource.NextChar;
   end;
   ExpectChar('>');
 
   if Assigned(ElDef) and Assigned(ElDef.FAttributes) then
     ProcessDefaultAttributes(NewElem, ElDef.FAttributes);
-  PushVC(ElDef);  // this increases FNesting
+  PushVC(NewElem, ElDef);  // this increases FNesting
   if FNamespaces then
     ProcessNamespaceAtts(NewElem);
 
-  // SAX: ContentHandler.StartElement(...)
-  // SAX: ContentHandler.StartPrefixMapping(...)
-
-  ErrOffset := 0;
   if not IsEmpty then
   begin
     FCursor := NewElem;
     if not FPreserveWhitespace then   // critical for testsuite compliance
       SkipS;
-    ParseContent;
-    if FSource.FBuf^ = '/' then         // Get ETag [42]
-    begin
-      FSource.NextChar;
-      CheckName;
-      if not BufEquals(FName, ElName^.Key) then
-        FatalError('Unmatching element end tag (expected "</%s>")', [ElName^.Key], FName.Length);
-      if FSource.FBuf^ = '>' then    // this handles majority of cases
-      begin
-        ErrOffset := FName.Length+1;
-        FSource.NextChar;
-      end
-      else    // but if closing '>' is preceded by whitespace,
-      begin   // skipping it is likely to lose position info.
-        StoreLocation(FTokenStart);
-        Dec(FTokenStart.LinePos, FName.Length);
-        ErrOffset := -1;
-        SkipS;
-        ExpectChar('>');
-      end;
-    end
-    else if FSource.FBuf^ <> #0 then
-      RaiseNameNotFound
-    else // End of stream in content
-      FatalError('End-tag is missing for ''%s''', [ElName^.Key]);
-  end;
-  // SAX: ContentHandler.EndElement(...)
-  // SAX: ContentHandler.EndPrefixMapping(...)
+  end
+  else
+    DoEndElement(0);
+end;
+
+procedure TXMLReader.DoEndElement(ErrOffset: Integer);
+var
+  NewElem: TDOMElement;
+begin
+  NewElem := FValidator[FNesting].FElement;
   TDOMNode(FCursor) := NewElem.ParentNode;
   if FCursor = doc then
     FState := rsEpilog;
 
   if FValidate and FValidator[FNesting].Incomplete then
-    ValidationError('Element ''%s'' is missing required sub-elements', [ElName^.Key], ErrOffset);
+    ValidationError('Element ''%s'' is missing required sub-elements', [NewElem.NSI.QName^.Key], ErrOffset);
 
   if FNamespaces then
     EndNamespaceScope(FBindingStack[FNesting]);
   PopVC;
 end;
 
+procedure TXMLReader.ParseEndTag;     // [42]
+var
+  ErrOffset: Integer;
+  ElName: PHashItem;
+begin
+  ElName := FValidator[FNesting].FElement.NSI.QName;
+
+  CheckName;
+  if not BufEquals(FName, ElName^.Key) then
+    FatalError('Unmatching element end tag (expected "</%s>")', [ElName^.Key], FName.Length);
+  if FSource.FBuf^ = '>' then    // this handles majority of cases
+  begin
+    ErrOffset := FName.Length+1;
+    FSource.NextChar;
+  end
+  else    // but if closing '>' is preceded by whitespace,
+  begin   // skipping it is likely to lose position info.
+    StoreLocation(FTokenStart);
+    Dec(FTokenStart.LinePos, FName.Length);
+    ErrOffset := -1;
+    SkipS;
+    ExpectChar('>');
+  end;
+  DoEndElement(ErrOffset);
+end;
+
 procedure TXMLReader.ParseAttribute(Elem: TDOMElement; ElDef: TDOMElementDef);
 var
   attr: TDOMAttr;
@@ -3038,14 +3111,8 @@ var
   w: PForwardRef;
 begin
   New(w);
-  SetString(w^.Value, Buf, Abs(Length));
-  if Length > 0 then
-  begin
-    StoreLocation(w^.Loc);
-    Dec(w^.Loc.LinePos, Length);
-  end
-  else
-    w^.Loc := FTokenStart;
+  SetString(w^.Value, Buf, Length);
+  w^.Loc := FTokenStart;
   aList.Add(w);
 end;
 
@@ -3299,8 +3366,7 @@ begin
         EndPos := StartPos;
         while (EndPos <= L) and (aValue[EndPos] <> #32) do
           Inc(EndPos);
-        // pass negative length, so uses FTokenStart as location
-        AddForwardRef(FIDRefs, @aValue[StartPos], StartPos-EndPos);
+        AddForwardRef(FIDRefs, @aValue[StartPos], EndPos-StartPos);
         StartPos := EndPos + 1;
       end;
     end;
@@ -3421,11 +3487,12 @@ begin
     ValidationError('Duplicate notation declaration: ''%s''', [aName]);
 end;
 
-procedure TXMLReader.PushVC(aElDef: TDOMElementDef);
+procedure TXMLReader.PushVC(aElement: TDOMElement; aElDef: TDOMElementDef);
 begin
   Inc(FNesting);
   if FNesting >= Length(FValidator) then
     SetLength(FValidator, FNesting * 2);
+  FValidator[FNesting].FElement := aElement;
   FValidator[FNesting].FElementDef := aElDef;
   FValidator[FNesting].FCurCP := nil;
   FValidator[FNesting].FFailed := False;
@@ -3486,7 +3553,7 @@ begin
         else
           FFailed := True;  // used to prevent extra error at the end of element
       end;
-      // ctAny: returns True by default
+      // ctAny, ctUndeclared: returns True by default
     end;
   end;
 end;
@@ -3639,8 +3706,8 @@ begin
   Reader := TXMLReader.Create;
   try
     Reader.ProcessXML(Src);
-    ADoc := TXMLDocument(Reader.Doc);
   finally
+    ADoc := TXMLDocument(Reader.Doc);
     Reader.Free;
   end;
 end;
@@ -3688,7 +3755,6 @@ begin
   Reader := TXMLReader.Create;
   try
     Src := TXMLFileInputSource.Create(f);
-    Src.SystemID := FilenameToURI(TTextRec(f).Name);
     Reader.ProcessFragment(Src, AParentNode);
   finally
     Reader.Free;
@@ -3737,10 +3803,9 @@ begin
   Reader := TXMLReader.Create;
   try
     Src := TXMLFileInputSource.Create(f);
-    Src.SystemID := FilenameToURI(TTextRec(f).Name);
     Reader.ProcessDTD(Src);
-    ADoc := TXMLDocument(Reader.doc);
   finally
+    ADoc := TXMLDocument(Reader.doc);
     Reader.Free;
   end;
 end;
@@ -3756,8 +3821,8 @@ begin
     Src := TXMLStreamInputSource.Create(f, False);
     Src.SystemID := ABaseURI;
     Reader.ProcessDTD(Src);
-    ADoc := TXMLDocument(Reader.doc);
   finally
+    ADoc := TXMLDocument(Reader.doc);
     Reader.Free;
   end;
 end;

packages/fcl-xml/src/xmlwrite.pp

@@ -191,8 +191,13 @@ begin
     wc := Cardinal(Src^);  Inc(Src);
     case wc of
       $0A: pb := StrECopy(pb, PChar(FLineBreak));
+      $0D: begin
+        pb := StrECopy(pb, PChar(FLineBreak));
+        if (Src < SrcEnd) and (Src^ = #$0A) then
+          Inc(Src);
+      end;
 
-      0..$09, $0B..$7F:  begin
+      0..$09, $0B, $0C, $0E..$7F:  begin
         pb^ := char(wc); Inc(pb);
       end;
 

packages/fcl-xml/tests/api.xml

@@ -195,7 +195,7 @@
   <arg>namespaceURI</arg>
   <arg>qualifiedName</arg>
 </item>
-<item id="createDocument">
+<item id="createDocument" gc="yes">
   <arg>namespaceURI</arg>
   <arg>qualifiedName</arg>
   <arg>doctype</arg>
@@ -258,8 +258,10 @@
 <item id="canSetParameter"/>
 <item id="setParameter"/>
 <item id="normalizeDocument"/>
+-->
 <item id="isId"/>
-
+<item id="documentURI" type="prop"/>
+<!--
 // assertNotEquals
 // assertLowerSeverity
 
@@ -267,9 +269,11 @@
 <item id="setUserData"/>
 <item id="isEqualNode"/>
 <item id="isSameNode"/>
+-->
 <item id="lookupNamespaceURI">
   <arg>prefix</arg>
 </item>
+<!--
 <item id="lookupPrefix"/>
 <item id="isDefaultNamespace"/>
 <item id="adoptNode"/>
@@ -703,4 +707,4 @@
 
 
 </api>
-</test-data>
+</test-data>

packages/fcl-xml/tests/xpathts.pp

@@ -22,13 +22,13 @@ uses
   dom, xmlread, xmlwrite, xpath;
 
 type
-  TResultType = (rtString, rtNumber, rtBool, rtNodeset);
+  TResultType = (rtString, rtNumber, rtBool, rtNodeStr, rtOther);
 
   TTestRec = record
     data: string;              // UTF-8 encoded
     expr: DOMString;
   case rt: TResultType of
-    rtString: (s: DOMPChar);   // cannot use DOMString here
+    rtString, rtNodeStr: (s: DOMPChar);   // cannot use DOMString here
     rtNumber: (n: Extended);
     rtBool:   (b: Boolean);
   end;
@@ -414,12 +414,20 @@ const
   '<a id="c"/>'+
   '<a id="d"/>'+
   '</t04>';
+  
+  pos04='<doc>'+
+  '<a test="true"><num>1</num></a>'+
+  '<a><num>1191</num></a>'+
+  '<a><num>263</num></a>'+
+  '<a test="true"><num>2</num></a>'+
+  '<a><num>827</num></a>'+
+  '<a><num>256</num></a>'+
+  '<a test="true"><num>3</num></a>'+
+  '<a test="true"><num>4</num></a>'+
+  '</doc>';
 
-  FunctionTests: array[0..50] of TTestRec = (
+  FunctionTests: array[0..51] of TTestRec = (
   // last()
-  // position()
-  // count()
-  // id()
   // local-name()
   // namespace-uri()
   // name()
@@ -442,13 +450,15 @@ const
     (expr: 'not("")';      rt: rtBool; b: True),
 
     // lang() tests. These ones, however, test much more than lang().
-    // Moreover, I've added string(), otherwise result would be a nodeset
-    (data: expr01; expr: 'string(para[@id="1" and lang("en")])'; rt: rtString; s: 'en'),     // expression01
-    (data: expr01; expr: 'string(para[@id="4" and lang("en")])'; rt: rtString; s: 'en-us'),  // expression03
-    (data: expr01; expr: 'string(div/para[lang("en")])'; rt: rtString; s: 'en'),             // expression04
-    (data: expr01; expr: 'string(para[@id="3" and lang("en")])'; rt: rtString; s: 'EN'),     // expression05
+    (data: expr01; expr: 'para[@id="1" and lang("en")]'; rt: rtNodeStr; s: 'en'),     // expression01
+    (data: expr01; expr: 'para[@id="4" and lang("en")]'; rt: rtNodeStr; s: 'en-us'),  // expression03
+    (data: expr01; expr: 'div/para[lang("en")]'; rt: rtNodeStr; s: 'en'),             // expression04
+    (data: expr01; expr: 'para[@id="3" and lang("en")]'; rt: rtNodeStr; s: 'EN'),     // expression05
+    
+    (data: id04; expr: 'id("c")/@id'; rt: rtNodeStr; s: 'c'),  // idkey04
     
-    (data: id04; expr: 'id("c")/@id'; rt: rtString; s: 'c'),  // idkey04
+    // position() tests
+    (data: pos04; expr: '*[@test][position()=4]/num'; rt: rtNodeStr; s: '4'),
 
     (expr: 'number("1.5")';   rt: rtNumber; n: 1.5),
     (expr: 'number("abc")';   rt: rtNumber; n: NaN),
@@ -512,10 +522,32 @@ const
 '      e'#10+
 '    ';
 
-  StringTests: array[0..59] of TTestRec = (
-    (expr: 'string(5)';       rt: rtString; s: '5'),
+  node08='<docs xmlns:ped="http://www.ped.com"><?MyPI DoesNothing ?><!-- This is a big tree containing all letters of the alphabet -->'#10+
+  '<a attr1="This should not be seen">A</a>'#10+
+  '<b><c attr1="tsnbs" attr2="tsnbs">B-C</c>'#10+
+  '<d><e><f>TextNode_between_F_and_G'#10+
+  '<g><h><i><j><k><l><m><n><o><p><q><r><s><t><u><v><w><x><y><z><Yahoo>Yahoo</Yahoo>'#10+
+  '</z></y></x></w></v></u></t></s></r></q></p></o></n></m></l></k></j></i></h>SecondNode_after_H</g></f></e></d></b>'#10+
+  '</docs>';
+  
+  out08=#10+
+  'A'#10+
+  'B-C'#10+
+  'TextNode_between_F_and_G'#10+
+  'Yahoo'#10+
+  'SecondNode_after_H'#10;
+
+  str30='<doc xmlns="http://xsl.lotus.com/ns2" xmlns:ns1="http://xsl.lotus.com/ns1">'#10+
+  '<ns1:a attrib1="test" xmlns="http://xsl.lotus.com/ns2" xmlns:ns1="http://xsl.lotus.com/ns1"/>'#10+
+  '<b ns1:attrib2="test"/>'#10+
+  '</doc>';
+
+  StringTests: array[0..75] of TTestRec = (             // numbers refer to xalan/string/stringXX
+    (expr: 'string(5)';       rt: rtString; s: '5'),    // #38/39
     (expr: 'string(0.5)';     rt: rtString; s: '0.5'),
     (expr: 'string(-0.5)';    rt: rtString; s: '-0.5'),
+    (expr: 'string("test")';  rt: rtString; s: 'test'), // #40
+    (expr: 'string("")';      rt: rtString; s: ''),     // #41
     (expr: 'string(true())';  rt: rtString; s: 'true'),
     (expr: 'string(false())'; rt: rtString; s: 'false'),
     (expr: 'string(0 div 0)'; rt: rtString; s: 'NaN'),
@@ -523,6 +555,7 @@ const
     (expr: 'string(-1 div 0)'; rt: rtString; s: '-Infinity'),
     // maybe other checks for correct numeric formats
     (data: str14; expr: 'string(av//*)'; rt: rtString; s: out14),
+    (data: node08; expr: '/'; rt: rtNodeStr; s: out08),
 
     (expr: 'concat("titi","toto")'; rt: rtString; s: 'tititoto'),
     (expr: 'concat("titi","toto","tata")'; rt: rtString; s: 'tititototata'),
@@ -533,9 +566,11 @@ const
 
     (expr: 'starts-with("tititoto","titi")'; rt: rtBool; b: True),
     (expr: 'starts-with("tititoto","to")';   rt: rtBool; b: False),
-    (expr: 'starts-with("ab", "abc")';       rt: rtBool; b: False),
-    (expr: 'starts-with("abc", "")';         rt: rtBool; b: True),     // xalan/string/string48
+    (expr: 'starts-with("ab", "abc")';       rt: rtBool; b: False),    // #46
+    (expr: 'starts-with("abc", "bc")';       rt: rtBool; b: False),    // #47
+    (expr: 'starts-with("abc", "")';         rt: rtBool; b: True),     // #48
     (expr: 'starts-with("", "")';            rt: rtBool; b: True),     // #49
+    (expr: 'starts-with(true(), "tr")';      rt: rtBool; b: True),     // #50
 
 
 
@@ -543,11 +578,12 @@ const
     (expr: 'contains("tititototata","toto")'; rt: rtBool; b: True),
     (expr: 'contains("tititototata","tata")'; rt: rtBool; b: True),
     (expr: 'contains("tititototata","tita")'; rt: rtBool; b: False),
-    (expr: 'contains("ab", "abc")';           rt: rtBool; b: False),   // #59
+    // 'contains(concat(.,'BC'),concat('A','B','C'))' == true          // #57    
+    (expr: 'contains("ab", "abc")';           rt: rtBool; b: False),   // #58
     (expr: 'contains("abc", "bcd")';          rt: rtBool; b: False),   // #60
     (expr: 'contains("abc", "")';             rt: rtBool; b: True),    // #61
     (expr: 'contains("", "")';                rt: rtBool; b: True),    // #62
-    // 'contains(concat(.,'BC'),concat('A','B','C'))' == true
+    (expr: 'contains(true(), "e")';           rt: rtBool; b: True),    // #63    
 
     (expr: 'substring("12345",2,3)'; rt: rtString; s: '234'),
     (expr: 'substring("12345",2)';   rt: rtString; s: '2345'),
@@ -555,24 +591,24 @@ const
     (expr: 'substring("12345",3.4)'; rt: rtString; s: '345'),
     (expr: 'substring("12345",3.6)'; rt: rtString; s: '45'),
 
-    (expr: 'substring("12345",1.5,2.6)'; rt: rtString; s: '234'),
+    (expr: 'substring("12345",1.5,2.6)'; rt: rtString; s: '234'), // #16
     (expr: 'substring("12345",2.2,2.2)'; rt: rtString; s: '23'),
-    (expr: 'substring("12345",0,3)';     rt: rtString; s: '12'),
+    (expr: 'substring("12345",0,3)';     rt: rtString; s: '12'),  // #17
     (expr: 'substring("12345",-8,10)';   rt: rtString; s: '1'),
     (expr: 'substring("12345",4,-10)';   rt: rtString; s: ''),
 
-    (expr: 'substring("12345",0 div 0, 3)'; rt: rtString; s: ''),
-    (expr: 'substring("12345",1, 0 div 0)'; rt: rtString; s: ''),
+    (expr: 'substring("12345",0 div 0, 3)'; rt: rtString; s: ''), // #18
+    (expr: 'substring("12345",1, 0 div 0)'; rt: rtString; s: ''), // #19
     (expr: 'substring("12345",1 div 0, 3)'; rt: rtString; s: ''),
     (expr: 'substring("12345",3,-1 div 0)'; rt: rtString; s: ''),
-    (expr: 'substring("12345",-42, 1 div 0)'; rt: rtString; s: '12345'),
+    (expr: 'substring("12345",-42, 1 div 0)'; rt: rtString; s: '12345'), // #20
 
-    (expr: 'substring("12345",-1 div 0, 1 div 0)'; rt: rtString; s: ''),
+    (expr: 'substring("12345",-1 div 0, 1 div 0)'; rt: rtString; s: ''), // #21
     (expr: 'substring("12345",-1 div 0,5)';        rt: rtString; s: ''),
 
-    (expr: 'substring-before("1999/04/01","/")'; rt: rtString; s: '1999'),
-    (expr: 'substring-before("1999/04/01","a")'; rt: rtString; s: ''),
-    (expr: 'substring-after("1999/04/01","/")'; rt: rtString; s: '04/01'),
+    (expr: 'substring-before("1999/04/01","/")'; rt: rtString; s: '1999'),  // #08
+    (expr: 'substring-before("1999/04/01","a")'; rt: rtString; s: ''),      // #68 modified
+    (expr: 'substring-after("1999/04/01","/")'; rt: rtString; s: '04/01'),  // #09
     (expr: 'substring-after("1999/04/01","19")'; rt: rtString; s: '99/04/01'),
     (expr: 'substring-after("1999/04/01","a")'; rt: rtString; s: ''),
 
@@ -582,11 +618,80 @@ const
     (data: str04;  expr: 'string-length(/)'; rt: rtNumber; n:27),    // #04.1 modified
     (data: str04;  expr: 'string-length(/doc/a)'; rt: rtNumber; n: 12), // #04.2
     (data: str04;  expr: 'string-length()';  rt: rtNumber; n: 27),
-    (expr: 'normalize-space("'#9#10#13' ab   cd'#10#13#9'ef'#9#10#13'  ")'; rt: rtString; s: 'ab cd ef'),
+    (expr: 'normalize-space("'#9#10#13' ab   cd'#10#13#9'ef'#9#10#13'  ")'; rt: rtString; s: 'ab cd ef'), // #10
 
-    (expr: 'translate("bar", "abc", "ABC")'; rt: rtString; s: 'BAr'),
+    (expr: 'translate("bar", "abc", "ABC")'; rt: rtString; s: 'BAr'),  // #11
     (expr: 'translate("--aaa--","abc-","ABC")'; rt: rtString; s: 'AAA'),
-    (expr: 'translate("ddaaadddd","abcd","ABCxy")'; rt: rtString; s: 'xxAAAxxxx')   // #96
+    (expr: 'translate("ddaaadddd","abcd","ABCxy")'; rt: rtString; s: 'xxAAAxxxx'),   // #96
+
+    (data: str30; expr: 'namespace-uri(baz1:a/@baz2:attrib1)'; rt: rtString; s: ''), // #30
+    (data: str30; expr: 'namespace-uri(baz2:b/@baz1:attrib2)'; rt: rtString; s: 'http://xsl.lotus.com/ns1'), // #31
+    (data: str30; expr: 'name(*)'; rt: rtString; s: 'ns1:a'),       // #32
+    (data: str30; expr: 'name(baz1:a)'; rt: rtString; s: 'ns1:a'),  // #33
+    (data: str30; expr: 'name(baz2:b)'; rt: rtString; s: 'b'),      // #34
+    (data: str30; expr: 'name(baz1:a/@baz2:attrib1)'; rt: rtString; s: ''),            // #35
+    (data: str30; expr: 'name(baz2:b/@baz1:attrib2)'; rt: rtString; s: 'ns1:attrib2'), // #36
+
+    (data: str30; expr: 'local-name(baz2:b)'; rt: rtString; s: 'b'), // namespace07
+    (data: str30; expr: 'local-name(baz2:b/@baz1:attrib2)'; rt: rtString; s: 'attrib2'), // namespace09
+    (data: str30; expr: 'local-name()'; rt: rtString; s: 'doc')      // namespace26
+  );
+  
+  ax114='<doc>'+
+  '<foo att1="c">'+
+  '  <foo att1="b">'+
+  '     <foo att1="a"/>'+
+  '  </foo>'+
+  '</foo>'+
+  '<baz/>'+
+  '</doc>';
+
+  ax115='<doc>'+
+  '<foo att1="c"/>'+
+  '<foo att1="b"/>'+
+  '<foo att1="a"/>'+
+  '<baz/>'+
+  '</doc>';
+
+
+  ax117='<chapter title="A" x="0">'+
+  '<section title="A1" x="1">'+
+  '  <subsection title="A1a" x="2">hello</subsection>'+
+  '  <subsection title="A1b">ahoy</subsection>'+
+  '</section>'+
+  '<section title="A2">'+
+  '  <subsection title="A2a">goodbye</subsection>'+
+  '  <subsection title="A2b">sayonara</subsection>'+
+  '  <subsection title="A2c">adios</subsection>'+
+  '</section>'+
+  '<section title="A3">'+
+  '  <subsection title="A3a">aloha</subsection>'+
+  '  <subsection title="A3b">'+
+  '    <footnote x="3">A3b-1</footnote>'+
+  '    <footnote>A3b-2</footnote>'+
+  '  </subsection>'+
+  '  <subsection title="A3c">shalom</subsection>'+
+  '</section>'+
+  '</chapter>';
+
+  AxesTests: array[0..13] of TTestRec = (
+    (data: ax117; expr: 'count(//@*)';                        rt: rtNumber; n: 16),
+    (data: ax117; expr: 'count(//@title)';                    rt: rtNumber; n: 12),
+    (data: ax117; expr: 'count(//section//@*)';               rt: rtNumber; n: 14),
+    (data: ax117; expr: 'count(//section//@title)';           rt: rtNumber; n: 11),
+    (data: ax117; expr: 'count(/chapter/.//@*)';              rt: rtNumber; n: 16),
+    (data: ax117; expr: 'count(/chapter/.//@title)';          rt: rtNumber; n: 12),
+    (data: ax117; expr: 'count(/chapter/section[1]//@*)';     rt: rtNumber; n: 5),
+    (data: ax117; expr: 'count(/chapter/section[1]//@title)'; rt: rtNumber; n: 3),
+    (data: ax117; expr: 'count(/chapter/section[2]//@*)';     rt: rtNumber; n: 4),
+    (data: ax117; expr: 'count(/chapter/section[2]//@title)'; rt: rtNumber; n: 4),
+    (data: ax117; expr: 'count(/chapter/section[3]//@*)';     rt: rtNumber; n: 5),
+    (data: ax117; expr: 'count(/chapter/section[3]//@title)'; rt: rtNumber; n: 4),
+
+    (data: ax114; expr: '//baz/preceding::foo[1]/@att1';    rt: rtNodeStr; s: 'a'),
+//  (data: ax114; expr: '//baz/(preceding::foo)[1]/@att1';  rt: rtNodeStr; s: 'c'),         // won't parse
+    (data: ax115; expr: '//baz/preceding-sibling::foo[1]/@att1';    rt: rtNodeStr; s: 'a')
+//  (data: ax115; expr: '//baz/(preceding-sibling::foo)[1]/@att1';  rt: rtNodeStr; s: 'c')  // won't parse
   );
 {$warnings on}
 
@@ -629,6 +734,16 @@ begin
       writeln('Failed: ', t.expr);
       writeln('Expected: ', DOMString(t.s), ' got: ', r.AsText);
     end;
+    rtNodeStr:
+    begin
+      if (r is TXPathNodeSetVariable) and (r.AsNodeSet.Count = 1) and (r.AsText = DOMString(t.s)) then
+        Exit;
+      writeln;  
+      writeln('Failed: ', t.expr);
+      if r.AsNodeSet.Count > 1 then
+        writeln('Result is not a single node');
+      writeln('Expected: ', DOMString(t.s), ' got: ', r.AsText);
+    end;
   end;
   Inc(FailCount);
 end;
@@ -641,6 +756,7 @@ begin
   parser := TDOMParser.Create;
   try
     parser.Options.PreserveWhitespace := True;
+    parser.Options.Namespaces := True;
     src := TXMLInputSource.Create(data);
     try
       parser.Parse(src, Result);
@@ -693,6 +809,7 @@ begin
   DoSuite(FloatTests);
   DoSuite(FunctionTests);
   DoSuite(StringTests);
+  DoSuite(AxesTests);
 
   writeln;
   writeln('Total failed tests: ', FailCount);

packages/fpgtk/src/fpgtk.pp

@@ -606,9 +606,9 @@ TYPE
   Protected
     procedure CreateGtkObject; override;
   Public
-    function TheGtkObject : PGtkImage;
     FMask:PGdkBitMap;
     FImage:PGdkImage;
+    function TheGtkObject : PGtkImage;
     property Image : PGdkImage read GetImageProp write SetImageProp;
     property Mask : PGdkBitMap read GetMask write SetMask;
     procedure SetImage (anImage:PGdkImage; aMask:PGdkBitmap);
@@ -629,9 +629,9 @@ TYPE
   Protected
     procedure CreateGtkObject; override;
   Public
-    function TheGtkObject : PGtkPixmap;
     FMask:PGdkBitMap;
     FPixMap:PGdkPixmap;
+    function TheGtkObject : PGtkPixmap;
     property BuildInsensitive : longbool read GetBuildInsensitive write SetBuildInsensitive;
     constructor Create;
     constructor CreateFromFile (Filename:string; Window:TFPgtkWidget);
@@ -655,8 +655,8 @@ TYPE
     procedure SetBorder (TheValue : integer);
     function GetChildren : TFPgtkWidgetGroup;
   Public
-    function TheGtkObject : PGtkContainer;
     FChildren:TFPgtkWidgetGroup;
+    function TheGtkObject : PGtkContainer;
     property Border : integer read GetBorder write SetBorder;
     procedure Add (AWidget:TFPgtkWidget; IsVisible:boolean); Overload;
     procedure Add (AWidget:TFPgtkWidget); Overload;
@@ -802,8 +802,8 @@ TYPE
   Protected
     procedure CreateGtkObject; Override;
   Public
-    function TheGtkObject : PGtkRadioButton;
     FGroup:TFPgtkRadioButtonGroup;
+    function TheGtkObject : PGtkRadioButton;
     constructor Create (AGroup:TFPgtkRadioButtonGroup);
     constructor CreateWithLabel (AGroup:TFPgtkRadioButtonGroup; aText:string);
   end;
@@ -1957,8 +1957,8 @@ TYPE
     procedure GtkInsert (MenuItem:TFPgtkWidget; position:integer); Override;
     procedure GtkAppend (MenuItem:TFPgtkWidget); Override;
   Public
-    function TheGtkObject : PGtkMenu;
     FDetacher:TFPgtkMenuDetachFunction;
+    function TheGtkObject : PGtkMenu;
     procedure ReorderChild (MenuItem:TFPgtkWidget; position:integer);
     procedure Popup (button:guint); Overload;
     procedure Popup (ParentShell:TFPgtkWidget; ParentItem:TFPgtkWidget; func:TFPgtkMenuPosFunction; data:pointer; button:guint; ActivateTime:guint32); Overload;

packages/fpmkunit/src/fpmkunit.pp

@@ -210,13 +210,19 @@ Type
     FCommandAt: TCommandAt;
     FDestFile: String;
     FIgnoreResult: Boolean;
-    FOptions: String;
+    FOptions: TStrings;
     FSourceFile: String;
+    Function GetOptions : TStrings;
+    Procedure SetOptions(Const Value : TStrings);
   Public
+    Destructor Destroy; override;
+    Function HaveOptions : Boolean;
+    Function CmdLineOptions : String;
+    Procedure ParseOptions(S : String);
     Property SourceFile : String Read FSourceFile Write FSourceFile;
     Property DestFile : String Read FDestFile Write FDestFile;
     Property Command : String Read FCommand Write FCommand;
-    Property Options : String Read FOptions Write FOptions;
+    Property Options : TStrings Read GetOptions Write SetOptions;
     Property At : TCommandAt Read FCommandAt Write FCommandAt;
     Property IgnoreResult : Boolean Read FIgnoreResult Write FIgnoreResult;
     Property BeforeCommand : TNotifyEvent Read FBeforeCommand Write FBeforeCommand;
@@ -370,10 +376,12 @@ Type
     FExtension: String;
     FTargetSourceFileName : String;
     FFileType: TFileType;
-    FOptions: String;
+    FOptions: TStrings;
     FFPCTarget: String;
     FTargetState: TTargetState;
     FTargetType: TTargetType;
+    function GetOptions: TStrings;
+    procedure SetOptions(const AValue: TStrings);
   Protected
     Function GetSourceFileName : String; virtual;
     Function GetUnitFileName : String; virtual;
@@ -384,6 +392,7 @@ Type
     Constructor Create(ACollection : TCollection); override;
     Destructor Destroy; override;
     Function  GetOutputFileName (AOs : TOS) : String; Virtual;
+    Function HaveOptions : Boolean;
     procedure SetName(const AValue: String);override;
     Procedure GetCleanFiles(List : TStrings; const APrefixU, APrefixB : String; ACPU:TCPU; AOS : TOS); virtual;
     Procedure GetInstallFiles(List : TStrings; const APrefixU, APrefixB: String; ACPU:TCPU; AOS : TOS); virtual;
@@ -395,7 +404,7 @@ Type
     Property OSes : TOSes Read FOSes Write FOSes;
     Property CPUs : TCPUs Read FCPUs Write FCPUs;
     Property Mode : TCompilerMode Read FMode Write FMode;
-    Property Options : String Read FOptions Write Foptions;
+    Property Options : TStrings Read GetOptions Write SetOptions;
     Property SourceFileName: String Read GetSourceFileName ;
     Property UnitFileName : String Read GetUnitFileName;
     Property ObjectFileName : String Read GetObjectFileName;
@@ -515,7 +524,7 @@ Type
     FTargets: TTargets;
     FSources: TSources;
     FDirectory: String;
-    FOptions: String;
+    FOptions: TStrings;
     FFileName: String;
     FAuthor: String;
     FLicense: String;
@@ -532,7 +541,9 @@ Type
     FUnitDir : String;
     Function GetDescription : string;
     Function GetFileName : string;
+    function GetOptions: TStrings;
     Function GetVersion : string;
+    procedure SetOptions(const AValue: TStrings);
     Procedure SetVersion(const V : string);
   Protected
     procedure SetName(const AValue: String);override;
@@ -541,6 +552,7 @@ Type
   Public
     constructor Create(ACollection: TCollection); override;
     destructor destroy; override;
+    Function HaveOptions : Boolean;
     Function  GetUnitsOutputDir(ACPU:TCPU; AOS : TOS):String;
     Function  GetBinOutputDir(ACPU:TCPU; AOS : TOS) : String;
     Procedure GetCleanFiles(List : TStrings; ACPU:TCPU; AOS : TOS); virtual;
@@ -562,7 +574,7 @@ Type
     Property OSes : TOSes Read FOSes Write FOSes;
     Property CPUs : TCPUs Read FCPUs Write FCPUs;
     Property NeedLibC : Boolean Read FNeedLibC Write FNeedLibC;
-    Property Options: String Read FOptions Write FOptions;
+    Property Options: TStrings Read GetOptions Write SetOptions;
     Property UnitPath : TConditionalStrings Read FUnitPath;
     Property ObjectPath : TConditionalStrings Read FObjectPath;
     Property IncludePath : TConditionalStrings Read FIncludePath;
@@ -613,7 +625,7 @@ Type
     FCopy: String;
     FMkDir: String;
     FMove: String;
-    FOptions: String;
+    FOptions: TStrings;
     FCPU: TCPU;
     FOS: TOS;
     FMode : TCompilerMode;
@@ -637,19 +649,23 @@ Type
     function GetCompiler: String;
     function GetDocInstallDir: String;
     function GetExamplesInstallDir: String;
+    function GetOptions: TStrings;
     function GetUnitInstallDir: String;
     procedure SetLocalUnitDir(const AValue: String);
     procedure SetGlobalUnitDir(const AValue: String);
     procedure SetBaseInstallDir(const AValue: String);
     procedure SetCPU(const AValue: TCPU);
+    procedure SetOptions(const AValue: TStrings);
     procedure SetOS(const AValue: TOS);
     procedure SetPrefix(const AValue: String);
     procedure SetTarget(const AValue: String);
   Protected
     procedure RecalcTarget;
+    Function CmdLineOptions : String;
   Public
     Constructor Create;
     Procedure InitDefaults;
+    Function HaveOptions: Boolean;
     procedure CompilerDefaults; virtual;
     Procedure LocalInit(Const AFileName : String);
     Procedure LoadFromFile(Const AFileName : String);
@@ -662,7 +678,7 @@ Type
     Property CPU : TCPU Read FCPU Write SetCPU;
     Property Mode : TCompilerMode Read FMode Write FMode;
     Property UnixPaths : Boolean Read FUnixPaths Write FUnixPaths;
-    Property Options : String Read FOptions Write FOptions;    // Default compiler options.
+    Property Options : TStrings Read GetOptions Write SetOptions;    // Default compiler options.
     Property NoFPCCfg : Boolean Read FNoFPCCfg Write FNoFPCCfg;
     // paths etc.
     Property LocalUnitDir : String Read GetLocalUnitDir Write SetLocalUnitDir;
@@ -1435,13 +1451,12 @@ begin
     List[i] := ExtractRelativepath(IncludeTrailingPathDelimiter(CurrDir), List[i]);
 end;
 
-
-procedure SplitCommand(const Cmd : String; var Exe, Options : String);
-
 Const
   WhiteSpace = [#9,#10,#13,' '];
   QuoteChars = ['''','"'];
 
+procedure SplitCommand(const Cmd : String; var Exe, Options : String);
+
 Var
   I : Integer;
   InQuote : Boolean;
@@ -1470,6 +1485,46 @@ begin
   Options:=Trim(S);
 end;
 
+Function OptionListToString(L : TStrings) : String;
+
+var
+  I : Integer;
+  S : String;
+
+begin
+  Result:='';
+  For I:=0 to L.Count-1 do
+    begin
+    If (Result<>'') then
+      Result:=Result+' ';
+    S:=L[I];
+    If (Pos(' ',S)<>0) or (S='') then
+     Result:='"'+S+'"';
+    end;
+end;
+
+Function OptionsToStringList(S : String) : TStrings;
+
+Var
+  P : Integer;
+
+begin
+  Result:=Nil;
+  If (S='') then
+    Exit;
+  Result:=TStringList.Create;
+  Repeat
+    P:=Pos(' ',S);
+    If P=0 then
+      P:=Length(S)+1;
+    Result.Add(Copy(S,1,P-1));
+    Delete(S,1,P);
+    S:=Trim(S);
+  Until Length(S)=0;
+  If Result.Count=0 then
+    FreeAndNil(Result);
+end;
+
 
 {$ifdef HAS_UNIT_PROCESS}
 function GetCompilerInfo(const ACompiler,AOptions:string):string;
@@ -1883,9 +1938,15 @@ begin
   FreeAndNil(FSources);
   FreeAndNil(FTargets);
   FreeAndNil(FVersion);
+  FreeAndNil(FOptions);
   inherited destroy;
 end;
 
+function TPackage.HaveOptions: Boolean;
+begin
+  Result:=(FOptions<>Nil);
+end;
+
 
 procedure TPackage.SetName(const AValue: String);
 begin
@@ -1981,6 +2042,14 @@ begin
   result:=FVersion.AsString;
 end;
 
+procedure TPackage.SetOptions(const AValue: TStrings);
+begin
+  If (AValue=Nil) or (AValue.Count=0) then
+    FreeAndNil(Foptions)
+  else
+    Options.Assign(AValue);
+end;
+
 
 Procedure TPackage.SetVersion(const V : string);
 begin
@@ -1999,6 +2068,13 @@ begin
       Result := Name;
 end;
 
+function TPackage.GetOptions: TStrings;
+begin
+  If (FOptions=Nil) then
+    FOptions:=TStringList.Create;
+  Result:=FOptions;
+end;
+
 
 Procedure TPackage.GetManifest(Manifest : TStrings);
 
@@ -2204,6 +2280,14 @@ begin
   RecalcTarget;
 end;
 
+procedure TCustomDefaults.SetOptions(const AValue: TStrings);
+begin
+  If (AValue=Nil) or (AValue.Count=0) then
+    FreeAndNil(Foptions)
+  else
+    Options.Assign(AValue)
+end;
+
 
 function TCustomDefaults.GetBaseInstallDir: String;
 begin
@@ -2261,6 +2345,13 @@ begin
       Result:=BaseInstallDir+'examples';
 end;
 
+function TCustomDefaults.GetOptions: TStrings;
+begin
+  If (FOptions=Nil) then
+    FOptions:=TStringList.Create;
+  Result:=FOptions;
+end;
+
 
 function TCustomDefaults.GetUnitInstallDir: String;
 begin
@@ -2361,6 +2452,12 @@ begin
   Ftarget:=CPUToString(FCPU)+'-'+OStoString(FOS);
 end;
 
+function TCustomDefaults.CmdLineOptions: String;
+begin
+  If Haveoptions then
+    Result:=OptionListToString(FOptions);
+end;
+
 
 constructor TCustomDefaults.Create;
 begin
@@ -2380,6 +2477,11 @@ begin
   FOS:=osNone;
 end;
 
+function TCustomDefaults.HaveOptions: Boolean;
+begin
+  Result:=Assigned(FOptions);
+end;
+
 
 procedure TCustomDefaults.LocalInit(Const AFileName : String);
 Var
@@ -2486,7 +2588,7 @@ begin
       Values[KeyCopy]:=FCopy;
       Values[KeyMkDir]:=FMkDir;
       Values[KeyMove]:=FMove;
-      Values[KeyOptions]:=FOptions;
+      Values[KeyOptions]:=CmdLineOptions;
       Values[KeyCPU]:=CPUToString(FCPU);
       Values[KeyOS]:=OSToString(FOS);
       Values[KeyMode]:=ModeToString(FMode);
@@ -2538,7 +2640,7 @@ begin
       FMkDir:=Values[KeyMkDir];
       FMove:=Values[KeyMove];
       FRemove:=Values[KeyRemove];
-      FOptions:=Values[KeyOptions];
+      Options:=OptionsToStringList(Values[KeyOptions]);
       Line:=Values[KeyCPU];
       If (Line<>'') then
         FCPU:=StringToCPU(Line);
@@ -3228,7 +3330,7 @@ begin
             begin
             If Assigned(C.BeforeCommand) then
               C.BeforeCommand(C);
-            O:=Substitute(C.Options,['SOURCE',C.SourceFile,'DEST',C.DestFile]);
+            O:=Substitute(C.CmdLineOptions,['SOURCE',C.SourceFile,'DEST',C.DestFile]);
             Cmd:=C.Command;
             If (ExtractFilePath(Cmd)='') then
               Cmd:=ExeSearch(Cmd,GetEnvironmentvariable('PATH'));
@@ -3556,12 +3658,12 @@ begin
     Args.Add('-Fi'+L[i]);
   FreeAndNil(L);
   // Custom Options
-  If (Defaults.Options<>'') then
-    Args.Add(Defaults.Options);
-  If (APackage.Options<>'') then
-    Args.Add(APackage.Options);
-  If (ATarget.Options<>'') then
-    Args.Add(ATarget.Options);
+  If (Defaults.HaveOptions) then
+    Args.AddStrings(Defaults.Options);
+  If (APackage.HaveOptions) then
+    Args.AddStrings(APackage.Options);
+  If (ATarget.HaveOptions) then
+    Args.AddStrings(ATarget.Options);
   // Add Filename to compile
   Args.Add(ATarget.TargetSourceFileName);
   // Convert to string
@@ -4432,9 +4534,24 @@ begin
   FreeAndNil(FIncludePath);
   FreeAndNil(FDependencies);
   FreeAndNil(FCommands);
+  FreeAndNil(Foptions);
   inherited Destroy;
 end;
 
+function TTarget.GetOptions: TStrings;
+begin
+  If Foptions=Nil then
+    FOptions:=TStringList.Create;
+  Result:=FOptions;
+end;
+
+procedure TTarget.SetOptions(const AValue: TStrings);
+begin
+  If (AValue=Nil) or (AValue.Count=0) then
+    FreeAndNil(FOptions)
+  else
+    Options.Assign(AValue);
+end;
 
 function TTarget.GetSourceFileName: String;
 begin
@@ -4477,6 +4594,11 @@ begin
     Result:=GetProgramFileName(AOs);
 end;
 
+function TTarget.HaveOptions: Boolean;
+begin
+  Result:=(FOptions<>Nil);
+end;
+
 
 procedure TTarget.SetName(const AValue: String);
 Var
@@ -4615,7 +4737,8 @@ function TCommands.AddCommand(At: TCommandAt; const Cmd, Options, Dest, Source:
 begin
   Result:=Add as TCommand;
   Result.Command:=Cmd;
-  Result.Options:=Options;
+  If (Options<>'') then
+    Result.ParseOptions(Options);
   Result.At:=At;
   Result.SourceFile:=Source;
   Result.DestFile:=Dest;
@@ -4972,7 +5095,6 @@ begin
     end;
 end;
 
-
 {****************************************************************************
                                  Default Instances
 ****************************************************************************}
@@ -4994,6 +5116,48 @@ begin
 end;
 
 
+
+{ TCommand }
+
+function TCommand.GetOptions: TStrings;
+begin
+  If (FOptions=Nil) then
+    FOptions:=TStringList.Create;
+  Result:=FOptions;
+end;
+
+procedure TCommand.SetOptions(const Value: TStrings);
+begin
+  If (Value=Nil) or (Value.Count=0) then
+    FreeAndNil(FOptions)
+  else
+    Options.Assign(Value);
+end;
+
+destructor TCommand.Destroy;
+begin
+  FreeAndNil(FOptions);
+  inherited Destroy;
+end;
+
+function TCommand.HaveOptions: Boolean;
+begin
+  Result:=(FOptions<>Nil);
+end;
+
+
+function TCommand.CmdLineOptions: String;
+begin
+  If HaveOptions then
+    Result:=OptionListToString(Options);
+end;
+
+procedure TCommand.ParseOptions(S: String);
+
+begin
+  Options:=OptionsToStringList(S);
+end;
+
 Initialization
   OnGetApplicationName:=@GetFPMakeName;
 

packages/gdbint/src/gdbint.pp

@@ -459,6 +459,9 @@ type
     last_breakpoint_line : longint;
     last_breakpoint_file : pchar;
     invalid_breakpoint_line : boolean;
+    user_screen_shown,
+    switch_to_user     : boolean;
+
     { init }
     constructor init;
     destructor  done;
@@ -475,8 +478,6 @@ type
     function  set_current_frame(level : longint) : boolean;
     procedure clear_frames;
     { Highlevel }
-    user_screen_shown,
-    switch_to_user     : boolean;
     procedure GetAddrSyminfo(addr:ptrint;var si:tsyminfo);
     procedure SelectSourceline(fn:pchar;line:longint);
     procedure StartSession;

packages/graph/src/inc/fills.inc

@@ -78,9 +78,11 @@ begin
     p0 := ptable[i];
     if (i+1) >= numpoints then p1 := ptable[0]
     else p1 := ptable[i+1];
+   { draw the edges }
+    Line(p0.x,p0.y,p1.x,p1.y);
    { ignore if this is a horizontal edge}
     if (p0.y = p1.y) then continue;
-    {swap ptable if necessary to ensure p0 contains yMin}
+   { swap ptable if necessary to ensure p0 contains yMin}
     if (p0.y > p1.y) then begin
       p0 := p1;
       p1 := ptable[i];
@@ -169,7 +171,7 @@ begin
       x0 := AET^[i]^.x;
       x1 := AET^[i+1]^.x;
       {Left edge adjustment for positive fraction.  0 is interior. }
-      if (AET^[i]^.frac > 0) then inc(x0);
+      if (AET^[i]^.frac >= 0) then inc(x0);
       {Right edge adjustment for negative fraction.  0 is exterior. }
       if (AET^[i+1]^.frac <= 0) then dec(x1);
 

packages/graph/src/inc/graph.inc

@@ -466,7 +466,7 @@ var
                     { with predefined line patterns...                 }
                     if LinePatterns[PixelCount and 15] = TRUE then
                       begin
-                    DirectPutPixel(x1,PixelCount);
+                        DirectPutPixel(x1,PixelCount);
                       end;
               end
             else
@@ -590,7 +590,7 @@ var
              begin
                   if LinePatterns[i and 15] = TRUE then
                     begin
-                          DirectPutPixel(x,y);
+                      DirectPutPixel(x,y);
                     end;
              if d < 0 then
                  begin
@@ -843,24 +843,29 @@ var
              Begin
                for j:=0 to 7 do
                     Begin
-                            { x1 mod 8 }
+                    { x1 mod 8 }
                     if RevBitArray[x1 and 7] and TmpFillPattern <> 0 then
-                       DirectPutpixel(x1,y)
+                      begin
+                        OldCurrentColor := CurrentColor;
+                        CurrentColor := FillSettings.Color;
+                        DirectPutpixel(x1,y);
+                        CurrentColor := OldCurrentColor;
+                      end
                     else
                       begin
-                            { According to the TP graph manual, we overwrite everything }
-                            { which is filled up - checked against VGA and CGA drivers  }
-                            { of TP.                                                    }
-                            OldCurrentColor := CurrentColor;
-                            CurrentColor := CurrentBkColor;
-                            DirectPutPixel(x1,y);
-                            CurrentColor := OldCurrentColor;
+                        { According to the TP graph manual, we overwrite everything }
+                        { which is filled up - checked against VGA and CGA drivers  }
+                        { of TP.                                                    }
+                        OldCurrentColor := CurrentColor;
+                        CurrentColor := CurrentBkColor;
+                        DirectPutPixel(x1,y);
+                        CurrentColor := OldCurrentColor;
                       end;
                     Inc(x1);
                     if x1 > x2 then
                      begin
-                           CurrentWriteMode := OldWriteMode;
-                           exit;
+                       CurrentWriteMode := OldWriteMode;
+                       exit;
                      end;
                    end;
              end;
@@ -870,8 +875,6 @@ var
    end;
 
 
-
-
   procedure LineRel(Dx, Dy: smallint);
 
    Begin

packages/gtk2/src/gtk+/gdk/gdkevents.inc

@@ -455,11 +455,13 @@ const
    GDK_SCROLL_MASK              = 1 shl 21;
    GDK_ALL_EVENTS_MASK          = $3FFFFE;
 
-   GDK_WINDOW_STATE_WITHDRAWN = 1 shl 0;
-   GDK_WINDOW_STATE_ICONIFIED = 1 shl 1;
-   GDK_WINDOW_STATE_MAXIMIZED = 1 shl 2;
-   GDK_WINDOW_STATE_STICKY    = 1 shl 3;
-
+   GDK_WINDOW_STATE_WITHDRAWN  = 1 shl 0;
+   GDK_WINDOW_STATE_ICONIFIED  = 1 shl 1;
+   GDK_WINDOW_STATE_MAXIMIZED  = 1 shl 2;
+   GDK_WINDOW_STATE_STICKY     = 1 shl 3;
+   GDK_WINDOW_STATE_FULLSCREEN = 1 shl 4;
+   GDK_WINDOW_STATE_ABOVE      = 1 shl 5;
+   GDK_WINDOW_STATE_BELOW      = 1 shl 6;
 
 function gdk_event_get_type:GType; cdecl; external gdklib;
 function gdk_events_pending:gboolean; cdecl; external gdklib;

packages/iconvenc/src/iconvert.inc

@@ -49,7 +49,15 @@ begin
 
     // iconv has a buffer that needs flushing, specially if the last char is not #0
     iconv(H, nil, nil, @Dst, @Outlen);
-
+    lerr:=cerrno;
+    if (iconvres=Cint(-1)) and (lerr=ESysE2BIG) then
+      begin
+        Offset:=Dst-PChar(Res);
+        SetLength(Res, Length(Res)+InLen*2+5); // 5 is minimally one utf-8 char
+        Dst:=PChar(Res)+Offset;
+        OutLen:=Length(Res)-Offset;
+        iconv(H, nil, nil, @Dst, @Outlen);
+      end;
     // trim output buffer
     SetLength(Res, Length(Res) - Outlen);
   finally

packages/libxml/src/xml2.pas

@@ -22,6 +22,7 @@ const
 {$IF Defined(WINDOWS)}
   xml2lib = 'libxml2.'+sharedsuffix;
   {$DEFINE EXTDECL := cdecl}
+  {$DEFINE NO_EXTERNAL_VARS}
 {$ELSEIF Defined(UNIX)}
   xml2lib = 'libxml2.'+sharedsuffix;
   {$DEFINE EXTDECL := cdecl}
@@ -264,7 +265,7 @@ begin
   Result := not assigned(ns) or (ns^.nodeNr = 0) or (ns^.nodeTab = nil);
 end;
 
-{$IFDEF WINDOWS}
+{$IFDEF NO_EXTERNAL_VARS}
 procedure LoadExternalVariables;
 var
   libHandle: THandle;
@@ -311,7 +312,7 @@ end;
 {$ENDIF}
 
 initialization
-{$IFDEF WINDOWS}
+{$IFDEF NO_EXTERNAL_VARS}
   LoadExternalVariables;
 {$ENDIF}
 

packages/mysql/src/mysql.inc

@@ -540,6 +540,31 @@ uses
 {  ------------ Stop of declaration in "mysql_com.h"   -----------------------  }
 
 { $include "mysql_time.h"}
+    type
+        mysql_timestamp_type = (
+          MYSQL_TIMESTAMP_NONE = -2,
+          MYSQL_TIMESTAMP_ERROR = -1,
+          MYSQL_TIMESTAMP_DATE = 0,
+          MYSQL_TIMESTAMP_DATETIME = 1,
+          MYSQL_TIMESTAMP_TIME = 2
+        );
+
+        Pst_mysql_time = ^st_mysql_time;
+        st_mysql_time = record
+          year:        cuint;
+          month:       cuint;
+          day:         cuint;
+          hour:        cuint;
+          minute:      cuint;
+          second:      cuint;
+          second_part: culong;
+          neg:         my_bool;
+          time_type:   mysql_timestamp_type;
+        end;
+
+        PMYSQL_TIME = ^MYSQL_TIME;
+        MYSQL_TIME = st_mysql_time;
+
 { $include "mysql_version.h"}
 { $include "typelib.h"}
 { $include "my_list.h" /* for LISTs used in 'MYSQL' and 'MYSQL_STMT' */}

packages/objcrtl/src/objcrtlutils.pas

@@ -28,6 +28,11 @@ function super(obj: id): objc_super;
 
 implementation
 
+var
+  SEL_alloc   : SEL = nil;
+  SEL_init    : SEL = nil;
+  SEL_release : SEL = nil;
+
 function super(obj: id): objc_super;
 begin
   Result.reciever := obj;
@@ -57,17 +62,20 @@ end;
 
 procedure release(objc: id); inline;
 begin
-  objc_msgSend(objc, selector('release'), []);
+  if SEL_release=nil then SEL_release := selector('release');
+  objc_msgSend(objc, SEL_release, []);
 end;
 
 function AllocAndInit(classname: PChar): id; inline;
 begin
-  Result:= objc_msgSend( alloc( classname ), selector('init'), []);
+  if SEL_init=nil then SEL_init := selector('init');
+  Result:= objc_msgSend( alloc( classname ), SEL_init, []);
 end;
 
 function AllocAndInitEx(classname: PChar; extraBytes: Integer): id; inline;
 begin
-  Result := objc_msgSend( allocEx( classname, extraBytes ), selector('init'), []);
+  if SEL_init=nil then SEL_init := selector('init');
+  Result := objc_msgSend( allocEx( classname, extraBytes ), SEL_init, []);
 end;
 
 

packages/winunits-base/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/05/10]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2009/06/04]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-darwin x86_64-win64 x86_64-embedded arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian powerpc64-linux powerpc64-darwin powerpc64-embedded avr-embedded armeb-linux armeb-embedded
@@ -439,178 +439,178 @@ ifeq ($(FULL_TARGET),armeb-embedded)
 override TARGET_UNITS+=buildwinutilsbase
 endif
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-os2)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-haiku)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-netware)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-darwin)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-emx)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-watcom)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-netwlibc)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-symbian)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-atari)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),m68k-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-amiga)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),sparc-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),x86_64-darwin)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),x86_64-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-palmos)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-darwin)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-gba)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-nds)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),arm-symbian)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc64-darwin)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),powerpc64-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),avr-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),armeb-linux)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),armeb-embedded)
-override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme
+override TARGET_IMPLICITUNITS+=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_RSTS+=jwawintype comconst

packages/winunits-base/Makefile.fpc

@@ -9,7 +9,7 @@ version=2.2.2
 [target]
 units=buildwinutilsbase
 implicitunits=flatsb winver mmsystem comobj comconst commdlg commctrl ole2 activex shellapi shlobj oleserver \
-               shfolder richedit imagehlp wininet uxtheme
+               shfolder richedit imagehlp wininet uxtheme dwmapi multimon htmlhelp
 
 examples=examples
 

packages/winunits-base/fpmake.pp

@@ -49,6 +49,9 @@ begin
 	  AddUnit('wininet');
           AddUnit('uxtheme');  
           AddInclude('tmschema.inc');
+          AddUnit('dwmapi');
+          AddUnit('multimon');
+          AddUnit('htmlhelp');
         end;
     T:=P.Targets.AddImplicitUnit('activex.pp');
     T:=P.Targets.AddImplicitUnit('comconst.pp');
@@ -69,6 +72,9 @@ begin
     T:=P.Targets.AddImplicitUnit('commdlg.pp');
     T:=P.Targets.AddImplicitUnit('wininet.pp');
     T:=P.Targets.AddImplicitUnit('uxtheme.pp');
+    T:=P.Targets.AddImplicitUnit('multimon.pp');
+    T:=P.Targets.AddImplicitUnit('dwmapi.pp');
+    T:=P.Targets.AddImplicitUnit('htmlhelp.pp');
     T.Dependencies.AddInclude('tmschema.inc');
     P.ExamplePath.Add('tests/');
     P.Targets.AddExampleProgram('testcom1.pp');

packages/winunits-base/src/activex.pp

@@ -2036,7 +2036,7 @@ TYPE
      IEnumUnknown = Interface(IUnknown)
         ['{00000100-0000-0000-C000-000000000046}']
         //    pointer_default(unique)
-     Function Next(Celt:Ulong;out rgelt:IUnknown;out pCeltFetched:pulong):HRESULT;StdCall;
+     Function Next(Celt:Ulong;out rgelt;out pCeltFetched:pulong):HRESULT;StdCall;
 //    HRESULT RemoteNext(        [in] ULONG celt,        [out, size_is(celt), length_is( *pceltFetched)]        IUnknown **rgelt,        [out] ULONG *pceltFetched);
      Function Skip(Celt:Ulong):HResult;StdCall;
      Function Reset():HResult;
@@ -2940,7 +2940,7 @@ TYPE
      Function  FindName(szNameBuf: pOleStr; lHashVal: ULONG; OUT ppTInfo: ITypeInfo; OUT rgMemId: MEMBERID; VAR pcFound: USHORT; OUT pBstrLibName: WideString):HResult;StdCall;
      {$endif}
      {$ifndef Call_as}
-      Procedure ReleaseTLibAttr(Const pTLibAttr : TLIBATTR); StdCall;
+      Procedure ReleaseTLibAttr( pTLibAttr : LPTLIBATTR); StdCall;
       {$else}
      Function  LocalReleaseTLibAttr:HResult;StdCall;
      {$endif}

packages/winunits-base/src/buildwinutilsbase.pp

@@ -22,7 +22,8 @@ interface
 
 uses
     flatsb, winver, mmsystem, comconst, commctrl, comobj, commdlg,
-    ole2, activex, shellapi, shlobj, oleserver,  shfolder, richedit,imagehlp,wininet,uxtheme;
+    ole2, activex, shellapi, shlobj, oleserver,  shfolder, richedit,
+    imagehlp, wininet, uxtheme, dwmapi, multimon, htmlhelp;
 
 implementation
 

packages/winunits-base/src/dwmapi.pp

@@ -0,0 +1,525 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2009 by the Free Pascal development team
+    member of 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.
+
+ **********************************************************************}
+{*=========================================================================*
+
+    Copyright (c) Microsoft Corporation.  All rights reserved.
+
+    File: dwmapi.h
+
+    Module Name: dwmapi
+
+    Description: DWM API declarations
+
+ *=========================================================================*}
+unit DwmApi;
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Windows, UxTheme;
+
+procedure FreeDwmLibrary;
+function InitDwmLibrary: Boolean;
+function DwmCompositionEnabled: Boolean;
+
+// Blur behind data structures
+const
+  DWM_BB_ENABLE                = $00000001; // fEnable has been specified
+  DWM_BB_BLURREGION            = $00000002; // hRgnBlur has been specified
+  DWM_BB_TRANSITIONONMAXIMIZED = $00000004; // fTransitionOnMaximized has been specified
+
+type
+  _DWM_BLURBEHIND = record
+    dwFlags: DWORD;
+    fEnable: BOOL;
+    hRgnBlur: HRGN;
+    fTransitionOnMaximized: BOOL;
+  end;
+  DWM_BLURBEHIND = _DWM_BLURBEHIND;
+  PDWM_BLURBEHIND = ^_DWM_BLURBEHIND;
+  TDWMBlurBehind = DWM_BLURBEHIND;
+  PDWMBlurBehind = PDWM_BLURBEHIND;
+
+// Window attributes
+const
+  DWMWA_NCRENDERING_ENABLED         = 01; // [get] Is non-client rendering enabled/disabled
+  DWMWA_NCRENDERING_POLICY          = 02; // [set] Non-client rendering policy
+  DWMWA_TRANSITIONS_FORCEDISABLED   = 03; // [set] Potentially enable/forcibly disable transitions
+  DWMWA_ALLOW_NCPAINT               = 04; // [set] Allow contents rendered in the non-client area to be visible on the DWM-drawn frame.
+  DWMWA_CAPTION_BUTTON_BOUNDS       = 05; // [get] Bounds of the caption button area in window-relative space.
+  DWMWA_NONCLIENT_RTL_LAYOUT        = 06; // [set] Is non-client content RTL mirrored
+  DWMWA_FORCE_ICONIC_REPRESENTATION = 07; // [set] Force this window to display iconic thumbnails.
+  DWMWA_FLIP3D_POLICY               = 08; // [set] Designates how Flip3D will treat the window.
+  DWMWA_EXTENDED_FRAME_BOUNDS       = 09; // [get] Gets the extended frame bounds rectangle in screen space
+  DWMWA_HAS_ICONIC_BITMAP           = 10; // [set] Indicates an available bitmap when there is no better thumbnail representation.
+  DWMWA_DISALLOW_PEEK               = 11; // [set] Don't invoke Peek on the window.
+  DWMWA_EXCLUDED_FROM_PEEK          = 12; // [set] LivePreview exclusion information
+  DWMWA_LAST                        = 13;
+
+// Non-client rendering policy attribute values
+const
+  DWMNCRP_USEWINDOWSTYLE = 0; // Enable/disable non-client rendering based on window style
+  DWMNCRP_DISABLED       = 1; // Disabled non-client rendering; window style is ignored
+  DWMNCRP_ENABLED        = 2; // Enabled non-client rendering; window style is ignored
+  DWMNCRP_LAST           = 3;
+
+// Values designating how Flip3D treats a given window.
+const
+  DWMFLIP3D_DEFAULT      = 0; // Hide or include the window in Flip3D based on window style and visibility.
+  DWMFLIP3D_EXCLUDEBELOW = 1; // Display the window under Flip3D and disabled.
+  DWMFLIP3D_EXCLUDEABOVE = 2; // Display the window above Flip3D and enabled.
+  DWMFLIP3D_LAST         = 3;
+
+// Thumbnails
+type
+  HTHUMBNAIL = HANDLE;
+  PHTHUMBNAIL = ^HTHUMBNAIL;
+
+const
+  DWM_TNP_RECTDESTINATION      = $00000001;
+  DWM_TNP_RECTSOURCE           = $00000002;
+  DWM_TNP_OPACITY              = $00000004;
+  DWM_TNP_VISIBLE              = $00000008;
+  DWM_TNP_SOURCECLIENTAREAONLY = $00000010;
+
+type
+  _DWM_THUMBNAIL_PROPERTIES = record
+    dwFlags: DWORD;
+    rcDestination: TRect;
+    rcSource: TRect;
+    opacity: Byte;
+    fVisible: BOOL;
+    fSourceClientAreaOnly: BOOL;
+  end;
+  DWM_THUMBNAIL_PROPERTIES = _DWM_THUMBNAIL_PROPERTIES;
+  PDWM_THUMBNAIL_PROPERTIES = ^_DWM_THUMBNAIL_PROPERTIES;
+  TDWMThumbnailProperties = DWM_THUMBNAIL_PROPERTIES;
+  PDWMThumbnailProperties = PDWM_THUMBNAIL_PROPERTIES;
+
+// Video enabling apis
+
+type
+  DWM_FRAME_COUNT = ULONGLONG;
+  QPC_TIME = ULONGLONG;
+
+type
+  _UNSIGNED_RATIO = record
+    uiNumerator: LongWord;
+    uiDenominator: LongWord;
+  end;
+  UNSIGNED_RATIO = _UNSIGNED_RATIO;
+  TUnsignedRatio = UNSIGNED_RATIO;
+
+type
+  _DWM_TIMING_INFO = record
+    cbSize: LongWord;
+
+    // Data on DWM composition overall
+
+    // Monitor refresh rate
+    rateRefresh: UNSIGNED_RATIO;
+
+    // Actual period
+    qpcRefreshPeriod: QPC_TIME;
+
+    // composition rate
+    rateCompose: UNSIGNED_RATIO;
+
+    // QPC time at a VSync interupt
+    qpcVBlank: QPC_TIME;
+
+    // DWM refresh count of the last vsync
+    // DWM refresh count is a 64bit number where zero is
+    // the first refresh the DWM woke up to process
+    cRefresh: DWM_FRAME_COUNT;
+
+    // DX refresh count at the last Vsync Interupt
+    // DX refresh count is a 32bit number with zero
+    // being the first refresh after the card was initialized
+    // DX increments a counter when ever a VSync ISR is processed
+    // It is possible for DX to miss VSyncs
+    //
+    // There is not a fixed mapping between DX and DWM refresh counts
+    // because the DX will rollover and may miss VSync interupts
+    cDXRefresh: UINT;
+
+    // QPC time at a compose time.
+    qpcCompose: QPC_TIME;
+
+    // Frame number that was composed at qpcCompose
+    cFrame: DWM_FRAME_COUNT;
+
+    // The present number DX uses to identify renderer frames
+    cDXPresent: UINT;
+
+    // Refresh count of the frame that was composed at qpcCompose
+    cRefreshFrame: DWM_FRAME_COUNT;
+
+
+    // DWM frame number that was last submitted
+    cFrameSubmitted: DWM_FRAME_COUNT;
+
+    // DX Present number that was last submitted
+    cDXPresentSubmitted: UINT;
+
+    // DWM frame number that was last confirmed presented
+    cFrameConfirmed: DWM_FRAME_COUNT;
+
+    // DX Present number that was last confirmed presented
+    cDXPresentConfirmed: UINT;
+
+    // The target refresh count of the last
+    // frame confirmed completed by the GPU
+    cRefreshConfirmed: DWM_FRAME_COUNT;
+
+    // DX refresh count when the frame was confirmed presented
+    cDXRefreshConfirmed: UINT;
+
+    // Number of frames the DWM presented late
+    // AKA Glitches
+    cFramesLate: DWM_FRAME_COUNT;
+
+    // the number of composition frames that
+    // have been issued but not confirmed completed
+    cFramesOutstanding: UINT;
+
+
+    // Following fields are only relavent when an HWND is specified
+    // Display frame
+
+
+    // Last frame displayed
+    cFrameDisplayed: DWM_FRAME_COUNT;
+
+    // QPC time of the composition pass when the frame was displayed
+    qpcFrameDisplayed: QPC_TIME;
+
+    // Count of the VSync when the frame should have become visible
+    cRefreshFrameDisplayed: DWM_FRAME_COUNT;
+
+    // Complete frames: DX has notified the DWM that the frame is done rendering
+
+    // ID of the the last frame marked complete (starts at 0)
+    cFrameComplete: DWM_FRAME_COUNT;
+
+    // QPC time when the last frame was marked complete
+    qpcFrameComplete: QPC_TIME;
+
+    // Pending frames:
+    // The application has been submitted to DX but not completed by the GPU
+
+    // ID of the the last frame marked pending (starts at 0)
+    cFramePending: DWM_FRAME_COUNT;
+
+    // QPC time when the last frame was marked pending
+    qpcFramePending: QPC_TIME;
+
+    // number of unique frames displayed
+    cFramesDisplayed: DWM_FRAME_COUNT;
+
+    // number of new completed frames that have been received
+    cFramesComplete: DWM_FRAME_COUNT;
+
+     // number of new frames submitted to DX but not yet complete
+    cFramesPending: DWM_FRAME_COUNT;
+
+    // number of frames available but not displayed, used or dropped
+    cFramesAvailable: DWM_FRAME_COUNT;
+
+    // number of rendered frames that were never
+    // displayed because composition occured too late
+    cFramesDropped: DWM_FRAME_COUNT;
+
+    // number of times an old frame was composed
+    // when a new frame should have been used
+    // but was not available
+    cFramesMissed: DWM_FRAME_COUNT;
+
+    // the refresh at which the next frame is
+    // scheduled to be displayed
+    cRefreshNextDisplayed: DWM_FRAME_COUNT;
+
+    // the refresh at which the next DX present is
+    // scheduled to be displayed
+    cRefreshNextPresented: DWM_FRAME_COUNT;
+
+    // The total number of refreshes worth of content
+    // for this HWND that have been displayed by the DWM
+    // since DwmSetPresentParameters was called
+    cRefreshesDisplayed: DWM_FRAME_COUNT;
+
+    // The total number of refreshes worth of content
+    // that have been presented by the application
+    // since DwmSetPresentParameters was called
+    cRefreshesPresented: DWM_FRAME_COUNT;
+
+
+    // The actual refresh # when content for this
+    // window started to be displayed
+    // it may be different than that requested
+    // DwmSetPresentParameters
+    cRefreshStarted: DWM_FRAME_COUNT;
+
+    // Total number of pixels DX redirected
+    // to the DWM.
+    // If Queueing is used the full buffer
+    // is transfered on each present.
+    // If not queuing it is possible only
+    // a dirty region is updated
+    cPixelsReceived: ULONGLONG;
+
+    // Total number of pixels drawn.
+    // Does not take into account if
+    // if the window is only partial drawn
+    // do to clipping or dirty rect management
+    cPixelsDrawn: ULONGLONG;
+
+    // The number of buffers in the flipchain
+    // that are empty.   An application can
+    // present that number of times and guarantee
+    // it won't be blocked waiting for a buffer to
+    // become empty to present to
+    cBuffersEmpty: DWM_FRAME_COUNT;
+
+  end;
+  DWM_TIMING_INFO = _DWM_TIMING_INFO;
+  TDWMTimingInfo = DWM_TIMING_INFO;
+
+const
+  // Use the first source frame that
+  // includes the first refresh of the output frame
+  DWM_SOURCE_FRAME_SAMPLING_POINT = 0;
+
+  // use the source frame that includes the most
+  // refreshes of out the output frame
+  // in case of multiple source frames with the
+  // same coverage the last will be used
+  DWM_SOURCE_FRAME_SAMPLING_COVERAGE = 1;
+
+     // Sentinel value
+  DWM_SOURCE_FRAME_SAMPLING_LAST = 2;
+
+const
+  c_DwmMaxQueuedBuffers = 8;
+  c_DwmMaxMonitors = 16;
+  c_DwmMaxAdapters = 16;
+
+type
+  _DWM_PRESENT_PARAMETERS = record
+    cbSize: LongWord;
+    fQueue: BOOL;
+    cRefreshStart: DWM_FRAME_COUNT;
+    cBuffer: UINT;
+    fUseSourceRate: BOOL;
+    rateSource: UNSIGNED_RATIO;
+    cRefreshesPerFrame: UINT;
+    eSampling: LongWord;
+  end;
+  DWM_PRESENT_PARAMETERS = _DWM_PRESENT_PARAMETERS;
+  TDWMPresentParameters = DWM_PRESENT_PARAMETERS;
+
+const
+  DWM_FRAME_DURATION_DEFAULT = -1;
+
+var
+  DwmDefWindowProc: function(hWnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM; out plResult: LRESULT): BOOL; stdcall;
+
+  DwmEnableBlurBehindWindow: function(hWnd: HWND; pBlurBehind: PDWM_BLURBEHIND): HRESULT; stdcall;
+
+const
+  DWM_EC_DISABLECOMPOSITION = 0;
+  DWM_EC_ENABLECOMPOSITION  = 1;
+
+var
+  DwmEnableComposition: function(uCompositionAction: UINT): HRESULT; stdcall;
+
+  DwmEnableMMCSS: function(fEnableMMCSS: BOOL): HRESULT; stdcall;
+
+  DwmExtendFrameIntoClientArea: function(hWnd: HWND; pMarInset: PMARGINS): HRESULT; stdcall;
+
+  DwmGetColorizationColor: function(out pcrColorization: DWORD; out pfOpaqueBlend: BOOL): HRESULT; stdcall;
+
+  DwmGetCompositionTimingInfo: function(hwnd: HWND; out pTimingInfo: DWM_TIMING_INFO): HRESULT; stdcall;
+
+  DwmGetWindowAttribute: function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall;
+
+  DwmIsCompositionEnabled: function(out pfEnabled: BOOL): HRESULT; stdcall;
+
+  DwmModifyPreviousDxFrameDuration: function(hwnd: HWND; cRefreshes: Integer; fRelative: BOOL): HRESULT; stdcall;
+
+  DwmQueryThumbnailSourceSize: function(hThumbnail: HTHUMBNAIL; out pSize: TSIZE): HRESULT; stdcall;
+
+  DwmRegisterThumbnail: function(hwndDestination: HWND; hwndSource: HWND; out phThumbnailId: HTHUMBNAIL): HRESULT; stdcall;
+
+  DwmSetDxFrameDuration: function(hwnd: HWND; cRefreshes: Integer): HRESULT; stdcall;
+
+  DwmSetPresentParameters: function(hwnd: HWND; var pPresentParams: DWM_PRESENT_PARAMETERS): HRESULT; stdcall;
+
+  DwmSetWindowAttribute: function(hwnd: HWND; dwAttribute: DWORD; pvAttribute: Pointer; cbAttribute: DWORD): HRESULT; stdcall;
+
+  DwmUnregisterThumbnail: function(hThumbnailId: HTHUMBNAIL): HRESULT; stdcall;
+
+  DwmUpdateThumbnailProperties: function(hThumbnailId: HTHUMBNAIL; ptnProperties: PDWM_THUMBNAIL_PROPERTIES): HRESULT; stdcall;
+
+// if(_WIN32_WINNT >= 0x0601)
+const
+  DWM_SIT_DISPLAYFRAME = $00000001; // Display a window frame around the provided bitmap
+
+var
+  DwmSetIconicThumbnail: function(hwnd: HWND; hbmp: HBITMAP; dwSITFlags: DWORD): HRESULT; stdcall;
+
+  DwmSetIconicLivePreviewBitmap: function(hwnd: HWND; hbmp: HBITMAP; var ptClient: PPOINT; dwSITFlags: DWORD): HRESULT; stdcall;
+
+  DwmInvalidateIconicBitmaps: function(hwnd: HWND): HRESULT; stdcall;
+
+// endif /* _WIN32_WINNT >= 0x0601 */
+
+var
+  DwmAttachMilContent: function(hwnd: HWND): HRESULT; stdcall;
+
+  DwmDetachMilContent: function(hwnd: HWND): HRESULT; stdcall;
+
+  DwmFlush: function(): HRESULT; stdcall;
+
+type
+  _MilMatrix3x2D = record
+    S_11: DOUBLE;
+    S_12: DOUBLE;
+    S_21: DOUBLE;
+    S_22: DOUBLE;
+    DX: DOUBLE;
+    DY: DOUBLE;
+  end;
+  MilMatrix3x2D = _MilMatrix3x2D;
+  TMilMatrix3x2D = MilMatrix3x2D;
+
+var
+  DwmGetGraphicsStreamTransformHint: function(uIndex: UINT; out pTransform: MilMatrix3x2D): HRESULT; stdcall;
+
+  DwmGetGraphicsStreamClient: function(uIndex: UINT; out pClientUuid: TGUID): HRESULT; stdcall;
+
+  DwmGetTransportAttributes: function(out pfIsRemoting: BOOL; out pfIsConnected: BOOL; out pDwGeneration: DWORD): HRESULT; stdcall;
+
+implementation
+
+const
+  dwmlib = 'dwmapi.dll';
+
+var
+  DwmLibrary: THandle;
+  ReferenceCount: Integer;  // We have to keep track of several load/unload calls.
+
+procedure FreeDwmLibrary;
+begin
+  if ReferenceCount > 0 then
+    Dec(ReferenceCount);
+
+  if (DwmLibrary <> 0) and (ReferenceCount = 0) then
+  begin
+    FreeLibrary(DwmLibrary);
+    DwmLibrary := 0;
+
+    DwmDefWindowProc := nil;
+    DwmEnableBlurBehindWindow := nil;
+    DwmEnableComposition := nil;
+    DwmEnableMMCSS := nil;
+    DwmExtendFrameIntoClientArea := nil;
+    DwmGetColorizationColor := nil;
+    DwmGetCompositionTimingInfo := nil;
+    DwmGetWindowAttribute := nil;
+    DwmIsCompositionEnabled := nil;
+    DwmModifyPreviousDxFrameDuration := nil;
+    DwmQueryThumbnailSourceSize := nil;
+    DwmRegisterThumbnail := nil;
+    DwmSetDxFrameDuration := nil;
+    DwmSetPresentParameters := nil;
+    DwmSetWindowAttribute := nil;
+    DwmUnregisterThumbnail := nil;
+    DwmUpdateThumbnailProperties := nil;
+    DwmAttachMilContent := nil;
+    DwmDetachMilContent := nil;
+    DwmFlush := nil;
+    DwmGetGraphicsStreamTransformHint := nil;
+    DwmGetGraphicsStreamClient := nil;
+    DwmGetTransportAttributes := nil;
+
+    DwmSetIconicThumbnail := nil;
+    DwmSetIconicLivePreviewBitmap := nil;
+    DwmInvalidateIconicBitmaps := nil;
+  end;
+end;
+
+//----------------------------------------------------------------------------------------------------------------------
+
+function InitDwmLibrary: Boolean;
+begin
+  Inc(ReferenceCount);
+
+  if DwmLibrary = 0 then
+  begin
+    DwmLibrary := LoadLibrary(dwmlib);
+    if DwmLibrary > 0 then
+    begin
+      // windows vista
+      Pointer(DwmDefWindowProc) := GetProcAddress(DwmLibrary, 'DwmDefWindowProc');
+      Pointer(DwmEnableBlurBehindWindow) := GetProcAddress(DwmLibrary, 'DwmEnableBlurBehindWindow');
+      Pointer(DwmEnableComposition) := GetProcAddress(DwmLibrary, 'DwmEnableComposition');
+      Pointer(DwmEnableMMCSS) := GetProcAddress(DwmLibrary, 'DwmEnableMMCSS');
+      Pointer(DwmExtendFrameIntoClientArea) := GetProcAddress(DwmLibrary, 'DwmExtendFrameIntoClientArea');
+      Pointer(DwmGetColorizationColor) := GetProcAddress(DwmLibrary, 'DwmGetColorizationColor');
+      Pointer(DwmGetCompositionTimingInfo) := GetProcAddress(DwmLibrary, 'DwmGetCompositionTimingInfo');
+      Pointer(DwmGetWindowAttribute) := GetProcAddress(DwmLibrary, 'DwmGetWindowAttribute');
+      Pointer(DwmIsCompositionEnabled) := GetProcAddress(DwmLibrary, 'DwmIsCompositionEnabled');
+      Pointer(DwmModifyPreviousDxFrameDuration) := GetProcAddress(DwmLibrary, 'DwmModifyPreviousDxFrameDuration');
+      Pointer(DwmQueryThumbnailSourceSize) := GetProcAddress(DwmLibrary, 'DwmQueryThumbnailSourceSize');
+      Pointer(DwmRegisterThumbnail) := GetProcAddress(DwmLibrary, 'DwmRegisterThumbnail');
+      Pointer(DwmSetDxFrameDuration) := GetProcAddress(DwmLibrary, 'DwmSetDxFrameDuration');
+      Pointer(DwmSetPresentParameters) := GetProcAddress(DwmLibrary, 'DwmSetPresentParameters');
+      Pointer(DwmSetWindowAttribute) := GetProcAddress(DwmLibrary, 'DwmSetWindowAttribute');
+      Pointer(DwmUnregisterThumbnail) := GetProcAddress(DwmLibrary, 'DwmUnregisterThumbnail');
+      Pointer(DwmUpdateThumbnailProperties) := GetProcAddress(DwmLibrary, 'DwmUpdateThumbnailProperties');
+      Pointer(DwmAttachMilContent) := GetProcAddress(DwmLibrary, 'DwmAttachMilContent');
+      Pointer(DwmDetachMilContent) := GetProcAddress(DwmLibrary, 'DwmDetachMilContent');
+      Pointer(DwmFlush) := GetProcAddress(DwmLibrary, 'DwmFlush');
+      Pointer(DwmGetGraphicsStreamTransformHint) := GetProcAddress(DwmLibrary, 'DwmGetGraphicsStreamTransformHint');
+      Pointer(DwmGetGraphicsStreamClient) := GetProcAddress(DwmLibrary, 'DwmGetGraphicsStreamClient');
+      Pointer(DwmGetTransportAttributes) := GetProcAddress(DwmLibrary, 'DwmGetTransportAttributes');
+
+      // windows 7
+      Pointer(DwmSetIconicThumbnail) := GetProcAddress(DwmLibrary, 'DwmSetIconicThumbnail');
+      Pointer(DwmSetIconicLivePreviewBitmap) := GetProcAddress(DwmLibrary, 'DwmSetIconicLivePreviewBitmap');
+      Pointer(DwmInvalidateIconicBitmaps) := GetProcAddress(DwmLibrary, 'DwmInvalidateIconicBitmaps');
+    end;
+  end;
+  Result := DwmLibrary > 0;
+end;
+
+function DwmCompositionEnabled: Boolean;
+var
+  B: BOOL;
+begin
+  Result := DwmLibrary > 0;
+  if Result then
+    Result := (DwmIsCompositionEnabled(B) = S_OK) and B;
+end;
+
+initialization
+  ReferenceCount := 0;
+
+finalization
+  while ReferenceCount > 0 do
+    FreeDwmLibrary;
+
+end.