* synchronised with trunk till r42189

git-svn-id: branches/debug_eh@42190 -

.gitattributes

@@ -1947,6 +1947,7 @@ packages/fcl-base/examples/databom.txt svneol=native#text/plain
 packages/fcl-base/examples/dbugsrv.pp svneol=native#text/plain
 packages/fcl-base/examples/debugtest.pp svneol=native#text/plain
 packages/fcl-base/examples/decodeascii85.pp svneol=native#text/plain
+packages/fcl-base/examples/demoio.pp svneol=native#text/plain
 packages/fcl-base/examples/dobserver.pp svneol=native#text/plain
 packages/fcl-base/examples/doecho.pp svneol=native#text/plain
 packages/fcl-base/examples/dparser.pp svneol=native#text/plain
@@ -1996,6 +1997,7 @@ packages/fcl-base/examples/stringl.pp svneol=native#text/plain
 packages/fcl-base/examples/tarmakercons.pas svneol=native#text/plain
 packages/fcl-base/examples/tarmakerconsgzip.pas svneol=native#text/plain
 packages/fcl-base/examples/testapp.pp svneol=native#text/plain
+packages/fcl-base/examples/testappexit.pp svneol=native#text/plain
 packages/fcl-base/examples/testbf.pp svneol=native#text/plain
 packages/fcl-base/examples/testbs.pp svneol=native#text/plain
 packages/fcl-base/examples/testcgi.html -text
@@ -12037,6 +12039,13 @@ tests/test/cg/obj/haiku/i386/tcext3.o -text
 tests/test/cg/obj/haiku/i386/tcext4.o -text
 tests/test/cg/obj/haiku/i386/tcext5.o -text
 tests/test/cg/obj/haiku/i386/tcext6.o -text
+tests/test/cg/obj/haiku/x86_64/cpptcl1.o -text
+tests/test/cg/obj/haiku/x86_64/cpptcl2.o -text
+tests/test/cg/obj/haiku/x86_64/ctest.o -text
+tests/test/cg/obj/haiku/x86_64/tcext3.o -text
+tests/test/cg/obj/haiku/x86_64/tcext4.o -text
+tests/test/cg/obj/haiku/x86_64/tcext5.o -text
+tests/test/cg/obj/haiku/x86_64/tcext6.o -text
 tests/test/cg/obj/linux/aarch64/cpptcl1.o -text
 tests/test/cg/obj/linux/aarch64/cpptcl2.o -text
 tests/test/cg/obj/linux/aarch64/ctest.o -text
@@ -16628,6 +16637,7 @@ tests/webtbs/tw35187.pp svneol=native#text/pascal
 tests/webtbs/tw35224.pp svneol=native#text/plain
 tests/webtbs/tw3523.pp svneol=native#text/plain
 tests/webtbs/tw35233.pp svneol=native#text/plain
+tests/webtbs/tw35272.pp svneol=native#text/plain
 tests/webtbs/tw3529.pp svneol=native#text/plain
 tests/webtbs/tw3531.pp svneol=native#text/plain
 tests/webtbs/tw3533.pp svneol=native#text/plain

compiler/arm/armins.dat

@@ -321,6 +321,7 @@ reg32,memam2              \x17\x04\x50                   ARM32,ARMv4
 reglo,memam3              \x65\x58\x0\2                  THUMB,ARMv4T
 reglo,memam4              \x66\x68\x0\2                  THUMB,ARMv4T
 reglo,memam5              \x67\x98\x0\2                  THUMB,ARMv4T
+reglo,memam2              \x67\x98\x0\2                  THUMB,ARMv4T
 reglo,memam6              \x67\x48\x0\2                  THUMB,ARMv4T
 reg32,memam2              \x88\xF8\x50\x0\x0\0           THUMB32,WIDE,ARMv6T2
 reg32,memam2              \x17\x04\x10                   ARM32,ARMv4
@@ -543,6 +544,7 @@ reg32,reglist		          \x26\x80			   ARM32,ARMv4
 reglo,memam3                \x65\x50\x0\2                  THUMB,ARMv4T
 reglo,memam4                \x66\x60\x0\2                  THUMB,ARMv4T
 reglo,memam5                \x67\x90\x0\2                  THUMB,ARMv4T
+reglo,memam2                \x67\x90\x0\2                  THUMB,ARMv4T
 reg32,memam2                \x88\xF8\x40\x0\x0\0           THUMB32,WIDE,ARMv6T2
 reg32,memam2                \x17\x04\x00                   ARM32,ARMv4
 

compiler/arm/armnop.inc

@@ -1,2 +1,2 @@
 { don't edit, this file is generated from armins.dat }
-959;
+961;

compiler/arm/armtab.inc

@@ -1043,6 +1043,13 @@
     code    : #103#152#0#2;
     flags   : if_thumb or if_armv4t
   ),
+  (
+    opcode  : A_LDR;
+    ops     : 2;
+    optypes : (ot_reglo,ot_memoryam2,ot_none,ot_none,ot_none,ot_none);
+    code    : #103#152#0#2;
+    flags   : if_thumb or if_armv4t
+  ),
   (
     opcode  : A_LDR;
     ops     : 2;
@@ -2016,6 +2023,13 @@
     code    : #103#144#0#2;
     flags   : if_thumb or if_armv4t
   ),
+  (
+    opcode  : A_STR;
+    ops     : 2;
+    optypes : (ot_reglo,ot_memoryam2,ot_none,ot_none,ot_none,ot_none);
+    code    : #103#144#0#2;
+    flags   : if_thumb or if_armv4t
+  ),
   (
     opcode  : A_STR;
     ops     : 2;

compiler/arm/narmmat.pas

@@ -164,7 +164,7 @@ implementation
                       cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SAR,OS_INT,31,numerator,helper1);
                     if GenerateThumbCode then
                       begin
-                        cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,OS_INT,32-power,helper1);
+                        cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,32-power,helper1);
                         current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_ADD,helper2,numerator,helper1));
                       end
                     else
@@ -179,9 +179,12 @@ implementation
                else
                  cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SHR,OS_INT,power,numerator,resultreg)
              end
-           else {Everything else is handled the generic code}
+           else if CPUARM_HAS_UMULL in cpu_capabilities[current_settings.cputype] then
+             {Everything else is handled the generic code}
              cg.g_div_const_reg_reg(current_asmdata.CurrAsmList,def_cgsize(resultdef),
-               tordconstnode(right).value.svalue,numerator,resultreg);
+               tordconstnode(right).value.svalue,numerator,resultreg)
+           else
+             internalerror(2019012601);
          end;
 
 {
@@ -286,8 +289,7 @@ implementation
                 resultreg:=cg.getintregister(current_asmdata.CurrAsmList,size);
               end;
 
-            if (right.nodetype=ordconstn) and
-               (CPUARM_HAS_UMULL in cpu_capabilities[current_settings.cputype]) then
+            if (right.nodetype=ordconstn) then
               begin
                 if nodetype=divn then
                   genOrdConstNodeDiv

compiler/avr/aoptcpu.pas

@@ -42,6 +42,8 @@ Type
     function RegLoadedWithNewValue(reg : tregister; hp : tai) : boolean; override;
     function InstructionLoadsFromReg(const reg : TRegister; const hp : tai) : boolean; override;
 
+    function InvertSkipInstruction(var p: tai): boolean;
+
     { uses the same constructor as TAopObj }
     function PeepHoleOptPass1Cpu(var p: tai): boolean; override;
     procedure PeepHoleOptPass2;override;
@@ -225,6 +227,71 @@ Implementation
         end;
     end;
 
+
+  {
+    Turns
+      sbis ?
+      jmp .Lx
+      op
+    .Lx:
+
+    Into
+      sbic ?
+      op
+
+    For all types of skip instructions
+  }
+  function TCpuAsmOptimizer.InvertSkipInstruction(var p: tai): boolean;
+
+    function GetNextInstructionWithoutLabel(p: tai; var next: tai): boolean;
+      begin
+        repeat
+          result:=GetNextInstruction(p,next);
+          p:=next;
+        until
+          (not result) or
+          (not assigned(next)) or
+          (next.typ in [ait_instruction]);
+
+        result:=assigned(next) and (next.typ in [ait_instruction]);
+      end;
+
+    var
+      hp1, hp2, hp3: tai;
+      s: string;
+    begin
+      result:=false;
+
+      if GetNextInstruction(taicpu(p),hp1) and
+        (hp1.typ=ait_instruction) and
+        (taicpu(hp1).opcode in [A_RJMP,A_JMP]) and
+        (taicpu(hp1).ops=1) and
+        (taicpu(hp1).oper[0]^.typ=top_ref) and
+        (taicpu(hp1).oper[0]^.ref^.offset=0) and
+        (taicpu(hp1).oper[0]^.ref^.symbol is TAsmLabel) and
+        GetNextInstructionWithoutLabel(hp1,hp2) and
+        (hp2.typ=ait_instruction) and
+        (not taicpu(hp2).is_jmp) and
+        GetNextInstruction(hp2,hp3) and
+        FindLabel(TAsmLabel(taicpu(hp1).oper[0]^.ref^.symbol),hp3) then
+        begin
+          DebugMsg('SkipJump2InvertedSkip', p);
+
+          case taicpu(p).opcode of
+            A_SBIS: taicpu(p).opcode:=A_SBIC;
+            A_SBIC: taicpu(p).opcode:=A_SBIS;
+            A_SBRS: taicpu(p).opcode:=A_SBRC;
+            A_SBRC: taicpu(p).opcode:=A_SBRS;
+          end;
+
+          TAsmLabel(taicpu(hp1).oper[0]^.ref^.symbol).decrefs;
+
+          asml.remove(hp1);
+          hp1.free;
+        end;
+    end;
+
+
   function TCpuAsmOptimizer.PeepHoleOptPass1Cpu(var p: tai): boolean;
     var
       hp1,hp2,hp3,hp4,hp5: tai;
@@ -520,6 +587,9 @@ Implementation
 
                         result:=true;
                       end;
+
+                    if InvertSkipInstruction(p) then
+                      result:=true;
                   end;
                 A_ANDI:
                   begin
@@ -810,7 +880,7 @@ Implementation
                        (MatchInstruction(hp1,[A_PUSH,A_MOV,A_CP,A_CPC,A_ADD,A_SUB,A_ADC,A_SBC,A_EOR,A_AND,A_OR,
                                                A_OUT,A_IN]) or
                        { the reference register of ST/STD cannot be replaced }
-                       (MatchInstruction(hp1,[A_STD,A_ST]) and (MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^)))) and
+                       (MatchInstruction(hp1,[A_STD,A_ST,A_STS]) and (MatchOperand(taicpu(p).oper[0]^,taicpu(hp1).oper[1]^)))) and
                        (not RegModifiedByInstruction(taicpu(p).oper[0]^.reg, hp1)) and
                        {(taicpu(hp1).ops=1) and
                        (taicpu(hp1).oper[0]^.typ = top_reg) and
@@ -1023,33 +1093,8 @@ Implementation
                           op
                         .L1:
                     }
-                    if GetNextInstruction(p, hp1) and
-                       (hp1.typ=ait_instruction) and
-                       (taicpu(hp1).opcode in [A_JMP,A_RJMP]) and
-                       (taicpu(hp1).ops>0) and
-                       (taicpu(hp1).oper[0]^.typ = top_ref) and
-                       (taicpu(hp1).oper[0]^.ref^.symbol is TAsmLabel) and
-                       GetNextInstruction(hp1, hp2) and
-                       (hp2.typ=ait_instruction) and
-                       (not taicpu(hp2).is_jmp) and
-                       GetNextInstruction(hp2, hp3) and
-                       (hp3.typ=ait_label) and
-                       (taicpu(hp1).oper[0]^.ref^.symbol=tai_label(hp3).labsym) then
-                      begin
-                        DebugMsg('Peephole SbiJmp2Sbi performed',p);
-
-                        if taicpu(p).opcode=A_SBIC then
-                          taicpu(p).opcode:=A_SBIS
-                        else
-                          taicpu(p).opcode:=A_SBIC;
-
-                        tai_label(hp3).labsym.decrefs;
-
-                        AsmL.remove(hp1);
-                        taicpu(hp1).Free;
-
-                        result:=true;
-                      end
+                    if InvertSkipInstruction(p) then
+                      result:=true
                     {
                       Turn
                           sbiX X, y

compiler/avr/cgcpu.pas

@@ -274,8 +274,9 @@ unit cgcpu;
                   begin
                     load_para_loc(r,hp);
 
-                    for i2:=1 to tcgsize2size[hp^.Size] do
-                      r:=GetNextReg(r);
+                    if i<tcgsize2size[cgpara.Size] then
+                      for i2:=1 to tcgsize2size[hp^.Size] do
+                        r:=GetNextReg(r);
 
                     hp:=hp^.Next;
                   end;

compiler/cfileutl.pas

@@ -1284,8 +1284,16 @@ end;
 
 
    function  FindExe(const bin:TCmdStr;allowcache:boolean;var foundfile:TCmdStr):boolean;
+     var
+       b : TCmdStr;
      begin
-       FindExe:=FindFileInExeLocations(ChangeFileExt(bin,source_info.exeext),allowcache,foundfile);
+       { change extension only on platforms that use an exe extension, otherwise on OpenBSD
+         'ld.bfd' gets converted to 'ld' }
+       if source_info.exeext<>'' then
+         b:=ChangeFileExt(bin,source_info.exeext)
+       else
+         b:=bin;
+       FindExe:=FindFileInExeLocations(b,allowcache,foundfile);
      end;
 
 

compiler/hlcgobj.pas

@@ -1416,12 +1416,57 @@ implementation
   procedure thlcgobj.a_load_subsetref_reg(list: TAsmList; fromsubsetsize, tosize: tdef; const sref: tsubsetreference; destreg: tregister);
     var
       tmpref: treference;
-      valuereg,extra_value_reg: tregister;
+      valuereg,extra_value_reg, tmpreg: tregister;
       tosreg: tsubsetregister;
       loadsize: torddef;
       loadbitsize: byte;
       extra_load: boolean;
+      tmpsref: tsubsetreference;
     begin
+      if sref.bitlen>AIntBits then
+        begin
+          tmpsref:=sref;
+          tmpsref.bitlen:=AIntBits;
+          valuereg:=hlcg.getintregister(list,tosize);
+          a_load_subsetref_reg(list,sinttype,tosize,tmpsref,valuereg);
+          tmpsref.bitlen:=sref.bitlen-AIntBits;
+          inc(tmpsref.ref.offset,AIntBits div 8);
+          extra_value_reg:=hlcg.getintregister(list,tosize);
+          a_load_subsetref_reg(list,sinttype,tosize,tmpsref,extra_value_reg);
+          { can't use a_load_reg_subsetreg to merge the results, as that one
+            does not support sizes > AIntBits either }
+          tmpreg:=hlcg.getintregister(list,tosize);
+          if target_info.endian=endian_big then
+            begin
+              a_op_const_reg_reg(list,OP_SHL,tosize,sref.bitlen-AIntBits,valuereg,tmpreg);
+              if is_signed(fromsubsetsize) then
+                begin
+                  valuereg:=tmpreg;
+                  tmpreg:=hlcg.getintregister(list,tosize);
+                  a_op_const_reg_reg(list,OP_AND,tosize,(tcgint(1) shl (sref.bitlen-AIntBits))-1,extra_value_reg,tmpreg);
+                  valuereg:=tmpreg;
+                end
+            end
+          else
+            begin
+              a_op_const_reg_reg(list,OP_SHL,tosize,AIntBits,extra_value_reg,tmpreg);
+              if is_signed(fromsubsetsize) then
+                begin
+                  extra_value_reg:=hlcg.getintregister(list,tosize);
+                  a_op_const_reg_reg(list,OP_AND,tosize,(tcgint(1) shl AIntBits)-1,valuereg,extra_value_reg);
+                  valuereg:=extra_value_reg;
+                end
+            end;
+          if is_signed(fromsubsetsize) then
+            begin
+              extra_value_reg:=hlcg.getintregister(list,tosize);
+              a_op_const_reg_reg(list,OP_AND,tosize,(tcgint(1) shl AIntBits)-1,valuereg,extra_value_reg);
+              valuereg:=extra_value_reg;
+            end;
+          a_op_reg_reg_reg(list,OP_OR,tosize,valuereg,tmpreg,destreg);
+          exit;
+        end;
+
       get_subsetref_load_info(sref,loadsize,extra_load);
       loadbitsize:=loadsize.size*8;
 
@@ -1512,7 +1557,37 @@ implementation
     end;
 
   procedure thlcgobj.a_load_reg_subsetref(list: TAsmList; fromsize, tosubsetsize: tdef; fromreg: tregister; const sref: tsubsetreference);
+    var
+      tmpsref: tsubsetreference;
+      fromreg1: tregister;
     begin
+      if sref.bitlen>AIntBits then
+        begin
+          if ((sref.bitlen mod AIntBits)<>0) then
+            internalerror(2019052901);
+          tmpsref:=sref;
+          tmpsref.bitlen:=AIntBits;
+          fromreg1:=hlcg.getintregister(list,uinttype);
+          a_load_reg_reg(list,fromsize,uinttype,fromreg,fromreg1);
+          if target_info.endian=endian_big then
+            begin
+              inc(tmpsref.ref.offset,sref.bitlen-AIntBits);
+            end;
+          a_load_reg_subsetref(list,uinttype,uinttype,fromreg1,tmpsref);
+          if target_info.endian=endian_big then
+            begin
+              tmpsref.ref.offset:=sref.ref.offset;
+            end
+          else
+            begin
+              inc(tmpsref.ref.offset,AIntBits div 8);
+            end;
+          tmpsref.bitlen:=sref.bitlen-AIntBits;
+          fromreg1:=hlcg.getintregister(list,fromsize);
+          hlcg.a_op_const_reg_reg(list,OP_SHR,fromsize,AIntBits,fromreg,fromreg1);
+          a_load_reg_subsetref(list,fromsize,tosubsetsize,fromreg1,tmpsref);
+          exit;
+        end;
       a_load_regconst_subsetref_intern(list,fromsize,tosubsetsize,fromreg,sref,SL_REG);
     end;
 
@@ -1545,9 +1620,37 @@ implementation
 
   procedure thlcgobj.a_load_const_subsetref(list: TAsmlist; tosubsetsize: tdef; a: tcgint; const sref: tsubsetreference);
     var
+      tmpref: treference;
+      tmpsref: tsubsetreference;
       tmpreg: tregister;
       slopt: tsubsetloadopt;
+      newdef: tdef;
+      newbytesize: longint;
+      loval, hival: longint;
     begin
+      if sref.bitlen>AIntBits then
+        begin
+          if ((sref.bitlen mod AIntBits)<>0) then
+            internalerror(2019052901);
+          tmpsref:=sref;
+          tmpsref.bitlen:=AIntBits;
+          if target_info.endian=endian_big then
+            begin
+              inc(tmpsref.ref.offset,sref.bitlen-AIntBits);
+            end;
+          a_load_const_subsetref(list,tosubsetsize,aint(a),tmpsref);
+          if target_info.endian=endian_big then
+            begin
+              tmpsref.ref.offset:=sref.ref.offset;
+            end
+          else
+            begin
+              inc(tmpsref.ref.offset,AIntBits div 8);
+            end;
+          tmpsref.bitlen:=sref.bitlen-AIntBits;
+          a_load_const_subsetref(list,tosubsetsize,a shr AIntBits,tmpsref);
+          exit;
+        end;
       { perform masking of the source value in advance }
       slopt:=SL_REGNOSRCMASK;
       if (sref.bitlen<>AIntBits) then

compiler/link.pas

@@ -691,10 +691,20 @@ Implementation
         if cs_link_on_target in current_settings.globalswitches then
           begin
             { If linking on target, don't add any path PM }
-            FindUtil:=ChangeFileExt(s,target_info.exeext);
+            { change extension only on platforms that use an exe extension, otherwise on OpenBSD 'ld.bfd' gets
+              converted to 'ld' }
+            if target_info.exeext<>'' then
+              FindUtil:=ChangeFileExt(s,target_info.exeext)
+            else
+              FindUtil:=s;
             exit;
           end;
-        UtilExe:=ChangeFileExt(s,source_info.exeext);
+        { change extension only on platforms that use an exe extension, otherwise on OpenBSD 'ld.bfd' gets converted
+          to 'ld' }
+        if source_info.exeext<>'' then
+          UtilExe:=ChangeFileExt(s,source_info.exeext)
+        else
+          UtilExe:=s;
         FoundBin:='';
         Found:=false;
         if utilsdirectory<>'' then

compiler/llvm/hlcgllvm.pas

@@ -1102,35 +1102,6 @@ implementation
       invert: boolean;
       fallthroughlab, falselab, tmplab: tasmlabel;
     begin
-      { since all comparisons return their results in a register, we'll often
-        get comparisons against true/false -> optimise }
-      if (size=pasbool1type) and
-         (cmp_op in [OC_EQ,OC_NE]) then
-        begin
-          { convert to an llvmbool1type and use directly }
-          tmpreg:=getintregister(list,llvmbool1type);
-          a_load_reg_reg(list,size,llvmbool1type,reg,tmpreg);
-          case cmp_op of
-            OC_EQ:
-              invert:=a=0;
-            OC_NE:
-              invert:=a=1;
-            else
-              { avoid uninitialised warning }
-              internalerror(2015031504);
-            end;
-          current_asmdata.getjumplabel(falselab);
-          fallthroughlab:=falselab;
-          if invert then
-            begin
-              tmplab:=l;
-              l:=falselab;
-              falselab:=tmplab;
-            end;
-          list.concat(taillvm.op_size_reg_lab_lab(la_br,llvmbool1type,tmpreg,l,falselab));
-          a_label(list,fallthroughlab);
-          exit;
-        end;
       tmpreg:=getregisterfordef(list,size);
       a_load_const_reg(list,size,a,tmpreg);
       a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);

compiler/nadd.pas

@@ -1650,6 +1650,40 @@ implementation
                   andn,
                   orn:
                     begin
+                      { in case of xor, or 'and' with full  and cbool: convert both to Pascal bool and then
+                        perform the xor/and to prevent issues with "longbool(1) and/xor
+                        longbool(2)" }
+                      if (is_cbool(ld) or is_cbool(rd)) and
+                         ((nodetype=xorn) or
+                          ((nodetype=andn) and
+                           ((cs_full_boolean_eval in current_settings.localswitches) or
+                            not(nf_short_bool in flags)
+                           )
+                          )
+                         ) then
+                        begin
+                          resultdef:=nil;
+                          if is_cbool(ld) then
+                            begin
+                              inserttypeconv(left,pasbool8type);
+                              ttypeconvnode(left).convtype:=tc_bool_2_bool;
+                              if not is_cbool(rd) or
+                                 (ld.size>=rd.size) then
+                                resultdef:=ld;
+                            end;
+                          if is_cbool(rd) then
+                            begin
+                              inserttypeconv(right,pasbool8type);
+                              ttypeconvnode(right).convtype:=tc_bool_2_bool;
+                              if not assigned(resultdef) then
+                                resultdef:=rd;
+                            end;
+                          result:=ctypeconvnode.create_explicit(caddnode.create(nodetype,left,right),resultdef);
+                          ttypeconvnode(result).convtype:=tc_bool_2_bool;
+                          left:=nil;
+                          right:=nil;
+                          exit;
+                        end;
                       { Make sides equal to the largest boolean }
                       if (torddef(left.resultdef).size>torddef(right.resultdef).size) or
                         (is_cbool(left.resultdef) and not is_cbool(right.resultdef)) then

compiler/ogomf.pas

@@ -316,6 +316,53 @@ interface
         property MZFlatContentSection: TMZExeSection read GetMZFlatContentSection;
       end;
 
+      TNewExeHeaderFlag = (
+        nehfSingleData,                                               { bit  0 }
+        nehfMultipleData,                                             { bit  1 }
+        { 'Global initialization' according to BP7's TDUMP.EXE                 }
+        nehfRealMode,                                                 { bit  2 }
+        nehfProtectedModeOnly,                                        { bit  3 }
+        { 'EMSDIRECT' according to OpenWatcom's wdump                          }
+        { '8086 instructions' according to Ralf Brown's Interrupt List         }
+        nehfReserved4,                                                { bit  4 }
+        { 'EMSBANK' according to OpenWatcom's wdump                            }
+        { '80286 instructions' according to Ralf Brown's Interrupt List        }
+        nehfReserved5,                                                { bit  5 }
+        { 'EMSGLOBAL' according to OpenWatcom's wdump                          }
+        { '80386 instructions' according to Ralf Brown's Interrupt List        }
+        nehfReserved6,                                                { bit  6 }
+        nehfNeedsFPU,                                                 { bit  7 }
+        { Not compatible with windowing API                                    }
+        nehfNotWindowAPICompatible,                                   { bit  8 }
+        { Compatible with windowing API                                        }
+        { (NotWindowAPICompatible + WindowAPICompatible) = Uses windowing API  }
+        nehfWindowAPICompatible,                                      { bit  9 }
+        { Family Application (OS/2) according to Ralf Brown's Interrupt List   }
+        nehfReserved10,                                               { bit 10 }
+        nehfSelfLoading,                                              { bit 11 }
+        nehfReserved12,                                               { bit 12 }
+        nehfLinkErrors,                                               { bit 13 }
+        nehfReserved14,                                               { bit 14 }
+        nehfIsDLL);                                                   { bit 15 }
+      TNewExeHeaderFlags = set of TNewExeHeaderFlag;
+
+      TNewExeAdditionalHeaderFlag = (
+        neahfLFNSupport,                                              { bit  0 }
+        neahfWindows2ProtectedMode,                                   { bit  1 }
+        neahfWindows2ProportionalFonts,                               { bit  2 }
+        neahfHasGangloadArea);                                        { bit  3 }
+      TNewExeAdditionalHeaderFlags = set of TNewExeAdditionalHeaderFlag;
+
+      TNewExeTargetOS = (
+        netoUnknown                        = $00,
+        netoOS2                            = $01,
+        netoWindows                        = $02,
+        netoMultitaskingMsDos4             = $03,
+        netoWindows386                     = $04,
+        netoBorlandOperatingSystemServices = $05,
+        netoPharLap286DosExtenderOS2       = $81,
+        netoPharLap286DosExtenderWindows   = $82);
+
       TOmfAssembler = class(tinternalassembler)
         constructor create(info: pasminfo; smart:boolean);override;
       end;

compiler/symdef.pas

@@ -3074,7 +3074,7 @@ implementation
                   system_x86_64_linux,system_x86_64_freebsd,
                   system_x86_64_openbsd,system_x86_64_netbsd,
                   system_x86_64_solaris,system_x86_64_embedded,
-                  system_x86_64_dragonfly] then
+                  system_x86_64_dragonfly,system_x86_64_haiku] then
                savesize:=16
              else
                savesize:=12;

compiler/systems/t_bsd.pas

@@ -165,7 +165,11 @@ procedure TLinkerBSD.SetDefaultInfo;
 {
   This will also detect which libc version will be used
 }
+var
+  LdProgram: string='ld';
 begin
+  if target_info.system in systems_openbsd then
+    LdProgram:='ld.bfd';
   LibrarySuffix:=' ';
   LdSupportsNoResponseFile := (target_info.system in ([system_m68k_netbsd]+systems_darwin));
   with Info do
@@ -174,8 +178,8 @@ begin
        begin
          if not(target_info.system in systems_darwin) then
            begin
-             ExeCmd[1]:='ld $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -L. -o $EXE $CATRES $FILELIST';
-             DllCmd[1]:='ld $TARGET $EMUL $OPT $MAP $LTO $ORDERSYMS -shared -L. -o $EXE $CATRES $FILELIST'
+             ExeCmd[1]:=LdProgram+' $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -L. -o $EXE $CATRES $FILELIST';
+             DllCmd[1]:=LdProgram+' $TARGET $EMUL $OPT $MAP $LTO $ORDERSYMS -shared -L. -o $EXE $CATRES $FILELIST'
            end
          else
            begin
@@ -194,22 +198,22 @@ begin
                programs with problems that require Valgrind will have more
                than 60KB of data (first 4KB of address space is always invalid)
              }
-               ExeCmd[1]:='ld $PRTOBJ $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST';
+             ExeCmd[1]:=LdProgram+' $PRTOBJ $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST';
              if not(cs_gdb_valgrind in current_settings.globalswitches) then
                ExeCmd[1]:=ExeCmd[1]+' -pagezero_size 0x10000';
 {$else ndef cpu64bitaddr}
-             ExeCmd[1]:='ld $PRTOBJ $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST';
+             ExeCmd[1]:=LdProgram+' $PRTOBJ $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST';
 {$endif ndef cpu64bitaddr}
              if (apptype<>app_bundle) then
-               DllCmd[1]:='ld $PRTOBJ $TARGET $EMUL $OPT $GCSECTIONS $MAP $LTO $ORDERSYMS -dynamic -dylib -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST'
+               DllCmd[1]:=LdProgram+' $PRTOBJ $TARGET $EMUL $OPT $GCSECTIONS $MAP $LTO $ORDERSYMS -dynamic -dylib -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST'
              else
-               DllCmd[1]:='ld $PRTOBJ $TARGET $EMUL $OPT $GCSECTIONS $MAP $LTO $ORDERSYMS -dynamic -bundle -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST'
+               DllCmd[1]:=LdProgram+' $PRTOBJ $TARGET $EMUL $OPT $GCSECTIONS $MAP $LTO $ORDERSYMS -dynamic -bundle -multiply_defined suppress -L. -o $EXE $CATRES $FILELIST'
            end
        end
      else
        begin
-         ExeCmd[1]:='ld $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -L. -o $EXE $RES';
-         DllCmd[1]:='ld $TARGET $EMUL $OPT $INIT $FINI $SONAME $MAP $LTO $ORDERSYMS -shared -L. -o $EXE $RES';
+         ExeCmd[1]:=LdProgram+' $TARGET $EMUL $OPT $DYNLINK $STATIC $GCSECTIONS $STRIP $MAP $LTO $ORDERSYMS -L. -o $EXE $RES';
+         DllCmd[1]:=LdProgram+' $TARGET $EMUL $OPT $INIT $FINI $SONAME $MAP $LTO $ORDERSYMS -shared -L. -o $EXE $RES';
        end;
      if not(target_info.system in systems_darwin) then
        DllCmd[2]:='strip --strip-unneeded $EXE'

compiler/x86/rax86int.pas

@@ -2702,7 +2702,8 @@ Unit Rax86int;
               { convert 'call/jmp [proc/label]' to 'call/jmp proc/label'. Ugly,
                 but Turbo Pascal 7 compatible. }
               if (instr.opcode in [A_CALL,A_JMP]) and
-                 (instr.operands[i].haslabelref or instr.operands[i].hasproc)
+                 (instr.operands[i].haslabelref or instr.operands[i].hasproc) and
+                 (not instr.operands[i].hastype)
                  and (typ=OPR_REFERENCE) and
                  assigned(ref.symbol) and (ref.symbol.typ in [AT_FUNCTION,AT_LABEL,AT_ADDR]) and
                  (ref.base=NR_NO) and (ref.index=NR_NO) then

packages/chm/fpmake.pp

@@ -31,6 +31,7 @@ begin
 
     D:=P.Dependencies.Add('fcl-xml');
     D:=P.Dependencies.Add('fcl-base');
+    D:=P.Dependencies.Add('rtl-generics');
     D.Version:='3.3.1';
 
     P.SourcePath.Add('src');

packages/chm/src/chmcmd.lpr

@@ -145,7 +145,7 @@ begin
   else
     begin
      try
-      project.ScanHtmlContents:=htmlscan=scanforce;  // .hhp default SCAN
+      project.ScanHtmlContents:=htmlscan in [scanforce, scandefault];  // .hhp default SCAN
       Project.LoadFromFile(name);
      except
        on e:exception do
@@ -166,7 +166,6 @@ begin
     end;
   OutStream.Free;
   Project.Free;
-
 end;
 
 var
@@ -178,7 +177,7 @@ var
 
 begin
   InitOptions;
-  Writeln(stderr,'chmcmd, a CHM compiler. (c) 2010 Free Pascal core.');
+  Writeln(stderr,'chmcmd, a CHM compiler. (c) 2010-2019 Free Pascal core.');
   Writeln(Stderr);
   repeat
     c:=getlongopts('h',@theopts[1],optionindex);

packages/chm/src/chmfilewriter.pas

@@ -25,7 +25,7 @@ unit chmfilewriter;
 interface
 
 uses
-  Strings, Classes, SysUtils, chmwriter, inifiles, contnrs, chmsitemap, avl_tree,
+  Classes, SysUtils, chmwriter, inifiles, contnrs, chmsitemap, avl_tree,
   {for html scanning } dom,SAX_HTML,dom_html;
 
 type
@@ -68,7 +68,8 @@ type
     FIndex         : TCHMSiteMap;
     FTocStream,
     FIndexStream   : TMemoryStream;
-    FCores	   : integer;
+    FCores         : Integer;
+    FLocaleID      : Word;
   protected
     function GetData(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
     procedure LastFileAdded(Sender: TObject);
@@ -84,6 +85,7 @@ type
     procedure LoadFromFile(AFileName: String); virtual;
     procedure LoadFromhhp (AFileName:String;LeaveInclude:Boolean); virtual;
     procedure SaveToFile(AFileName: String); virtual;
+    procedure SaveToHHP(AFileName: String);
     procedure WriteChm(AOutStream: TStream); virtual;
     procedure ShowUndefinedAnchors;
     function ProjectDir: String;
@@ -113,17 +115,16 @@ type
     property ScanHtmlContents  : Boolean read fScanHtmlContents write fScanHtmlContents;
     property ReadmeMessage : String read FReadmeMessage write FReadmeMessage;
     property AllowedExtensions : TStringList read FAllowedExtensions;
-    property Cores : integer read fcores write fcores; 
+    property Cores : integer read fcores write fcores;
+    property LocaleID: word read FLocaleID write FLocaleID;
   end;
 
   TChmContextNode = Class
                      URLName       : AnsiString;
-                     ContextNumber : Integer;
+                     ContextNumber : THelpContext;
                      ContextName   : AnsiString;
                     End;
 
-
-
 Const
   ChmErrorKindText : array[TCHMProjectErrorKind] of string = ('Error','Warning','Hint','Note','');
 
@@ -272,6 +273,23 @@ begin
     inc(result);
 end;
 
+// hex codes of LCID (Locale IDs) see at http://msdn.microsoft.com/en-us/goglobal/bb964664.aspx
+function GetLanguageID(const sValue: String): word;
+const
+  DefaultLCID = $0409; // default "English - United States", 0x0409
+var
+  ACode: word;
+begin
+  Result := DefaultLCID;
+  if Length(sValue) >= 5 then
+  begin
+    Val(Trim(Copy(sValue, 1, 6)), Result, ACode);
+    //if Code <> 0 then
+    //Result := DefaultLCID;
+  end
+end;
+
+
 procedure TChmProject.readIniOptions(keyvaluepairs:tstringlist);
 var i : integer;
     Opt : TOptionEnum;
@@ -308,7 +326,7 @@ begin
       OPTFULL_TEXT_SEARCH          : MakeSearchable:=optvalupper='YES';
       OPTIGNORE                    : ;
       OPTINDEX_FILE                : Indexfilename:=optval;
-      OPTLANGUAGE                  : ;
+      OPTLANGUAGE                  : LocaleID := GetLanguageID(optval);
       OPTPREFIX                    : ;  // doesn't seem to have effect
       OPTSAMPLE_STAGING_PATH       : ;
       OPTSAMPLE_LIST_FILE          : ;
@@ -401,6 +419,7 @@ begin
   DefaultFont  := Cfg.GetValue('Settings/DefaultFont/Value', '');
   DefaultWindow:= Cfg.GetValue('Settings/DefaultWindow/Value', '');
   ScanHtmlContents:=  Cfg.GetValue('Settings/ScanHtmlContents/Value', False);
+  LocaleID := Cfg.GetValue('Settings/LocaleID/Value', $0409);
 
   Cfg.Free;
 end;
@@ -698,7 +717,7 @@ begin
 
   Cfg.SetValue('Settings/DefaultWindow/Value', DefaultWindow);
   Cfg.SetValue('Settings/ScanHtmlContents/Value', ScanHtmlContents);
-
+  Cfg.SetValue('Settings/LocaleID/Value', LocaleID);
 
   Cfg.Flush;
   Cfg.Free;
@@ -742,16 +761,19 @@ begin
 
    i:=pos('#',outstring);
    if i<>0 then begin
-     if i > 1 then
-       Anchor := outstring
-     else
-       Anchor := localname+outstring;
-     j := fAnchorList.IndexOf(Anchor);
-     if j < 0 then begin
-       fAnchorList.AddObject(Anchor,TFirstReference.Create(localname));
-       Anchor := '(new) '+Anchor;
-     end;
-     Error(CHMNote, 'Anchor found '+Anchor+' while scanning '+localname,1);
+     if i<>length(outstring) then // trims lone '#' at end of url.
+       begin
+         if i > 1 then
+           Anchor := outstring
+         else
+           Anchor := localname+outstring;
+         j := fAnchorList.IndexOf(Anchor);
+         if j < 0 then begin
+           fAnchorList.AddObject(Anchor,TFirstReference.Create(localname));
+           Anchor := '(new) '+Anchor;
+         end;
+         Error(CHMNote, 'Anchor found '+Anchor+' while scanning '+localname,1);
+       end;
      delete(outstring,i,length(outstring)-i+1);
    end;
 
@@ -759,6 +781,8 @@ begin
 
   outstring:=extractrelativepath(basepath,outstring);
   outstring:=StringReplace(outstring,'\','/',[rfReplaceAll]);
+  if outstring='' then
+    result:=false;
 end;
 
 function  TChmProject.FileInTotalList(const s:String):boolean;
@@ -808,13 +832,55 @@ begin
       filelist.add(fn);
 end;
 
+procedure checkattributesA(node:TDomNode;const localname: string; filelist :TStringList);
+// workaround for "a" tag that has href and src. If src exists, don't check href, this
+// avoids spurious warnings.
+var
+    fn  : String;
+    val : String;
+    found : boolean;
+begin
+  found:=false;
+  val := findattribute(node,'SRC');
+  if sanitizeurl(fbasepath,val,localpath,localname,fn) then
+      found:=true;
+  if not found then
+    begin
+      val := findattribute(node,'HREF');
+      if sanitizeurl(fbasepath,val,localpath,localname,fn) then
+        found:=true;
+    end;
+ if found and not FileInTotalList(uppercase(fn)) then
+      filelist.add(fn);
+end;
 
 function scantags(prnt:TDomNode; const localname: string; filelist:TStringlist):TDomNode;
-// Seach first matching tag in siblings
+
+var
+  att : ansistring;
+
+procedure AddAnchor(const s:string);
+var
+   i   : Integer;
+begin
+  i := fAnchorList.IndexOf(localname+'#'+s);
+  if i < 0 then begin
+    fAnchorList.Add(localname+'#'+s);
+    Error(ChmNote,'New Anchor with '+att+' '+s+' found while scanning '+localname,1);
+  end else if fAnchorList.Objects[i] = nil then
+    Error(chmwarning,'Duplicate anchor definitions with '+att+' '+s+' found while scanning '+localname,1)
+  else begin
+    fAnchorList.Objects[i].Free;
+    fAnchorList.Objects[i] := nil;
+    Error(ChmNote,'Anchor with '+att+' '+s+' defined while scanning '+localname,1);
+  end;
+end;
+
 var chld: TDomNode;
-    s,
-    att : ansistring;
-    i   : Integer;
+    s,attrval  : ansistring;
+    idfound : boolean;
+
+
 begin
   result:=nil;
   if assigned(prnt )  then
@@ -826,6 +892,11 @@ begin
           if (chld is TDomElement) then
             begin
               s:=uppercase(tdomelement(chld).tagname);
+              att := 'ID';
+              attrval := findattribute(chld, att);
+              idfound:=attrval  <> '' ;
+              if idfound then
+                addanchor(attrval);
               if s='LINK' then
                 begin
                   //printattributes(chld,'');
@@ -836,34 +907,21 @@ begin
                   //printattributes(chld,'');
                   checkattributes(chld,'SRC',localname,filelist);
                 end;
-             if s='IMG'then
+             if s='IMG' then
                begin
                   //printattributes(chld,'');
                   checkattributes(chld,'SRC',localname,filelist);
                end;
-             if s='A'then
+             if s='A' then
                begin
                   //printattributes(chld,'');
-                  checkattributes(chld,'HREF',localname,filelist);
-                  att := 'NAME';
-                  s := findattribute(chld, att);
-                  if s = '' then begin
-                     att := 'ID';
-                     s := findattribute(chld, att);
-                  end;
-                  if s <> '' then
+                  checkattributesA(chld,localname,filelist);
+                  if not idfound then
                     begin
-                      i := fAnchorList.IndexOf(localname+'#'+s);
-                      if i < 0 then begin
-                        fAnchorList.Add(localname+'#'+s);
-                        Error(ChmNote,'New Anchor with '+att+' '+s+' found while scanning '+localname,1);
-                      end else if fAnchorList.Objects[i] = nil then
-                        Error(chmwarning,'Duplicate anchor definitions with '+att+' '+s+' found while scanning '+localname,1)
-                      else begin
-                        fAnchorList.Objects[i].Free;
-                        fAnchorList.Objects[i] := nil;
-                        Error(ChmNote,'Anchor with '+att+' '+s+' defined while scanning '+localname,1);
-                      end;
+                      att := 'NAME';
+                      attrval := findattribute(chld, att);
+                      if attrval  <> '' then
+                       addanchor(attrval);
                     end;
                 end;
             end;
@@ -876,11 +934,8 @@ var
   localfilelist: TStringList;
   domdoc : THTMLDocument;
   i,j    : Integer;
-  fn,s   : string;
-  ext    : String;
+  fn,reffn   : string;
   tmplst : Tstringlist;
-  strrec : TStringIndex;
-  //localpath : string;
 
 function trypath(const vn:string):boolean;
 var vn2: String;
@@ -926,10 +981,9 @@ begin
                scantags(domdoc,extractfilename(fn),localfilelist);
                for i:=0 to localFilelist.count-1 do
                  begin
-                   s:=localfilelist[i];
-                   if not trypath(s) then
-//                     if not trypath(localpath+s) then
-                       Error(ChmWarning,'Found file '+s+' while scanning '+fn+', but couldn''t find it on disk',2);
+                   reffn:=localfilelist[i];
+                   if not trypath(reffn) then  //  if not trypath(localpath+s) then
+                       Error(ChmWarning,'Found file '+reffn+' while scanning '+fn+', but couldn''t find it on disk',2);
                  end;
              except
                on e:EDomError do
@@ -952,15 +1006,14 @@ begin
 
            for i:=0 to tmplst.Count-1 do
              begin
-               s:=tmplst[i];
-               if pos('url(''', tmplst[i])>0 then
+               reffn:=tmplst[i];
+               if pos('url(''', reffn)>0 then
                  begin
-                   delete(s,1,pos('url(''', tmplst[i])+4);
-                   s:=trim(copy(s,1,pos('''',s)-1));
-
-                   if not trypath(s) then
+                   delete(reffn,1,pos('url(''', reffn)+4);
+                   reffn:=trim(copy(reffn,1,pos('''',reffn)-1));
+                   if not trypath(reffn) then
 //                     if not trypath(localpath+s) then
-                       Error(ChmWarning,'Found file '+s+' while scanning '+fn+', but couldn''t find it on disk',2);
+                       Error(ChmWarning,'Found file '+reffn+' while scanning '+fn+', but couldn''t find it on disk',2);
                  end;
              end;
          finally
@@ -984,8 +1037,9 @@ procedure TChmProject.ScanSitemap(sitemap:TChmSiteMap;newfiles:TStrings;recursio
 
 procedure scanitems(it:TChmSiteMapItems);
 
-var i : integer;
+var i,j : integer;
     x : TChmSiteMapItem;
+    si  : TChmSiteMapSubItem;
     s : string;
     strrec : TStringIndex;
 
@@ -993,34 +1047,37 @@ begin
   for i:=0 to it.count -1 do
     begin
       x:=it.item[i];
-      if sanitizeurl(fbasepath,x.local,'','Site Map for '+x.Text,S) then   // sanitize, remove stuff etc.
-        begin
-          if not FileInTotalList(uppercase(s)) then
-            begin
-              if fileexists(s) then
-                begin
-                  Error(chmnote,'Good url: '+s+'.',5);
-                  StrRec:=TStringIndex.Create;
-                  StrRec.TheString:=uppercase(s);
-                  StrRec.Strid    :=0;
-                  fTotalFileList.Add(StrRec);
-                  newfiles.add(s);
-                end
-              else
-                Error(chmnote,'duplicate url: '+s+'.',5);
-            end
-          else
-            Error(chmnote,'duplicate url: '+s+'.',5);
-        end
-      else
-       Error(chmnote,'Bad url: '+s+'.',5);
-
+      for j:=0 to x.SubItemcount-1 do
+         begin
+           si:=x.SubItem[j];
+           if sanitizeurl(fbasepath,si.local,'','Site Map for '+x.Text,S) then   // sanitize, remove stuff etc.
+             begin
+               if not FileInTotalList(uppercase(s)) then
+                 begin
+                   if fileexists(s) then
+                     begin
+                       Error(chmnote,'Good url: '+s+'.',5);
+                       StrRec:=TStringIndex.Create;
+                       StrRec.TheString:=uppercase(s);
+                       StrRec.Strid    :=0;
+                       fTotalFileList.Add(StrRec);
+                       newfiles.add(s);
+                     end
+                   else
+                     Error(chmnote,'duplicate url: '+s+'.',5);
+                 end
+               else
+                 Error(chmnote,'duplicate url: '+s+'.',5);
+             end
+           else
+            Error(chmnote,'Bad url: '+s+'.',5);
+         end;
       if assigned(x.children) and (x.children.count>0) then
         scanitems(x.children);
     end;
 end;
 
-var i : integer;
+var
     localfilelist: TStringList;
 
 begin
@@ -1137,6 +1194,7 @@ begin
   Writer.TocName   := ExtractFileName(TableOfContentsFileName);
   Writer.ReadmeMessage := ReadmeMessage;
   Writer.DefaultWindow := FDefaultWindow;
+  Writer.LocaleID := FLocaleID;
   for i:=0 to files.count-1 do
     begin
       nd:=TChmContextNode(files.objects[i]);
@@ -1169,7 +1227,7 @@ var
 begin
   for i := 0 to fAnchorList.Count-1 do
     if fAnchorList.Objects[i] <> nil then
-      Error(chmerror,'Anchor '+fAnchorList[i]+' undefined; first use '+TFirstReference(fAnchorList.Objects[i]).Location);
+       Error(chmerror,'Anchor '+fAnchorList[i]+' undefined; first use '+TFirstReference(fAnchorList.Objects[i]).Location);
 end;
 
 procedure TChmProject.LoadSitemaps;
@@ -1188,7 +1246,6 @@ begin
            FreeAndNil(FToc);
            FToc:=TChmSiteMap.Create(sttoc);
            FToc.loadfromstream(FTocStream);
-           ftoc.savetofile('bla.something');
          except
           on e:exception do
             begin
@@ -1227,5 +1284,101 @@ begin
 end;
 
 
+function BoolAsStr(b: Boolean): string;
+begin
+  if b then
+    Result := 'Yes'
+  else
+    Result := 'No';
+end;
+
+procedure TChmProject.SaveToHHP(AFileName: String);
+var
+  sl: TStringList;
+  s : string;
+  i: Integer;
+  ContextItem: TChmContextNode;
+
+  procedure SetOption(const AKey, AValue: string);
+  begin
+    if AValue <> '' then
+      sl.Add(AKey + '=' + AValue);
+  end;
+
+begin
+  sl := TStringList.Create();
+  try
+    sl.Add('[OPTIONS]');
+    SetOption('Title', Title);
+    SetOption('Compatibility', '1.1 or later');
+    SetOption('Compiled file', OutputFileName);
+    SetOption('Default Topic', DefaultPage);
+    SetOption('Default Font', DefaultFont);
+    SetOption('Default Window', DefaultWindow);
+    SetOption('Display compile progress', 'Yes');
+    //SetOption('Error log file', 'errors.log');
+    SetOption('Contents file', TableOfContentsFileName);
+    //SetOption('Auto Index', BoolAsStr(MakeBinaryIndex));
+    SetOption('Index file', IndexFileName);
+    SetOption('Binary Index', BoolAsStr(MakeBinaryIndex));
+    SetOption('Binary TOC', BoolAsStr(MakeBinaryTOC));
+    SetOption('Full-text search', BoolAsStr(MakeSearchable));
+    SetOption('Language', '0x' + IntToHex(LocaleID, 4));
+
+    sl.Add('');
+    sl.Add('[FILES]');
+    for i := 0 to Files.Count - 1 do
+    begin
+      s := StringReplace(Files.Strings[i], '/', '\', [rfReplaceAll]);
+      sl.Add(s);
+    end;
+
+    if MergeFiles.Count > 0 then
+    begin
+      sl.Add('');
+      sl.Add('[MERGE FILES]');
+      for i := 0 to MergeFiles.Count - 1 do
+      begin
+        sl.Add(MergeFiles.Strings[i]);
+      end;
+    end;
+
+    if Windows.Count > 0 then
+    begin
+      sl.Add('');
+      sl.Add('[WINDOWS]');
+      for i := 0 to Windows.Count-1 do
+      begin
+        TCHMWindow(Windows[i]).SaveToIni(s);
+        sl.Add(s);
+      end;
+    end;
+
+    if Files.Count > 0 then
+    begin
+      sl.Add('');
+      sl.Add('[ALIAS]');
+      for i := 0 to Files.Count - 1 do
+      begin
+        contextitem:=TChmContextNode(files.objects[i]);
+        if assigned(contextitem) then
+          sl.Add(ContextItem.ContextName + '=' + ContextItem.UrlName);
+      end;
+
+      sl.Add('');
+      sl.Add('[MAP]');
+      for I := 0 to Files.Count-1 do
+      begin
+        contextitem:=TChmContextNode(files.objects[i]);
+        if assigned(contextitem) then
+          sl.Add('#define ' + ContextItem.ContextName + ' ' + IntToStr(ContextItem.ContextNumber));
+      end;
+    end;
+
+    sl.SaveToFile(AFileName);
+  finally
+    sl.Free();
+  end;
+end;
 end.
 

packages/chm/src/chmreader.pas

@@ -20,15 +20,17 @@
 }
 unit chmreader;
 
-{$mode objfpc}{$H+}
+{$mode delphi}
 
 //{$DEFINE CHM_DEBUG}
 { $DEFINE CHM_DEBUG_CHUNKS}
-
+{define binindex}
+{define nonumber}
 interface
 
 uses
-  Classes, SysUtils, Contnrs, chmbase, paslzx, chmFIftiMain, chmsitemap;
+  Generics.Collections, Classes, SysUtils,  Contnrs,
+  chmbase, paslzx, chmFIftiMain, chmsitemap;
 
 type
 
@@ -729,7 +731,7 @@ var
   PMGIndex: Integer;
   {$ENDIF}
 begin
-  if ForEach = nil then Exit;
+  if not assigned(ForEach) then Exit;
   ChunkStream := TMemoryStream.Create;
   {$IFDEF CHM_DEBUG_CHUNKS}
   WriteLn('ChunkCount = ',fDirectoryHeader.DirectoryChunkCount);
@@ -970,6 +972,12 @@ begin
     fTOPICSStream.ReadDWord;
     TopicTitleOffset := LEtoN(fTOPICSStream.ReadDWord);
     TopicURLTBLOffset := LEtoN(fTOPICSStream.ReadDWord);
+    {$ifdef binindex}
+    {$ifndef nonumber}
+    writeln('titleid:',TopicTitleOffset);
+    writeln('urlid  :',TopicURLTBLOffset);
+    {$endif}
+    {$endif}
     if TopicTitleOffset <> $FFFFFFFF then
       ATitle := ReadStringsEntry(TopicTitleOffset);
      //WriteLn('Got a title: ', ATitle);
@@ -1016,7 +1024,10 @@ begin
   result:=head<tail;
 
   n:=head-oldhead;
-  if (n>0) and (oldhead[n-1]=0) then dec(n); // remove trailing #0
+
+  pw:=pword(@oldhead[n]);
+  if (n>1) and (pw[-1]=0) then
+    dec(n,2); // remove trailing #0
   setlength(ws,n div sizeof(widechar));
   move(oldhead^,ws[1],n);
   for n:=1 to length(ws) do
@@ -1024,10 +1035,15 @@ begin
   readv:=ws; // force conversion for now, and hope it doesn't require cwstring
 end;
 
+
+Type TLookupRec = record
+                   item : TChmSiteMapItems;
+                   depth : integer;
+                   end;
+     TLookupDict = TDictionary<string,TLookupRec>;
 function TChmReader.GetIndexSitemap(ForceXML:boolean=false): TChmSiteMap;
 var Index   : TMemoryStream;
-    sitemap : TChmSiteMap;
-    Item    : TChmSiteMapItem;
+
 
 function  AbortAndTryTextual:tchmsitemap;
 
@@ -1045,76 +1061,48 @@ begin
       result:=nil;
 end;
 
-procedure createentry(Name:ansistring;CharIndex:integer;Topic,Title:ansistring);
-var litem : TChmSiteMapItem;
-    shortname : ansistring;
-    longpart  : ansistring;
-begin
- if charindex=0 then
-   begin
-     item:=sitemap.items.NewItem;
-     item.keyword:=Name;
-     item.local:=topic;
-     item.text:=title;
-   end
- else
-   begin
-     shortname:=copy(name,1,charindex-2);
-     longpart:=copy(name,charindex,length(name)-charindex+1);
-     if assigned(item) and (shortname=item.text) then
-       begin
-         litem:=item.children.newitem;
-         litem.local:=topic;
-         litem.keyword :=longpart; // recursively split this? No examples.
-         litem.text:=title;
-       end
-      else
-       begin
-         item:=sitemap.items.NewItem;
-         item.keyword:=shortname;
-         item.local:=topic;
-         item.text:=title;
-         litem:=item.children.newitem;
-         litem.keyword:=longpart;
-         litem.local:=topic;
-         litem.text :=Title; // recursively split this? No examples.
-       end;
-   end;
-end;
+var
+   parentitem:TChmSiteMapItems;
+   itemstack :TObjectList;
+   lookup  : TLookupDict;
+   curitemdepth : integer;
+   sitemap : TChmSiteMap;
 
-procedure createentryseealso(Name:ansistring;CharIndex:integer;seealso:ansistring);
-var litem : TChmSiteMapItem;
+function getitem(anentrydepth:integer):Tchmsitemapitems;
 begin
-     item:=sitemap.items.NewItem;
-     item.KeyWord:=name;
-     item.SeeAlso:=seealso;
+   if anentrydepth<itemstack.count then
+     result:=tchmsitemapitems(itemstack[anentrydepth])
+   else
+     begin
+       {$ifdef binindex}
+         writeln('pop from emptystack at ',anentrydepth,' ',itemstack.count);
+       {$endif}
+       result:=tchmsitemapitems(itemstack[itemstack.Count-1]);
+     end;
 end;
 
+procedure pushitem(anentrydepth:integer;anitem:tchmsitemapitem);
+begin
 
+ if anentrydepth<itemstack.count then
+   itemstack[anentrydepth]:=anitem.children
+ else
+   if anentrydepth=itemstack.count then
+     itemstack.add(anitem.Children)
+   else
+     begin
+       {$ifdef binindex}
+         writeln('push more than 1 larger ' ,anentrydepth,' ',itemstack.count);
+       {$endif}
+       itemstack.add(anitem.Children)
+     end;
+end;
 procedure parselistingblock(p:pbyte);
 var
-    itemstack:TObjectStack;
-    curitemdepth : integer;
-    parentitem:TChmSiteMap;
 
-procedure updateparentitem(entrydepth:integer);
-begin
-  if entrydepth>curitemdepth then
-    begin
-      if curitemdepth<>0 then
-        itemstack.push(parentitem);
-      curitemdepth:=entrydepth;
-    end
-  else
-   if entrydepth>curitemdepth then
-    begin
-      if curitemdepth<>0 then
-        itemstack.push(parentitem);
-      curitemdepth:=entrydepth;
-    end
-end;
+    Item    : TChmSiteMapItem;
 
-var hdr:PBTreeBlockHeader;
+    hdr:PBTreeBlockHeader;
     head,tail : pbyte;
     isseealso,
     entrydepth,
@@ -1125,8 +1113,41 @@ var hdr:PBTreeBlockHeader;
     CharIndex,
     ind:integer;
     seealsostr,
-    topic,
+    s,
     Name : AnsiString;
+    path,
+    shortname : AnsiString;
+    anitem:TChmSiteMapItems;
+    litem : TChmSiteMapItem;
+    lookupitem : TLookupRec;
+
+function readvalue:string;
+begin
+  if head<tail Then
+    begin
+      ind:=LEToN(plongint(head)^);
+
+      result:=lookuptopicbyid(ind,title);
+      {$ifdef binindex}
+        writeln(i:3,' topic: ' {$ifndef nonumber},'  (',ind,')' {$endif});
+        writeln('    title: ',title);
+        writeln('    result: ',result);
+      {$endif}
+      inc(head,4);
+    end;
+end;
+
+procedure dumpstack;
+var fp : TChmSiteMapItems;
+     ix : Integer;
+begin
+  for ix:=0 to itemstack.Count-1 do
+    begin
+      fp :=TChmSiteMapItems(itemstack[ix]);
+      writeln(ix:3,' ',fp.parentname);
+    end;
+end;
+
 begin
   //setlength (curitem,10);
   hdr:=PBTreeBlockHeader(p);
@@ -1135,17 +1156,21 @@ begin
   hdr^.IndexOfPrevBlock:=LEToN(hdr^.IndexOfPrevBlock);
   hdr^.IndexOfNextBlock:=LEToN(hdr^.IndexOfNextBlock);
 
+  {$ifdef binindex}
+  writeln('hdr:',hdr^.length);
+  {$endif}
   tail:=p+(2048-hdr^.length);
   head:=p+sizeof(TBtreeBlockHeader);
 
-  itemstack:=TObjectStack.create;
   {$ifdef binindex}
+  {$ifndef nonumber}
   writeln('previndex  : ',hdr^.IndexOfPrevBlock);
   writeln('nextindex  : ',hdr^.IndexOfNextBlock);
   {$endif}
-  curitemdepth:=0;
+  {$endif}
   while head<tail do
     begin
+      //writeln(tail-head);
       if not ReadWCharString(Head,Tail,Name) Then
         Break;
       {$ifdef binindex}
@@ -1158,6 +1183,75 @@ begin
       IsSeealso:=LEToN(PE^.isseealso);
       EntryDepth:=LEToN(PE^.entrydepth);
       CharIndex:=LEToN(PE^.CharIndex);
+      Path:='';
+
+      if charindex<>0 then
+        begin
+          Path:=Trim(Copy(Name,1,charindex-2));
+          Shortname:=trim(copy(Name,charindex,Length(Name)-Charindex+1));
+        end
+      else
+        shortname:=name;
+      {$ifdef binindex}
+      writeln('depth:', curitemdepth, ' ' ,entrydepth);
+      {$endif}
+      if curitemdepth=entrydepth then // same level, so of same parent
+         begin
+           item:=parentitem.newitem;
+           pushitem(entrydepth+1,item);
+         end
+      else
+        if curitemdepth=entrydepth-1 then // new child, one lower.
+          begin
+            parentitem:=getitem(entrydepth);
+            item:=parentitem.newitem;
+            pushitem(entrydepth+1,item);
+          end
+        else
+         if entrydepth<curitemdepth then
+          begin
+            parentitem:=getitem(entrydepth);
+            {$ifdef binindex}
+            writeln('bingo!', parentitem.parentname);
+            dumpstack;
+            {$endif}
+            item:=parentitem.newitem;
+            pushitem(entrydepth+1,item);
+          end;
+
+      curitemdepth:=entrydepth;
+      {$ifdef binindex}
+      writeln('lookup:', Name, ' = ', path,' = ',shortname);
+      {$endif}
+
+    (*  if lookup.trygetvalue(path,lookupitem) then
+        begin
+//          if lookupitem.item<>parentitem then
+//             writeln('mismatch: ',lookupitem.item.item[0].name,' ',name);
+{          if curitemdepth<entrydepth then
+            begin
+              writeln('lookup ok!',curitemdepth,' ' ,entrydepth);
+              curitemdepth:=entrydepth;
+            end
+          else
+           begin
+             writeln('lookup odd!',curitemdepth,' ' ,entrydepth);
+           end;
+          curitemdepth:=lookupitem.depth+1;
+          parentitem:=lookupitem.item;}
+        end
+      else
+        begin
+ //            parentitem:=sitemap.Items;
+          if not curitemdepth=entrydepth then
+             writeln('no lookup odd!',curitemdepth,' ' ,entrydepth);
+        end;  *)
+{      item:=parentitem.newitem;}
+      lookupitem.item:=item.children;
+      lookupitem.depth:=entrydepth;
+      lookup.addorsetvalue(name,lookupitem);
+      item.AddName(Shortname);
+
       {$ifdef binindex}
         Writeln('seealso   :  ',IsSeeAlso);
         Writeln('entrydepth:  ',EntryDepth);
@@ -1178,7 +1272,7 @@ begin
           {$ifdef binindex}
             writeln('seealso: ',seealsostr);
           {$endif}
-
+          item.AddSeeAlso(seealsostr);
         end
       else
         begin
@@ -1190,24 +1284,13 @@ begin
 
             for i:=0 to nrpairs-1 do
               begin
-                if head<tail Then
-                  begin
-                    ind:=LEToN(plongint(head)^);
-                    topic:=lookuptopicbyid(ind,title);
-                    {$ifdef binindex}
-                      writeln(i:3,' topic: ',topic);
-                      writeln('    title: ',title);
-                    {$endif}
-                    inc(head,4);
-                  end;
+               s:=readvalue;
+             //  if not ((i=0) and (title=shortname)) then
+               item.addname(title);
+               item.addlocal(s);
               end;
           end;
          end;
-      if isseealso>0 then
-         createentryseealso(name,charindex,seealsostr)
-      else
-        if nrpairs<>0 Then
-          createentry(Name,CharIndex,Topic,Title);
       inc(head,4); // always 1
       {$ifdef binindex}
         if head<tail then
@@ -1215,15 +1298,16 @@ begin
       {$endif}
       inc(head,4); // zero based index (13 higher than last
     end;
-  ItemStack.Free;
 end;
 
 var TryTextual : boolean;
     BHdr       : TBTreeHeader;
     block      : Array[0..2047] of Byte;
     i          : Integer;
+
 begin
    Result := nil;  SiteMap:=Nil;
+   lookup:=TDictionary<string,TLookupRec>.create;
    // First Try Binary
    Index := GetObject('/$WWKeywordLinks/BTree');
    if (Index = nil) or ForceXML then
@@ -1237,9 +1321,12 @@ begin
      Exit;
    end;
    SiteMap:=TChmSitemap.Create(StIndex);
-   Item   :=Nil;  // cached last created item, in case we need to make
+   itemstack :=TObjectList.create(false);
+   //Item   :=Nil;  // cached last created item, in case we need to make
                   // a child.
-
+   parentitem:=sitemap.Items;
+   itemstack.add(parentitem); // level 0
+   curitemdepth:=0;
    TryTextual:=True;
    BHdr.LastLstBlock:=0;
    if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>=0) Then
@@ -1248,7 +1335,7 @@ begin
          begin
            for i:=0 to BHdr.lastlstblock do
              begin
-               if (index.size-index.position)>=defblocksize then
+               if (index.size-index.position)>=defblocksize then // skips last incomplete block?
                  begin
                    Index.read(block,defblocksize);
                    parselistingblock(@block)
@@ -1264,6 +1351,7 @@ begin
       Result:=AbortAndTryTextual;
     end
   else Index.Free;
+  lookup.free;
 end;
 
 function TChmReader.GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
@@ -1273,19 +1361,19 @@ function TChmReader.GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
       Item: TChmSiteMapItem;
       NextEntry: DWord;
       TopicsIndex: DWord;
-      Title: String;
+      Title, Local : String;
     begin
       Toc.Position:= AItemOffset + 4;
       Item := SiteMapITems.NewItem;
       Props := LEtoN(TOC.ReadDWord);
       if (Props and TOC_ENTRY_HAS_LOCAL) = 0 then
-        Item.Text:= ReadStringsEntry(LEtoN(TOC.ReadDWord))
+        Item.AddName(ReadStringsEntry(LEtoN(TOC.ReadDWord)))
       else
       begin
         TopicsIndex := LEtoN(TOC.ReadDWord);
-        Item.Local := LookupTopicByID(TopicsIndex, Title);
-        Item.Text := Title;
-
+        Local:=LookupTopicByID(TopicsIndex, Title);
+        Item.AddName(Title);
+        Item.AddLocal(Local);
       end;
       TOC.ReadDWord;
       Result := LEtoN(TOC.ReadDWord);
@@ -1724,7 +1812,7 @@ var
   X: Integer;
 begin
   fOnOpenNewFile := AValue;
-  if AValue = nil then exit;
+  if not assigned(AValue)  then exit;
   for X := 0 to fUnNotifiedFiles.Count-1 do
     AValue(Self, X);
   fUnNotifiedFiles.Clear;

packages/chm/src/chmsitemap.pas

@@ -20,54 +20,105 @@
 }
 unit chmsitemap;
 
-{$mode objfpc}{$H+}
-
+{$mode Delphi}{$H+}
+{define preferlower}
 interface
 
 uses
-  Classes, SysUtils, fasthtmlparser;
+  Classes, SysUtils, fasthtmlparser, contnrs, strutils, generics.collections;
 
 type
   TChmSiteMapItems = class; // forward
   TChmSiteMap = class;
+  TChmSiteMapItem = class;
 
   { TChmSiteMapItem }
 
+  TChmSiteMapItemAttrName = (siteattr_NONE,
+                             siteattr_KEYWORD, // alias for name in sitemap
+                             siteattr_NAME,
+                             siteattr_LOCAL,
+                             siteattr_URL,
+                             siteattr_TYPE,
+                             siteattr_SEEALSO,
+                             siteattr_IMAGENUMBER,
+                             siteattr_NEW,
+                             siteattr_COMMENT,
+                             siteattr_MERGE,
+                             siteattr_FRAMENAME,
+                             siteattr_WINDOWNAME,
+                             siteattr_WINDOW_STYLES,
+                             siteattr_EXWINDOW_STYLES,
+                             siteattr_FONT,
+                             siteattr_IMAGELIST,
+                             siteattr_IMAGETYPE
+                            );
+
+  { TChmSiteMapSubItem }
+  TChmSiteMapGenerationOptions = (Default,emitkeyword);
+  TChmSiteMapSubItem = class(TPersistent)
+  private
+    FName,
+    FType,
+    FLocal,
+    FUrl,
+    FSeeAlso  : String;
+    FOwner : TChmSiteMapItem;
+  public
+    constructor Create(AOwner: TChmSiteMapItem);
+    destructor Destroy; override;
+  published
+    property Name : String read FName  write FName;  //hhk
+    property ItemType : String read FType write FType; //both
+    property Local: String read FLocal write FLocal; //both
+    property URL  : String read FURL write FURL;     //both
+    property SeeAlso: String read FSeeAlso write FSeeAlso; //hhk
+  end;
+
+// hhk items:  Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
+// hhc items:  Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
   TChmSiteMapItem = class(TPersistent)
   private
     FChildren: TChmSiteMapItems;
     FComment: String;
     FImageNumber: Integer;
     FIncreaseImageIndex: Boolean;
-    FKeyWord: String;
-    FLocal: String;
     FOwner: TChmSiteMapItems;
-    FSeeAlso: String;
-    FText: String;
-    FURL: String;
+    FName   : String;
     FMerge : String;
     FFrameName : String;
     FWindowName : String;
+    FSubItems : TObjectList;
+    function getlocal: string;
+    function getseealso:string;
+    function getsubitem( index : integer): TChmSiteMapSubItem;
+    function getsubitemcount: integer;
     procedure SetChildren(const AValue: TChmSiteMapItems);
   public
     constructor Create(AOwner: TChmSiteMapItems);
     destructor Destroy; override;
+    procedure AddName(const Name:string);
+    procedure AddLocal(const Local:string);
+    procedure AddSeeAlso(const SeeAlso:string);
+    procedure AddURL(const URL:string);
+    procedure AddType(const AType:string);
+    procedure Sort(Compare: TListSortCompare);
   published
     property Children: TChmSiteMapItems read FChildren write SetChildren;
-    property Text: String read FText write FText; // Name for TOC; KeyWord for index
-    property KeyWord: String read FKeyWord write FKeyWord;
-    property Local: String read FLocal write FLocal;
-    property URL: String read FURL write FURL;
-    property SeeAlso: String read FSeeAlso write FSeeAlso;
+    property Name: String read FName write FName;
     property ImageNumber: Integer read FImageNumber write FImageNumber default -1;
     property IncreaseImageIndex: Boolean read FIncreaseImageIndex write FIncreaseImageIndex;
     property Comment: String read FComment write FComment;
     property Owner: TChmSiteMapItems read FOwner;
-
+    property Keyword : string read fname; // deprecated;             // Use name, sitemaps don't store the difference.
+    property Local : string read getlocal; // deprecated;            // should work on ALL pairs
+    property Text : string read fname write fname; // deprecated;    // should work on ALL pairs
+    property SeeAlso : string read getseealso; // deprecated;        // should work on ALL pairs
     property FrameName: String read FFrameName write FFrameName;
     property WindowName: String read FWindowName write FWindowName;
-//    property Type_: Integer read FType_ write FType_; either Local or URL
     property Merge: String read FMerge write FMerge;
+    property SubItem[ index :integer]:TChmSiteMapSubItem read getsubitem;
+    property SubItemcount  :integer read getsubitemcount;
   end;
 
   { TChmSiteMapItems }
@@ -80,6 +131,7 @@ type
     FParentItem: TChmSiteMapItem;
     function GetCount: Integer;
     function GetItem(AIndex: Integer): TChmSiteMapItem;
+    function getparentname: String;
     procedure SetItem(AIndex: Integer; const AValue: TChmSiteMapItem);
   public
     constructor Create(AOwner: TChmSiteMap; AParentItem: TChmSiteMapItem);
@@ -95,6 +147,7 @@ type
     property ParentItem: TChmSiteMapItem read FParentItem;
     property Owner: TChmSiteMap read FOwner;
     property InternalData: Dword read FInternalData write FInternalData;
+    property ParentName : String read getparentname;
   end;
   
 
@@ -130,13 +183,17 @@ type
     FLevel: Integer;
     FLevelForced: Boolean;
     FWindowStyles: LongInt;
+    FLoadDict : TDictionary<String,TChmSiteMapItemAttrName>;
+    fChmSiteMapGenerationOptions:TChmSiteMapGenerationOptions;
     procedure SetItems(const AValue: TChmSiteMapItems);
+    procedure CheckLookup;
   protected
     procedure FoundTag (ACaseInsensitiveTag, AActualTag: string);
     procedure FoundText(AText: string);
   public
     constructor Create(AType: TSiteMapType);
     destructor Destroy; override;
+    Procedure Sort(Compare: TListSortCompare);
     procedure LoadFromFile(AFileName: String);
     procedure LoadFromStream(AStream: TStream);
     procedure SaveToFile(AFileName:String);
@@ -155,11 +212,50 @@ type
     property UseFolderImages: Boolean read FUseFolderImages write FUseFolderImages;
     property Font: String read FFont write FFont;
     property AutoGenerated: Boolean read FAutoGenerated write FAutoGenerated;
+    property ChmSiteMapGenerationOptions : TChmSiteMapGenerationOptions read fChmSiteMapGenerationOptions write fChmSiteMapGenerationOptions;
   end;
 
+
+function indexitemcompare(Item1, Item2: Pointer): Integer;
 implementation
 uses HTMLUtil;
 
+const sitemapkws : array[TChmSiteMapItemAttrName] of string = (
+                    '',
+                    'KEYWORD',
+                    'NAME',
+                    'LOCAL',
+                    'URL',
+                    'TYPE',
+                    'SEE ALSO',
+                    'IMAGENUMBER',
+                    'NEW',
+                    'COMMENT',
+                    'MERGE',
+                    'FRAMENAME',
+                    'WINDOWNAME',
+                    'WINDOW STYLES',
+                    'EXWINDOW STYLES',
+                    'FONT',
+                    'IMAGELIST',
+                    'IMAGETYPE');
+
+function indexitemcompare(Item1, Item2: Pointer): Integer;
+begin
+    Result := naturalComparetext(LowerCase(TChmSiteMapItem(item1).name), Lowercase(TChmSiteMapItem(item2).name));
+end;
+{ TChmSiteMapSubItem }
+
+constructor TChmSiteMapSubItem.Create(AOwner: TChmSiteMapItem);
+begin
+  FOwner:=AOwner;
+end;
+
+destructor TChmSiteMapSubItem.Destroy;
+begin
+  inherited Destroy;
+end;
+
 { TChmSiteMapTree }
 
 procedure TChmSiteMap.SetItems(const AValue: TChmSiteMapItems);
@@ -168,6 +264,16 @@ begin
   FItems:=AValue;
 end;
 
+procedure TChmSiteMap.CheckLookup;
+var en : TChmSiteMapItemAttrName;
+begin
+  if assigned(FLoadDict) then
+    exit;
+  FLoadDict :=TDictionary<String,TChmSiteMapItemAttrName>.Create;
+  for en:=succ(low(en)) to high(en) do
+    FLoadDict.add(sitemapkws[en],en);
+end;
+
 procedure TChmSiteMap.FoundTag(ACaseInsensitiveTag, AActualTag: string);
     procedure NewSiteMapItem;
     begin
@@ -196,131 +302,98 @@ procedure TChmSiteMap.FoundTag(ACaseInsensitiveTag, AActualTag: string);
       else FCurrentItems := nil;
       Dec(FLevel);
     end;
+
+// hhk items:  Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
+// hhc items:  Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
 var
   TagName,
-  //TagAttribute,
   TagAttributeName,
   TagAttributeValue: String;
   isParam,IsMerged : string;
+  TagAttrName  : TChmSiteMapItemAttrName;
 begin
-  //WriteLn('TAG:', AActualTag);
   TagName := GetTagName(ACaseInsensitiveTag);
-
-{  if not (smtHTML in FSiteMapTags) then begin
-    if (TagName = 'HTML') or (TagName = '/HTML') then Include(FSiteMapTags, smtHTML);
-  end
-  else begin // looking for /HTML
-    if TagName = '/HTML' then Exclude(FSiteMapTags, smtHTML);
-  end;}
-
-  //if (smtHTML in FSiteMapTags) then begin
-     if not (smtBODY in FSiteMapTags) then begin
-       if TagName = 'BODY' then Include(FSiteMapTags, smtBODY);
-     end
-     else begin
-       if TagName = '/BODY' then Exclude(FSiteMapTags, smtBODY);
+   if TagName = 'UL' then begin
+     IncreaseULevel;
+   end
+   else if TagName = '/UL' then begin
+     DecreaseULevel;
+   end
+   else if (TagName = 'LI') and (FLevel = 0) then
+     FLevelForced := True
+   else if TagName = 'OBJECT' then begin
+     Include(FSiteMapBodyTags, smbtOBJECT);
+     if FLevelForced then
+       IncreaseULevel;
+     If FLevel > 0 then // if it is zero it is the site properties
+       NewSiteMapItem;
+   end
+   else if TagName = '/OBJECT' then begin
+     Exclude(FSiteMapBodyTags, smbtOBJECT);
+     if FLevelForced then
+     begin
+       DecreaseULevel;
+       FLevelForced := False;
      end;
-
-     if (smtBODY in FSiteMapTags) then begin
-       //WriteLn('GOT TAG: ', AActualTag);
-       if TagName = 'UL' then begin
-         //WriteLN('Inc Level');
-         IncreaseULevel;
-       end
-       else if TagName = '/UL' then begin
-         //WriteLN('Dec Level');
-         DecreaseULevel;
-       end
-       else if (TagName = 'LI') and (FLevel = 0) then
-         FLevelForced := True
-       else if TagName = 'OBJECT' then begin
-         Include(FSiteMapBodyTags, smbtOBJECT);
-         if FLevelForced then
-           IncreaseULevel;
-         If FLevel > 0 then // if it is zero it is the site properties
-           NewSiteMapItem;
-       end
-       else if TagName = '/OBJECT' then begin
-         Exclude(FSiteMapBodyTags, smbtOBJECT);
-         if FLevelForced then
+   end
+   else begin // we are the properties of the object tag
+     if (smbtOBJECT in FSiteMapBodyTags) then
+       begin
+        if (FLevel > 0 ) then
          begin
-           DecreaseULevel;
-           FLevelForced := False;
-         end;
-       end
-       else begin // we are the properties of the object tag
-         if (smbtOBJECT in FSiteMapBodyTags) then
-           begin
-            if (FLevel > 0 ) then 
-             begin
-                if LowerCase(GetTagName(AActualTag)) = 'param' then begin
-                  TagAttributeName := GetVal(AActualTag, 'name');
-                TagAttributeValue := GetVal(AActualTag, 'value');
-                //writeln('name,value',tagattributename, ' ',tagattributevalue);
-                if TagAttributeName <> '' then begin
-                  if CompareText(TagAttributeName, 'keyword') = 0 then begin
-                    ActiveItem.Text := TagAttributeValue;
-                  end
-                  else if CompareText(TagAttributeName, 'name') = 0 then begin
-                    if ActiveItem.Text = '' then ActiveItem.Text := TagAttributeValue;
-                  end
-                  else if CompareText(TagAttributeName, 'local') = 0 then begin
-                    ActiveItem.Local := TagAttributeValue;
-                  end
-                  else if CompareText(TagAttributeName, 'URL') = 0 then begin
-                    ActiveItem.URL := TagAttributeValue;
-                  end
-                  else if CompareText(TagAttributeName, 'ImageNumber') = 0 then begin
-                    ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
-                  end
-                  else if CompareText(TagAttributeName, 'New') = 0 then begin
-                    ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
-                  end
-                  else if CompareText(TagAttributeName, 'Comment') = 0 then begin
-                    ActiveItem.Comment := TagAttributeValue
-                  end
-                  else if CompareText(TagAttributeName, 'Merge') = 0 then begin
-                    ActiveItem.Merge:= TagAttributeValue
-                  end;
-                  //else if CompareText(TagAttributeName, '') = 0 then begin
-                  //end;
-                end;
-              end;
-            end
-           else
-             begin // object and level is zero?
-               if LowerCase(GetTagName(AActualTag)) = 'param' then begin
-                 begin
-                   TagAttributeName := uppercase(GetVal(AActualTag, 'name'));
-                   TagAttributeValue := GetVal(AActualTag, 'value');
-                   if TagAttributeName = 'FRAMENAME' then
-                     framename:=TagAttributeValue
-                   else
-                     if TagAttributeName = 'WINDOWNAME' then
-                       WINDOWname:=TagAttributeValue
-                   else
-                     if TagAttributeName = 'WINDOW STYLES' then
-                       WindowStyles:=StrToIntDef(TagAttributeValue,0)
-                   else
-                     if TagAttributeName = 'EXWINDOW STYLES' then
-                       ExWindowStyles:=StrToIntDef(TagAttributeValue,0)
-                   else
-                     if TagAttributeName = 'FONT' then
-                       FONT:=TagAttributeValue
-                   else
-                     if TagAttributeName = 'IMAGELIST' then
-                      IMAGELIST:=TagAttributeValue
-                    else
-                     if TagAttributeName = 'IMAGETYPE' then
-                      UseFolderImages:=uppercase(TagAttributeValue)='FOLDER';
-                  // writeln('0:',flevel,' ' ,aactualtag,' ',tagname,' ' ,tagattributename, ' ' ,tagattributevalue);
-                 end;
+            if LowerCase(GetTagName(AActualTag)) = 'param' then begin
+              TagAttributeName := GetVal(AActualTag, 'name');
+              TagAttributeValue := GetVal(AActualTag, 'value');
+
+              // a hash reduces comparisons and casing, and generics make it easy.
+              if not FLoadDict.trygetvalue(uppercase(TagAttributeName),TagAttrName) then
+                 TagAttrName:=siteattr_none;
+
+              if TagAttrName <> siteattr_none then begin
+                 case TagAttrName of
+                 siteattr_KEYWORD,
+                 siteattr_NAME         : Activeitem.AddName(TagAttributeValue);
+                 siteattr_LOCAL        : ActiveItem.AddLocal(TagAttributeValue);
+                 siteattr_URL          : ActiveItem.AddURL (TagAttributeValue);
+                 siteattr_TYPE         : ActiveItem.AddType (TagAttributeValue);
+                 siteattr_SEEALSO      : ActiveItem.AddSeeAlso(TagAttributeValue);
+                 siteattr_IMAGENUMBER  : ActiveItem.ImageNumber := StrToInt(TagAttributeValue);
+                 siteattr_NEW          : ActiveItem.IncreaseImageIndex := (LowerCase(TagAttributeValue) = 'yes');
+                 siteattr_COMMENT      : ActiveItem.Comment := TagAttributeValue;
+                 siteattr_MERGE        : ActiveItem.Merge:= TagAttributeValue;
+                 siteattr_FRAMENAME    : ActiveItem.FrameName:=TagAttributeValue;
+                 siteattr_WINDOWNAME   : ActiveItem.WindowName:=TagAttributeValue;
                  end;
+              end;
+            end;
+         end
+       else
+         begin // object and level is zero?
+           if LowerCase(GetTagName(AActualTag)) = 'param' then begin
+             begin
+               TagAttributeName := uppercase(GetVal(AActualTag, 'name'));
+               TagAttributeValue := GetVal(AActualTag, 'value');
+               if not FLoadDict.trygetvalue(uppercase(TagAttributeName),TagAttrName) then
+                  TagAttrName:=siteattr_none;
+               if TagAttrName <> siteattr_none then begin
+                  case TagAttrName of
+                   siteattr_FRAMENAME       : FrameName:=TagAttributeValue;
+                   siteattr_WINDOWNAME      : WindowName:=TagAttributeValue;
+                   siteattr_WINDOW_STYLES   : WindowStyles:=StrToIntDef(TagAttributeValue,0);
+                   siteattr_EXWINDOW_STYLES : ExWindowStyles:=StrToIntDef(TagAttributeValue,0);
+                   siteattr_FONT            : Font:=TagAttributeValue;
+                   siteattr_IMAGELIST       : ImageList:=TagAttributeValue;
+                   siteattr_IMAGETYPE       : UseFolderImages:=uppercase(TagAttributeValue)='FOLDER';
+                   end;
              end;
-          end;
-       end;
-     end;
-  //end
+              // writeln('0:',flevel,' ' ,aactualtag,' ',tagname,' ' ,tagattributename, ' ' ,tagattributevalue);
+             end;
+             end;
+         end;
+      end;
+   end;
+// end; {body}
+  //end   {html}
 end;
 
 procedure TChmSiteMap.FoundText(AText: string);
@@ -342,14 +415,22 @@ destructor TChmSiteMap.Destroy;
 begin
   if Assigned(FHTMLParser) then FHTMLParser.Free;
   FItems.Free;
+  FLoadDict.Free;
+
   Inherited Destroy;
 end;
 
+procedure TChmSiteMap.Sort(Compare: TListSortCompare);
+begin
+  FItems.sort(compare);
+end;
+
 procedure TChmSiteMap.LoadFromFile(AFileName: String);
 var
   Buffer: String;
   TmpStream: TMemoryStream;
 begin
+  CheckLookup;
   if Assigned(FHTMLParser) then FHTMLParser.Free;
   TmpStream := TMemoryStream.Create;
   try
@@ -362,8 +443,8 @@ begin
   end;
   FHTMLParser := THTMLParser.Create(Buffer);
   try
-    FHTMLParser.OnFoundTag := @FoundTag;
-    FHTMLParser.OnFoundText := @FoundText;
+    FHTMLParser.OnFoundTag := FoundTag;
+    FHTMLParser.OnFoundText := FoundText;
     FHTMLParser.Exec;
   finally
     FreeAndNil(FHTMLParser);
@@ -374,12 +455,13 @@ procedure TChmSiteMap.LoadFromStream(AStream: TStream);
 var
   Buffer: String;
 begin
+  CheckLookup;
   if Assigned(FHTMLParser) then FHTMLParser.Free;
   SetLength(Buffer, AStream.Size-AStream.Position);
   if AStream.Read(Buffer[1], AStream.Size-AStream.Position) > 0 then begin;
     FHTMLParser := THTMLParser.Create(Buffer);
-    FHTMLParser.OnFoundTag := @FoundTag;
-    FHTMLParser.OnFoundText := @FoundText;
+    FHTMLParser.OnFoundTag := FoundTag;
+    FHTMLParser.OnFoundText := FoundText;
     FHTMLParser.Exec;
     FreeAndNil(FHTMLParser);
   end;
@@ -397,6 +479,9 @@ begin
     end;
 end;
 
+// hhk items:  Merge | ([Name] ([Name] [Type...] [Local [URL] | See Also])... [FrameName] [WindowName] [Comment])
+// hhc items:  Merge | ([Name] ([Type...] [Local] [URL])... [FrameName] [WindowName] [Comment] [New] [ImageNumber])
+
 procedure TChmSiteMap.SaveToStream(AStream: TStream);
 var
   Indent: Integer;
@@ -408,44 +493,86 @@ var
      AStream.Write(AString[1], Length(AString));
      AStream.WriteByte(10);
   end;
+  procedure WriteStringNoIndent(AString: String);
+  var
+    I: Integer;
+  begin
+     AStream.Write(AString[1], Length(AString));
+  end;
+
   procedure WriteParam(AName: String; AValue: String);
   begin
     WriteString('<param name="'+AName+'" value="'+AValue+'">');
   end;
   procedure WriteEntries(AItems: TChmSiteMapItems);
   var
-    I : Integer;
+    I,J : Integer;
     Item: TChmSiteMapItem;
+    Sub : TChmSiteMapSubItem;
+    lemitkeyword : boolean;
   begin
+    lemitkeyword:=ChmSiteMapGenerationOptions=emitkeyword;
     for I := 0 to AItems.Count-1 do begin
       Item := AItems.Item[I];
+
+      {$ifdef preferlower}
+      WriteString('<li> <object type="text/sitemap">');
+      {$else}
       WriteString('<LI> <OBJECT type="text/sitemap">');
+      {$endif}
       Inc(Indent, 8);
 
-      if (SiteMapType = stIndex) and ((Item.Children.Count > 0) or (item.seealso<>'')) then
-         WriteParam('Keyword', Item.Text);
-      //if Item.KeyWord <> '' then WriteParam('Keyword', Item.KeyWord);
-      if Item.Text <> '' then WriteParam('Name', Item.Text);
-      if (Item.Local <> '') or (SiteMapType = stIndex) then WriteParam('Local', StringReplace(Item.Local, '\', '/', [rfReplaceAll]));
-      if Item.URL <> '' then WriteParam('URL', StringReplace(Item.URL, '\', '/', [rfReplaceAll]));
-      if (SiteMapType = stIndex) and (Item.SeeAlso <> '') then WriteParam('See Also', Item.SeeAlso);
-      //if Item.FrameName <> '' then WriteParam('FrameName', Item.FrameName);
-      //if Item.WindowName <> '' then WriteParam('WindowName', Item.WindowName);
+      if Item.Name<>'' then
+        begin
+          if lemitkeyword then
+            WriteParam('Keyword', item.Name)
+          else
+            WriteParam('Name', Item.Name);
+        end;
+
+      if item.FSubItems.count>0 then
+        begin
+          For j:=0 to item.FSubItems.count-1 do
+            begin
+              Sub:=TChmSiteMapSubItem(item.fsubitems[j]);
+              if Sub.Name <> ''     then WriteParam('Name', Sub.Name);
+              if Sub.ItemType <> '' then WriteParam('Type', Sub.ItemType);
+              if Sub.Local <> ''    then WriteParam('Local', Sub.Local);
+              if Sub.URL <> ''      then WriteParam('URL', Sub.URL);
+              if Sub.SeeAlso <> ''  then WriteParam('See Also', Sub.SeeAlso);
+            end;
+        end;
+      if Item.FrameName <> '' then WriteParam('FrameName', Item.FrameName);
+      if Item.WindowName <> '' then WriteParam('WindowName', Item.WindowName);
       if Item.Comment <> '' then WriteParam('Comment', Item.Comment);
-      if (SiteMapType = stTOC) and (Item.IncreaseImageIndex) then WriteParam('New', 'yes'); // is this a correct value?
-      if (SiteMapType = stTOC) and (Item.ImageNumber <> -1) then WriteParam('ImageNumber', IntToStr(Item.ImageNumber));
-
+      if (SiteMapType = stTOC) and (Item.IncreaseImageIndex) then
+          WriteParam('New', 'yes'); // is this a correct value?
+      if (SiteMapType = stTOC) and (Item.ImageNumber <> -1) then
+          WriteParam('ImageNumber', IntToStr(Item.ImageNumber));
       Dec(Indent, 3);
+      {$ifdef preferlower}
+      WriteString('</object>');
+      {$else}
       WriteString('</OBJECT>');
+      {$endif}
       Dec(Indent, 5);
 
       // Now Sub Entries
       if Item.Children.Count > 0 then begin
-        WriteString('<UL>');
+        {$ifdef preferlower}
+        WriteString('<ul>');
+        {$else}
+        WriteString('<UL> ');
+        {$endif}
         Inc(Indent, 8);
         WriteEntries(Item.Children);
         Dec(Indent, 8);
-        WriteString('</UL>');
+        {$ifdef preferlower}
+        WriteString('</ul>');
+        {$else}
+        WriteString('</UL>'); //writestringnoident
+        {$endif}
+
       end;
     end;
   end;
@@ -475,7 +602,7 @@ begin
     // both TOC and Index have font
     if Font <> '' then
       WriteParam('Font', Font);
-    Dec(Indent, 8);
+  Dec(Indent, 8);
   WriteString('</OBJECT>');
   
   // And now the items
@@ -501,19 +628,137 @@ begin
   FChildren := AValue;
 end;
 
+function TChmSiteMapItem.getlocal: string;
+begin
+  result:='';
+  if FSubItems.count>0 then
+     result:=TChmSiteMapSubItem(FSubItems[0]).local;
+end;
+
+function TChmSiteMapItem.getseealso: string;
+begin
+  result:='';
+  if FSubItems.count>0 then
+    result:=TChmSiteMapSubItem(FSubItems[FSubItems.count-1]).SeeAlso;
+end;
+
+function TChmSiteMapItem.getsubitem( index : integer): TChmSiteMapSubItem;
+begin
+  result:=nil;
+  if index<FSubItems.count then
+    result:=TChmSiteMapSubItem(FSubItems[index]);
+end;
+
+function TChmSiteMapItem.getsubitemcount: integer;
+begin
+   result:=FSubItems.count;
+end;
+
 constructor TChmSiteMapItem.Create(AOwner: TChmSiteMapItems);
 begin
   Inherited Create;
   FOwner := AOwner;
   FChildren := TChmSiteMapItems.Create(Owner.Owner, Self);
+  FSubItems := TObjectList.Create(true);
+  imagenumber:=-1;
 end;
 
 destructor TChmSiteMapItem.Destroy;
 begin
+  fsubitems.Free;
   FChildren.Free;
   Inherited Destroy;
 end;
 
+procedure TChmSiteMapItem.AddName(const Name: string);
+var sub :TChmSiteMapSubItem;
+begin
+  if fname='' then
+    fname:=name
+  else
+    begin
+      sub :=TChmSiteMapSubItem.create(self);
+      FSubItems.add(sub);
+      sub.Name:=Name;
+    end;
+end;
+
+procedure TChmSiteMapItem.AddLocal(const Local: string);
+var sub :TChmSiteMapSubItem;
+    addnew : boolean;
+begin
+   if fsubitems.count>0 then
+      begin
+        sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
+        if sub.FLocal<>'' then
+          begin
+            sub.flocal:=local;
+            exit;
+          end;
+      end;
+   sub :=TChmSiteMapSubItem.create(self);
+   FSubItems.add(sub);
+//   sub.name:=name;
+   sub.Local:=Local;
+end;
+
+procedure TChmSiteMapItem.AddSeeAlso(const SeeAlso: string);
+// see also is mutually exclusive with "local url", so addition procedure is same as "local"
+var sub :TChmSiteMapSubItem;
+begin
+   if fsubitems.count>0 then
+      begin
+        sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
+        if sub.FSeeAlso<>'' then
+          begin
+            sub.FSeeAlso:=SeeAlso;
+            exit;
+          end;
+      end;
+   sub :=TChmSiteMapSubItem.create(self);
+   FSubItems.add(sub);
+   sub.FSeeAlso:=SeeAlso;
+end;
+
+
+procedure TChmSiteMapItem.AddURL(const URL: string);
+var sub :TChmSiteMapSubItem;
+begin
+   if fsubitems.count>0 then
+      begin
+        sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
+        if sub.FURL<>'' then
+          begin
+            sub.fURL:=URL;
+            exit;
+          end;
+      end
+   { else not possible according to chmspec. An URL must always follow a "local" item}
+end;
+
+procedure TChmSiteMapItem.AddType(const AType: string);
+// in Tocs, Type can be the first is the same as local
+var sub :TChmSiteMapSubItem;
+begin
+   if fsubitems.count>0 then
+      begin
+        sub:=TChmSiteMapSubItem(fsubitems[FSubItems.count-1]);
+        if sub.ItemType<>'' then
+          begin
+            sub.ItemType:=AType;
+            exit;
+          end;
+      end;
+   sub :=TChmSiteMapSubItem.create(self);
+   FSubItems.add(sub);
+   sub.ItemType:=AType;
+end;
+
+procedure TChmSiteMapItem.Sort(Compare: TListSortCompare);
+begin
+  FChildren.sort(compare);
+end;
+
 { TChmSiteMapItems }
 
 function TChmSiteMapItems.GetItem(AIndex: Integer): TChmSiteMapItem;
@@ -521,6 +766,15 @@ begin
   Result := TChmSiteMapItem(FList.Items[AIndex]);
 end;
 
+function TChmSiteMapItems.getparentname: String;
+begin
+  result:='Not assigned';
+  if assigned(fparentitem) then
+    begin
+      result:=FParentItem.name;
+    end;
+end;
+
 function TChmSiteMapItems.GetCount: Integer;
 begin
   Result := FList.Count;
@@ -577,8 +831,11 @@ begin
 end;
 
 procedure TChmSiteMapItems.Sort(Compare: TListSortCompare);
+var I :Integer;
 begin
   FList.Sort(Compare);
+  for i:=0 to flist.Count-1 do
+    TChmSiteMapItem(flist[i]).sort(Compare)
 end;
 
 end.

packages/chm/src/chmtypes.pas

@@ -136,6 +136,7 @@ type
                                             // of certain fields. Needs to be inserted into #windows stream
                 Constructor create(s:string='');
                 procedure load_from_ini(txt:string);
+                procedure SaveToIni(out s: string);
                 procedure savetoxml(cfg:TXMLConfig;key:string);
                 procedure loadfromxml(cfg:TXMLConfig;key:string);
                 procedure assign(obj : TCHMWindow);
@@ -547,6 +548,39 @@ begin
   wm_notify_id             :=getnextint(txt,ind,len,flags,valid_unknown1);
 end;
 
+
+procedure TCHMWindow.SaveToIni(out s: string);
+begin
+  s := window_type + '=';
+  s := s + '"' + Title_bar_text + '"';
+  s := s + ',"' + Toc_file + '"';
+  s := s + ',"' + index_file + '"';
+  s := s + ',"' + Default_File + '"';
+  s := s + ',"' + Home_button_file + '"';
+  s := s + ',"' + Jumpbutton_1_File + '"';
+  s := s + ',"' + Jumpbutton_1_Text + '"';
+  s := s + ',"' + Jumpbutton_2_File + '"';
+  s := s + ',"' + Jumpbutton_2_Text + '"';
+  s := s + ',0x' + IntToHex(nav_style, 1);
+  s := s + ',' + IntToStr(navpanewidth);
+  s := s + ',0x' + IntToHex(buttons, 1);
+  s := s + ',[' + IntToStr(left);
+  s := s + ',' + IntToStr(top);
+  s := s + ',' + IntToStr(right);
+  s := s + ',' + IntToStr(bottom) + ']';
+  s := s + ',0x' + IntToHex(styleflags, 1);
+  if xtdstyleflags <> 0 then
+   s := s + ',0x' + IntToHex(xtdstyleflags, 1)
+  else
+   s := s + ',';
+  s := s + ',0x' + IntToHex(window_show_state, 1);
+  s := s + ',' + IntToStr(navpane_initially_closed);
+  s := s + ',' + IntToStr(navpane_default);
+  s := s + ',' + IntToStr(navpane_location);
+  //s := s + ',' + IntToStr(wm_notify_id);
+end;
+
+
 procedure TCHMWindow.savetoxml(cfg:TXMLConfig;key:string);
 begin
   cfg.setvalue(key+'window_type',window_type);

packages/chm/src/chmwriter.pas

@@ -6,7 +6,7 @@
   option) any later version.
 
   This program is distributed in the hope that it will be useful, but WITHOUT
-  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+    ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
   for more details.
 
@@ -22,7 +22,7 @@ unit chmwriter;
 {$MODE OBJFPC}{$H+}
 
 interface
-uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree, lzxcompressthread;
+uses Generics.Collections,Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree, lzxcompressthread;
 
 Const
    DefaultHHC = 'Default.hhc';
@@ -126,7 +126,8 @@ Type
     property TempRawStream: TStream read FTempStream write SetTempRawStream;
     property ReadmeMessage : String read fReadmeMessage write fReadmeMessage;
     property Cores : integer read fcores write fcores;
-    //property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
+    { MS Locale ID code }
+    property LocaleID: dword read ITSFHeader.LanguageID write ITSFHeader.LanguageID;
   end;
 
   { TChmWriter }
@@ -154,6 +155,7 @@ Type
     FAvlStrings   : TAVLTree;    // dedupe strings
     FAVLTopicdedupe : TAVlTree;  // Topic deduping, if we load it both from hhp and TOC
     FAvlURLStr    : TAVLTree;    // dedupe urltbl + binindex must resolve URL to topicid
+    FDictTopicsUrlInd    : specialize TDictionary<string,integer>; // if url exists reuse topic.
     SpareString   : TStringIndex;
     SpareUrlStr   : TUrlStrIndex;
     FWindows      : TObjectList;
@@ -186,6 +188,7 @@ Type
     function AddURL(AURL: String; TopicsIndex: DWord): LongWord;
     procedure CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
     function AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
+    function AddTopicindex(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
     procedure ScanSitemap(asitemap:TCHMSiteMap);
     function NextTopicIndex: Integer;
     procedure Setwindows (AWindowList:TObjectList);
@@ -1521,6 +1524,7 @@ begin
   FDefaultWindow:= '';
   FMergeFiles   :=TStringList.Create;
   FNrTopics     :=0;
+  FDictTopicsUrlInd    :=specialize TDictionary<string,integer>.Create;
 end;
 
 destructor TChmWriter.Destroy;
@@ -1543,7 +1547,7 @@ begin
   FAVLTopicdedupe.FreeAndClear;
   FAVLTopicdedupe.free;
   FWindows.Free;
-
+  FDictTopicsUrlInd.Free;
   inherited Destroy;
 end;
 
@@ -1664,6 +1668,7 @@ var
     TopicEntry: TTopicEntry;
 
 begin
+    ATitle :=StringReplace(Atitle, '&x27;', '', [rfReplaceAll]);
     anurl:=StringReplace(anurl, '\', '/', [rfReplaceAll]);
     if ATitle <> '' then
       TopicEntry.StringsOffset := AddString(ATitle)
@@ -1691,6 +1696,35 @@ begin
     FTopicsStream.WriteDWord(LEtoN(TopicEntry.URLTableOffset));
     FTopicsStream.WriteWord(LEtoN(TopicEntry.InContents));
     FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
+    {$ifdef binindex}
+    writeln('topout:',result, ' ' , TopicEntry.StringsOffset,' ' ,TopicEntry.URLTableOffset, ' ',atitle,' - ', anurl);
+    {$endif}
+end;
+
+function TChmWriter.AddTopicindex(ATitle, AnUrl: AnsiString; code: integer
+  ): integer;
+
+begin
+   ATitle :=StringReplace(Atitle, '&x27;', '', [rfReplaceAll]);
+
+  // adhoc subsitutions. Replace with real code if exact behaviour is known.
+{  Atitle:=StringReplace(atitle, '&x27;', '''', [rfReplaceAll]);
+  if length(atitle)>0 then
+    atitle[1]:=uppercase(atitle[1])[1];}
+  {$ifdef binindex}
+  writeln('Enter ',ATitle,' ',AnUrl);
+  {$endif}
+  if FDictTopicsUrlInd.trygetvalue(anurl,result) then
+   begin
+     {$ifdef binindex}
+       writeln('found:',result);
+     {$endif}
+   end
+   else
+    begin
+      result:=addtopic(atitle,anurl);
+      FDictTopicsUrlInd.add(anurl,result);
+    end;
 end;
 
 procedure TChmWriter.ScanSitemap(asitemap:TCHMSiteMap);
@@ -2039,32 +2073,64 @@ begin
   inc(blockind,indexentrysize);
 end;
 
-procedure CreateEntry(Item:TChmSiteMapItem;Str:WideString;commaatposition:integer);
+procedure WritestrNT(var p:pbyte;const str:Unicodestring);
+var i : integer;
+    p2 : pbyte;
+begin
+  p2:=p;
+  for i:=1 to Length(str) do
+    WriteWord(p2,Word(str[i]));   // write the wstr in little endian
+  WriteWord(p2,0);                // NT
+  p:=p2;
+end;
+
+procedure CreateEntry(Item:TChmSiteMapItem;const Str:UnicodeString;commaatposition,level:integer);
 
 var p      : pbyte;
     topicid: integer;
     seealso: Integer;
     entrysize:Integer;
     i      : Integer;
+    sb :TChmSiteMapSubItem;
 begin
   inc(TotalEntries);
   fillchar(testblock[0],DefBlockSize,#0);
   p:=@TestBlock[0];
-  for i:=1 to Length(str) do
-    WriteWord(p,Word(str[i]));   // write the wstr in little endian
-  WriteWord(p,0);                // NT
-//  if item.seealso='' then    // no seealso for now
-    seealso:=0;
- // else
-//    seealso:=2;
+
+  WritestrNT(p,Str);
+  if item.seealso='' then    // no seealso for now
+    seealso:=0
+   else
+    seealso:=2;
   WriteWord(p,seealso);          // =0 not a see also 2 =seealso
-  WriteWord(p,0);                // Entrydepth.  We can't know it, so write 2.
+  WriteWord(p,level);            // Entrydepth.  We can't know it, so write 2.
   WriteDword(p,commaatposition); // position of the comma
   WriteDword(p,0);               // unused 0
-  WriteDword(p,1);               // for now only local pair.
-  TopicId:=AddTopic(Item.Text,item.Local);
-  WriteDword(p,TopicId);
-  // if seealso then _here_ a wchar NT string with seealso?
+
+  if seealso=2 then
+   begin
+     {$ifdef binindex}
+     write('!seealso');
+     {$endif}
+     WriteDword(p,1);
+     WritestrNT(p,item.seealso)
+   end
+  else
+    begin
+      WriteDword(p,item.SubItemcount);
+      for i:=0 to item.SubItemcount-1 do
+        begin
+          sb:=item.SubItem[i];
+          if sb.name='' then
+            sb.name:=item.name;
+          {$ifdef binindex}
+          writeln('---',sb.name,' ',sb.local);
+          {$endif}
+          TopicId:=AddTopicIndex(sb.Name,sb.Local);
+          WriteDword(p,TopicId);
+        end;
+    end;
+
   WriteDword(p,1);               // always 1 (unknown);
   WriteDword(p,mod13value);      //a value that increments with 13.
   mod13value:=mod13value+13;
@@ -2158,32 +2224,36 @@ begin
   Result:=blk-start;
 end;
 
-procedure CombineWithChildren(ParentItem:TChmSiteMapItem;Str:WideString;commaatposition:integer;first:boolean);
+procedure CombineWithChildren(ParentItem:TChmSiteMapItem;Str:UnicodeString;commaatposition:integer;level:integer);
 var i    : Integer;
-    Item : TChmSiteMapItem;
-begin
-  if ParentItem.Children.Count = 0 Then
-    Begin
+    llItem : TChmSiteMapItem;
+begin
+   str:=StringReplace(str, '&x27;', '', [rfReplaceAll]);
+   {$ifdef binindex}
+     writeln('i:',level,' ',str);
+   {$endif}
+//  if ParentItem.Children.Count = 0 Then
+//    Begin
      // comment/fix next
      //   if commatposition=length(str) then commaatposition:=0;
-       if first then
-        CreateEntry(ParentItem,Str,0)
+       if level=0 then
+        CreateEntry(ParentItem,Str,0,level)
        else
-        CreateEntry(ParentItem,Str,commaatposition);
-    End
-  Else
+        CreateEntry(ParentItem,Str,commaatposition,level);
+//    End
+//  Else
     for i:=0 to ParentItem.Children.Count-1 do
       begin
-        item := TChmSiteMapItem(ParentItem.Children.Item[i]);
-        if first Then
-          CombineWithChildren(Item,Str+', '+item.text,commaatposition+2,false)
-        else
-          CombineWithChildren(Item,Str+', '+item.text,commaatposition,false);
+        llitem := TChmSiteMapItem(ParentItem.Children.Item[i]);
+{        if level=0 Then
+          CombineWithChildren(Item,str+', '+item.text,0,level+1)
+        else}
+          CombineWithChildren(llItem,Str+', '+llitem.text,length(str)+2,level+1);
       end;
 end;
 
 Var i             : Integer;
-    Key           : WideString;
+    Key           : UnicodeString;
     Item          : TChmSiteMapItem;
     ListingBlocks : Integer;
     EntryBytes    : Integer;
@@ -2204,6 +2274,7 @@ begin
   {$ifdef binindex}
     writeln('starting index');
   {$endif}
+  ASiteMap.sort(@indexitemcompare);
   IndexStream:=TMemoryStream.Create;
   indexstream.size:=sizeof(TBTreeHeader);
   IndexStream.position:=Sizeof(TBTreeHeader);
@@ -2251,7 +2322,7 @@ begin
       // so we can see if Windows loads the binary or textual index.
       CombineWithChildren(Item,Key+'2',length(key)+1,true);
       {$else}
-      CombineWithChildren(Item,Key,length(key),true);
+      CombineWithChildren(Item,Key,length(key),0);
       {$endif}
     end;
   PrepareCurrentBlock(True);     // flush last listing block.
@@ -2420,7 +2491,6 @@ begin
   PostAddStreamToArchive(AName, '/', AStream);
 end;
 
-
 procedure TChmWriter.AddContext(AContext: DWord; ATopic: String);
 var
   Offset: DWord;
@@ -2448,7 +2518,6 @@ begin
 end;
 
 procedure TChmWriter.Setwindows(AWindowList: TObjectList);
-
 var i : integer;
     x : TCHMWindow;
 begin

packages/fcl-base/examples/README.txt

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

packages/fcl-base/examples/demoio.pp

@@ -0,0 +1,27 @@
+program demoio;
+
+{$mode objfpc}
+{$h+}
+uses streamio, classes;
+
+Var
+  S : TStringStream;
+  F : Text;
+  a,b,c : Integer;
+
+begin
+  a:=1;
+  b:=2;
+  c:=a+b;
+  S:=TStringStream.Create('');
+  try
+    AssignStream(F,S);
+    Rewrite(F);
+    Writeln(F,'Hello World !');
+    Writeln(F,a:3,b:3,c:3);
+    CloseFile(F);
+    Writeln(S.DataString); 
+  finally
+    S.Free;
+  end;
+end.

packages/fcl-base/examples/testappexit.pp

@@ -0,0 +1,32 @@
+program testappexit;
+
+uses sysutils,custapp;
+
+type
+  TApplication = Class(TCustomApplication)
+    Procedure DoRun; override;
+  end;
+  
+Procedure TApplication.DoRun;
+
+begin
+  ExceptionExitCode:=9;
+  If ParamStr(1)='-h' then
+    Terminate(10)
+  else if Paramstr(1)='-e' then
+    Raise Exception.Create('Stopping with exception')
+  else
+    Writeln('Normal stop');  
+  Terminate;  
+end;
+
+begin
+  With TApplication.Create(Nil) do
+    try
+      StopOnException:=True;
+      Initialize;
+      Run;
+    finally
+      Free;
+    end;     
+end.

packages/fcl-image/src/fpwritetiff.pas

@@ -82,6 +82,7 @@ type
     fStream: TStream;
     fPosition: DWord;
     procedure ClearEntries;
+    procedure SortEntries;
     procedure WriteTiff;
     procedure WriteHeader;
     procedure WriteIFDs;
@@ -257,6 +258,29 @@ begin
   WriteDWord(8);
 end;
 
+procedure TFPWriterTiff.SortEntries;
+var
+  i, j: Integer;
+  Entry: TTiffWriterEntry;
+  List: TFPList;
+begin
+  // Sort Entries by Tag Value Ascending
+  for i:= 0 to FEntries.Count-1 do begin
+    List := TFPList(FEntries[i]);
+    j := 0;
+    repeat
+        if TTiffWriterEntry(List[j]).Tag > TTiffWriterEntry(List[j+1]).Tag then begin
+          Entry := TTiffWriterEntry(List[j+1]);
+          List[j] := List[j+1];
+          List[j+1] := Entry;
+          j := 0;
+        end
+        else
+            j := j+1;
+    until j >= List.Count-2;
+  end;
+end;
+
 procedure TFPWriterTiff.WriteIFDs;
 var
   i: Integer;
@@ -265,6 +289,8 @@ var
   Entry: TTiffWriterEntry;
   NextIFDPos: DWord;
 begin
+  // Sort the Entries before writing!
+  SortEntries;
   for i:=0 to FEntries.Count-1 do begin
     List:=TFPList(FEntries[i]);
     // write count
@@ -553,7 +579,8 @@ begin
         TilesDown:=(OrientedHeight+IFD.TileLength{%H-}-1) div IFD.TileLength;
         ChunkCount:=TilesAcross*TilesDown;
         {$IFDEF FPC_Debug_Image}
-        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCount=',ChunkCount);
+        writeln('TFPWriterTiff.AddImage BitsPerPixel=',BitsPerPixel,' OrientedWidth=',OrientedWidth,' OrientedHeight=',OrientedHeight,' TileWidth=',IFD.TileWidth,' TileLength=',IFD.TileLength,' TilesAcross=',TilesAcross,' TilesDown=',TilesDown,' ChunkCoun
+t=',ChunkCount);
         {$ENDIF}
       end else begin
         ChunkCount:=(OrientedHeight+IFD.RowsPerStrip{%H-}-1) div IFD.RowsPerStrip;

packages/fcl-image/src/freetype.pp

@@ -31,7 +31,7 @@ uses sysutils, classes, {$IFDEF DYNAMIC}freetypehdyn{$ELSE}freetypeh{$ENDIF}, FP
               fontfiles and faces available in a fontfile }
 
 // determine if file comparison need to be case sensitive or not
-{$ifdef WIN32}
+{$ifdef windows}
   {$undef CaseSense}
 {$else}
   {$define CaseSense}
@@ -200,8 +200,6 @@ const
 
 implementation
 
-{$IFDEF win32}uses dos;{$ENDIF}
-
 procedure FTError (Event:string; Err:integer);
 begin
   raise FreeTypeException.CreateFmt (sErrFreeType, [Err,Event]);
@@ -1032,15 +1030,15 @@ begin
   aRect := FBounds;
 end;
 
-{$ifdef win32}
+{$ifdef WINDOWS}
 procedure SetWindowsFontPath;
 begin
-  DefaultSearchPath := includetrailingbackslash(GetEnv('windir')) + 'fonts';
+  DefaultSearchPath := includetrailingbackslash(GetEnvironmentVariable('windir')) + 'fonts';
 end;
 {$endif}
 
 initialization
-  {$ifdef win32}
+  {$ifdef WINDOWS}
   SetWindowsFontPath;
   {$endif}
 end.

packages/fcl-image/src/libfreetype.inc

@@ -6,7 +6,7 @@ Const
 
 // Windows
 {$ifdef windows}
-  FreeTypeDLL = 'freetype-6.dll';   // version 2.1.4
+  FreeTypeDLL = 'freetype.dll';
   {$define ft_found_platform}
 {$endif}
 

packages/fcl-passrc/src/pasresolver.pp

@@ -1474,7 +1474,6 @@ type
     procedure ResolveImplElement(El: TPasImplElement); virtual;
     procedure ResolveImplCaseOf(CaseOf: TPasImplCaseOf); virtual;
     procedure ResolveImplLabelMark(Mark: TPasImplLabelMark); virtual;
-    procedure ResolveImplForLoop(Loop: TPasImplForLoop); virtual;
     procedure ResolveImplWithDo(El: TPasImplWithDo); virtual;
     procedure ResolveImplAsm(El: TPasImplAsmStatement); virtual;
     procedure ResolveImplAssign(El: TPasImplAssign); virtual;
@@ -1534,6 +1533,7 @@ type
     procedure FinishExceptOnExpr; virtual;
     procedure FinishExceptOnStatement; virtual;
     procedure FinishWithDo(El: TPasImplWithDo); virtual;
+    procedure FinishForLoopHeader(Loop: TPasImplForLoop); virtual;
     procedure FinishDeclaration(El: TPasElement); virtual;
     procedure FinishVariable(El: TPasVariable); virtual;
     procedure FinishProperty(PropEl: TPasProperty); virtual;
@@ -6440,6 +6440,224 @@ begin
   PopWithScope(El);
 end;
 
+procedure TPasResolver.FinishForLoopHeader(Loop: TPasImplForLoop);
+var
+  VarResolved, StartResolved, EndResolved,
+    OrigStartResolved: TPasResolverResult;
+  EnumeratorFound, HasInValues: Boolean;
+  InRange, VarRange: TResEvalValue;
+  InRangeInt, VarRangeInt: TResEvalRangeInt;
+  bt: TResolverBaseType;
+  TypeEl, ElType: TPasType;
+  C: TClass;
+begin
+  CreateScope(Loop,TPasForLoopScope);
+
+  // loop var
+  ResolveExpr(Loop.VariableName,rraReadAndAssign);
+  ComputeElement(Loop.VariableName,VarResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
+  if not ResolvedElCanBeVarParam(VarResolved,Loop.VariableName) then
+    RaiseVarExpected(20170216151955,Loop.VariableName,VarResolved.IdentEl);
+
+  // resolve start expression
+  ResolveExpr(Loop.StartExpr,rraRead);
+  ComputeElement(Loop.StartExpr,StartResolved,[rcSetReferenceFlags]);
+
+  case Loop.LoopType of
+  ltNormal,ltDown:
+    begin
+    // start value
+    if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
+      RaiseIncompatibleTypeRes(20170216151958,nIncompatibleTypesGotExpected,
+        [],StartResolved,VarResolved,Loop.StartExpr);
+    CheckAssignExprRange(VarResolved,Loop.StartExpr);
+
+    // end value
+    ResolveExpr(Loop.EndExpr,rraRead);
+    ComputeElement(Loop.EndExpr,EndResolved,[rcSetReferenceFlags]);
+    if CheckAssignResCompatibility(VarResolved,EndResolved,Loop.EndExpr,false)=cIncompatible then
+      RaiseIncompatibleTypeRes(20170216152001,nIncompatibleTypesGotExpected,
+        [],EndResolved,VarResolved,Loop.EndExpr);
+    CheckAssignExprRange(VarResolved,Loop.EndExpr);
+    end;
+  ltIn:
+    begin
+    // check range
+    EnumeratorFound:=CheckForIn(Loop,VarResolved,StartResolved);
+    if (not EnumeratorFound)
+        and not (StartResolved.IdentEl is TPasType)
+        and (rrfReadable in StartResolved.Flags) then
+      begin
+      EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved);
+      end;
+
+    if not EnumeratorFound then
+      begin
+      VarRange:=nil;
+      InRange:=nil;
+      try
+        OrigStartResolved:=StartResolved;
+        if StartResolved.IdentEl is TPasType then
+          begin
+          // e.g. for e in TEnum do
+          TypeEl:=StartResolved.LoTypeEl;
+          if TypeEl is TPasArrayType then
+            begin
+            if length(TPasArrayType(TypeEl).Ranges)=1 then
+              InRange:=Eval(TPasArrayType(TypeEl).Ranges[0],[refConst]);
+            end;
+          if InRange=nil then
+            InRange:=EvalTypeRange(TypeEl,[]);
+          {$IFDEF VerbosePasResolver}
+          {AllowWriteln}
+          if InRange<>nil then
+            writeln('TPasResolver.ResolveImplForLoop in type: InRange=',InRange.AsDebugString)
+          else
+            writeln('TPasResolver.ResolveImplForLoop in type: InRange=nil');
+          {AllowWriteln-}
+          {$ENDIF}
+          end
+        else if rrfReadable in StartResolved.Flags then
+          begin
+          // value  (variable or expression)
+          bt:=StartResolved.BaseType;
+          if bt in [btSet,btArrayOrSet] then
+            begin
+            if (StartResolved.IdentEl=nil) and (StartResolved.ExprEl<>nil) then
+              InRange:=Eval(StartResolved.ExprEl,[]);
+            if InRange=nil then
+              InRange:=EvalTypeRange(StartResolved.LoTypeEl,[]);
+            end
+          else if bt=btContext then
+            begin
+            TypeEl:=StartResolved.LoTypeEl;
+            C:=TypeEl.ClassType;
+            if C=TPasArrayType then
+              begin
+              ElType:=GetArrayElType(TPasArrayType(TypeEl));
+              ComputeElement(ElType,StartResolved,[rcType]);
+              StartResolved.Flags:=OrigStartResolved.Flags*[rrfReadable,rrfWritable];
+              if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
+                RaiseIncompatibleTypeRes(20171112210138,nIncompatibleTypesGotExpected,
+                  [],StartResolved,VarResolved,Loop.StartExpr);
+              EnumeratorFound:=true;
+              end;
+            end
+          else
+            begin
+            bt:=GetActualBaseType(bt);
+            case bt of
+            {$ifdef FPC_HAS_CPSTRING}
+            btAnsiString:
+              InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff);
+            {$endif}
+            btUnicodeString:
+              InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
+            end;
+            end;
+          end;
+        if (not EnumeratorFound) and (InRange<>nil) then
+          begin
+          // for v in <constant> do
+          // -> check if same type
+          VarRange:=EvalTypeRange(VarResolved.LoTypeEl,[]);
+          if VarRange=nil then
+            RaiseXExpectedButYFound(20171109191528,'range',
+                         GetResolverResultDescription(VarResolved),Loop.VariableName);
+          //writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
+          //writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString,' ElType=',GetResolverResultDbg(StartResolved));
+          case InRange.Kind of
+          revkRangeInt,revkSetOfInt:
+            begin
+            InRangeInt:=TResEvalRangeInt(InRange);
+            case VarRange.Kind of
+            revkRangeInt:
+              begin
+              VarRangeInt:=TResEvalRangeInt(VarRange);
+              HasInValues:=(InRange.Kind<>revkSetOfInt) or (length(TResEvalSet(InRange).Ranges)>0);
+              case InRangeInt.ElKind of
+                revskEnum:
+                  if (VarRangeInt.ElKind<>revskEnum)
+                      or not IsSameType(InRangeInt.ElType,VarRangeInt.ElType,prraAlias) then
+                    RaiseXExpectedButYFound(20171109200752,GetTypeDescription(InRangeInt.ElType),
+                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
+                revskInt:
+                  if VarRangeInt.ElKind<>revskInt then
+                    RaiseXExpectedButYFound(20171109200752,'integer',
+                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
+                revskChar:
+                  if VarRangeInt.ElKind<>revskChar then
+                    RaiseXExpectedButYFound(20171109200753,'char',
+                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
+                revskBool:
+                  if VarRangeInt.ElKind<>revskBool then
+                    RaiseXExpectedButYFound(20171109200754,'boolean',
+                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
+              else
+                if HasInValues then
+                  RaiseNotYetImplemented(20171109200954,Loop.StartExpr);
+              end;
+              if HasInValues then
+                begin
+                if (VarRangeInt.RangeStart>InRangeInt.RangeStart) then
+                  begin
+                  {$IFDEF VerbosePasResolver}
+                  writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
+                  {$ENDIF}
+                  fExprEvaluator.EmitRangeCheckConst(20171109201428,
+                    InRangeInt.ElementAsString(InRangeInt.RangeStart),
+                    VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
+                    VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
+                  end;
+                if (VarRangeInt.RangeEnd<InRangeInt.RangeEnd) then
+                  begin
+                  {$IFDEF VerbosePasResolver}
+                  writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
+                  {$ENDIF}
+                  fExprEvaluator.EmitRangeCheckConst(20171109201429,
+                    InRangeInt.ElementAsString(InRangeInt.RangeEnd),
+                    VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
+                    VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
+                  end;
+                end;
+              EnumeratorFound:=true;
+              end;
+            else
+              {$IFDEF VerbosePasResolver}
+              writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
+              {$ENDIF}
+            end;
+            end;
+          else
+            {$IFDEF VerbosePasResolver}
+            writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString);
+            {$ENDIF}
+          end;
+          end;
+        if not EnumeratorFound then
+          begin
+          {$IFDEF VerbosePasResolver}
+          {AllowWriteln}
+          writeln('TPasResolver.ResolveImplForLoop StartResolved=',GetResolverResultDbg(StartResolved));
+          if VarRange<>nil then
+            writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRange.AsDebugString);
+          {AllowWriteln-}
+          {$ENDIF}
+          RaiseMsg(20171108223818,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
+            [GetBaseDescription(OrigStartResolved)],Loop.StartExpr);
+          end;
+      finally
+        ReleaseEvalValue(VarRange);
+        ReleaseEvalValue(InRange);
+      end;
+      end;
+
+    end;
+  else
+    RaiseNotYetImplemented(20171108221334,Loop);
+  end;
+end;
+
 procedure TPasResolver.FinishDeclaration(El: TPasElement);
 var
   C: TClass;
@@ -8003,7 +8221,8 @@ begin
   else if C=TPasImplLabelMark then
     ResolveImplLabelMark(TPasImplLabelMark(El))
   else if C=TPasImplForLoop then
-    ResolveImplForLoop(TPasImplForLoop(El))
+    // the header was already resolved
+    ResolveImplElement(TPasImplForLoop(El).Body)
   else if C=TPasImplTry then
     begin
     ResolveImplBlock(TPasImplTry(El));
@@ -8346,225 +8565,6 @@ begin
   RaiseNotYetImplemented(20161014141636,Mark);
 end;
 
-procedure TPasResolver.ResolveImplForLoop(Loop: TPasImplForLoop);
-var
-  VarResolved, StartResolved, EndResolved,
-    OrigStartResolved: TPasResolverResult;
-  EnumeratorFound, HasInValues: Boolean;
-  InRange, VarRange: TResEvalValue;
-  InRangeInt, VarRangeInt: TResEvalRangeInt;
-  bt: TResolverBaseType;
-  TypeEl, ElType: TPasType;
-  C: TClass;
-begin
-  CreateScope(Loop,TPasForLoopScope);
-
-  // loop var
-  ResolveExpr(Loop.VariableName,rraReadAndAssign);
-  ComputeElement(Loop.VariableName,VarResolved,[rcNoImplicitProc,rcSetReferenceFlags]);
-  if not ResolvedElCanBeVarParam(VarResolved,Loop.VariableName) then
-    RaiseVarExpected(20170216151955,Loop.VariableName,VarResolved.IdentEl);
-
-  // resolve start expression
-  ResolveExpr(Loop.StartExpr,rraRead);
-  ComputeElement(Loop.StartExpr,StartResolved,[rcSetReferenceFlags]);
-
-  case Loop.LoopType of
-  ltNormal,ltDown:
-    begin
-    // start value
-    if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
-      RaiseIncompatibleTypeRes(20170216151958,nIncompatibleTypesGotExpected,
-        [],StartResolved,VarResolved,Loop.StartExpr);
-    CheckAssignExprRange(VarResolved,Loop.StartExpr);
-
-    // end value
-    ResolveExpr(Loop.EndExpr,rraRead);
-    ComputeElement(Loop.EndExpr,EndResolved,[rcSetReferenceFlags]);
-    if CheckAssignResCompatibility(VarResolved,EndResolved,Loop.EndExpr,false)=cIncompatible then
-      RaiseIncompatibleTypeRes(20170216152001,nIncompatibleTypesGotExpected,
-        [],EndResolved,VarResolved,Loop.EndExpr);
-    CheckAssignExprRange(VarResolved,Loop.EndExpr);
-    end;
-  ltIn:
-    begin
-    // check range
-    EnumeratorFound:=CheckForIn(Loop,VarResolved,StartResolved);
-    if (not EnumeratorFound)
-        and not (StartResolved.IdentEl is TPasType)
-        and (rrfReadable in StartResolved.Flags) then
-      begin
-      EnumeratorFound:=CheckForInClassOrRec(Loop,VarResolved,StartResolved);
-      end;
-
-    if not EnumeratorFound then
-      begin
-      VarRange:=nil;
-      InRange:=nil;
-      try
-        OrigStartResolved:=StartResolved;
-        if StartResolved.IdentEl is TPasType then
-          begin
-          // e.g. for e in TEnum do
-          TypeEl:=StartResolved.LoTypeEl;
-          if TypeEl is TPasArrayType then
-            begin
-            if length(TPasArrayType(TypeEl).Ranges)=1 then
-              InRange:=Eval(TPasArrayType(TypeEl).Ranges[0],[refConst]);
-            end;
-          if InRange=nil then
-            InRange:=EvalTypeRange(TypeEl,[]);
-          {$IFDEF VerbosePasResolver}
-          {AllowWriteln}
-          if InRange<>nil then
-            writeln('TPasResolver.ResolveImplForLoop in type: InRange=',InRange.AsDebugString)
-          else
-            writeln('TPasResolver.ResolveImplForLoop in type: InRange=nil');
-          {AllowWriteln-}
-          {$ENDIF}
-          end
-        else if rrfReadable in StartResolved.Flags then
-          begin
-          // value  (variable or expression)
-          bt:=StartResolved.BaseType;
-          if bt in [btSet,btArrayOrSet] then
-            begin
-            if (StartResolved.IdentEl=nil) and (StartResolved.ExprEl<>nil) then
-              InRange:=Eval(StartResolved.ExprEl,[]);
-            if InRange=nil then
-              InRange:=EvalTypeRange(StartResolved.LoTypeEl,[]);
-            end
-          else if bt=btContext then
-            begin
-            TypeEl:=StartResolved.LoTypeEl;
-            C:=TypeEl.ClassType;
-            if C=TPasArrayType then
-              begin
-              ElType:=GetArrayElType(TPasArrayType(TypeEl));
-              ComputeElement(ElType,StartResolved,[rcType]);
-              StartResolved.Flags:=OrigStartResolved.Flags*[rrfReadable,rrfWritable];
-              if CheckAssignResCompatibility(VarResolved,StartResolved,Loop.StartExpr,true)=cIncompatible then
-                RaiseIncompatibleTypeRes(20171112210138,nIncompatibleTypesGotExpected,
-                  [],StartResolved,VarResolved,Loop.StartExpr);
-              EnumeratorFound:=true;
-              end;
-            end
-          else
-            begin
-            bt:=GetActualBaseType(bt);
-            case bt of
-            {$ifdef FPC_HAS_CPSTRING}
-            btAnsiString:
-              InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ff);
-            {$endif}
-            btUnicodeString:
-              InRange:=TResEvalRangeInt.CreateValue(revskChar,nil,0,$ffff);
-            end;
-            end;
-          end;
-        if (not EnumeratorFound) and (InRange<>nil) then
-          begin
-          // for v in <constant> do
-          // -> check if same type
-          VarRange:=EvalTypeRange(VarResolved.LoTypeEl,[]);
-          if VarRange=nil then
-            RaiseXExpectedButYFound(20171109191528,'range',
-                         GetResolverResultDescription(VarResolved),Loop.VariableName);
-          //writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
-          //writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString,' ElType=',GetResolverResultDbg(StartResolved));
-          case InRange.Kind of
-          revkRangeInt,revkSetOfInt:
-            begin
-            InRangeInt:=TResEvalRangeInt(InRange);
-            case VarRange.Kind of
-            revkRangeInt:
-              begin
-              VarRangeInt:=TResEvalRangeInt(VarRange);
-              HasInValues:=(InRange.Kind<>revkSetOfInt) or (length(TResEvalSet(InRange).Ranges)>0);
-              case InRangeInt.ElKind of
-                revskEnum:
-                  if (VarRangeInt.ElKind<>revskEnum)
-                      or not IsSameType(InRangeInt.ElType,VarRangeInt.ElType,prraAlias) then
-                    RaiseXExpectedButYFound(20171109200752,GetTypeDescription(InRangeInt.ElType),
-                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
-                revskInt:
-                  if VarRangeInt.ElKind<>revskInt then
-                    RaiseXExpectedButYFound(20171109200752,'integer',
-                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
-                revskChar:
-                  if VarRangeInt.ElKind<>revskChar then
-                    RaiseXExpectedButYFound(20171109200753,'char',
-                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
-                revskBool:
-                  if VarRangeInt.ElKind<>revskBool then
-                    RaiseXExpectedButYFound(20171109200754,'boolean',
-                      GetResolverResultDescription(VarResolved,true),loop.VariableName);
-              else
-                if HasInValues then
-                  RaiseNotYetImplemented(20171109200954,Loop.StartExpr);
-              end;
-              if HasInValues then
-                begin
-                if (VarRangeInt.RangeStart>InRangeInt.RangeStart) then
-                  begin
-                  {$IFDEF VerbosePasResolver}
-                  writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
-                  {$ENDIF}
-                  fExprEvaluator.EmitRangeCheckConst(20171109201428,
-                    InRangeInt.ElementAsString(InRangeInt.RangeStart),
-                    VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
-                    VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
-                  end;
-                if (VarRangeInt.RangeEnd<InRangeInt.RangeEnd) then
-                  begin
-                  {$IFDEF VerbosePasResolver}
-                  writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRangeInt.AsDebugString,' ',InRangeInt.AsDebugString);
-                  {$ENDIF}
-                  fExprEvaluator.EmitRangeCheckConst(20171109201429,
-                    InRangeInt.ElementAsString(InRangeInt.RangeEnd),
-                    VarRangeInt.ElementAsString(VarRangeInt.RangeStart),
-                    VarRangeInt.ElementAsString(VarRangeInt.RangeEnd),Loop.VariableName,mtError);
-                  end;
-                end;
-              EnumeratorFound:=true;
-              end;
-            else
-              {$IFDEF VerbosePasResolver}
-              writeln('TPasResolver.ResolveImplForLoop ForIn VarRange=',VarRange.AsDebugString);
-              {$ENDIF}
-            end;
-            end;
-          else
-            {$IFDEF VerbosePasResolver}
-            writeln('TPasResolver.ResolveImplForLoop ForIn InRange=',InRange.AsDebugString);
-            {$ENDIF}
-          end;
-          end;
-        if not EnumeratorFound then
-          begin
-          {$IFDEF VerbosePasResolver}
-          {AllowWriteln}
-          writeln('TPasResolver.ResolveImplForLoop StartResolved=',GetResolverResultDbg(StartResolved));
-          if VarRange<>nil then
-            writeln('TPasResolver.ResolveImplForLoop VarRange=',VarRange.AsDebugString);
-          {AllowWriteln-}
-          {$ENDIF}
-          RaiseMsg(20171108223818,nCannotFindEnumeratorForType,sCannotFindEnumeratorForType,
-            [GetBaseDescription(OrigStartResolved)],Loop.StartExpr);
-          end;
-      finally
-        ReleaseEvalValue(VarRange);
-        ReleaseEvalValue(InRange);
-      end;
-      end;
-
-    end;
-  else
-    RaiseNotYetImplemented(20171108221334,Loop);
-  end;
-  ResolveImplElement(Loop.Body);
-end;
-
 procedure TPasResolver.ResolveImplWithDo(El: TPasImplWithDo);
 // Note: the expressions were already resolved during parsing
 //  and the scopes were already stored in a TPasWithScope.
@@ -16539,6 +16539,7 @@ begin
   stExceptOnExpr: FinishExceptOnExpr;
   stExceptOnStatement: FinishExceptOnStatement;
   stWithExpr: FinishWithDo(El as TPasImplWithDo);
+  stForLoopHeader: FinishForLoopHeader(El as TPasImplForLoop);
   stDeclaration: FinishDeclaration(El);
   stAncestors: FinishAncestors(El as TPasClassType);
   stInitialFinalization: FinishInitialFinalization(El as TPasImplBlock);

packages/fcl-passrc/src/pparser.pp

@@ -174,6 +174,7 @@ type
     stWithExpr, // calls BeginScope after parsing every WITH-expression
     stExceptOnExpr,
     stExceptOnStatement,
+    stForLoopHeader,
     stDeclaration, // e.g. a TPasProperty, TPasVariable, TPasArgument, ...
     stAncestors, // the list of ancestors and interfaces of a class
     stInitialFinalization
@@ -5809,6 +5810,7 @@ begin
           TPasImplForLoop(El).LoopType:=lt;
           if (CurToken<>tkDo) then
             ParseExcTokenError(TokenInfos[tkDo]);
+          Engine.FinishScope(stForLoopHeader,El);
           CreateBlock(TPasImplForLoop(El));
           El:=nil;
           //WriteLn(i,'FOR "',VarName,'" := ',StartValue,' to ',EndValue,' Token=',CurTokenText);

packages/fcl-passrc/tests/tcresolver.pas

@@ -470,6 +470,7 @@ type
     Procedure TestAnonymousProc_With;
     Procedure TestAnonymousProc_ExceptOn;
     Procedure TestAnonymousProc_Nested;
+    Procedure TestAnonymousProc_ForLoop;
 
     // record
     Procedure TestRecord;
@@ -7793,6 +7794,27 @@ begin
   ParseProgram;
 end;
 
+procedure TTestResolver.TestAnonymousProc_ForLoop;
+begin
+  StartProgram(false);
+  Add([
+  'type TProc = reference to procedure;',
+  'procedure Foo(p: TProc);',
+  'begin',
+  'end;',
+  'procedure DoIt;',
+  'var i: word;',
+  '  a: word;',
+  'begin',
+  '  for i:=1 to 10 do begin',
+  '    Foo(procedure begin a:=3; end);',
+  '  end;',
+  'end;',
+  'begin',
+  '  DoIt;']);
+  ParseProgram;
+end;
+
 procedure TTestResolver.TestRecord;
 begin
   StartProgram(false);

packages/pastojs/src/fppas2js.pp

@@ -17263,7 +17263,7 @@ end;
 
 function TPasToJSConverter.CreateRTTIMemberProperty(Members: TFPList;
   Index: integer; AContext: TConvertContext): TJSElement;
-// create  $r.addProperty("propname",flags,result,"getter","setter",{options})
+// create  $r.addProperty("propname",flags,proptype,"getter","setter",{options})
 var
   Prop: TPasProperty;
   Call: TJSCallExpression;

packages/pastojs/tests/tcmodules.pas

@@ -347,6 +347,7 @@ type
     Procedure TestAnonymousProc_Nested;
     Procedure TestAnonymousProc_NestedAssignResult;
     Procedure TestAnonymousProc_Class;
+    Procedure TestAnonymousProc_ForLoop;
 
     // enums, sets
     Procedure TestEnum_Name;
@@ -4801,6 +4802,44 @@ begin
     '']));
 end;
 
+procedure TTestModule.TestAnonymousProc_ForLoop;
+begin
+  StartProgram(false);
+  Add([
+  'type TProc = reference to procedure;',
+  'procedure Foo(p: TProc);',
+  'begin',
+  'end;',
+  'procedure DoIt;',
+  'var i: word;',
+  '  a: word;',
+  'begin',
+  '  for i:=1 to 10 do begin',
+  '    Foo(procedure begin a:=3; end);',
+  '  end;',
+  'end;',
+  'begin',
+  '  DoIt;']);
+  ConvertProgram;
+  CheckSource('TestAnonymousProc_ForLoop',
+    LinesToStr([ // statements
+    'this.Foo = function (p) {',
+    '};',
+    'this.DoIt = function () {',
+    '  var i = 0;',
+    '  var a = 0;',
+    '  for (i = 1; i <= 10; i++) {',
+    '    $mod.Foo(function () {',
+    '      a = 3;',
+    '    });',
+    '  };',
+    '};',
+    '']),
+    LinesToStr([
+    '$mod.DoIt();'
+    ]));
+end;
+
 procedure TTestModule.TestEnum_Name;
 begin
   StartProgram(false);

packages/paszlib/src/zipper.pp

@@ -2147,7 +2147,7 @@ Begin
   If Assigned(FOnCreateStream) then
     FOnCreateStream(Self, OutStream, Item);
   // If FOnCreateStream didn't create one, we create one now.
-  If (OutStream=Nil) then
+  If (OutStream=Nil) and (not Item.IsDirectory) then
     begin
     if (Path<>'') then
       ForceDirectories(Path);
@@ -2173,7 +2173,8 @@ Begin
     OutStream := nil;
   end
   else
-    FreeAndNil(OutStream);
+    if Assigned(OutStream) then
+      FreeAndNil(OutStream);
   DoEndOfFile;
 end;
 

packages/rtl-objpas/src/i386/invoke.inc

@@ -440,11 +440,513 @@ begin
   end;
 end;
 
+const
+  PlaceholderContext = LongWord($12345678);
+  PlaceholderAddress = LongWord($87654321);
+  PlaceholderRetPop  = Word($1234);
+
+  RetNear = $C2;
+  RetFar = $CA;
+
+label
+  CallbackRegisterContext,
+  CallbackRegisterAddress,
+  CallbackRegisterCall,
+  CallbackRegisterRet,
+  CallbackRegisterEnd;
+
+const
+  CallbackRegisterContextPtr: Pointer = @CallbackRegisterContext;
+  CallbackRegisterAddressPtr: Pointer = @CallbackRegisterAddress;
+  CallbackRegisterCallPtr: Pointer = @CallbackRegisterCall;
+  CallbackRegisterRetPtr: Pointer = @CallbackRegisterRet;
+  CallbackRegisterEndPtr: Pointer = @CallbackRegisterEnd;
+
+procedure CallbackRegister; assembler; nostackframe;
+asm
+  { establish frame }
+  pushl %ebp
+  movl %esp, %ebp
+
+  { store registers }
+  pushl %ecx
+  pushl %edx
+  pushl %eax
+
+  { store pointer to stack area (including GP registers) }
+  lea (%esp), %edx
+
+  { also store ebx as we'll use that for the function address }
+  pushl %ebx
+
+  { call function with context }
+CallbackRegisterContext:
+  movl $0x12345678, %eax
+CallbackRegisterAddress:
+  movl $0x87654321, %ebx
+CallbackRegisterCall:
+
+  call *%ebx
+
+  { restore ebx }
+  popl %ebx
+
+  { restore stack }
+  movl %ebp, %esp
+  popl %ebp
+
+CallbackRegisterRet:
+  ret $0x1234
+CallbackRegisterEnd:
+end;
+
+type
+  TSystemFunctionCallback = class(TFunctionCallCallback)
+  private type
+    {$ScopedEnums On}
+    TArgType = (
+      GenReg,
+      Stack
+    );
+    {$ScopedEnums Off}
+
+    TArgInfo = record
+      ArgType: TArgType;
+      ArgIdx: SizeInt;
+      Slots: SizeInt;
+      Offset: SizeInt;
+      Deref: Boolean;
+    end;
+  private
+    fData: Pointer;
+    fSize: PtrUInt;
+    fFlags: TFunctionCallFlags;
+    fContext: Pointer;
+    fArgs: specialize TArray<TFunctionCallParameterInfo>;
+    fArgInfos: specialize TArray<TArgInfo>;
+    fRefArgs: specialize TArray<SizeInt>;
+    fResultType: PTypeInfo;
+    fResultIdx: SizeInt;
+    fResultInParam: Boolean;
+  private
+    function Handler(aStack: Pointer): Int64;
+  protected
+    procedure CreateCallback;
+    procedure CreateArgInfos;
+    function GetCodeAddress: CodePointer; override;
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); virtual; abstract;
+  public
+    constructor Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+    destructor Destroy; override;
+  end;
+
+  TSystemFunctionCallbackMethod = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallMethod;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+  TSystemFunctionCallbackProc = class(TSystemFunctionCallback)
+  private
+    fHandler: TFunctionCallProc;
+  protected
+    procedure CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer); override;
+  public
+    constructor Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+  end;
+
+function TSystemFunctionCallback.Handler(aStack: Pointer): Int64;
+{
+  aStack has the following layout:
+    0:  EAX
+    4:  EDX
+    8:  ECX
+    12: EBP (not needed)
+    16: RET (not needed)
+    20: ARGS
+}
+var
+  args: specialize TArray<Pointer>;
+  i, len: SizeInt;
+  val: PPtrUInt;
+  resptr: Pointer;
+  genargs, stackargs: PPtrUInt;
+  floatres, floattmp: Extended;
+  td: PTypeData;
+begin
+  len := Length(fArgInfos);
+  if fResultInParam then
+    Dec(len);
+  SetLength(args, len);
+  genargs := PPtrUInt(aStack);
+  stackargs := @genargs[5];
+  for i := 0 to High(fArgInfos) do begin
+    if i = fResultIdx then
+      Continue;
+    case fArgInfos[i].ArgType of
+      TArgType.GenReg:
+        val := @genargs[fArgInfos[i].Offset];
+      TArgType.Stack:
+        val := @stackargs[fArgInfos[i].Offset];
+    end;
+    if fArgInfos[i].Deref then
+      args[fArgInfos[i].ArgIdx] := PPtrUInt(val^)
+    else
+      args[fArgInfos[i].ArgIdx] := val;
+  end;
+
+  if fResultInParam then begin
+    case fArgInfos[fResultIdx].ArgType of
+      TArgType.GenReg:
+        resptr := @genargs[fArgInfos[fResultIdx].Offset];
+      TArgType.Stack:
+        resptr := @stackargs[fArgInfos[fResultIdx].Offset];
+    end;
+    if fArgInfos[fResultIdx].Deref then
+      resptr := PPointer(resptr)^;
+  end else if Assigned(fResultType) then begin
+    if fResultType^.Kind = tkFloat then begin
+      resptr := @floatres;
+    end else
+      resptr := @Result;
+  end else
+    resptr := Nil;
+
+  CallHandler(args, resptr, fContext);
+
+  if Assigned(fResultType) and not fResultInParam and (fResultType^.Kind = tkFloat) then begin
+    td := GetTypeData(fResultType);
+    case td^.FloatType of
+      ftSingle:
+        asm
+          lea floatres, %eax
+          flds (%eax)
+          fwait
+        end ['eax'];
+      ftDouble:
+        asm
+          lea floatres, %eax
+          fldl (%eax)
+          fwait
+        end ['eax'];
+      ftExtended:
+        asm
+          lea floatres, %eax
+          fldt (%eax)
+          fwait
+        end ['eax'];
+      ftCurr,
+      ftComp:
+        asm
+          lea floatres, %eax
+          fildq (%eax)
+          fwait
+        end ['eax'];
+    end;
+  end;
+end;
+
+procedure TSystemFunctionCallback.CreateCallback;
+
+  procedure ReplacePlaceholder(aPlaceholder: PtrUInt; aValue: PtrUInt; aOfs, aSize: PtrUInt);
+  var
+    found: Boolean;
+    i: PtrUInt;
+  begin
+    found := False;
+    for i := aOfs to aOfs + aSize - 1 do begin
+      if PPtrUInt(@PByte(fData)[i])^ = PtrUInt(aPlaceholder) then begin
+        PPtrUInt(@(PByte(fData)[i]))^ := PtrUInt(aValue);
+        found := True;
+        Break;
+      end;
+    end;
+
+    if not found then
+      raise Exception.Create(SErrMethodImplCreateFailed);
+  end;
+
+var
+  src: Pointer;
+  ofs, size: PtrUInt;
+  method: TMethod;
+  i, stacksize: SizeInt;
+begin
+  fSize := PtrUInt(CallbackRegisterEndPtr) - PtrUInt(@CallbackRegister) + 1;
+  fData := AllocateMemory(fSize);
+  if not Assigned(fData) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+
+  src := @CallbackRegister;
+  Move(src^, fData^, fSize);
+
+  ofs := PtrUInt(CallbackRegisterContextPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterAddressPtr) - PtrUInt(CallbackRegisterContextPtr);
+
+  method := TMethod(@Handler);
+
+  ReplacePlaceholder(PlaceholderContext, PtrUInt(method.Data), ofs, size);
+
+  ofs := PtrUInt(CallbackRegisterAddressPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterCallPtr) - PtrUInt(CallbackRegisterAddressPtr);
+
+  ReplacePlaceholder(PlaceholderAddress, PtrUInt(method.Code), ofs, size);
+
+  ofs := PtrUInt(CallbackRegisterRetPtr) - PtrUInt(@CallbackRegister);
+  size := PtrUInt(CallbackRegisterEndPtr) - PtrUInt(CallbackRegisterRetPtr);
+
+  if not (PByte(fData)[ofs] = RetNear) and not (PByte(fData)[ofs] = RetFar) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+
+  stacksize := 0;
+  for i := 0 to High(fArgInfos) do
+    if fArgInfos[i].ArgType = TArgType.Stack then
+      Inc(stacksize, fArgInfos[i].Slots);
+
+  stacksize := stacksize * 4;
+
+  Inc(ofs);
+  if PWord(@PByte(fData)[ofs])^ = PlaceholderRetPop then
+    PWord(@PByte(fData)[ofs])^ := Word(stacksize);
+
+  if not ProtectMemory(fData, fSize, True) then
+    raise Exception.Create(SErrMethodImplCreateFailed);
+end;
+
+procedure TSystemFunctionCallback.CreateArgInfos;
+var
+  pass, genofs, stackofs: LongInt;
+  td: PTypeData;
+  i, c, argcount, stackcount, idx, argidx: SizeInt;
+  stackargs: array of SizeInt;
+begin
+  fResultInParam := ReturnResultInParam(fResultType);
+
+  genofs := 0;
+  stackofs := 0;
+  argidx := 0;
+  argcount := Length(fArgs);
+  if fResultInParam then begin
+    if fcfStatic in fFlags then
+      fResultIdx := 0
+    else
+      fResultIdx := 1;
+    Inc(argcount);
+  end else
+    fResultIdx := -1;
+  SetLength(fArgInfos, argcount);
+  SetLength(fRefArgs, argcount);
+  if fResultIdx >= 0 then begin
+    fArgInfos[fResultIdx].ArgType := TArgType.GenReg;
+    fArgInfos[fResultIdx].Offset := fResultIdx;
+  end;
+
+  SetLength(stackargs, argcount);
+  stackcount := 0;
+
+  for pass := 0 to 1 do begin
+    if pass = 0 then
+      c := High(fArgs)
+    else
+      c := stackcount - 1;
+    for i := 0 to c do begin
+      if argidx = fResultIdx then
+        Inc(argidx);
+      if pfResult in fArgs[i].ParamFlags then begin
+        fResultIdx := argidx;
+        fResultInParam := True;
+      end;
+      if (pass = 0) and (genofs >= 3) then begin
+        stackargs[stackcount] := i;
+        Inc(stackcount);
+        Continue;
+      end;
+      if pass = 0 then
+        idx := i
+      else
+        idx := stackargs[c - i];
+      if pass = 0 then
+        fArgInfos[argidx].ArgType := TArgType.GenReg
+      else
+        fArgInfos[argidx].ArgType := TArgType.Stack;
+      fArgInfos[argidx].Deref := False;
+      fArgInfos[argidx].Slots := 1;
+      if pfArray in fArgs[idx].ParamFlags then
+        fArgInfos[argidx].Deref := True
+      else if fArgs[idx].ParamFlags * [pfOut, pfVar, pfConstRef] <> [] then
+        fArgInfos[argidx].Deref := True
+      else if (pfConst in fArgs[idx].ParamFlags) and not Assigned(fArgs[idx].ParamType) then
+        fArgInfos[argidx].Deref := True
+      else begin
+        td := GetTypeData(fArgs[idx].ParamType);
+        case fArgs[idx].ParamType^.Kind of
+          tkSString,
+          tkMethod:
+            fArgInfos[argidx].Deref := True;
+          tkArray:
+            if td^.ArrayData.Size <= 4 then begin
+              fArgInfos[argidx].Deref := True;
+              fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkRecord:
+            if td^.RecSize <= 4 then begin
+              fArgInfos[argidx].Deref := True;
+              fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkObject,
+          tkWString,
+          tkUString,
+          tkAString,
+          tkDynArray,
+          tkClass,
+          tkClassRef,
+          tkInterface,
+          tkInterfaceRaw,
+          tkProcVar,
+          tkPointer:
+            ;
+          tkInt64,
+          tkQWord: begin
+            fArgInfos[argidx].ArgType := TArgType.Stack;
+            fArgInfos[argidx].Slots := 2;
+          end;
+          tkSet: begin
+            case td^.OrdType of
+              otUByte: begin
+                case td^.SetSize of
+                  0, 1, 2, 4:
+                    ;
+                  else
+                    fArgInfos[argidx].Deref := True;
+                end;
+              end;
+              otUWord,
+              otULong:
+                ;
+            end;
+          end;
+          tkEnumeration,
+          tkInteger:
+            ;
+          tkBool:
+            case td^.OrdType of
+              otUQWord,
+              otSQWord:
+                fArgInfos[argidx].ArgType := TArgType.Stack;
+            end;
+          tkFloat: begin
+            fArgInfos[argidx].ArgType := TArgType.Stack;
+            case td^.FloatType of
+              ftSingle:
+                ;
+              ftCurr,
+              ftComp,
+              ftDouble:
+                fArgInfos[argidx].Slots := 2;
+              ftExtended:
+                fArgInfos[argidx].Slots := 3;
+            end;
+          end;
+        else
+          raise EInvocationError.CreateFmt(SErrFailedToConvertArg, [idx, fArgs[idx].ParamType^.Name]);
+        end;
+      end;
+
+      { ignore stack arguments in first pass }
+      if (pass = 0) and (fArgInfos[argidx].ArgType = TArgType.Stack) then begin
+        stackargs[stackcount] := idx;
+        Inc(stackcount);
+        Continue;
+      end;
+
+      if fArgInfos[argidx].ArgType = TArgType.GenReg then begin
+        fArgInfos[argidx].ArgIdx := idx;
+        fArgInfos[argidx].Offset := genofs;
+        Inc(genofs);
+      end else if fArgInfos[argidx].ArgType = TArgType.Stack then begin
+        fArgInfos[argidx].ArgIdx := idx;
+        fArgInfos[argidx].Offset := stackofs;
+        Inc(stackofs, fArgInfos[argidx].Slots);
+      end;
+
+      Inc(argidx);
+    end;
+  end;
+end;
+
+function TSystemFunctionCallback.GetCodeAddress: CodePointer;
+begin
+  Result := fData;
+end;
+
+constructor TSystemFunctionCallback.Create(aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+
+  function CallConvName: String; inline;
+  begin
+    WriteStr(Result, aCallConv);
+  end;
+
+var
+  i: SizeInt;
+begin
+  if not (aCallConv in [ccReg]) then
+    raise ENotImplemented.CreateFmt(SErrCallConvNotSupported, [CallConvName]);
+  fContext := aContext;
+  SetLength(fArgs, Length(aArgs));
+  for i := 0 to High(aArgs) do
+    fArgs[i] := aArgs[i];
+  fResultType := aResultType;
+  fFlags := aFlags;
+  CreateArgInfos;
+  CreateCallback;
+end;
+
+destructor TSystemFunctionCallback.Destroy;
+begin
+  if Assigned(fData) then
+    FreeMemory(fData, fSize);
+end;
+
+constructor TSystemFunctionCallbackProc.Create(aHandler: TFunctionCallProc; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackProc.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+constructor TSystemFunctionCallbackMethod.Create(aHandler: TFunctionCallMethod; aContext: Pointer; aCallConv: TCallConv; constref aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags);
+begin
+  inherited Create(aContext, aCallConv, aArgs, aResultType, aFlags);
+  fHandler := aHandler;
+end;
+
+procedure TSystemFunctionCallbackMethod.CallHandler(constref aArgs: specialize TArray<Pointer>; aResult: Pointer; aContext: Pointer);
+begin
+  fHandler(aArgs, aResult, aContext);
+end;
+
+function SystemCreateCallbackProc(aHandler: TFunctionCallProc; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackProc.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
+function SystemCreateCallbackMethod(aHandler: TFunctionCallMethod; aCallConv: TCallConv; aArgs: array of TFunctionCallParameterInfo; aResultType: PTypeInfo; aFlags: TFunctionCallFlags; aContext: Pointer): TFunctionCallCallback;
+begin
+  Result := TSystemFunctionCallbackMethod.Create(aHandler, aContext, aCallConv, aArgs, aResultType, aFlags);
+end;
+
 const
   SystemFunctionCallManager: TFunctionCallManager = (
     Invoke: @SystemInvoke;
-    CreateCallbackProc: Nil;
-    CreateCallbackMethod: Nil;
+    CreateCallbackProc: @SystemCreateCallbackProc;
+    CreateCallbackMethod: @SystemCreateCallbackMethod;
   );
 
 procedure InitSystemFunctionCallManager;

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

@@ -576,6 +576,9 @@ implementation
 uses
 {$ifdef windows}
   Windows,
+{$endif}
+{$ifdef unix}
+  BaseUnix,
 {$endif}
   fgl;
 
@@ -749,8 +752,10 @@ function AllocateMemory(aSize: PtrUInt): Pointer;
 begin
 {$IF DEFINED(WINDOWS)}
   Result := VirtualAlloc(Nil, aSize, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE);
+{$ELSEIF DEFINED(UNIX)}
+  Result := fpmmap(Nil, aSize, PROT_READ or PROT_WRITE, MAP_PRIVATE or MAP_ANONYMOUS, 0, 0);
 {$ELSE}
-  Result := GetMem(aSize);
+  Result := Nil;
 {$ENDIF}
 end;
 
@@ -765,17 +770,24 @@ begin
     Result := VirtualProtect(aPtr, aSize, PAGE_EXECUTE_READ, oldprot)
   else
     Result := VirtualProtect(aPtr, aSize, PAGE_READWRITE, oldprot);
+{$ELSEIF DEFINED(UNIX)}
+  if aExecutable then
+    Result := Fpmprotect(aPtr, aSize, PROT_EXEC or PROT_READ) = 0
+  else
+    Result := Fpmprotect(aPtr, aSize, PROT_READ or PROT_WRITE) = 0;
 {$ELSE}
-  Result := True;
+  Result := False;
 {$ENDIF}
 end;
 
-procedure FreeMemory(aPtr: Pointer);
+procedure FreeMemory(aPtr: Pointer; aSize: PtrUInt);
 begin
 {$IF DEFINED(WINDOWS)}
   VirtualFree(aPtr, 0, MEM_RELEASE);
+{$ELSEIF DEFINED(UNIX)}
+  fpmunmap(aPtr, aSize);
 {$ELSE}
-  FreeMem(aPtr);
+  { nothing }
 {$ENDIF}
 end;
 

packages/rtl-objpas/src/x86_64/invoke.inc

@@ -654,7 +654,7 @@ destructor TSystemFunctionCallback.Destroy;
 begin
 {$ifdef windows}
   if Assigned(fData) then
-    FreeMemory(fData);
+    FreeMemory(fData, fSize);
 {$endif}
 end;
 

packages/rtl-objpas/tests/testrunner.rtlobjpas.pp

@@ -11,6 +11,7 @@ program testrunner.rtlobjpas;
 {$define testimpl}
 {$elseif defined(CPUI386)}
 {$define testinvoke}
+{$define testimpl}
 {$else}
 {$ifdef useffi}
 {$define testinvoke}

packages/rtl-objpas/tests/tests.rtti.impl.pas

@@ -426,7 +426,12 @@ begin
         InputUntypedTypes[i + 1] := Nil;
     end;
 
-    impl := method.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    try
+      impl := method.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    except
+      on e: ENotImplemented do
+        Exit;
+    end;
     CheckNotNull(impl, 'Method implementation is Nil');
 
     mrec.Data := Self;
@@ -501,7 +506,12 @@ begin
         InputUntypedTypes[i] := Nil;
     end;
 
-    impl := proc.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    try
+      impl := proc.CreateImplementation({$ifdef fpc}@{$endif}OnHandleInvokable);
+    except
+      on e: ENotImplemented do
+        Exit;
+    end;
     CheckNotNull(impl, 'Method implementation is Nil');
 
     cp := impl.CodeAddress;
@@ -555,7 +565,12 @@ procedure TTestImpl.TestIntfMethods;
 var
   intf: ITestInterface;
 begin
-  intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(ITestInterface)), {$ifdef fpc}@{$endif}OnHandleIntfMethod) as ITestInterface;
+  try
+    intf := TVirtualInterface.Create(PTypeInfo(TypeInfo(ITestInterface)), {$ifdef fpc}@{$endif}OnHandleIntfMethod) as ITestInterface;
+  except
+    on e: ENotImplemented do
+      Exit;
+  end;
   Check(Assigned(intf), 'ITestInterface instance is Nil');
 
   {$ifdef fpc}specialize{$endif}GenDoIntfImpl<ITestInterface>(intf, 1, [], [], [], TValue.Empty);

packages/winunits-base/src/imm.pas

@@ -434,7 +434,7 @@ function ImmGetStatusWindowPos(imc: HIMC; lpptPos: LPPOINT): LongBool; stdcall ;
 function ImmSetStatusWindowPos(imc: HIMC; lpptPos: LPPOINT): LongBool; stdcall ; external Imm name 'ImmSetStatusWindowPos';
 function ImmGetCompositionWindow(imc: HIMC; lpCompForm: LPCOMPOSITIONFORM): LongBool; stdcall ; external Imm name 'ImmGetCompositionWindow';
 function ImmSetCompositionWindow(imc: HIMC; lpCompForm: LPCOMPOSITIONFORM): LongBool; stdcall ; external Imm name 'ImmSetCompositionWindow';
-function ImmGetCandidateWindow(imc: HIMC; par1: DWORD; lpCandidate: LPCANDIDATEFORM): LongBool; stdcall ; external Imm name 'ImmGetCandidateWindow(';
+function ImmGetCandidateWindow(imc: HIMC; par1: DWORD; lpCandidate: LPCANDIDATEFORM): LongBool; stdcall ; external Imm name 'ImmGetCandidateWindow';
 function ImmSetCandidateWindow(imc: HIMC; lpCandidate: LPCANDIDATEFORM): LongBool; stdcall ; external Imm name 'ImmSetCandidateWindow';
 
 function ImmIsUIMessageA(wnd: HWND; msg: UINT; wPar: WPARAM; lPar: LPARAM): LongBool; stdcall ; external Imm name 'ImmIsUIMessageA';

packages/winunits-base/src/shlwapi.pp

@@ -2,8 +2,8 @@ unit shlwapi;
 
 {
     This file is part of the Free Pascal run time library.
-    shlwapi calls are parked here for now.
-    Copyright (c) 1999-2002 by Marco van de Voort,
+    partial shlwapi.h header translation
+    Copyright (c) 1999-2019 by Marco van de Voort,
     member of the Free Pascal development team.
 
     See the file COPYING.FPC, included in this distribution,
@@ -18,8 +18,967 @@ unit shlwapi;
 interface
 {$mode delphi}
 
-function StrCmpLogicalW(psz1, psz2: PWideChar): Integer; stdcall; external 'shlwapi.dll';
+Uses Windows,ActiveX;
+  const
+    SHLWAPIDLL='shlwapi.dll'; {Setup as you need}
+
+Type
+  SFBS_FLAGS = longint;
+  STIF_FLAGS = longint;
+  SRRF       = integer;
+  LSTATUS    = LONG;
+  HUSKEY     = THANDLE;
+  PHUSKEY    = PHANDLE;
+  SHCT_FLAGS = DWORD;   // SHCreateThread flags values
+  ASSOCF     = DWORD;
+  PHWND      = PHANDLE;
+  PPIDLIST_RELATIVE  = PITEMIDLIST;
+  PCUIDLIST_RELATIVE = PITEMIDLIST;
+  PCIDLIST_ABSOLUTE  = PITEMIDLIST;
+
+  PPERCEIVEDFLAG     = ^PERCEIVEDFLAG;
+  PERCEIVEDFLAG      = DWORD;
+
+  PSFBS_FLAGS  = ^SFBS_FLAGS;
+  PSTIF_FLAGS  = ^STIF_FLAGS;
+  PtagSFBS_FLAGS  = ^tagSFBS_FLAGS;
+    tagSFBS_FLAGS = (SFBS_FLAGS_ROUND_TO_NEAREST_DISPLAYED_DIGIT = $0001,
+      SFBS_FLAGS_TRUNCATE_UNDISPLAYED_DECIMAL_DIGITS = $0002
+      );
+  PCUITEMID_CHILD= PITEMIDLIST;
+  PZPCSTR = PLPSTR;   // PLPCSTR
+  PZPCWSTR = PLPWSTR; // PLPCWSTR
+
+const
+  STIF_DEFAULT     = $00000000;
+  STIF_SUPPORT_HEX = $00000001;
+
+Type
+  PURL_SCHEME = ^URL_SCHEME;
+  URL_SCHEME = (
+      URL_SCHEME_INVALID = -(1),
+      URL_SCHEME_UNKNOWN = 0,
+      URL_SCHEME_FTP,
+      URL_SCHEME_HTTP,
+      URL_SCHEME_GOPHER,
+      URL_SCHEME_MAILTO,
+      URL_SCHEME_NEWS,
+      URL_SCHEME_NNTP,
+      URL_SCHEME_TELNET,
+      URL_SCHEME_WAIS,
+      URL_SCHEME_FILE,
+      URL_SCHEME_MK,
+      URL_SCHEME_HTTPS,
+      URL_SCHEME_SHELL,
+      URL_SCHEME_SNEWS,
+      URL_SCHEME_LOCAL,
+      URL_SCHEME_JAVASCRIPT,
+      URL_SCHEME_VBSCRIPT,
+      URL_SCHEME_ABOUT,
+      URL_SCHEME_RES,
+      URL_SCHEME_MSSHELLROOTED,
+      URL_SCHEME_MSSHELLIDLIST,
+      URL_SCHEME_MSHELP,
+      URL_SCHEME_MSSHELLDEVICE,
+      URL_SCHEME_WILDCARD,
+      URL_SCHEME_SEARCH_MS,
+      URL_SCHEME_SEARCH,
+      URL_SCHEME_KNOWNFOLDER,
+      URL_SCHEME_MAXVALUE
+      );
+
+  PURL_PART = ^URL_PART;
+  URL_PART = (
+      URL_PART_NONE = 0,
+      URL_PART_SCHEME = 1,
+      URL_PART_HOSTNAME,
+      URL_PART_USERNAME,
+      URL_PART_PASSWORD,
+      URL_PART_PORT,
+      URL_PART_QUERY);
+
+  PURLIS = ^URLIS;
+  URLIS = (
+      URLIS_URL =0,
+      URLIS_OPAQUE,
+      URLIS_NOHISTORY,
+      URLIS_FILEURL,
+      URLIS_APPLIABLE,
+      URLIS_DIRECTORY,
+      URLIS_HASQUERY);
+
+
+  SHREGDEL_FLAGS = (
+    SHREGDEL_DEFAULT = $00000000,       // Delete's HKCU, or HKLM if HKCU is not found.
+    SHREGDEL_HKCU    = $00000001,       // Delete HKCU only
+    SHREGDEL_HKLM    = $00000010,       // Delete HKLM only.
+    SHREGDEL_BOTH    = $00000011        // Delete both HKCU and HKLM.
+   );
+
+
+  SHREGENUM_FLAGS = (
+    SHREGENUM_DEFAULT = $00000000,       // Enumerates HKCU or HKLM if not found.
+    SHREGENUM_HKCU    = $00000001,       // Enumerates HKCU only
+    SHREGENUM_HKLM    = $00000010,       // Enumerates HKLM only.
+    SHREGENUM_BOTH    = $00000011        // Enumerates both HKCU and HKLM without duplicates.
+   );                                       // This option is NYI.
+  ASSOCSTR = (
+      ASSOCSTR_COMMAND      = 1,  //  shell\verb\command string
+      ASSOCSTR_EXECUTABLE,        //  the executable part of command string
+      ASSOCSTR_FRIENDLYDOCNAME,   //  friendly name of the document type
+      ASSOCSTR_FRIENDLYAPPNAME,   //  friendly name of executable
+      ASSOCSTR_NOOPEN,            //  noopen value
+      ASSOCSTR_SHELLNEWVALUE,     //  query values under the shellnew key
+      ASSOCSTR_DDECOMMAND,        //  template for DDE commands
+      ASSOCSTR_DDEIFEXEC,         //  DDECOMMAND to use if just create a process
+      ASSOCSTR_DDEAPPLICATION,    //  Application name in DDE broadcast
+      ASSOCSTR_DDETOPIC,          //  Topic Name in DDE broadcast
+      ASSOCSTR_INFOTIP,           //  info tip for an item, or list of properties to create info tip from
+  //#if (_WIN32_IE >= _WIN32_IE_IE60)
+      ASSOCSTR_QUICKTIP,          //  same as ASSOCSTR_INFOTIP, except, this list contains only quickly retrievable properties
+      ASSOCSTR_TILEINFO,          //  similar to ASSOCSTR_INFOTIP - lists important properties for tileview
+      ASSOCSTR_CONTENTTYPE,       //  MIME Content type
+      ASSOCSTR_DEFAULTICON,       //  Default icon source
+      ASSOCSTR_SHELLEXTENSION,    //  Guid string pointing to the Shellex\Shellextensionhandler value.
+  //#endif // _WIN32_IE_IE60
+
+      ASSOCSTR_DROPTARGET,        //  The CLSID of DropTarget   IE8+
+      ASSOCSTR_DELEGATEEXECUTE,   //  The CLSID of DelegateExecute IE8+
+
+      // a string value of the uri protocol schemes, for example "http:https:ftp:file:" or "*" indicating all
+      ASSOCSTR_SUPPORTED_URI_PROTOCOLS,
+  //#if (NTDDI_VERSION >= NTDDI_WIN10)
+      ASSOCSTR_PROGID,            // The ProgId provided by the app associated with the file type or uri scheme based on user default settings.
+      ASSOCSTR_APPID,             // The AppUserModelID of the app associated with the file type or uri scheme based on user default settings.
+      ASSOCSTR_APPPUBLISHER,      // THe publisher of the app associated with the file type or uri scheme based on user default settings.
+      ASSOCSTR_APPICONREFERENCE,  // The icon reference of the app associated with the file type or uri scheme based on user default settings.
+  //#endif // NTDDI_WIN10
+      ASSOCSTR_MAX                //  last item in enum...
+  );
+
+
+  ASSOCKEY = (
+      ASSOCKEY_SHELLEXECCLASS = 1,  //  the key that should be passed to ShellExec(hkeyClass)
+      ASSOCKEY_APP,                 //  the "Application" key for the association
+      ASSOCKEY_CLASS,               //  the progid or class key
+      ASSOCKEY_BASECLASS,           //  the BaseClass key
+      ASSOCKEY_MAX                  //  last item in enum...
+   );
+
+  ASSOCDATA = (
+      ASSOCDATA_MSIDESCRIPTOR = 1,  //  Component Descriptor to pass to MSI APIs
+      ASSOCDATA_NOACTIVATEHANDLER,  //  restrict attempts to activate window
+      ASSOCDATA_UNUSED1,            //  removed QUERYCLASSSTORE, dead code
+      ASSOCDATA_HASPERUSERASSOC,    //  defaults to user specified association
+      ASSOCDATA_EDITFLAGS,          //  Edit flags. IE6+
+      ASSOCDATA_VALUE,              //  use pszExtra as the Value name IE6+
+      ASSOCDATA_MAX
+  );
+
+  ASSOCENUM = (
+      ASSOCENUM_NONE = 1
+  );
+
+
+ SHGLOBALCOUNTER = (
+    GLOBALCOUNTER_SEARCHMANAGER =0,
+    GLOBALCOUNTER_SEARCHOPTIONS,
+    GLOBALCOUNTER_FOLDERSETTINGSCHANGE,
+    GLOBALCOUNTER_RATINGS,
+    GLOBALCOUNTER_APPROVEDSITES,
+    GLOBALCOUNTER_RESTRICTIONS,
+    GLOBALCOUNTER_SHELLSETTINGSCHANGED,
+    GLOBALCOUNTER_SYSTEMPIDLCHANGE,
+    GLOBALCOUNTER_OVERLAYMANAGER,
+    GLOBALCOUNTER_QUERYASSOCIATIONS,
+    GLOBALCOUNTER_IESESSIONS,
+    GLOBALCOUNTER_IEONLY_SESSIONS,
+    GLOBALCOUNTER_APPLICATION_DESTINATIONS,
+    __UNUSED_RECYCLE_WAS_GLOBALCOUNTER_CSCSYNCINPROGRESS,
+    GLOBALCOUNTER_BITBUCKETNUMDELETERS,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_SHARES,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_A,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_B,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_C,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_D,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_E,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_F,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_G,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_H,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_I,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_J,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_K,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_L,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_M,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_N,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_O,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_P,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_Q,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_R,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_S,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_T,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_U,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_V,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_W,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_X,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_Y,
+    GLOBALCOUNTER_RECYCLEDIRTYCOUNT_DRIVE_Z,
+    __UNUSED_RECYCLE_WAS_GLOBALCOUNTER_RECYCLEDIRTYCOUNT_SERVERDRIVE,
+    __UNUSED_RECYCLE_WAS_GLOBALCOUNTER_RECYCLEGLOBALDIRTYCOUNT,
+    GLOBALCOUNTER_RECYCLEBINENUM,
+    GLOBALCOUNTER_RECYCLEBINCORRUPTED,
+    GLOBALCOUNTER_RATINGS_STATECOUNTER,
+    GLOBALCOUNTER_PRIVATE_PROFILE_CACHE,
+    GLOBALCOUNTER_INTERNETTOOLBAR_LAYOUT,
+    GLOBALCOUNTER_FOLDERDEFINITION_CACHE,
+    GLOBALCOUNTER_COMMONPLACES_LIST_CACHE,
+    GLOBALCOUNTER_PRIVATE_PROFILE_CACHE_MACHINEWIDE,
+    GLOBALCOUNTER_ASSOCCHANGED,  // throttles reading of the registry value "GlobalAssocChangedCounter" from HKLM\Software\Microsoft\Windows\CurrentVersion\Explorer
+//#if (NTDDI_VERSION >= NTDDI_WIN8)
+    GLOBALCOUNTER_APP_ITEMS_STATE_STORE_CACHE,
+    GLOBALCOUNTER_SETTINGSYNC_ENABLED,
+    GLOBALCOUNTER_APPSFOLDER_FILETYPEASSOCIATION_COUNTER,
+    GLOBALCOUNTER_USERINFOCHANGED,
+    GLOBALCOUNTER_SYNC_ENGINE_INFORMATION_CACHE_MACHINEWIDE, // WINBLUE+
+//#endif // (NTDDI_VERSION >= NTDDI_WIN8)
+    GLOBALCOUNTER_BANNERS_DATAMODEL_CACHE_MACHINEWIDE, // WIN10_RS1+
+
+    GLOBALCOUNTER_MAXIMUMVALUE // should always be last value
+  );
+
+
+  // Stored under HKCR\<progId> EditFlags(REG_DWORD)
+  //
+  // Retrieve these values using IQueryAssociations::GetData as follows
+  //
+  // DWORD editFlags, size = sizeof(editFlags);
+  // queryAssoc->GetData(nullptr, ASSOCDATA_EDITFLAGS, nullptr, &editFlags, &size);
+  //
+  // Some of these flags are no longer used since editing file type associations has been
+  // removed from Explorer's folder options UI.
+
+
+  FILETYPEATTRIBUTEFLAGS = (
+      FTA_None                    = $00000000,
+      FTA_Exclude                 = $00000001, // used to exclude (hide) types like drvfile
+      FTA_Show                    = $00000002, // used to show types like folder that don't have associations
+      FTA_HasExtension            = $00000004, // type has a file name extension
+      FTA_NoEdit                  = $00000008, // no editing of file type
+      FTA_NoRemove                = $00000010, // no removing of the file type
+      FTA_NoNewVerb               = $00000020, // no adding of verbs
+      FTA_NoEditVerb              = $00000040, // no editing of predefined verbs
+      FTA_NoRemoveVerb            = $00000080, // no removing of predefined verbs
+      FTA_NoEditDesc              = $00000100, // no editing of file type description
+      FTA_NoEditIcon              = $00000200, // no editing of doc icon
+      FTA_NoEditDflt              = $00000400, // no changing of default verb
+      FTA_NoEditVerbCmd           = $00000800, // no modification of the commnds associated with the verbs
+      FTA_NoEditVerbExe           = $00001000, // no editing of the verb's exe
+      FTA_NoDDE                   = $00002000, // no editing of the DDE fields
+
+      FTA_NoEditMIME              = $00008000, // no editing of the Content Type or Default Extension fields
+      FTA_OpenIsSafe              = $00010000, // the open verb should be invoked automaticaly for downloaded files
+      FTA_AlwaysUnsafe            = $00020000, // don't allow the "Never ask me" checkbox to be enabled; File Type dialog still allows user to turn this off
+
+      FTA_NoRecentDocs            = $00100000, // don't add this file type to the Recent Documents folder
+      FTA_SafeForElevation        = $00200000, // Win8: can be launched in medium IL by a process running in AppContainer
+      FTA_AlwaysUseDirectInvoke   = $00400000 // Win8: when downloading use the direct invoke feature even if the server headers are not provided
+   );
+  PPERCEIVED  = ^PERCEIVED;
+  PERCEIVED = (
+       PERCEIVED_TYPE_CUSTOM    = -3,
+       PERCEIVED_TYPE_UNSPECIFIED       = -2,
+       PERCEIVED_TYPE_FOLDER    = -1,
+       PERCEIVED_TYPE_UNKNOWN   = 0,
+       PERCEIVED_TYPE_TEXT      = 1,
+       PERCEIVED_TYPE_IMAGE     = 2,
+       PERCEIVED_TYPE_AUDIO     = 3,
+       PERCEIVED_TYPE_VIDEO     = 4,
+       PERCEIVED_TYPE_COMPRESSED        = 5,
+       PERCEIVED_TYPE_DOCUMENT  = 6,
+       PERCEIVED_TYPE_SYSTEM    = 7,
+       PERCEIVED_TYPE_APPLICATION       = 8,
+       PERCEIVED_TYPE_GAMEMEDIA = 9,
+       PERCEIVED_TYPE_CONTACTS  = 10
+       );
+
+const
+      PERCEIVED_TYPE_LAST      = PERCEIVED_TYPE_CONTACTS;
+      PERCEIVED_TYPE_FIRST     = PERCEIVED_TYPE_CUSTOM;
+
+type
+
+
+
+  PtagPARSEDURLA = ^tagPARSEDURLA;
+    tagPARSEDURLA = record
+        cbSize : DWORD;
+        pszProtocol : LPCSTR;
+        cchProtocol : UINT;
+        pszSuffix : LPCSTR;
+        cchSuffix : UINT;
+        nScheme : UINT;
+      end;
+    PARSEDURLA = tagPARSEDURLA;
+    PPARSEDURLA = ^PARSEDURLA;
+    PPPARSEDURLA = ^PPARSEDURLA;
+    PtagPARSEDURLW = ^tagPARSEDURLW;
+    tagPARSEDURLW = record
+        cbSize : DWORD;
+        pszProtocol : LPCWSTR;
+        cchProtocol : UINT;
+        pszSuffix : LPCWSTR;
+        cchSuffix : UINT;
+        nScheme : UINT;
+      end;
+    PARSEDURLW = tagPARSEDURLW;
+    PPARSEDURLW = ^PARSEDURLW;
+    PPPARSEDURLW = ^PPARSEDURLW;
+{$ifdef UNICODE}
+    PARSEDURL = PARSEDURLW;
+    PPPARSEDURL = ^PPARSEDURL;
+    PPARSEDURL = PPARSEDURLW;
+{$else}
+    PARSEDURL = PARSEDURLA;
+    PPPARSEDURL = ^PPARSEDURL;
+    PPARSEDURL = PPARSEDURLA;
+{$endif}
+
+const
+
+    URL_UNESCAPE               = $10000000;
+    URL_ESCAPE_UNSAFE          = $20000000;
+    URL_PLUGGABLE_PROTOCOL     = $40000000;
+    URL_WININET_COMPATIBILITY  = $80000000;
+    URL_DONT_ESCAPE_EXTRA_INFO = $02000000;
+    URL_DONT_UNESCAPE_EXTRA_INFO = URL_DONT_ESCAPE_EXTRA_INFO;
+    URL_BROWSER_MODE           = URL_DONT_ESCAPE_EXTRA_INFO;
+    URL_ESCAPE_SPACES_ONLY     = $04000000;
+    URL_DONT_SIMPLIFY          = $08000000;
+    URL_NO_META = URL_DONT_SIMPLIFY;
+    URL_UNESCAPE_INPLACE       = $00100000;
+    URL_CONVERT_IF_DOSPATH     = $00200000;
+    URL_UNESCAPE_HIGH_ANSI_ONLY= $00400000;
+    URL_INTERNAL_PATH          = $00800000;    { Will escape #'s in paths }
+    URL_FILE_USE_PATHURL       = $00010000;
+    URL_DONT_UNESCAPE          = $00020000;    { Do not unescape the path/url at all IE6.0SP2++ }
+    URL_ESCAPE_AS_UTF8         = $00040000;    { Percent-encode all non-ASCII characters as their UTF-8 equivalents. Win7+ }
+  {#if (NTDDI_VERSION >= NTDDI_WIN8) }
+    URL_UNESCAPE_AS_UTF8       = URL_ESCAPE_AS_UTF8;
+    URL_ESCAPE_ASCII_URI_COMPONENT = $00080000;    { Percent-encode all ASCII characters outside of the unreserved set from URI RFC 3986 (a-zA-Z0-9-.~_) (i.e.) No need for URL_ESCAPE_PERCENT along with this. }
+    URL_ESCAPE_URI_COMPONENT   = URL_ESCAPE_ASCII_URI_COMPONENT or URL_ESCAPE_AS_UTF8;
+    URL_UNESCAPE_URI_COMPONENT = URL_UNESCAPE_AS_UTF8;
+  {#endif // (NTDDI_VERSION >= NTDDI_WIN8) }
+    URL_ESCAPE_PERCENT         = $00001000;
+    URL_ESCAPE_SEGMENT_ONLY    = $00002000;    { Treat the entire URL param as one URL segment. }
+    URL_PARTFLAG_KEEPSCHEME    = $00000001;
+    URL_APPLY_DEFAULT          = $00000001;
+    URL_APPLY_GUESSSCHEME      = $00000002;
+    URL_APPLY_GUESSFILE        = $00000004;
+    URL_APPLY_FORCEAPPLY       = $00000008;
+    SRRF_RT_REG_NONE           = $00000001;  // restrict type to REG_NONE      (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_REG_SZ             = $00000002;  // restrict type to REG_SZ        (other data types will not return ERROR_SUCCESS) (automatically converts REG_EXPAND_SZ to REG_SZ unless SRRF_NOEXPAND is specified)
+    SRRF_RT_REG_EXPAND_SZ      = $00000004;  // restrict type to REG_EXPAND_SZ (other data types will not return ERROR_SUCCESS) (must specify SRRF_NOEXPAND or SHRegGetValue will fail with ERROR_INVALID_PARAMETER)
+    SRRF_RT_REG_BINARY         = $00000008;  // restrict type to REG_BINARY    (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_REG_DWORD          = $00000010;  // restrict type to REG_DWORD     (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_REG_MULTI_SZ       = $00000020;  // restrict type to REG_MULTI_SZ  (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_REG_QWORD          = $00000040;  // restrict type to REG_QWORD     (other data types will not return ERROR_SUCCESS)
+
+    SRRF_RT_DWORD              = (SRRF_RT_REG_BINARY or SRRF_RT_REG_DWORD); // restrict type to *32-bit* SRRF_RT_REG_BINARY or SRRF_RT_REG_DWORD (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_QWORD              = (SRRF_RT_REG_BINARY or SRRF_RT_REG_QWORD); // restrict type to *64-bit* SRRF_RT_REG_BINARY or SRRF_RT_REG_DWORD (other data types will not return ERROR_SUCCESS)
+    SRRF_RT_ANY                = $0000ffff;                               // no type restriction
+
+    SRRF_RM_ANY                = $00000000;  // no mode restriction (default is to allow any mode)
+    SRRF_RM_NORMAL             = $00010000;  // restrict system startup mode to "normal boot"               (other startup modes will not return ERROR_SUCCESS)
+    SRRF_RM_SAFE               = $00020000;  // restrict system startup mode to "safe mode"                 (other startup modes will not return ERROR_SUCCESS)
+    SRRF_RM_SAFENETWORK        = $00040000;  // restrict system startup mode to "safe mode with networking" (other startup modes will not return ERROR_SUCCESS)
+
+    SRRF_NOEXPAND              = $10000000;  // do not automatically expand environment strings if value is of type REG_EXPAND_SZ
+    SRRF_ZEROONFAILURE         = $20000000;  // if pvData is not NULL, set content to all zeros on failure
+    SRRF_NOVIRT                = $40000000;  // if the requested key is virtualized, then fail with ERROR_FILE_NOT_FOUND
+
+
+    SHREGSET_HKCU              = $00000001;       // Write to HKCU if empty.
+    SHREGSET_FORCE_HKCU        = $00000002;       // Write to HKCU.
+    SHREGSET_HKLM              = $00000004;       // Write to HKLM if empty.
+    SHREGSET_FORCE_HKLM        = $00000008;       // Write to HKLM.
+    SHREGSET_DEFAULT           = (SHREGSET_FORCE_HKCU or SHREGSET_HKLM);          // Default is SHREGSET_FORCE_HKCU | SHREGSET_HKLM.
+
+    //
+    //  Association APIs
+    //
+    //  these APIs are to assist in accessing the data in HKCR
+    //  getting the Command strings and exe paths
+    //  for different verbs and extensions are simplified this way
+    //
+
+
+    ASSOCF_NONE                = $00000000;
+    ASSOCF_INIT_NOREMAPCLSID   = $00000001;  //  do not remap clsids to progids
+    ASSOCF_INIT_BYEXENAME      = $00000002;  //  executable is being passed in
+    ASSOCF_OPEN_BYEXENAME      = $00000002;  //  executable is being passed in
+    ASSOCF_INIT_DEFAULTTOSTAR  = $00000004;  //  treat "*" as the BaseClass
+    ASSOCF_INIT_DEFAULTTOFOLDER= $00000008;  //  treat "Folder" as the BaseClass
+    ASSOCF_NOUSERSETTINGS      = $00000010;  //  dont use HKCU
+    ASSOCF_NOTRUNCATE          = $00000020;  //  dont truncate the return string
+    ASSOCF_VERIFY              = $00000040;  //  verify data is accurate (DISK HITS)
+    ASSOCF_REMAPRUNDLL         = $00000080;  //  actually gets info about rundlls target if applicable
+    ASSOCF_NOFIXUPS            = $00000100;  //  attempt to fix errors if found
+    ASSOCF_IGNOREBASECLASS     = $00000200;  //  dont recurse into the baseclass
+    ASSOCF_INIT_IGNOREUNKNOWN  = $00000400;  //  dont use the "Unknown" progid, instead fail
+    //#if (NTDDI_VERSION >= NTDDI_WIN8)
+    ASSOCF_INIT_FIXED_PROGID   = $00000800;  //  the Init() pszAssoc value is a ProgId that should not be mapped using the current user defaults
+    ASSOCF_IS_PROTOCOL         = $00001000;  //  the Init() pszAssoc value is an uri scheme (not including the ":") that should be mapped using the current user defaults
+    ASSOCF_INIT_FOR_FILE       = $00002000;  //  use this flag when specifying ASSOCF_INIT_FIXED_PROGID if the ProgId corresponds with a file extension based association
+    //#endif
+    //#if (NTDDI_VERSION >= NTDDI_WIN10_RS1)
+    ASSOCF_IS_FULL_URI         = $00004000;  //  Used to specify that full http/https URI is being passed for target resolution
+                                             //  Only one of ASSOCF_INIT_FIXED_PROGID, ASSOCF_IS_PROTOCOL or ASSOCF_IS_FULL_URI can be specified at a time.
+    ASSOCF_PER_MACHINE_ONLY    = $00008000;  //  Enforces per-machine association look-up only and avoid HKCU.
+    //#endif
+
+    ASSOCF_APP_TO_APP          = $00010000;  // #if NTDDI_WIN10_RS4+
+
+
+
+    CTF_INSIST                 = $00000001;   // call pfnThreadProc synchronously if CreateThread() fails
+    CTF_THREAD_REF             = $00000002;   // hold a reference to the creating thread
+    CTF_PROCESS_REF            = $00000004;   // hold a reference to the creating process
+    CTF_COINIT_STA             = $00000008;   // init COM as STA for the created thread
+    CTF_COINIT                 = $00000008;   // init COM as STA for the created thread
+    CTF_FREELIBANDEXIT         = $00000010;   // hold a ref to the DLL and call FreeLibraryAndExitThread() when done IE6+
+    CTF_REF_COUNTED            = $00000020;   // thread supports ref counting via SHGetThreadRef() or CTF_THREAD_REF so that child threads can keep this thread alive IE6+
+    CTF_WAIT_ALLOWCOM          = $00000040;   // while waiting for pfnCallback, allow COM marshaling to the blocked calling thread IE6+
+
+    CTF_UNUSED                 = $00000080;   // IE7+
+    CTF_INHERITWOW64           = $00000100;   // new thread should inherit the wow64 disable state for the file system redirector IE7+
+
+
+    CTF_WAIT_NO_REENTRANCY  = $00000200;   // don't allow re-entrancy when waiting for the sync proc, this won't work with marshalled objects or SendMessages() from the sync proc Vista+
+
+    //#if (NTDDI_VERSION >= NTDDI_WIN7)
+    CTF_KEYBOARD_LOCALE        = $00000400;   // carry the keyboard locale from creating to created thread
+    CTF_OLEINITIALIZE          = $00000800;   // init OLE on the created thread (this will also init COM as STA)
+    CTF_COINIT_MTA             = $00001000;   // init COM as MTA for the created thread
+    CTF_NOADDREFLIB            = $00002000;   // this flag is the opposite of CTF_FREELIBANDEXIT that is now implicit as of Vista
+                                                    // this avoids the LoadLibrary/FreeLibraryAndExitThread calls that result in contention for the loader lock
+                                                    // only use this when the thread being created has some other means to ensure that the code
+                                                    // of the thread proc will remain loaded. This should not be used in the context of COM objects as those
+                                                    // need to ensure that the DLL stays loaded as COM will unload DLLs
+    //#endif // (NTDDI_VERSION >= NTDDI_WIN7)
+
+
+     OS_WINDOWS                  = 0;           // Windows 9x vs. NT
+     OS_NT                       = 1;           // Windows 9x vs. NT
+     OS_WIN95ORGREATER           = 2;           // Win95 or greater
+     OS_NT4ORGREATER             = 3;           // NT4 or greater
+     OS_WIN98ORGREATER           = 5;           // Win98 or greater
+     OS_WIN98_GOLD               = 6;           // Win98 Gold (Version 4.10 build 1998)
+     OS_WIN2000ORGREATER         = 7;           // Some derivative of Win2000
+
+// NOTE: these flags check explicitly for (dwMajorVersion == 5)
+     OS_WIN2000PRO               = 8;           // Windows 2000 Professional (Workstation)
+     OS_WIN2000SERVER            = 9;           // Windows 2000 Server
+     OS_WIN2000ADVSERVER         = 10;          // Windows 2000 Advanced Server
+     OS_WIN2000DATACENTER        = 11;          // Windows 2000 Data Center Server
+     OS_WIN2000TERMINAL          = 12;          // Windows 2000 Terminal Server in "Application Server" mode (now simply called "Terminal Server")
+
+     OS_EMBEDDED                 = 13;          // Embedded Windows Edition
+     OS_TERMINALCLIENT           = 14;          // Windows Terminal Client (eg user is comming in via tsclient)
+     OS_TERMINALREMOTEADMIN      = 15;          // Terminal Server in "Remote Administration" mode
+     OS_WIN95_GOLD               = 16;          // Windows 95 Gold (Version 4.0 Build 1995)
+     OS_MEORGREATER              = 17;          // Windows Millennium (Version 5.0)
+     OS_XPORGREATER              = 18;          // Windows XP or greater
+     OS_HOME                     = 19;          // Home Edition (eg NOT Professional, Server, Advanced Server, or Datacenter)
+     OS_PROFESSIONAL             = 20;          // Professional     (aka Workstation; eg NOT Server, Advanced Server, or Datacenter)
+     OS_DATACENTER               = 21;          // Datacenter       (eg NOT Server, Advanced Server, Professional, or Personal)
+     OS_ADVSERVER                = 22;          // Advanced Server  (eg NOT Datacenter, Server, Professional, or Personal)
+     OS_SERVER                   = 23;          // Server           (eg NOT Datacenter, Advanced Server, Professional, or Personal)
+     OS_TERMINALSERVER           = 24;          // Terminal Server - server running in what used to be called "Application Server" mode (now simply called "Terminal Server")
+     OS_PERSONALTERMINALSERVER   = 25;          // Personal Terminal Server - per/pro machine running in single user TS mode
+     OS_FASTUSERSWITCHING        = 26;          // Fast User Switching
+     OS_WELCOMELOGONUI           = 27;          // New friendly logon UI
+     OS_DOMAINMEMBER             = 28;          // Is this machine a member of a domain (eg NOT a workgroup)
+     OS_ANYSERVER                = 29;          // is this machine any type of server? (eg datacenter or advanced server or server)?
+     OS_WOW6432                  = 30;          // Is this process a 32-bit process running on an 64-bit platform?
+     OS_WEBSERVER                = 31;          // Web Edition Server
+     OS_SMALLBUSINESSSERVER      = 32;          // SBS Server
+     OS_TABLETPC                 = 33;          // Are we running on a TabletPC?
+     OS_SERVERADMINUI            = 34;          // Should defaults lean towards those preferred by server administrators?
+     OS_MEDIACENTER              = 35;          // eHome Freestyle Project
+     OS_APPLIANCE                = 36;          // Windows .NET Appliance Server
+     PERCEIVEDFLAG_UNDEFINED     = $0000;
+     PERCEIVEDFLAG_SOFTCODED     = $0001;
+     PERCEIVEDFLAG_HARDCODED     = $0002;
+     PERCEIVEDFLAG_NATIVESUPPORT = $0004;
+     PERCEIVEDFLAG_GDIPLUS       = $0010;
+     PERCEIVEDFLAG_WMSDK         = $0020;
+     PERCEIVEDFLAG_ZIPFOLDER     = $0040;
+
+  function  StrChrA(pszStart:PCSTR; wMatch:WORD):PCSTR;stdcall;external SHLWAPIDLL name 'StrChrA';
+  function  StrChrW(pszStart:PCWSTR; wMatch:WCHAR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrChrW';
+  function  StrChrIA(pszStart:PCSTR; wMatch:WORD):PCSTR;stdcall;external SHLWAPIDLL name 'StrChrIA';
+  function  StrChrIW(pszStart:PCWSTR; wMatch:WCHAR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrChrIW';
+  function  StrChrNW(pszStart:PCWSTR; wMatch:WCHAR; cchMax:UINT):PCWSTR;stdcall;external SHLWAPIDLL name 'StrChrNW';
+  function  StrChrNIW(pszStart:PCWSTR; wMatch:WCHAR; cchMax:UINT):PWSTR;stdcall;external SHLWAPIDLL name 'StrChrNIW';
+  function  StrCmpNA(psz1:PCSTR; psz2:PCSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNA';
+  function  StrCmpNW(psz1:PCWSTR; psz2:PCWSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNW';
+  function  StrCmpNIA(psz1:PCSTR; psz2:PCSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNIA';
+  function  StrCmpNIW(psz1:PCWSTR; psz2:PCWSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNIW';
+  function  StrCSpnA(pszStr:PCSTR; pszSet:PCSTR):longint;stdcall;external SHLWAPIDLL name 'StrCSpnA';
+  function  StrCSpnW(pszStr:PCWSTR; pszSet:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCSpnW';
+  function  StrCSpnIA(pszStr:PCSTR; pszSet:PCSTR):longint;stdcall;external SHLWAPIDLL name 'StrCSpnIA';
+  function  StrCSpnIW(pszStr:PCWSTR; pszSet:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCSpnIW';
+  function  StrDupA(pszSrch:PCSTR):PSTR;stdcall;external SHLWAPIDLL name 'StrDupA';
+  function  StrDupW(pszSrch:PCWSTR):PWSTR;stdcall;external SHLWAPIDLL name 'StrDupW';
+  function  StrFormatByteSizeEx(ull:ULONGLONG; flags:SFBS_FLAGS; pszBuf:PWSTR; cchBuf:UINT):HRESULT;stdcall;external SHLWAPIDLL name 'StrFormatByteSizeEx';
+  function  StrFormatByteSizeA(dw:DWORD; pszBuf:PSTR; cchBuf:UINT):PSTR;stdcall;external SHLWAPIDLL name 'StrFormatByteSizeA';
+  function  StrFormatByteSize64A(qdw:LONGLONG; pszBuf:PSTR; cchBuf:UINT):PSTR;stdcall;external SHLWAPIDLL name 'StrFormatByteSize64A';
+  function  StrFormatByteSizeW(qdw:LONGLONG; pszBuf:PWSTR; cchBuf:UINT):PWSTR;stdcall;external SHLWAPIDLL name 'StrFormatByteSizeW';
+  function  StrFormatKBSizeW(qdw:LONGLONG; pszBuf:PWSTR; cchBuf:UINT):PWSTR;stdcall;external SHLWAPIDLL name 'StrFormatKBSizeW';
+  function  StrFormatKBSizeA(qdw:LONGLONG; pszBuf:PSTR; cchBuf:UINT):PSTR;stdcall;external SHLWAPIDLL name 'StrFormatKBSizeA';
+  function  StrFromTimeIntervalA(pszOut:PSTR; cchMax:UINT; dwTimeMS:DWORD; digits:longint):longint;stdcall;external SHLWAPIDLL name 'StrFromTimeIntervalA';
+  function  StrFromTimeIntervalW(pszOut:PWSTR; cchMax:UINT; dwTimeMS:DWORD; digits:longint):longint;stdcall;external SHLWAPIDLL name 'StrFromTimeIntervalW';
+  function  StrIsIntlEqualA(fCaseSens:BOOL; pszString1:PCSTR; pszString2:PCSTR; nChar:longint):BOOL;stdcall;external SHLWAPIDLL name 'StrIsIntlEqualA';
+  function  StrIsIntlEqualW(fCaseSens:BOOL; pszString1:PCWSTR; pszString2:PCWSTR; nChar:longint):BOOL;stdcall;external SHLWAPIDLL name 'StrIsIntlEqualW';
+  function  StrNCatA(psz1:PSTR; psz2:PCSTR; cchMax:longint):PSTR;stdcall;external SHLWAPIDLL name 'StrNCatA';
+  function  StrNCatW(psz1:PWSTR; psz2:PCWSTR; cchMax:longint):PWSTR;stdcall;external SHLWAPIDLL name 'StrNCatW';
+  function  StrPBrkA(psz:PCSTR; pszSet:PCSTR):PCSTR;stdcall;external SHLWAPIDLL name 'StrPBrkA';
+  function  StrPBrkW(psz:PCWSTR; pszSet:PCWSTR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrPBrkW';
+  function  StrRChrA(pszStart:PCSTR; pszEnd:PCSTR; wMatch:WORD):PCSTR;stdcall;external SHLWAPIDLL name 'StrRChrA';
+  function  StrRChrW(pszStart:PCWSTR; pszEnd:PCWSTR; wMatch:WCHAR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrRChrW';
+  function  StrRChrIA(pszStart:PCSTR; pszEnd:PCSTR; wMatch:WORD):PCSTR;stdcall;external SHLWAPIDLL name 'StrRChrIA';
+  function  StrRChrIW(pszStart:PCWSTR; pszEnd:PCWSTR; wMatch:WCHAR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrRChrIW';
+  function  StrRStrIA(pszSource:PCSTR; pszLast:PCSTR; pszSrch:PCSTR):PCSTR;stdcall;external SHLWAPIDLL name 'StrRStrIA';
+  function  StrRStrIW(pszSource:PCWSTR; pszLast:PCWSTR; pszSrch:PCWSTR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrRStrIW';
+  function  StrSpnA(psz:PCSTR; pszSet:PCSTR):longint;stdcall;external SHLWAPIDLL name 'StrSpnA';
+  function  StrSpnW(psz:PCWSTR; pszSet:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrSpnW';
+  function  StrStrA(pszFirst:PCSTR; pszSrch:PCSTR):PCSTR;stdcall;external SHLWAPIDLL name 'StrStrA';
+  function  StrStrW(pszFirst:PCWSTR; pszSrch:PCWSTR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrStrW';
+  function  StrStrIA(pszFirst:PCSTR; pszSrch:PCSTR):PCSTR;stdcall;external SHLWAPIDLL name 'StrStrIA';
+  function  StrStrIW(pszFirst:PCWSTR; pszSrch:PCWSTR):PCWSTR;stdcall;external SHLWAPIDLL name 'StrStrIW';
+  function  StrStrNW(pszFirst:PCWSTR; pszSrch:PCWSTR; cchMax:UINT):PCWSTR;stdcall;external SHLWAPIDLL name 'StrStrNW';
+  function  StrStrNIW(pszFirst:PCWSTR; pszSrch:PCWSTR; cchMax:UINT):PCWSTR;stdcall;external SHLWAPIDLL name 'StrStrNIW';
+  function  StrToIntA(pszSrc:PCSTR):longint;stdcall;external SHLWAPIDLL name 'StrToIntA';
+  function  StrToIntW(pszSrc:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrToIntW';
+  function  StrToIntExA(pszString:PCSTR; dwFlags:STIF_FLAGS; piRet:plongint):BOOL;stdcall;external SHLWAPIDLL name 'StrToIntExA';
+  function  StrToIntExW(pszString:PCWSTR; dwFlags:STIF_FLAGS; piRet:plongint):BOOL;stdcall;external SHLWAPIDLL name 'StrToIntExW';
+  function  StrToInt64ExA(pszString:PCSTR; dwFlags:STIF_FLAGS; pllRet:pLONGLONG):BOOL;stdcall;external SHLWAPIDLL name 'StrToInt64ExA';
+  function  StrToInt64ExW(pszString:PCWSTR; dwFlags:STIF_FLAGS; pllRet:pLONGLONG):BOOL;stdcall;external SHLWAPIDLL name 'StrToInt64ExW';
+  function  StrTrimA(psz:PSTR; pszTrimChars:PCSTR):BOOL;stdcall;external SHLWAPIDLL name 'StrTrimA';
+  function  StrTrimW(psz:PWSTR; pszTrimChars:PCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'StrTrimW';
+  function  StrCatW(psz1:PWSTR; psz2:PCWSTR):PWSTR;stdcall;external SHLWAPIDLL name 'StrCatW';
+  function  StrCmpW(psz1:PCWSTR; psz2:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpW';
+  function  StrCmpIW(psz1:PCWSTR; psz2:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpIW';
+  function  StrCpyW(psz1:PWSTR; psz2:PCWSTR):PWSTR;stdcall;external SHLWAPIDLL name 'StrCpyW';
+  function  StrCpyNW(pszDst:PWSTR; pszSrc:PCWSTR; cchMax:longint):PWSTR;stdcall;external SHLWAPIDLL name 'StrCpyNW';
+  function  StrCatBuffW(pszDest:PWSTR; pszSrc:PCWSTR; cchDestBuffSize:longint):PWSTR;stdcall;external SHLWAPIDLL name 'StrCatBuffW';
+  function  StrCatBuffA(pszDest:PSTR; pszSrc:PCSTR; cchDestBuffSize:longint):PSTR;stdcall;external SHLWAPIDLL name 'StrCatBuffA';
+  function  ChrCmpIA(w1:WORD; w2:WORD):BOOL;stdcall;external SHLWAPIDLL name 'ChrCmpIA';
+  function  ChrCmpIW(w1:WCHAR; w2:WCHAR):BOOL;stdcall;external SHLWAPIDLL name 'ChrCmpIW';
+
+  function  StrRetToStrA(pstr:PSTRRET; pidl:PCUITEMID_CHILD; ppsz:PLPSTR):HRESULT;stdcall;external SHLWAPIDLL name 'StrRetToStrA';
+  function  StrRetToStrW(pstr:PSTRRET; pidl:PCUITEMID_CHILD; ppsz:PLPWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'StrRetToStrW';
+  function  StrRetToBufA(pstr:PSTRRET; pidl:PCUITEMID_CHILD; pszBuf:LPSTR; cchBuf:UINT):HRESULT;stdcall;external SHLWAPIDLL name 'StrRetToBufA';
+  function  StrRetToBufW(pstr:PSTRRET; pidl:PCUITEMID_CHILD; pszBuf:LPWSTR; cchBuf:UINT):HRESULT;stdcall;external SHLWAPIDLL name 'StrRetToBufW';
+  function  SHStrDupA(psz:LPCSTR; ppwsz:PLPWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'SHStrDupA';
+  function  SHStrDupW(psz:LPCWSTR; ppwsz:PLPWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'SHStrDupW';
+  function  StrCmpLogicalW(psz1:PCWSTR; psz2:PCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpLogicalW';
+  function  StrCatChainW(pszDst:PWSTR; cchDst:DWORD; ichAt:DWORD; pszSrc:PCWSTR):DWORD;stdcall;external SHLWAPIDLL name 'StrCatChainW';
+  function  StrRetToBSTR(pstr:PSTRRET; pidl:PCUITEMID_CHILD; out pbstr:BSTR):HRESULT;stdcall;external SHLWAPIDLL name 'StrRetToBSTR';
+  function  SHLoadIndirectString(pszSource:PCWSTR; pszOutBuf:PWSTR; cchOutBuf:UINT; ppvReserved:Ppointer):HRESULT;stdcall;external SHLWAPIDLL name 'SHLoadIndirectString';
+  function  IsCharSpaceA(wch:CHAR):BOOL;stdcall;external SHLWAPIDLL name 'IsCharSpaceA';
+  function  IsCharSpaceW(wch:WCHAR):BOOL;stdcall;external SHLWAPIDLL name 'IsCharSpaceW';
+  function  StrCmpCA(pszStr1:LPCSTR; pszStr2:LPCSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpCA';
+  function  StrCmpCW(pszStr1:LPCWSTR; pszStr2:LPCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpCW';
+  function  StrCmpICA(pszStr1:LPCSTR; pszStr2:LPCSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpICA';
+  function  StrCmpICW(pszStr1:LPCWSTR; pszStr2:LPCWSTR):longint;stdcall;external SHLWAPIDLL name 'StrCmpICW';
+  function  StrCmpNCA(pszStr1:LPCSTR; pszStr2:LPCSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNCA';
+  function  StrCmpNCW(pszStr1:LPCWSTR; pszStr2:LPCWSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNCW';
+  function  StrCmpNICA(pszStr1:LPCSTR; pszStr2:LPCSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNICA';
+  function  StrCmpNICW(pszStr1:LPCWSTR; pszStr2:LPCWSTR; nChar:longint):longint;stdcall;external SHLWAPIDLL name 'StrCmpNICW';
+  function  IntlStrEqWorkerA(fCaseSens:BOOL; lpString1:LPCSTR; lpString2:LPCSTR; nChar:longint):BOOL;stdcall;external SHLWAPIDLL name 'IntlStrEqWorkerA';
+  function  IntlStrEqWorkerW(fCaseSens:BOOL; lpString1:LPCWSTR; lpString2:LPCWSTR; nChar:longint):BOOL;stdcall;external SHLWAPIDLL name 'IntlStrEqWorkerW';
+  function  PathAddBackslashA(pszPath:LPSTR):LPSTR;stdcall;external SHLWAPIDLL name 'PathAddBackslashA';
+  function  PathAddBackslashW(pszPath:LPWSTR):LPWSTR;stdcall;external SHLWAPIDLL name 'PathAddBackslashW';
+  function  PathAddExtensionA(pszPath:LPSTR; pszExt:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathAddExtensionA';
+  function  PathAddExtensionW(pszPath:LPWSTR; pszExt:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathAddExtensionW';
+  function  PathAppendA(pszPath:LPSTR; pszMore:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathAppendA';
+  function  PathAppendW(pszPath:LPWSTR; pszMore:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathAppendW';
+  function  PathBuildRootA(pszRoot:LPSTR; iDrive:longint):LPSTR;stdcall;external SHLWAPIDLL name 'PathBuildRootA';
+  function  PathBuildRootW(pszRoot:LPWSTR; iDrive:longint):LPWSTR;stdcall;external SHLWAPIDLL name 'PathBuildRootW';
+  function  PathCanonicalizeA(pszBuf:LPSTR; pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathCanonicalizeA';
+  function  PathCanonicalizeW(pszBuf:LPWSTR; pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathCanonicalizeW';
+  function  PathCombineA(pszDest:LPSTR; pszDir:LPCSTR; pszFile:LPCSTR):LPSTR;stdcall;external SHLWAPIDLL name 'PathCombineA';
+  function  PathCombineW(pszDest:LPWSTR; pszDir:LPCWSTR; pszFile:LPCWSTR):LPWSTR;stdcall;external SHLWAPIDLL name 'PathCombineW';
+  function  PathCompactPathA(hDC:HDC; pszPath:LPSTR; dx:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathCompactPathA';
+  function  PathCompactPathW(hDC:HDC; pszPath:LPWSTR; dx:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathCompactPathW';
+  function  PathCompactPathExA(pszOut:LPSTR; pszSrc:LPCSTR; cchMax:UINT; dwFlags:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathCompactPathExA';
+  function  PathCompactPathExW(pszOut:LPWSTR; pszSrc:LPCWSTR; cchMax:UINT; dwFlags:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathCompactPathExW';
+  function  PathCommonPrefixA(pszFile1:LPCSTR; pszFile2:LPCSTR; achPath:LPSTR):longint;stdcall;external SHLWAPIDLL name 'PathCommonPrefixA';
+  function  PathCommonPrefixW(pszFile1:LPCWSTR; pszFile2:LPCWSTR; achPath:LPWSTR):longint;stdcall;external SHLWAPIDLL name 'PathCommonPrefixW';
+  function  PathFileExistsA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathFileExistsA';
+  function  PathFileExistsW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathFileExistsW';
+  function  PathFindExtensionA(pszPath:LPCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'PathFindExtensionA';
+  function  PathFindExtensionW(pszPath:LPCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathFindExtensionW';
+  function  PathFindFileNameA(pszPath:LPCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'PathFindFileNameA';
+  function  PathFindFileNameW(pszPath:LPCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathFindFileNameW';
+  function  PathFindNextComponentA(pszPath:LPCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'PathFindNextComponentA';
+  function  PathFindNextComponentW(pszPath:LPCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathFindNextComponentW';
+  function  PathFindOnPathA(pszPath:LPSTR; ppszOtherDirs:PZPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathFindOnPathA';
+  function  PathFindOnPathW(pszPath:LPWSTR; ppszOtherDirs:PZPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathFindOnPathW';
+  function  PathFindSuffixArrayA(pszPath:LPCSTR; apszSuffix:PLPSTR; iArraySize:longint):LPCSTR;stdcall;external SHLWAPIDLL name 'PathFindSuffixArrayA';
+  function  PathFindSuffixArrayW(pszPath:LPCWSTR; apszSuffix:PLPWSTR; iArraySize:longint):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathFindSuffixArrayW';
+  function  PathGetArgsA(pszPath:LPCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'PathGetArgsA';
+  function  PathGetArgsW(pszPath:LPCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathGetArgsW';
+  function  PathIsLFNFileSpecA(pszName:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsLFNFileSpecA';
+  function  PathIsLFNFileSpecW(pszName:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsLFNFileSpecW';
+  function  PathGetCharTypeA(ch:UCHAR):Uint;stdcall;external SHLWAPIDLL name 'PathGetCharTypeA';
+  function  PathGetCharTypeW(ch:WCHAR):Uint;stdcall;external SHLWAPIDLL name 'PathGetCharTypeW';
+  function  PathGetDriveNumberA(pszPath:LPCSTR):longint;stdcall;external SHLWAPIDLL name 'PathGetDriveNumberA';
+  function  PathGetDriveNumberW(pszPath:LPCWSTR):longint;stdcall;external SHLWAPIDLL name 'PathGetDriveNumberW';
+  function  PathIsDirectoryA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsDirectoryA';
+  function  PathIsDirectoryW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsDirectoryW';
+  function  PathIsDirectoryEmptyA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsDirectoryEmptyA';
+  function  PathIsDirectoryEmptyW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsDirectoryEmptyW';
+  function  PathIsFileSpecA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsFileSpecA';
+  function  PathIsFileSpecW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsFileSpecW';
+  function  PathIsPrefixA(pszPrefix:LPCSTR; pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsPrefixA';
+  function  PathIsPrefixW(pszPrefix:LPCWSTR; pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsPrefixW';
+  function  PathIsRelativeA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsRelativeA';
+  function  PathIsRelativeW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsRelativeW';
+  function  PathIsRootA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsRootA';
+  function  PathIsRootW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsRootW';
+  function  PathIsSameRootA(pszPath1:LPCSTR; pszPath2:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsSameRootA';
+  function  PathIsSameRootW(pszPath1:LPCWSTR; pszPath2:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsSameRootW';
+  function  PathIsUNCA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCA';
+  function  PathIsUNCW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCW';
+  function  PathIsNetworkPathA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsNetworkPathA';
+  function  PathIsNetworkPathW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsNetworkPathW';
+  function  PathIsUNCServerA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCServerA';
+  function  PathIsUNCServerW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCServerW';
+  function  PathIsUNCServerShareA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCServerShareA';
+  function  PathIsUNCServerShareW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsUNCServerShareW';
+  function  PathIsContentTypeA(pszPath:LPCSTR; pszContentType:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsContentTypeA';
+  function  PathIsContentTypeW(pszPath:LPCWSTR; pszContentType:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsContentTypeW';
+  function  PathIsURLA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsURLA';
+  function  PathIsURLW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathIsURLW';
+  function  PathMakePrettyA(pszPath:LPSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMakePrettyA';
+  function  PathMakePrettyW(pszPath:LPWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMakePrettyW';
+  function  PathMatchSpecA(pszFile:LPCSTR; pszSpec:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMatchSpecA';
+  function  PathMatchSpecW(pszFile:LPCWSTR; pszSpec:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMatchSpecW';
+  function  PathMatchSpecExA(pszFile:LPCSTR; pszSpec:LPCSTR; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'PathMatchSpecExA';
+  function  PathMatchSpecExW(pszFile:LPCWSTR; pszSpec:LPCWSTR; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'PathMatchSpecExW';
+  function  PathParseIconLocationA(pszIconFile:LPSTR):longint;stdcall;external SHLWAPIDLL name 'PathParseIconLocationA';
+  function  PathParseIconLocationW(pszIconFile:LPWSTR):longint;stdcall;external SHLWAPIDLL name 'PathParseIconLocationW';
+  function  PathQuoteSpacesA(lpsz:LPSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathQuoteSpacesA';
+  function  PathQuoteSpacesW(lpsz:LPWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathQuoteSpacesW';
+  function  PathRelativePathToA(pszPath:LPSTR; pszFrom:LPCSTR; dwAttrFrom:DWORD; pszTo:LPCSTR; dwAttrTo:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathRelativePathToA';
+  function  PathRelativePathToW(pszPath:LPWSTR; pszFrom:LPCWSTR; dwAttrFrom:DWORD; pszTo:LPCWSTR; dwAttrTo:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathRelativePathToW';
+  procedure PathRemoveArgsA(pszPath:LPSTR);stdcall;external SHLWAPIDLL name 'PathRemoveArgsA';
+  procedure PathRemoveArgsW(pszPath:LPWSTR);stdcall;external SHLWAPIDLL name 'PathRemoveArgsW';
+  function  PathRemoveBackslashA(pszPath:LPSTR):LPSTR;stdcall;external SHLWAPIDLL name 'PathRemoveBackslashA';
+  function  PathRemoveBackslashW(pszPath:LPWSTR):LPWSTR;stdcall;external SHLWAPIDLL name 'PathRemoveBackslashW';
+  procedure PathRemoveBlanksA(pszPath:LPSTR);stdcall;external SHLWAPIDLL name 'PathRemoveBlanksA';
+  procedure PathRemoveBlanksW(pszPath:LPWSTR);stdcall;external SHLWAPIDLL name 'PathRemoveBlanksW';
+  procedure PathRemoveExtensionA(pszPath:LPSTR);stdcall;external SHLWAPIDLL name 'PathRemoveExtensionA';
+  procedure PathRemoveExtensionW(pszPath:LPWSTR);stdcall;external SHLWAPIDLL name 'PathRemoveExtensionW';
+  function  PathRemoveFileSpecA(pszPath:LPSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathRemoveFileSpecA';
+  function  PathRemoveFileSpecW(pszPath:LPWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathRemoveFileSpecW';
+  function  PathRenameExtensionA(pszPath:LPSTR; pszExt:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathRenameExtensionA';
+  function  PathRenameExtensionW(pszPath:LPWSTR; pszExt:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathRenameExtensionW';
+  function  PathSearchAndQualifyA(pszPath:LPCSTR; pszBuf:LPSTR; cchBuf:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathSearchAndQualifyA';
+  function  PathSearchAndQualifyW(pszPath:LPCWSTR; pszBuf:LPWSTR; cchBuf:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathSearchAndQualifyW';
+  procedure PathSetDlgItemPathA(hDlg:HWND; id:longint; pszPath:LPCSTR);stdcall;external SHLWAPIDLL name 'PathSetDlgItemPathA';
+  procedure PathSetDlgItemPathW(hDlg:HWND; id:longint; pszPath:LPCWSTR);stdcall;external SHLWAPIDLL name 'PathSetDlgItemPathW';
+  function  PathSkipRootA(pszPath:LPCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'PathSkipRootA';
+  function  PathSkipRootW(pszPath:LPCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'PathSkipRootW';
+  procedure PathStripPathA(pszPath:LPSTR);stdcall;external SHLWAPIDLL name 'PathStripPathA';
+  procedure PathStripPathW(pszPath:LPWSTR);stdcall;external SHLWAPIDLL name 'PathStripPathW';
+  function  PathStripToRootA(pszPath:LPSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathStripToRootA';
+  function  PathStripToRootW(pszPath:LPWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathStripToRootW';
+  function  PathUnquoteSpacesA(lpsz:LPSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathUnquoteSpacesA';
+  function  PathUnquoteSpacesW(lpsz:LPWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathUnquoteSpacesW';
+  function  PathMakeSystemFolderA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMakeSystemFolderA';
+  function  PathMakeSystemFolderW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathMakeSystemFolderW';
+  function  PathUnmakeSystemFolderA(pszPath:LPCSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathUnmakeSystemFolderA';
+  function  PathUnmakeSystemFolderW(pszPath:LPCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'PathUnmakeSystemFolderW';
+  function  PathIsSystemFolderA(pszPath:LPCSTR; dwAttrb:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathIsSystemFolderA';
+  function  PathIsSystemFolderW(pszPath:LPCWSTR; dwAttrb:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'PathIsSystemFolderW';
+  procedure PathUndecorateA(pszPath:LPSTR);stdcall;external SHLWAPIDLL name 'PathUndecorateA';
+  procedure PathUndecorateW(pszPath:LPWSTR);stdcall;external SHLWAPIDLL name 'PathUndecorateW';
+  function  PathUnExpandEnvStringsA(pszPath:LPCSTR; pszBuf:LPSTR; cchBuf:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathUnExpandEnvStringsA';
+  function  PathUnExpandEnvStringsW(pszPath:LPCWSTR; pszBuf:LPWSTR; cchBuf:UINT):BOOL;stdcall;external SHLWAPIDLL name 'PathUnExpandEnvStringsW';
+  function  UrlCompareA(psz1:PCSTR; psz2:PCSTR; fIgnoreSlash:BOOL):longint;stdcall;external SHLWAPIDLL name 'UrlCompareA';
+  function  UrlCompareW(psz1:PCWSTR; psz2:PCWSTR; fIgnoreSlash:BOOL):longint;stdcall;external SHLWAPIDLL name 'UrlCompareW';
+  function  UrlCombineA(pszBase:PCSTR; pszRelative:PCSTR; pszCombined:PSTR; pcchCombined:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCombineA';
+  function  UrlCombineW(pszBase:PCWSTR; pszRelative:PCWSTR; pszCombined:PWSTR; pcchCombined:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCombineW';
+  function  UrlCanonicalizeA(pszUrl:PCSTR; pszCanonicalized:PSTR; pcchCanonicalized:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCanonicalizeA';
+  function  UrlCanonicalizeW(pszUrl:PCWSTR; pszCanonicalized:PWSTR; pcchCanonicalized:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCanonicalizeW';
+  function  UrlIsOpaqueA(pszURL:PCSTR):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsOpaqueA';
+  function  UrlIsOpaqueW(pszURL:PCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsOpaqueW';
+  function  UrlIsNoHistoryA(pszURL:PCSTR):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsNoHistoryA';
+  function  UrlIsNoHistoryW(pszURL:PCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsNoHistoryW';
+  function  UrlIsA(pszUrl:PCSTR; UrlIs:URLIS):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsA';
+  function  UrlIsW(pszUrl:PCWSTR; UrlIs:URLIS):BOOL;stdcall;external SHLWAPIDLL name 'UrlIsW';
+  function  UrlGetLocationA(pszURL:PCSTR):LPCSTR;stdcall;external SHLWAPIDLL name 'UrlGetLocationA';
+  function  UrlGetLocationW(pszURL:PCWSTR):LPCWSTR;stdcall;external SHLWAPIDLL name 'UrlGetLocationW';
+  function  UrlUnescapeA(pszUrl:PSTR; pszUnescaped:PSTR; pcchUnescaped:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlUnescapeA';
+  function  UrlUnescapeW(pszUrl:PWSTR; pszUnescaped:PWSTR; pcchUnescaped:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlUnescapeW';
+  function  UrlEscapeA(pszUrl:PCSTR; pszEscaped:PSTR; pcchEscaped:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlEscapeA';
+  function  UrlEscapeW(pszUrl:PCWSTR; pszEscaped:PWSTR; pcchEscaped:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlEscapeW';
+  function  UrlCreateFromPathA(pszPath:PCSTR; pszUrl:PSTR; pcchUrl:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCreateFromPathA';
+  function  UrlCreateFromPathW(pszPath:PCWSTR; pszUrl:PWSTR; pcchUrl:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlCreateFromPathW';
+  function  PathCreateFromUrlA(pszUrl:PCSTR; pszPath:PSTR; pcchPath:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'PathCreateFromUrlA';
+  function  PathCreateFromUrlW(pszUrl:PCWSTR; pszPath:PWSTR; pcchPath:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'PathCreateFromUrlW';
+  function  PathCreateFromUrlAlloc(pszIn:PCWSTR; out ppszOut:PWSTR; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'PathCreateFromUrlAlloc';
+  function  UrlHashA(pszUrl:PCSTR; pbHash:PBYTE; cbHash:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlHashA';
+  function  UrlHashW(pszUrl:PCWSTR; pbHash:PBYTE; cbHash:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlHashW';
+  function  UrlGetPartW(pszIn:PCWSTR; pszOut:PWSTR; pcchOut:PDWORD; dwPart:DWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlGetPartW';
+  function  UrlGetPartA(pszIn:PCSTR; pszOut:PSTR; pcchOut:PDWORD; dwPart:DWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlGetPartA';
+  function  UrlApplySchemeA(pszIn:PCSTR; pszOut:PSTR; pcchOut:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlApplySchemeA';
+  function  UrlApplySchemeW(pszIn:PCWSTR; pszOut:PWSTR; pcchOut:PDWORD; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlApplySchemeW';
+  function  HashData(pbData:PBYTE; cbData:DWORD; pbHash:PBYTE; cbHash:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'HashData';
+  function  UrlFixupW(pcszUrl:PCWSTR; pszTranslatedUrl:PWSTR; cchMax:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'UrlFixupW';
+  function SHDeleteEmptyKeyA(hKey:HKEY; pszSubKey:LPCSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteEmptyKeyA';
+  function SHDeleteEmptyKeyW(hKey:HKEY; pszSubKey:LPCWSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteEmptyKeyW';
+  function SHDeleteKeyA(hKey:HKEY; pszSubKey:LPCSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteKeyA';
+  function SHDeleteKeyW(hKey:HKEY; pszSubKey:LPCWSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteKeyW';
+  function SHRegDuplicateHKey(hKey:HKEY):HKEY;stdcall;external SHLWAPIDLL name 'SHRegDuplicateHKey';
+  function SHDeleteValueA(hKey:HKEY; pszSubKey:LPCSTR; pszValue:LPCSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteValueA';
+  function SHDeleteValueW(hKey:HKEY; pszSubKey:LPCWSTR; pszValue:LPCWSTR):LSTATUS;stdcall;external SHLWAPIDLL name 'SHDeleteValueW';
+  {LSTATUS    SHGetValueA( }
+  {LSTATUS    SHGetValueW( }
+  function SHSetValueA(hKey:HKEY; pszSubKey:LPCSTR; pszValue:LPCSTR; dwType:DWORD; pvData:LPCVOID;
+             cbData:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHSetValueA';
+  function SHSetValueW(hKey:HKEY; pszSubKey:LPCWSTR; pszValue:LPCWSTR; dwType:DWORD; pvData:LPCVOID;
+             cbData:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHSetValueW';
+  function SHRegGetValueA(hKey:HKEY; pszSubKey:LPCSTR; pszValue:LPCSTR; srrfFlags:SRRF; pdwType:PDWORD;
+             pvData:pointer; pcbData:PDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegGetValueA';
+  function SHRegGetValueW(hKey:HKEY; pszSubKey:LPCWSTR; pszValue:LPCWSTR; srrfFlags:SRRF; pdwType:PDWORD;
+             pvData:pointer; pcbData:PDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegGetValueW';
+  function SHRegSetValue(hkey:HKEY; pszSubKey:LPCWSTR; pszValue:LPCWSTR; srrfFlags:SRRF; dwType:DWORD;
+             pvData:LPCVOID; cbData:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegSetValue';
+
+  function SHRegGetValueFromHKCUHKLM(pwszKey:PCWSTR; pwszValue:PCWSTR; srrfFlags:SRRF; pdwType:PDWORD; pvData:pointer;
+             pcbData:PDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegGetValueFromHKCUHKLM';
+
+  function SHQueryValueExA(hkey:HKEY; pszValue:LPCSTR; pdwReserved:PDWORD; pdwType:PDWORD; pvData:pointer;
+             pcbData:PDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHQueryValueExA';
+
+  function SHQueryValueExW(hkey:HKEY; pszValue:LPCWSTR; pdwReserved:PDWORD; pdwType:PDWORD; pvData:pointer;
+             pcbData:PDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHQueryValueExW';
+
+  function SHEnumKeyExA(hKey:HKEY; dwIndex:DWORD; pszName:LPSTR; pcchName:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHEnumKeyExA';
+
+  function SHEnumKeyExW(hKey:HKEY; dwIndex:DWORD; pszName:LPWSTR; pcchName:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHEnumKeyExW';
+
+  function SHEnumValueA(hKey:HKEY; dwIndex:DWORD; pszValueName:PSTR; pcchValueName:LPDWORD; pdwType:LPDWORD;
+             pvData:pointer; pcbData:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHEnumValueA';
+
+  function SHEnumValueW(hKey:HKEY; dwIndex:DWORD; pszValueName:PWSTR; pcchValueName:LPDWORD; pdwType:LPDWORD;
+             pvData:pointer; pcbData:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHEnumValueW';
+
+  function SHQueryInfoKeyA(hKey:HKEY; pcSubKeys:LPDWORD; pcchMaxSubKeyLen:LPDWORD; pcValues:LPDWORD; pcchMaxValueNameLen:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHQueryInfoKeyA';
+
+  function SHQueryInfoKeyW(hKey:HKEY; pcSubKeys:LPDWORD; pcchMaxSubKeyLen:LPDWORD; pcValues:LPDWORD; pcchMaxValueNameLen:LPDWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHQueryInfoKeyW';
+
+  function SHCopyKeyA(_hKeySrc:HKEY; pszSrcSubKey:LPCSTR; _hKeyDest:HKEY; fReserved:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHCopyKeyA';
+
+  function SHCopyKeyW(_hKeySrc:HKEY; pszSrcSubKey:LPCWSTR; _hKeyDest:HKEY; fReserved:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHCopyKeyW';
+
+  function SHRegGetPathA(hKey:HKEY; pcszSubKey:LPCSTR; pcszValue:LPCSTR; pszPath:LPSTR; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegGetPathA';
+
+  function SHRegGetPathW(hKey:HKEY; pcszSubKey:LPCWSTR; pcszValue:LPCWSTR; pszPath:LPWSTR; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegGetPathW';
+
+  function SHRegSetPathA(hKey:HKEY; pcszSubKey:LPCSTR; pcszValue:LPCSTR; pcszPath:LPCSTR; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegSetPathA';
+
+  function SHRegSetPathW(hKey:HKEY; pcszSubKey:LPCWSTR; pcszValue:LPCWSTR; pcszPath:LPCWSTR; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegSetPathW';
+
+  function SHRegCreateUSKeyA(pszPath:LPCSTR; samDesired:REGSAM; hRelativeUSKey:HUSKEY; phNewUSKey:PHUSKEY; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegCreateUSKeyA';
+
+  function SHRegCreateUSKeyW(pwzPath:LPCWSTR; samDesired:REGSAM; hRelativeUSKey:HUSKEY; phNewUSKey:PHUSKEY; dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegCreateUSKeyW';
+
+  function SHRegOpenUSKeyA(pszPath:LPCSTR; samDesired:REGSAM; hRelativeUSKey:HUSKEY; phNewUSKey:PHUSKEY; fIgnoreHKCU:BOOL):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegOpenUSKeyA';
+
+  function SHRegOpenUSKeyW(pwzPath:LPCWSTR; samDesired:REGSAM; hRelativeUSKey:HUSKEY; phNewUSKey:PHUSKEY; fIgnoreHKCU:BOOL):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegOpenUSKeyW';
+
+  function SHRegQueryUSValueA(hUSKey:HUSKEY; pszValue:LPCSTR; pdwType:PDWORD; pvData:pointer; pcbData:PDWORD;
+             fIgnoreHKCU:BOOL; pvDefaultData:pointer; dwDefaultDataSize:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegQueryUSValueA';
+
+  function SHRegQueryUSValueW(hUSKey:HUSKEY; pszValue:LPCWSTR; pdwType:PDWORD; pvData:pointer; pcbData:PDWORD;
+             fIgnoreHKCU:BOOL; pvDefaultData:pointer; dwDefaultDataSize:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegQueryUSValueW';
+
+(* Const before type ignored *)
+  function SHRegWriteUSValueA(hUSKey:HUSKEY; pszValue:LPCSTR; dwType:DWORD; pvData:pointer; cbData:DWORD;
+             dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegWriteUSValueA';
+
+(* Const before type ignored *)
+  function SHRegWriteUSValueW(hUSKey:HUSKEY; pwzValue:LPCWSTR; dwType:DWORD; pvData:pointer; cbData:DWORD;
+             dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegWriteUSValueW';
+
+  function SHRegDeleteUSValueA(hUSKey:HUSKEY; pszValue:LPCSTR; delRegFlags:SHREGDEL_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegDeleteUSValueA';
+
+  function SHRegDeleteUSValueW(hUSKey:HUSKEY; pwzValue:LPCWSTR; delRegFlags:SHREGDEL_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegDeleteUSValueW';
+
+  function SHRegDeleteEmptyUSKeyW(hUSKey:HUSKEY; pwzSubKey:LPCWSTR; delRegFlags:SHREGDEL_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegDeleteEmptyUSKeyW';
+
+  function SHRegDeleteEmptyUSKeyA(hUSKey:HUSKEY; pszSubKey:LPCSTR; delRegFlags:SHREGDEL_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegDeleteEmptyUSKeyA';
+
+  function SHRegEnumUSKeyA(hUSKey:HUSKEY; dwIndex:DWORD; pszName:LPSTR; pcchName:LPDWORD; enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegEnumUSKeyA';
+
+  function SHRegEnumUSKeyW(hUSKey:HUSKEY; dwIndex:DWORD; pwzName:LPWSTR; pcchName:LPDWORD; enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegEnumUSKeyW';
+
+  function SHRegEnumUSValueA(hUSkey:HUSKEY; dwIndex:DWORD; pszValueName:LPSTR; pcchValueName:LPDWORD; pdwType:LPDWORD;
+             pvData:pointer; pcbData:LPDWORD; enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegEnumUSValueA';
+
+  function SHRegEnumUSValueW(hUSkey:HUSKEY; dwIndex:DWORD; pszValueName:LPWSTR; pcchValueName:LPDWORD; pdwType:LPDWORD;
+             pvData:pointer; pcbData:LPDWORD; enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegEnumUSValueW';
+
+  function SHRegQueryInfoUSKeyA(hUSKey:HUSKEY; pcSubKeys:LPDWORD; pcchMaxSubKeyLen:LPDWORD; pcValues:LPDWORD; pcchMaxValueNameLen:LPDWORD;
+             enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegQueryInfoUSKeyA';
+
+  function SHRegQueryInfoUSKeyW(hUSKey:HUSKEY; pcSubKeys:LPDWORD; pcchMaxSubKeyLen:LPDWORD; pcValues:LPDWORD; pcchMaxValueNameLen:LPDWORD;
+             enumRegFlags:SHREGENUM_FLAGS):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegQueryInfoUSKeyW';
+
+  function SHRegCloseUSKey(hUSKey:HUSKEY):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegCloseUSKey';
+
+(* Const before type ignored *)
+  function SHRegSetUSValueA(pszSubKey:LPCSTR; pszValue:LPCSTR; dwType:DWORD; pvData:pointer; cbData:DWORD;
+             dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegSetUSValueA';
+
+(* Const before type ignored *)
+  function SHRegSetUSValueW(pwzSubKey:LPCWSTR; pwzValue:LPCWSTR; dwType:DWORD; pvData:pointer; cbData:DWORD;
+             dwFlags:DWORD):LSTATUS;stdcall;external SHLWAPIDLL name 'SHRegSetUSValueW';
+
+  function SHRegGetIntW(hk:HKEY; pwzKey:PCWSTR; iDefault:longint):longint;stdcall;external SHLWAPIDLL name 'SHRegGetIntW';
+  function SHRegGetBoolUSValueA(pszSubKey:LPCSTR; pszValue:LPCSTR; fIgnoreHKCU:BOOL; fDefault:BOOL):BOOL;stdcall;external SHLWAPIDLL name 'SHRegGetBoolUSValueA';
+  function SHRegGetBoolUSValueW(pszSubKey:LPCWSTR; pszValue:LPCWSTR; fIgnoreHKCU:BOOL; fDefault:BOOL):BOOL;stdcall;external SHLWAPIDLL name 'SHRegGetBoolUSValueW';
+  function AssocCreate(clsid:CLSID; riid:REFIID; ppv:Ppointer):HRESULT;stdcall;external SHLWAPIDLL name 'AssocCreate';
+  function AssocQueryStringA(flags:ASSOCF; str:ASSOCSTR; pszAssoc:LPCSTR; pszExtra:LPCSTR; pszOut:LPSTR;
+             pcchOut:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryStringA';
+  function AssocQueryStringW(flags:ASSOCF; str:ASSOCSTR; pszAssoc:LPCWSTR; pszExtra:LPCWSTR; pszOut:LPWSTR;
+             pcchOut:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryStringW';
+  function AssocQueryStringByKeyA(flags:ASSOCF; str:ASSOCSTR; hkAssoc:HKEY; pszExtra:LPCSTR; pszOut:LPSTR;
+             pcchOut:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryStringByKeyA';
+  function AssocQueryStringByKeyW(flags:ASSOCF; str:ASSOCSTR; hkAssoc:HKEY; pszExtra:LPCWSTR; pszOut:LPWSTR;
+             pcchOut:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryStringByKeyW';
+  function AssocQueryKeyA(flags:ASSOCF; key:ASSOCKEY; pszAssoc:LPCSTR; pszExtra:LPCSTR; phkeyOut:PHKEY):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryKeyA';
+  function AssocQueryKeyW(flags:ASSOCF; key:ASSOCKEY; pszAssoc:LPCWSTR; pszExtra:LPCWSTR; phkeyOut:PHKEY):HRESULT;stdcall;external SHLWAPIDLL name 'AssocQueryKeyW';
+  function AssocIsDangerous(pszAssoc:PCWSTR):BOOL;stdcall;external SHLWAPIDLL name 'AssocIsDangerous';
+  { these are cdecl varargs }
+ function wvnsprintfA(pszDest : PSTR;cchDest : WINT; pszFmt:PCSTR ):integer;  cdecl;varargs; external SHLWAPIDLL name 'wvnsprintfA';
+ function wvnsprintfW(pszDest :PWSTR;cchDest : WINT; pszFmt:PCWSTR ):integer; cdecl;varargs; external SHLWAPIDLL name 'wvnsprintfW';
+ function wnsprintfA (pszDest : PSTR;cchDest : WINT; pszFmt:PCSTR ):integer;  cdecl;varargs; external SHLWAPIDLL name 'wnsprintfA';
+ function wnsprintfW (pszDest :PWSTR;cchDest : WINT; pszFmt:PCWSTR ):integer; cdecl;varargs; external SHLWAPIDLL name 'wnsprintfW';
+
+ function  ParseURLA(pcszURL:LPCSTR; ppu:PPARSEDURLA):HRESULT;stdcall;external SHLWAPIDLL name 'ParseURLA';
+ function  ParseURLW(pcszURL:LPCWSTR; ppu:PPARSEDURLW):HRESULT;stdcall;external SHLWAPIDLL name 'ParseURLW';
+
+ function AssocGetPerceivedType(pszExt:PCWSTR; ptype:PPERCEIVED; pflag:PPERCEIVEDFLAG; ppszType:PLPWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'AssocGetPerceivedType';
+ function SHOpenRegStreamA(hKey:HKEY; pszSubkey:LPCSTR; pszValue:LPCSTR; grfMode:DWORD):IStream;stdcall;external SHLWAPIDLL name 'SHOpenRegStreamA';
+ function SHOpenRegStreamW(hKey:HKEY; pszSubkey:LPCWSTR; pszValue:LPCWSTR; grfMode:DWORD):IStream;stdcall;external SHLWAPIDLL name 'SHOpenRegStreamW';
+ function SHOpenRegStream2A(hKey:HKEY; pszSubkey:LPCSTR; pszValue:LPCSTR; grfMode:DWORD):IStream;stdcall;external SHLWAPIDLL name 'SHOpenRegStream2A';
+ function SHOpenRegStream2W(hKey:HKEY; pszSubkey:LPCWSTR; pszValue:LPCWSTR; grfMode:DWORD):IStream;stdcall;external SHLWAPIDLL name 'SHOpenRegStream2W';
+ function SHCreateStreamOnFileA(pszFile:LPCSTR; grfMode:DWORD; out ppstm:IStream):HRESULT;stdcall;external SHLWAPIDLL name 'SHCreateStreamOnFileA';
+ function SHCreateStreamOnFileW(pszFile:LPCWSTR; grfMode:DWORD; out ppstm:IStream):HRESULT;stdcall;external SHLWAPIDLL name 'SHCreateStreamOnFileW';
+ function SHCreateStreamOnFileEx(pszFile:LPCWSTR; grfMode:DWORD; dwAttributes:DWORD; fCreate:BOOL; pstmTemplate:IStream;
+            out ppstm:IStream):HRESULT;stdcall;external SHLWAPIDLL name 'SHCreateStreamOnFileEx';
+(* Const before type ignored *)
+ function SHCreateMemStream(pInit:PBYTE; cbInit:UINT):IStream;stdcall;external SHLWAPIDLL name 'SHCreateMemStream';
+ function GetAcceptLanguagesA(pszLanguages:LPSTR; pcchLanguages:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'GetAcceptLanguagesA';
+ function GetAcceptLanguagesW(pszLanguages:LPWSTR;  pcchLanguages:PDWORD):HRESULT;stdcall;external SHLWAPIDLL name 'GetAcceptLanguagesW';
+ procedure IUnknown_Set(out ppunk:IUnknown; punk:IUnknown);stdcall;external SHLWAPIDLL name 'IUnknown_Set';
+ procedure IUnknown_AtomicRelease(ppunk:Ppointer);stdcall;external SHLWAPIDLL name 'IUnknown_AtomicRelease';
+
+ function IUnknown_GetWindow(punk:IUnknown; phwnd:PHWND):HRESULT;stdcall;external SHLWAPIDLL name 'IUnknown_GetWindow';
+ function IUnknown_SetSite( punk:IUnknown; punkSite:IUnknown):HRESULT;stdcall;external SHLWAPIDLL name 'IUnknown_SetSite';
+ function IUnknown_GetSite( punk:IUnknown; riid:REFIID; ppv:Ppointer):HRESULT;stdcall;external SHLWAPIDLL name 'IUnknown_GetSite';
+ function IUnknown_QueryService(punk:IUnknown; constref guidService:TGUID; riid:REFIID; ppvOut:Ppointer):HRESULT;stdcall;external SHLWAPIDLL name 'IUnknown_QueryService';
+ { _COM_Outptr_  }
+ function IStream_Read(out pstm:IStream; pv:pointer; cb:ULONG):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_Read';
+
+(* Const before type ignored *)
+ function IStream_Write(out pstm:IStream; pv:pointer; cb:ULONG):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_Write';
+
+ function IStream_Reset(out pstm:IStream):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_Reset';
+
+ function IStream_Size(pstm:IStream; pui:PULARGE_INTEGER):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_Size';
+
+ function ConnectToConnectionPoint( punk:IUnknown; riidEvent:REFIID; fConnect:BOOL;  punkTarget:IUnknown; pdwCookie:PDWORD;
+            out ppcpOut:IConnectionPoint):HRESULT;stdcall;external SHLWAPIDLL name 'ConnectToConnectionPoint';
+
+ function IStream_ReadPidl(pstm:IStream; ppidlOut:PPIDLIST_RELATIVE):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_ReadPidl';
+ function IStream_WritePidl(pstm:IStream; pidlWrite:PCUIDLIST_RELATIVE):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_WritePidl';
+ function IStream_ReadStr(pstm:IStream; ppsz:PLPWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_ReadStr';
+ function IStream_WriteStr(pstm:IStream; psz:PCWSTR):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_WriteStr';
+ function IStream_Copy(pstmFrom:IStream; pstmTo:IStream; cb:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'IStream_Copy';
+ function SHGetViewStatePropertyBag(pidl:PCIDLIST_ABSOLUTE; pszBagName:PCWSTR; dwFlags:DWORD; riid:REFIID; ppv:Ppointer):HRESULT;stdcall;external SHLWAPIDLL name 'SHGetViewStatePropertyBag';
+
+(* Const before type ignored *)
+ function SHFormatDateTimeA(pft:PFILETIME; pdwFlags:PDWORD; pszBuf:LPSTR; cchBuf:UINT):longint;stdcall;external SHLWAPIDLL name 'SHFormatDateTimeA';
+
+(* Const before type ignored *)
+ function SHFormatDateTimeW(pft:PFILETIME;  pdwFlags:PDWORD; pszBuf:LPWSTR; cchBuf:UINT):longint;stdcall;external SHLWAPIDLL name 'SHFormatDateTimeW';
+
+ { filetime unaligned }
+ function SHAnsiToUnicode(pszSrc:PCSTR; pwszDst:PWSTR; cwchBuf:longint):longint;stdcall;external SHLWAPIDLL name 'SHAnsiToUnicode';
+
+ function SHAnsiToAnsi(pszSrc:PCSTR; pszDst:PSTR; cchBuf:longint):longint;stdcall;external SHLWAPIDLL name 'SHAnsiToAnsi';
+
+ function SHUnicodeToAnsi(pwszSrc:PCWSTR; pszDst:PSTR; cchBuf:longint):longint;stdcall;external SHLWAPIDLL name 'SHUnicodeToAnsi';
+
+ function SHUnicodeToUnicode(pwzSrc:PCWSTR; pwzDst:PWSTR; cwchBuf:longint):longint;stdcall;external SHLWAPIDLL name 'SHUnicodeToUnicode';
+
+ function SHMessageBoxCheckA(hwnd:HWND; pszText:LPCSTR; pszCaption:LPCSTR; uType:UINT; iDefault:longint;
+            pszRegVal:LPCSTR):longint;stdcall;external SHLWAPIDLL name 'SHMessageBoxCheckA';
+
+ function SHMessageBoxCheckW(hwnd:HWND; pszText:LPCWSTR; pszCaption:LPCWSTR; uType:UINT; iDefault:longint;
+            pszRegVal:LPCWSTR):longint;stdcall;external SHLWAPIDLL name 'SHMessageBoxCheckW';
+
+ function SHSendMessageBroadcastA(uMsg:UINT; wParam:WPARAM; lParam:LPARAM):LRESULT;stdcall;external SHLWAPIDLL name 'SHSendMessageBroadcastA';
+ function SHSendMessageBroadcastW(uMsg:UINT; wParam:WPARAM; lParam:LPARAM):LRESULT;stdcall;external SHLWAPIDLL name 'SHSendMessageBroadcastW';
+ function SHStripMneumonicA(pszMenu:LPSTR):CHAR;stdcall;external SHLWAPIDLL name 'SHStripMneumonicA';
+ function SHStripMneumonicW(pszMenu:LPWSTR):WCHAR;stdcall;external SHLWAPIDLL name 'SHStripMneumonicW';
+ function IsOS(dwOS:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'IsOS';
+(* Const before type ignored *)
+ function SHGlobalCounterGetValue(id:SHGLOBALCOUNTER):longint;stdcall;external SHLWAPIDLL name 'SHGlobalCounterGetValue';
+
+(* Const before type ignored *)
+ function SHGlobalCounterIncrement(id:SHGLOBALCOUNTER):longint;stdcall;external SHLWAPIDLL name 'SHGlobalCounterIncrement';
+
+(* Const before type ignored *)
+ function SHGlobalCounterDecrement(id:SHGLOBALCOUNTER):longint;stdcall;external SHLWAPIDLL name 'SHGlobalCounterDecrement';
+
+(* Const before type ignored *)
+ function SHAllocShared(pvData:pointer; dwSize:DWORD; dwProcessId:DWORD):HANDLE;stdcall;external SHLWAPIDLL name 'SHAllocShared';
+ function SHFreeShared(hData:HANDLE; dwProcessId:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'SHFreeShared';
+ function SHLockShared(hData:HANDLE; dwProcessId:DWORD):pointer;stdcall;external SHLWAPIDLL name 'SHLockShared';
+ function SHUnlockShared(pvData:pointer):BOOL;stdcall;external SHLWAPIDLL name 'SHUnlockShared';
+ function WhichPlatform:UINT;stdcall;external SHLWAPIDLL name 'WhichPlatform';
+ function SHIsLowMemoryMachine(dwType:DWORD):BOOL;stdcall;external SHLWAPIDLL name 'SHIsLowMemoryMachine';
+ function GetMenuPosFromID(hmenu:HMENU; id:UINT):longint;stdcall;external SHLWAPIDLL name 'GetMenuPosFromID';
+ function SHGetInverseCMAP(pbMap:PBYTE; cbMap:ULONG):HRESULT;stdcall;external SHLWAPIDLL name 'SHGetInverseCMAP';
+ function SHAutoComplete(hwndEdit:HWND; dwFlags:DWORD):HRESULT;stdcall;external SHLWAPIDLL name 'SHAutoComplete';
+ function SHCreateThreadRef(pcRef:PLONG; out ppunk:IUnknown):HRESULT;stdcall;external SHLWAPIDLL name 'SHCreateThreadRef';
+ function SHSetThreadRef(punk:IUnknown):HRESULT;stdcall;external SHLWAPIDLL name 'SHSetThreadRef';
+ function SHGetThreadRef(out ppunk:IUnknown):HRESULT;stdcall;external SHLWAPIDLL name 'SHGetThreadRef';
+
+ { _COM_Outptr_ }
+(* Const before type ignored *)
+ function SHSkipJunction(pbc:IBindCtx; pclsid:PCLSID):BOOL;stdcall;external SHLWAPIDLL name 'SHSkipJunction';
+ function SHCreateThread(pfnThreadProc:LPTHREAD_START_ROUTINE; pData:pointer; flags:SHCT_FLAGS; pfnCallback:LPTHREAD_START_ROUTINE):BOOL;stdcall;external SHLWAPIDLL name 'SHCreateThread';
+ function SHCreateThreadWithHandle(pfnThreadProc:LPTHREAD_START_ROUTINE; pData:pointer; flags:SHCT_FLAGS; pfnCallback:LPTHREAD_START_ROUTINE; pHandle:PHANDLE):BOOL;stdcall;external SHLWAPIDLL name 'SHCreateThreadWithHandle';
+ procedure SetProcessReference( punk:IUnknown);stdcall;external SHLWAPIDLL name 'SetProcessReference';
+ function GetProcessReference(punk:IUnknown):HRESULT;stdcall;external SHLWAPIDLL name 'GetProcessReference';
+ {_COM_Outptr_ }
+ function SHReleaseThreadRef:HRESULT;stdcall;external SHLWAPIDLL name 'SHReleaseThreadRef';
+ { release a CTF_THREAD_REF reference earlier than the return of pfnThreadProc }
+ function SHCreateShellPalette(hdc:HDC):HPALETTE;stdcall;external SHLWAPIDLL name 'SHCreateShellPalette';
+ procedure ColorRGBToHLS(clrRGB:COLORREF; pwHue:PWORD; pwLuminance:PWORD; pwSaturation:PWORD);stdcall;external SHLWAPIDLL name 'ColorRGBToHLS';
+ function ColorHLSToRGB(wHue:WORD; wLuminance:WORD; wSaturation:WORD):COLORREF;stdcall;external SHLWAPIDLL name 'ColorHLSToRGB';
+ function ColorAdjustLuma(clrRGB:COLORREF; n:longint; fScale:BOOL):COLORREF;stdcall;external SHLWAPIDLL name 'ColorAdjustLuma';
+ function IsInternetESCEnabled:BOOL;stdcall;external SHLWAPIDLL name 'IsInternetESCEnabled';
 
 implementation
 
-end.
+end.

rtl/avr/avr.inc

@@ -32,37 +32,43 @@ procedure fpc_cpuinit;{$ifdef SYSTEMINLINE}inline;{$endif}
 
 
 {$define FPC_SYSTEM_HAS_MOVE}
-procedure Move(const source;var dest;count:SizeInt);[public, alias: 'FPC_MOVE'];
-var
-  pdest,psrc,pend : pbyte;
-begin
-  if (@dest=@source) or (count<=0) then
-    exit;
-  if (@dest<@source) or (@source+count<@dest) then
-    begin
-      { Forward Move }
-      psrc:=@source;
-      pdest:=@dest;
-      pend:=psrc+count;
-      while psrc<pend do
-        begin
-          pdest^:=psrc^;
-          inc(pdest);
-          inc(psrc);
-        end;
-    end
-  else
-    begin
-      { Backward Move }
-      psrc:=@source+count;
-      pdest:=@dest+count;
-      while psrc>@source do
-        begin
-          dec(pdest);
-          dec(psrc);
-          pdest^:=psrc^;
-        end;
-    end;
+procedure Move(const source;var dest;count:SizeInt);[public, alias: 'FPC_MOVE']; assembler; nostackframe;
+asm
+  push r28
+  push r29
+
+  movw r26, r24         // Src=X
+  movw r28, r22         // Dest=Y
+  movw r30, r20         // Count=Z
+  cp r1, r30
+  cpc r1, r31
+  brge .Lexit           // if 0 >= Count
+  cp  r28, r26
+  cpc r29, r27
+  breq .Lexit           // if dest = source
+  brlo .LForwardMove    // if dest < source
+
+  // Add count to both pointers
+  add r26, r30
+  adc r27, r31
+  add r28, r30
+  adc r29, r31
+.LBackwardMove:
+  ld r18, -X
+  st -Y, r18
+  sbiw Z, 1
+  brne .LBackwardMove
+  rjmp .Lexit
+
+.LForwardMove:
+  ld r18, X+
+  st Y+, r18
+  sbiw Z, 1
+  brne .LForwardMove
+.Lexit:
+
+  pop r29
+  pop r28
 end;
 
 
@@ -107,6 +113,8 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;assembler;no
 {$define FPC_SYSTEM_HAS_SPTR}
 Function Sptr : pointer;assembler;nostackframe;
   asm
+    in r24, 0x3d
+    in r25, 0x3e
   end;
 
 
@@ -261,3 +269,5 @@ function InterLockedExchangeAdd (var Target: smallint;Source : smallint) : small
     avr_restore(temp_sreg);
   end;
 
+{include hand-optimized assembler code}
+{$i math.inc}

rtl/avr/math.inc

@@ -13,3 +13,257 @@
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 
  **********************************************************************}
+
+// Based on restoring division algorithm
+// Algorithm source document: Lecture notes by S. Galal and D. Pham, Division algorithms and hardware implementations.
+// Link to documentation http://www.seas.ucla.edu/~ingrid/ee213a/lectures/division_presentV2.pdf
+// Also refer to description on Wikipedia: https://en.wikipedia.org/wiki/Division_algorithm#Restoring_division
+
+// Note that the algorithm automatically yields the following results for special cases:
+// z div 0 = MAX(type)
+// 0 div 0 = MAX(type)
+// 0 div n = 0
+// Checks for z = 0; n = [0,1]; n = z and n > z could shortcut the algorithm for speed-ups
+// but would add extra code
+// Perhaps add the checks depending on optimization settings?
+
+// z (dividend) = q(quotient) x n(divisor) + p(remainder)
+
+{$ifndef FPC_SYSTEM_HAS_DIV_BYTE}
+{$define FPC_SYSTEM_HAS_DIV_BYTE}
+
+// z in Ra, n in Rb, 0 in Rp
+function fpc_div_byte(n, z: byte): byte; assembler; nostackframe;
+{$ifdef FPC_IS_SYSTEM}[public,alias: 'FPC_DIV_BYTE'];{$endif}
+label
+  start, div1, div2, div3, finish;
+asm
+// Symbol  Name        Register(s)
+// z (A)   dividend    R22
+// n (B)   divisor     R24
+// p (P)   remainder   R20
+// i	   counter     R18
+
+  cp R24, R1
+  brne start
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_pc_addr
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_pc_addr
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R20, R24
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_frame
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_frame
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R18, R24
+  ldi R22, 200
+  clr R23
+  clr R24
+  clr R25
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call HandleErrorAddrFrameInd
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall HandleErrorAddrFrameInd
+{$endif CPUAVR_HAS_JMP_CALL}
+
+
+start:
+  clr R20         // clear remainder
+  ldi R18, 8      // iterate over 8 bits
+
+div1:
+  lsl R22         // shift left A
+  rol R20         // shift left P with carry from A shift
+  sub R20, R24    // Subtract B from P, P <= P - B
+  brlo div2
+  ori R22, 1      // Set A[0] = 1
+  rjmp div3
+div2:             // negative branch, A[0] = 0 (default after shift), restore P
+  add R20, R24    // restore old value of P
+
+div3:
+  dec R18
+  brne div1
+
+finish:
+  mov R24, R22    // Move result from R22 to R24
+end;
+
+{It is a compilerproc (systemh.inc), make an alias for internal use.}
+{$ifdef FPC_IS_SYSTEM}
+function fpc_div_byte(n, z: byte): byte; external name 'FPC_DIV_BYTE';
+{$endif FPC_IS_SYSTEM}
+{$endif FPC_SYSTEM_HAS_DIV_BYTE}
+
+{$ifndef FPC_SYSTEM_HAS_DIV_WORD}
+{$define FPC_SYSTEM_HAS_DIV_WORD}
+
+// z in Ra, n in Rb, 0 in Rp
+function fpc_div_word(n, z: word): word; assembler; nostackframe;
+{$ifdef FPC_IS_SYSTEM}[public,alias: 'FPC_DIV_WORD'];{$endif}
+label
+  start, div1, div2, div3, finish;
+asm
+// Symbol  Name        Register(s)
+// z (A)   dividend    R23, R22
+// n (B)   divisor     R25, R24
+// p (P)   remainder   R21, R20
+// i	   counter     R18
+
+  cp R24, R1
+  brne start
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_pc_addr
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_pc_addr
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R20, R24
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_frame
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_frame
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R18, R24
+  ldi R22, 200
+  clr R23
+  clr R24
+  clr R25
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call HandleErrorAddrFrameInd
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall HandleErrorAddrFrameInd
+{$endif CPUAVR_HAS_JMP_CALL}
+
+start:            // Start of division...
+  clr R20         // clear remainder low
+  clr R21         // clear remainder hi
+  ldi R18, 16     // iterate over 16 bits
+
+div1:
+  lsl R22         // shift left A_L
+  rol R23
+  rol R20         // shift left P with carry from A shift
+  rol R21
+  sub R20, R24    // Subtract B from P, P <= P - B
+  sbc R21, R25
+  brlo div2
+  ori R22, 1      // Set A[0] = 1
+  rjmp div3
+div2:             // negative branch, A[0] = 0 (default after shift), restore P
+  add R20, R24    // restore old value of P
+  adc R21, R25
+
+div3:
+  dec R18
+  brne div1
+
+finish:
+  movw R24, R22    // Move result from R22:R23 to R24:R25
+end;
+
+{It is a compilerproc (systemh.inc), make an alias for internal use.}
+{$ifdef FPC_IS_SYSTEM}
+function fpc_div_word(n, z: word): word; external name 'FPC_DIV_WORD';
+{$endif FPC_IS_SYSTEM}
+{$endif FPC_SYSTEM_HAS_DIV_WORD}
+
+
+{$ifndef FPC_SYSTEM_HAS_DIV_DWORD}
+{$define FPC_SYSTEM_HAS_DIV_DWORD}
+
+// z in Ra, n in Rb, 0 in Rp
+function fpc_div_dword(n, z: dword): dword; assembler; nostackframe;
+{$ifdef FPC_IS_SYSTEM}[public,alias: 'FPC_DIV_DWORD'];{$endif}
+label
+  start, div1, div2, div3, finish;
+asm
+// Symbol  Name        Register(s)
+// z (A)   dividend    R21, R20, R19, R18
+// n (B)   divisor     R25, R24, R23, R22
+// p (P)   remainder   R17, R16, R15, R14
+// i	   counter     R26
+
+  cp R24, R1
+  cpc R25, R1
+  cpc R22, R1
+  cpc R23, R1
+  brne .LNonZero
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_pc_addr
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_pc_addr
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R20, R24
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call get_frame
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall get_frame
+{$endif CPUAVR_HAS_JMP_CALL}
+  movw R18, R24
+  ldi R22, 200
+  clr R23
+  clr R24
+  clr R25
+{$ifdef CPUAVR_HAS_JMP_CALL}
+  call HandleErrorAddrFrameInd
+{$else  CPUAVR_HAS_JMP_CALL}
+  rcall HandleErrorAddrFrameInd
+{$endif CPUAVR_HAS_JMP_CALL}
+
+.LNonZero:
+  push R17
+  push R16
+  push R15
+  push R14
+
+start:            // Start of division...
+  clr R14         // clear remainder
+  clr R15         // clear remainder
+  clr R16
+  clr R17
+  ldi R26, 32     // iterate over 32 bits
+
+div1:
+  lsl R18         // shift left A_L
+  rol R19
+  rol R20
+  rol R21
+  rol R14         // shift left P with carry from A shift
+  rol R15
+  rol R16
+  rol R17
+  sub R14, R22    // Subtract B from P, P <= P - B
+  sbc R15, R23
+  sbc R16, R24
+  sbc R17, R25
+  brlo div2
+  ori R18, 1      // Set A[0] = 1
+  rjmp div3
+div2:             // negative branch, A[0] = 0 (default after shift), restore P
+  add R14, R22    // restore old value of P
+  adc R15, R23
+  adc R16, R24
+  adc R17, R25
+
+div3:
+  dec R26
+  brne div1
+
+finish:
+  movw R22, R18    // Move result from R18:R21 to R22:R25
+  movw R24, R20
+
+  pop R14
+  pop R15
+  pop R16
+  pop R17
+end;
+
+{It is a compilerproc (systemh.inc), make an alias for internal use.}
+{$ifdef FPC_IS_SYSTEM}
+function fpc_div_dword(n, z: dword): dword; external name 'FPC_DIV_DWORD';
+{$endif FPC_IS_SYSTEM}
+{$endif FPC_SYSTEM_HAS_DIV_DWORD}
+

rtl/avr/setjump.inc

@@ -49,6 +49,11 @@ function fpc_setjmp(var S : jmp_buf) : shortint;assembler;[Public, alias : 'FPC_
     pop r19
     st x+,r18
     st x+,r19
+{$ifdef CPUAVR_3_BYTE_PC}
+    pop r20
+    st x+,r20
+    push r20
+{$endif CPUAVR_3_BYTE_PC}
     push r19
     push r18
 
@@ -94,6 +99,11 @@ procedure fpc_longjmp(var S : jmp_buf;value : shortint);assembler;[Public, alias
     pop r19
     ld r18,x+
     ld r19,x+
+{$ifdef CPUAVR_3_BYTE_PC}
+    pop r20
+    ld r20,x+
+    push r20
+{$endif CPUAVR_3_BYTE_PC}
     push r19
     push r18
     mov r24,r22

rtl/avr/setjumph.inc

@@ -17,6 +17,9 @@
 type
    jmp_buf = packed record
      r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14,r15,r16,r17,r28,r29,splo,sphi,pclo,pchi : byte;
+{$ifdef CPUAVR_3_BYTE_PC}
+     pchighest : byte
+{$endif CPUAVR_3_BYTE_PC}
    end;
    pjmp_buf = ^jmp_buf;
 

rtl/beos/ossysc.inc

@@ -789,6 +789,13 @@ begin
 end;
 
 
+Function Fpmprotect(start:pointer;len:size_t;prot:cint):cint; [public, alias : 'FPC_SYSC_MPROTECT'];
+begin
+  {$warning TODO BeOS Fpmprotect implementation}
+//  Fpmprotect:=do_syscall(syscall_nr_mprotect,TSysParam(start),TSysParam(len),TSysParam(prot));
+end;
+
+
 {
   Interface to Unix ioctl call.
   Performs various operations on the filedescriptor Handle.

rtl/bsd/ossysc.inc

@@ -470,6 +470,12 @@ begin
 end;
 
 
+Function Fpmprotect(start:pointer;len:size_t;prot:cint):cint; [public, alias : 'FPC_SYSC_MPROTECT'];
+begin
+  Fpmprotect:=do_syscall(syscall_nr_mprotect,TSysParam(start),TSysParam(len),TSysParam(prot));
+end;
+
+
 {
   Interface to Unix ioctl call.
   Performs various operations on the filedescriptor Handle.

rtl/embedded/system.pp

@@ -20,6 +20,8 @@ Unit System;
                                     interface
 {*****************************************************************************}
 
+{$define FPC_SYSTEM_HAS_STACKTOP}
+
 {$define FPC_IS_SYSTEM}
 {$define HAS_CMDLINE}
 
@@ -203,6 +205,14 @@ const calculated_cmdline:Pchar=nil;
 {*****************************************************************************
                        Misc. System Dependent Functions
 *****************************************************************************}
+var
+ _stack_top: record end; external name '_stack_top';
+
+function StackTop: pointer;
+begin
+  StackTop:=@_stack_top;
+end;
+
 
 procedure haltproc;cdecl;external name '_haltproc';
 
@@ -277,7 +287,7 @@ begin
 end;
 
 var
-  initialstkptr : Pointer; // external name '__stkptr';
+  initialstkptr : record end; external name '_stack_top';
 {$endif FPC_HAS_FEATURE_STACKCHECK}
 
 begin
@@ -294,7 +304,7 @@ begin
 
 {$ifdef FPC_HAS_FEATURE_STACKCHECK}
   StackLength := CheckInitialStkLen(initialStkLen);
-  StackBottom := initialstkptr - StackLength;
+  StackBottom := @initialstkptr - StackLength;
 {$endif FPC_HAS_FEATURE_STACKCHECK}
 
 {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}

rtl/freebsd/sysnr.inc

@@ -104,6 +104,7 @@ const
  syscall_nr_waitpid                     =   7;
  syscall_nr_write                       =   4;
  syscall_nr_munmap                      =  73;
+ syscall_nr_mprotect                    =  74;
  syscall_nr_getsockopt                  = 118;
  syscall_nr_rfork                       = 251;
  syscall_nr_clock_gettime               = 232;

rtl/inc/getopts.pp

@@ -15,7 +15,8 @@
  **********************************************************************}
 unit getopts;
 Interface
-
+{$modeswitch advancedrecords}
+{$modeswitch defaultparameters}
 Const
   No_Argument       = 0;
   Required_Argument = 1;
@@ -29,6 +30,7 @@ Type
     Has_arg : Integer;
     Flag    : PChar;
     Value   : Char;
+    Procedure SetOption(const aName:String;AHas_Arg:integer=0;AFlag:PChar=nil;AValue:Char=#0);
   end;
 
   Orderings = (require_order,permute,return_in_order);
@@ -48,6 +50,13 @@ Function GetLongOpts (ShortOpts : String;LongOpts : POption;var Longind : Longin
 
 Implementation
 
+
+Procedure TOption.SetOption(const aName:String;AHas_Arg:integer=0;AFlag:PChar=nil;AValue:Char=#0);
+begin
+  Name:=aName; Has_Arg:=AHas_Arg; Flag:=AFlag; Value:=Avalue;
+end;
+
+
 {$IFNDEF FPC}
 {***************************************************************************
                                Create an ArgV

rtl/inc/system.inc

@@ -44,7 +44,11 @@ type
 {$endif FPC_HAS_FEATURE_TEXTIO}
 
 const
+{$ifdef CPUAVR}
+  STACK_MARGIN = 64;    { Stack size margin for stack checking }
+{$else}
   STACK_MARGIN = 16384;    { Stack size margin for stack checking }
+{$endif}
 { Random / Randomize constants }
   OldRandSeed : Cardinal = 0;
 

rtl/linux/arm/sighnd.inc

@@ -15,9 +15,52 @@
 
  **********************************************************************}
 
+function GetHandleErrorAddrFrameAddr: pointer;
+begin
+  result:=@HandleErrorAddrFrame;
+end;
 
-procedure SignalToRunerror(Sig: longint; { _a2,_a3,_a4 : dword; } SigContext: PSigInfo; uContext : PuContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
+{$ifndef CPUTHUMB}
+Procedure SignalToHandleErrorAddrFrame_ARM(Errno : longint;addr : CodePointer; frame : Pointer); nostackframe; assembler;
+asm
+{$if FPC_VERSION >= 30200}
+.code 32
+{$endif}
+  // the address is of the faulting instruction, and sigreturn will
+  //  skip it -> start with a nop
+  nop
+  push {r0,r1,r2,r3}
+  bl GetHandleErrorAddrFrameAddr
+  // overwrite last stack slot with new return address
+  str r0, [sp,#12]
+  // lr := addr
+  ldr lr, [sp,#4]
+  pop {r0,r1,r2,pc}
+.text
+end;
+{$endif not CPUTHUMB}
+
+{$if FPC_VERSION >= 30200}
+Procedure SignalToHandleErrorAddrFrame_Thumb(Errno : longint;addr : CodePointer; frame : Pointer); nostackframe; assembler;
+asm
+.thumb_func
+.code 16
+  // the address is of the faulting instruction, and sigreturn will
+  // skip it -> start with a nop
+  nop
+  push {r0,r1,r2,r3}
+  bl GetHandleErrorAddrFrameAddr
+  // overwrite last stack slot with new return address
+  str r0, [sp,#12]
+  // lr := addr
+  ldr r0, [sp,#4]
+  mov lr, r0
+  pop {r0,r1,r2,pc}
+.text
+end;
+{$endif}
 
+procedure SignalToRunerror(Sig: longint; { _a2,_a3,_a4 : dword; } SigContext: PSigInfo; uContext : PuContext); public name '_FPC_DEFAULTSIGHANDLER'; cdecl;
 var
   res : word;
 begin
@@ -48,10 +91,27 @@ begin
     SIGQUIT:
         res:=233;
   end;
-  reenable_signal(sig);
   { give runtime error at the position where the signal was raised }
   if res<>0 then
-    HandleErrorAddrFrame(res,pointer(uContext^.uc_mcontext.arm_pc),pointer(uContext^.uc_mcontext.arm_fp));
+    begin
+      ucontext^.uc_mcontext.arm_r0:=res;
+      ucontext^.uc_mcontext.arm_r1:=uContext^.uc_mcontext.arm_pc;
+      ucontext^.uc_mcontext.arm_r2:=uContext^.uc_mcontext.arm_fp;
+{$if FPC_VERSION >= 30200}
+{$ifndef CPUTHUMB}
+      if (ucontext^.uc_mcontext.arm_cpsr and (1 shl 5))=0 then
+        begin
+          ucontext^.uc_mcontext.arm_pc:=ptruint(@SignalToHandleErrorAddrFrame_ARM);
+        end
+      else
+{$endif not CPUTHUMB}
+        begin
+          ucontext^.uc_mcontext.arm_pc:=ptruint(@SignalToHandleErrorAddrFrame_Thumb);
+        end;
+{$else}
+      ucontext^.uc_mcontext.arm_pc:=ptruint(@SignalToHandleErrorAddrFrame_ARM);
+{$endif}
+    end;
 end;
 
 

rtl/linux/ossysc.inc

@@ -603,6 +603,12 @@ begin
   Fpmunmap:=do_syscall(syscall_nr_munmap,TSysParam(Adr),TSysParam(Len));
 end;
 
+
+Function Fpmprotect(adr:pointer;len:size_t;prot:cint):cint; [public, alias : 'FPC_SYSC_MPROTECT'];
+begin
+  Fpmprotect:=do_syscall(syscall_nr_mprotect,TSysParam(adr),TSysParam(len),TSysParam(prot));
+end;
+
 {
   Interface to Unix ioctl call.
   Performs various operations on the filedescriptor Handle.

rtl/msdos/dos.pp

@@ -316,6 +316,7 @@ end;
 procedure setverify(verify : boolean);
 begin
   dosregs.ah:=$2e;
+  dosregs.dl:=0;
   dosregs.al:=ord(verify);
   msdos(dosregs);
 end;

rtl/objpas/classes/classesh.inc

@@ -602,11 +602,14 @@ type
   end;
 
 { TStrings class }
+  TMissingNameValueSeparatorAction = (mnvaValue,mnvaName,mnvaEmpty,mnvaError);
+  TMissingNameValueSeparatorActions = set of TMissingNameValueSeparatorAction;
 
   TStrings = class(TPersistent)
   private
     FDefaultEncoding: TEncoding;
     FEncoding: TEncoding;
+    FMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction;
     FSpecialCharsInited : boolean;
     FAlwaysQuote: Boolean;
     FQuoteChar : Char;
@@ -620,6 +623,7 @@ type
     FLineBreak : String;
     FWriteBOM: Boolean;
     function GetCommaText: string;
+    function GetMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction;
     function GetName(Index: Integer): string;
     function GetValue(const Name: string): string;
     Function GetLBS : TTextLineBreakStyle;
@@ -628,6 +632,7 @@ type
     Procedure SetLBS (AValue : TTextLineBreakStyle);
     procedure ReadData(Reader: TReader);
     procedure SetCommaText(const Value: string);
+    procedure SetMissingNameValueSeparatorAction(AValue: TMissingNameValueSeparatorAction);
     procedure SetStringsAdapter(const Value: IStringsAdapter);
     procedure SetValue(const Name, Value: string);
     procedure SetDelimiter(c:Char);
@@ -678,12 +683,12 @@ type
     function AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer; overload;
     function AddPair(const AName, AValue: string): TStrings; overload; {$IFDEF CLASSESINLINE}inline;{$ENDIF}
     function AddPair(const AName, AValue: string; AObject: TObject): TStrings; overload;
-    procedure Append(const S: string);
     procedure AddStrings(TheStrings: TStrings); overload; virtual;
     procedure AddStrings(TheStrings: TStrings; ClearFirst : Boolean); overload;
     procedure AddStrings(const TheStrings: array of string); overload; virtual;
     procedure AddStrings(const TheStrings: array of string; ClearFirst : Boolean); overload;
     Procedure AddText(Const S : String); virtual;
+    procedure Append(const S: string);
     procedure Assign(Source: TPersistent); override;
     procedure BeginUpdate;
     procedure Clear; virtual; abstract;
@@ -692,14 +697,15 @@ type
     function Equals(Obj: TObject): Boolean; override; overload;
     function Equals(TheStrings: TStrings): Boolean; overload;
     procedure Exchange(Index1, Index2: Integer); virtual;
+    function  ExtractName(Const S:String):String;
     function GetEnumerator: TStringsEnumerator;
+    procedure GetNameValue(Index : Integer; Out AName,AValue : String);
     function GetText: PChar; virtual;
     function IndexOf(const S: string): Integer; virtual;
     function IndexOfName(const Name: string): Integer; virtual;
     function IndexOfObject(AObject: TObject): Integer; virtual;
     procedure Insert(Index: Integer; const S: string); virtual; abstract;
-    procedure InsertObject(Index: Integer; const S: string;
-      AObject: TObject);
+    procedure InsertObject(Index: Integer; const S: string; AObject: TObject);
     procedure LoadFromFile(const FileName: string); overload; virtual;
     procedure LoadFromFile(const FileName: string; IgnoreEncoding : Boolean);
     procedure LoadFromFile(const FileName: string; AEncoding: TEncoding); overload; virtual;
@@ -712,29 +718,28 @@ type
     procedure SaveToStream(Stream: TStream); overload; virtual;
     procedure SaveToStream(Stream: TStream; AEncoding: TEncoding); overload; virtual;
     procedure SetText(TheText: PChar); virtual;
-    procedure GetNameValue(Index : Integer; Out AName,AValue : String);
-    function  ExtractName(Const S:String):String;
-    Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS;
-    property Delimiter: Char read GetDelimiter write SetDelimiter;
-    property DelimitedText: string read GetDelimitedText write SetDelimitedText;
-    property DefaultEncoding: TEncoding read FDefaultEncoding write SetDefaultEncoding;
-    property Encoding: TEncoding read FEncoding;
-    property LineBreak : string Read GetLineBreak write SetLineBreak;
-    Property StrictDelimiter : Boolean Read FStrictDelimiter Write FStrictDelimiter;
     property AlwaysQuote: Boolean read FAlwaysQuote write FAlwaysQuote;
-    property QuoteChar: Char read GetQuoteChar write SetQuoteChar;
-    Property NameValueSeparator : Char Read GetNameValueSeparator Write SetNameValueSeparator;
-    property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;
     property Capacity: Integer read GetCapacity write SetCapacity;
     property CommaText: string read GetCommaText write SetCommaText;
     property Count: Integer read GetCount;
+    property DefaultEncoding: TEncoding read FDefaultEncoding write SetDefaultEncoding;
+    property DelimitedText: string read GetDelimitedText write SetDelimitedText;
+    property Delimiter: Char read GetDelimiter write SetDelimiter;
+    property Encoding: TEncoding read FEncoding;
+    property LineBreak : string Read GetLineBreak write SetLineBreak;
+    Property MissingNameValueSeparatorAction : TMissingNameValueSeparatorAction Read GetMissingNameValueSeparatorAction Write SetMissingNameValueSeparatorAction;
     property Names[Index: Integer]: string read GetName;
+    Property NameValueSeparator : Char Read GetNameValueSeparator Write SetNameValueSeparator;
     property Objects[Index: Integer]: TObject read GetObject write PutObject;
-    property Values[const Name: string]: string read GetValue write SetValue;
+    property QuoteChar: Char read GetQuoteChar write SetQuoteChar;
+    Property SkipLastLineBreak : Boolean Read GetSkipLastLineBreak Write SetSkipLastLineBreak;
+    Property StrictDelimiter : Boolean Read FStrictDelimiter Write FStrictDelimiter;
     property Strings[Index: Integer]: string read Get write Put; default;
-    property Text: string read GetTextStr write SetTextStr;
     property StringsAdapter: IStringsAdapter read FAdapter write SetStringsAdapter;
-    Property SkipLastLineBreak : Boolean Read GetSkipLastLineBreak Write SetSkipLastLineBreak;
+    property Text: string read GetTextStr write SetTextStr;
+    Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS;
+    property ValueFromIndex[Index: Integer]: string read GetValueFromIndex write SetValueFromIndex;
+    property Values[const Name: string]: string read GetValue write SetValue;
     property WriteBOM: Boolean read FWriteBOM write FWriteBOM;
   end;
 

rtl/objpas/classes/stringl.inc

@@ -162,6 +162,7 @@ begin
   FNameValueSeparator:=c;
 end;
 
+
 Function TStrings.GetNameValueSeparator :Char;
 begin
   CheckSpecialChars;
@@ -192,6 +193,12 @@ begin
   end;
 end;
 
+function TStrings.GetMissingNameValueSeparatorAction: TMissingNameValueSeparatorAction;
+begin
+  CheckSpecialChars;
+  Result:=FMissingNameValueSeparatorAction;
+end;
+
 
 Function TStrings.GetDelimitedText: string;
 
@@ -240,6 +247,7 @@ procedure TStrings.GetNameValue(Index : Integer; Out AName,AValue : String);
 Var L : longint;
 
 begin
+  aName:='';
   CheckSpecialChars;
   AValue:=Strings[Index];
   L:=Pos(FNameValueSeparator,AValue);
@@ -249,7 +257,18 @@ begin
     System.Delete(AValue,1,L);
     end
   else
-    AName:='';
+    case FMissingNameValueSeparatorAction of
+      mnvaValue : ;
+      mnvaName :
+        begin
+        aName:=aValue;
+        aValue:='';
+        end;
+      mnvaEmpty :
+        aValue:='';
+      mnvaError :
+        Raise EStringListError.CreateFmt(SErrNoNameValuePairAt,[Index]);
+    end;
 end;
 
 function TStrings.ExtractName(const s:String):String;
@@ -445,6 +464,12 @@ begin
   end;
 end;
 
+procedure TStrings.SetMissingNameValueSeparatorAction(AValue: TMissingNameValueSeparatorAction);
+begin
+  CheckSpecialChars;
+  FMissingNameValueSeparatorAction:=aValue;
+end;
+
 
 Procedure TStrings.SetStringsAdapter(const Value: IStringsAdapter);
 

rtl/objpas/rtlconst.inc

@@ -308,6 +308,7 @@ ResourceString
   SParamIsNegative              = 'Parameter "%s" cannot be negative.';
   SErrCannotWriteToProperty     = 'Cannot write to property "%s".';
   SErrCannotReadProperty        = 'Cannot read property "%s".';
+  SErrNoNameValuePairAt         = 'No name=value pair at position %d.';
 
 { ---------------------------------------------------------------------
     Keysim Names

rtl/objpas/sysutils/syshelp.inc

@@ -1097,34 +1097,34 @@ end;
 
 function TStringHelper.Split(const Separators: array of Char): TStringArray;
 begin
-  Result:=SPlit(Separators,#0,#0,Length,TStringSplitOptions.None);
+  Result:=Split(Separators,#0,#0,Length+1,TStringSplitOptions.None);
 end;
 
 
 function TStringHelper.Split(const Separators: array of Char; ACount: SizeInt
   ): TStringArray;
 begin
-  Result:=SPlit(Separators,#0,#0,ACount,TStringSplitOptions.None);
+  Result:=Split(Separators,#0,#0,ACount,TStringSplitOptions.None);
 end;
 
 
 function TStringHelper.Split(const Separators: array of Char;
   Options: TStringSplitOptions): TStringArray;
 begin
-  Result:=SPlit(Separators,Length,Options);
+  Result:=Split(Separators,Length+1,Options);
 end;
 
 
 function TStringHelper.Split(const Separators: array of Char; ACount: SizeInt;
   Options: TStringSplitOptions): TStringArray;
 begin
-  Result:=SPlit(Separators,#0,#0,ACount,Options);
+  Result:=Split(Separators,#0,#0,ACount,Options);
 end;
 
 
 function TStringHelper.Split(const Separators: array of string): TStringArray;
 begin
-  Result:=Split(Separators,Length);
+  Result:=Split(Separators,Length+1);
 end;
 
 
@@ -1138,7 +1138,7 @@ end;
 function TStringHelper.Split(const Separators: array of string;
   Options: TStringSplitOptions): TStringArray;
 begin
-  Result:=Split(Separators,Length,Options);
+  Result:=Split(Separators,Length+1,Options);
 end;
 
 
@@ -1166,7 +1166,7 @@ end;
 function TStringHelper.Split(const Separators: array of Char; AQuoteStart,
   AQuoteEnd: Char; Options: TStringSplitOptions): TStringArray;
 begin
-  Result:=Split(Separators,AQuoteStart,AQuoteEnd,Length,Options);
+  Result:=Split(Separators,AQuoteStart,AQuoteEnd,Length+1,Options);
 end;
 
 
@@ -1211,7 +1211,7 @@ begin
   While (Sep<>-1) and ((ACount=0) or (Len<ACount)) do
     begin
     T:=SubString(LastSep,Sep-LastSep);
-//    Writeln('Examining >',T,'< at pos,',LastSep,' till pos ',Sep);
+//    Writeln('Examining >',T,'< at pos ',LastSep,', till pos ',Sep);
     If (T<>'') or (not (TStringSplitOptions.ExcludeEmpty=Options)) then
       begin
       MaybeGrow(Len);
@@ -1221,7 +1221,7 @@ begin
     LastSep:=Sep+1;
     Sep:=NextSep(LastSep);
     end;
-  if (LastSep<Length) and ((ACount=0) or (Len<ACount)) then
+  if (LastSep<=Length) and ((ACount=0) or (Len<ACount)) then
     begin
     T:=SubString(LastSep);
 //    Writeln('Examining >',T,'< at pos,',LastSep,' till pos ',Sep);
@@ -1243,14 +1243,14 @@ end;
 function TStringHelper.Split(const Separators: array of string; AQuoteStart,
   AQuoteEnd: Char): TStringArray;
 begin
-  Result:=SPlit(Separators,AQuoteStart,AQuoteEnd,Length,TStringSplitOptions.None);
+  Result:=SPlit(Separators,AQuoteStart,AQuoteEnd,Length+1,TStringSplitOptions.None);
 end;
 
 
 function TStringHelper.Split(const Separators: array of string; AQuoteStart,
   AQuoteEnd: Char; Options: TStringSplitOptions): TStringArray;
 begin
-  Result:=SPlit(Separators,AQuoteStart,AQuoteEnd,Length,Options);
+  Result:=SPlit(Separators,AQuoteStart,AQuoteEnd,Length+1,Options);
 end;
 
 
@@ -1304,7 +1304,7 @@ begin
     LastSep:=Sep+System.Length(Separators[Match]);
     Sep:=NextSep(LastSep,Match);
     end;
-  if (LastSep<Length) and ((ACount=0) or (Len<ACount)) then
+  if (LastSep<=Length) and ((ACount=0) or (Len<ACount)) then
     begin
     T:=SubString(LastSep);
 //    Writeln('Examining >',T,'< at pos,',LastSep,' till pos ',Sep);

rtl/openbsd/i386/si_c.inc

@@ -18,6 +18,7 @@
 
 procedure __init; cdecl; external name '__init';
 procedure c_exit(exit_code: cint); cdecl; noreturn; external name 'exit';
+function _csu_finish(_argv: PPChar; _envp: PPChar; _cleanup: TCdeclProcedure): PPPChar; cdecl; external name '_csu_finish';
 
 procedure _FPC_proc___start(argc: LongInt; argv: PPChar; envp: Pointer; cleanup: TCdeclProcedure); cdecl; forward;
 
@@ -41,9 +42,11 @@ function _strrchr(str: PChar; character: LongInt): PChar; forward;
 procedure _FPC_proc___start(argc: LongInt; argv: PPChar; envp: Pointer; cleanup: TCdeclProcedure); cdecl;
   var
     I: SizeUInt;
+    environp: PPPChar;
   begin
-    environ:=envp;
-    operatingsystem_parameter_envp:=envp;
+    environp:=_csu_finish(argv, envp, cleanup);
+    environ:=environp^;
+    operatingsystem_parameter_envp:=environ;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=argv;
     if argv[0]<>nil then

rtl/openbsd/i386/si_g.inc

@@ -25,6 +25,7 @@ function atexit(proc: TCdeclProcedure): cint; cdecl; external name 'atexit';
 procedure _monstartup(lowpc, highpc: u_long); cdecl; external name '_monstartup';
 procedure __init; cdecl; external name '__init';
 procedure c_exit(exit_code: cint); cdecl; noreturn; external name 'exit';
+function _csu_finish(_argv: PPChar; _envp: PPChar; _cleanup: TCdeclProcedure): PPPChar; cdecl; external name '_csu_finish';
 
 procedure _FPC_proc___start(argc: LongInt; argv: PPChar; envp: Pointer; cleanup: TCdeclProcedure); cdecl; forward;
 
@@ -48,9 +49,11 @@ function _strrchr(str: PChar; character: LongInt): PChar; forward;
 procedure _FPC_proc___start(argc: LongInt; argv: PPChar; envp: Pointer; cleanup: TCdeclProcedure); cdecl;
   var
     I: SizeUInt;
+    environp: PPPChar;
   begin
-    environ:=envp;
-    operatingsystem_parameter_envp:=envp;
+    environp:=_csu_finish(argv, envp, cleanup);
+    environ:=environp^;
+    operatingsystem_parameter_envp:=environ;
     operatingsystem_parameter_argc:=argc;
     operatingsystem_parameter_argv:=argv;
     if argv[0]<>nil then

rtl/unix/bunxh.inc

@@ -106,6 +106,7 @@ Type TGrpArr = Array [0..0] of TGid;            { C style array workarounds}
     Function  fpSetPriority(Which,Who,What:cint):cint;
     Function  Fpmmap(start:pointer;len:size_t;prot:cint;flags:cint;fd:cint;offst:off_t):pointer; external name 'FPC_SYSC_MMAP';
     Function  Fpmunmap(start:pointer;len:size_t):cint;  external name 'FPC_SYSC_MUNMAP';
+    Function  Fpmprotect(start:pointer;len:size_t;prot:cint):cint; external name 'FPC_SYSC_MPROTECT';
 
     Function  FpGetEnv (name : pChar): pChar; external name 'FPC_SYSC_FPGETENVPCHAR';
     function  fpsettimeofday(tp:ptimeval;tzp:ptimezone):cint;

rtl/unix/oscdeclh.inc

@@ -156,6 +156,7 @@ const
     Function  fpSetPriority (Which,Who,What:cint):cint; cdecl; external clib name 'setpriority';
     function  fpmmap    (addr:pointer;len:size_t;prot:cint;flags:cint;fd:cint;ofs:off_t):pointer; cdecl; external clib name 'mmap'+suffix64bit;
     function  fpmunmap  (addr:pointer;len:size_t):cint; cdecl; external clib name 'munmap';
+    function  fpmprotect(addr:pointer;len:size_t;prot:cint):cint; cdecl; external clib name 'mprotect';
 
     function  fpgetenv  (name : pchar):pchar; cdecl; external clib name 'getenv';
 {$ifndef beos}

tests/test/cg/obj/readme.txt

@@ -44,6 +44,7 @@ Android-mipsel : GCC 4.7
 Android-aarch64 : GCC 4.9
 Android-x86_64 : GCC 4.9
 haiku-i386 : gcc 2.95.3-haiku-100818
+haiku-x86_64 : gcc version 7.3.0 (2018_05_01)
 aix-powerpc64 : gcc (GCC) 4.8.1 using "gcc -maix64" for TEST_CCOMPILER
                 on (AIX power-aix 1 7 00F84C0C4C00)
 OS/2 (os2-i386): original EMX port of GCC (GCC 2.8.1) except for tcext6.c which

tests/test/cpu16/i8086/tfarcal2.pp

@@ -12,6 +12,11 @@
 
 program tfarcal2;
 
+{$ifdef FPC}
+{ FPC needs $goto on to accept labels and gotos }
+{$goto on}
+{$endif}
+
 uses
   dos;
 
@@ -24,9 +29,16 @@ const
   NearInt = $E7;
   FarInt = $E8;
 
+  NoSegOverride = 0;
+  SegOverrideCS = $2E;
+  SegOverrideSS = $36;
+  SegOverrideDS = $3E;
+  SegOverrideES = $26;
+
 var
   OldNearIntVec: FarPointer;
   OldFarIntVec: FarPointer;
+  ExpectSegOverride: Byte;
 
 procedure Error;
 begin
@@ -40,6 +52,12 @@ procedure IntNearHandler(Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word
 var
   modrm: Byte;
 begin
+  if ExpectSegOverride <> 0 then
+  begin
+    if Mem[CS:IP]<>ExpectSegOverride then
+      Error;
+    Inc(IP);
+  end;
   if Mem[CS:IP]<>$FF then
     Error;
   Inc(IP);
@@ -64,6 +82,12 @@ procedure IntFarHandler(Flags, CS, IP, AX, BX, CX, DX, SI, DI, DS, ES, BP: Word)
 var
   modrm: Byte;
 begin
+  if ExpectSegOverride <> 0 then
+  begin
+    if Mem[CS:IP]<>ExpectSegOverride then
+      Error;
+    Inc(IP);
+  end;
   if Mem[CS:IP]<>$FF then
     Error;
   Inc(IP);
@@ -115,6 +139,203 @@ begin
   end;
 end;
 
+procedure testlocallabels;
+label
+  local_label2;
+begin
+  ExpectSegOverride := SegOverrideCS;
+  asm
+    jmp @@skip_labels
+
+@@local_label1:
+    db 0, 0, 0, 0
+
+local_label2:
+    db 0, 0, 0, 0
+
+@@skip_labels:
+    int NearInt
+    call word [@@local_label1] { near }
+    int NearInt
+    call word ptr [@@local_label1] { near }
+    int NearInt
+    call word ptr @@local_label1 { near }
+
+    int FarInt
+    call dword [@@local_label1] { far }
+    int FarInt
+    call dword ptr [@@local_label1] { far }
+    int FarInt
+    call dword ptr @@local_label1 { far }
+
+    int NearInt
+    call word [local_label2] { near }
+    int NearInt
+    call word ptr [local_label2] { near }
+    int NearInt
+    call word ptr local_label2 { near }
+
+    int FarInt
+    call dword [local_label2] { far }
+    int FarInt
+    call dword ptr [local_label2] { far }
+    int FarInt
+    call dword ptr local_label2 { far }
+
+    { explicit CS: prefix }
+    int NearInt
+    call word [cs:@@local_label1] { near }
+    int NearInt
+    call word ptr cs:[@@local_label1] { near }
+    int NearInt
+    call word ptr [cs:@@local_label1] { near }
+    int NearInt
+    call word ptr cs:@@local_label1 { near }
+
+    int FarInt
+    call dword [cs:@@local_label1] { far }
+    int FarInt
+    call dword ptr cs:[@@local_label1] { far }
+    int FarInt
+    call dword ptr [cs:@@local_label1] { far }
+    int FarInt
+    call dword ptr cs:@@local_label1 { far }
+
+    int NearInt
+    call word [cs:local_label2] { near }
+    int NearInt
+    call word ptr cs:[local_label2] { near }
+    int NearInt
+    call word ptr [cs:local_label2] { near }
+    int NearInt
+    call word ptr cs:local_label2 { near }
+
+    int FarInt
+    call dword [cs:local_label2] { far }
+    int FarInt
+    call dword ptr cs:[local_label2] { far }
+    int FarInt
+    call dword ptr [cs:local_label2] { far }
+    int FarInt
+    call dword ptr cs:local_label2 { far }
+
+    { explicit DS: prefix }
+    mov byte ptr [ExpectSegOverride], NoSegOverride  { no segment override
+            should be produced, because DS is the default for the processor }
+    int NearInt
+    call word [ds:@@local_label1] { near }
+    int NearInt
+    call word ptr ds:[@@local_label1] { near }
+    int NearInt
+    call word ptr [ds:@@local_label1] { near }
+    int NearInt
+    call word ptr ds:@@local_label1 { near }
+
+    int FarInt
+    call dword [ds:@@local_label1] { far }
+    int FarInt
+    call dword ptr ds:[@@local_label1] { far }
+    int FarInt
+    call dword ptr [ds:@@local_label1] { far }
+    int FarInt
+    call dword ptr ds:@@local_label1 { far }
+
+    int NearInt
+    call word [ds:local_label2] { near }
+    int NearInt
+    call word ptr ds:[local_label2] { near }
+    int NearInt
+    call word ptr [ds:local_label2] { near }
+    int NearInt
+    call word ptr ds:local_label2 { near }
+
+    int FarInt
+    call dword [ds:local_label2] { far }
+    int FarInt
+    call dword ptr ds:[local_label2] { far }
+    int FarInt
+    call dword ptr [ds:local_label2] { far }
+    int FarInt
+    call dword ptr ds:local_label2 { far }
+
+    { explicit ES: prefix }
+    mov byte ptr [ExpectSegOverride], SegOverrideES
+    int NearInt
+    call word [es:@@local_label1] { near }
+    int NearInt
+    call word ptr es:[@@local_label1] { near }
+    int NearInt
+    call word ptr [es:@@local_label1] { near }
+    int NearInt
+    call word ptr es:@@local_label1 { near }
+
+    int FarInt
+    call dword [es:@@local_label1] { far }
+    int FarInt
+    call dword ptr es:[@@local_label1] { far }
+    int FarInt
+    call dword ptr [es:@@local_label1] { far }
+    int FarInt
+    call dword ptr es:@@local_label1 { far }
+
+    int NearInt
+    call word [es:local_label2] { near }
+    int NearInt
+    call word ptr es:[local_label2] { near }
+    int NearInt
+    call word ptr [es:local_label2] { near }
+    int NearInt
+    call word ptr es:local_label2 { near }
+
+    int FarInt
+    call dword [es:local_label2] { far }
+    int FarInt
+    call dword ptr es:[local_label2] { far }
+    int FarInt
+    call dword ptr [es:local_label2] { far }
+    int FarInt
+    call dword ptr es:local_label2 { far }
+
+    { explicit SS: prefix }
+    mov byte ptr [ExpectSegOverride], SegOverrideSS
+    int NearInt
+    call word [ss:@@local_label1] { near }
+    int NearInt
+    call word ptr ss:[@@local_label1] { near }
+    int NearInt
+    call word ptr [ss:@@local_label1] { near }
+    int NearInt
+    call word ptr ss:@@local_label1 { near }
+
+    int FarInt
+    call dword [ss:@@local_label1] { far }
+    int FarInt
+    call dword ptr ss:[@@local_label1] { far }
+    int FarInt
+    call dword ptr [ss:@@local_label1] { far }
+    int FarInt
+    call dword ptr ss:@@local_label1 { far }
+
+    int NearInt
+    call word [ss:local_label2] { near }
+    int NearInt
+    call word ptr ss:[local_label2] { near }
+    int NearInt
+    call word ptr [ss:local_label2] { near }
+    int NearInt
+    call word ptr ss:local_label2 { near }
+
+    int FarInt
+    call dword [ss:local_label2] { far }
+    int FarInt
+    call dword ptr ss:[local_label2] { far }
+    int FarInt
+    call dword ptr [ss:local_label2] { far }
+    int FarInt
+    call dword ptr ss:local_label2 { far }
+  end;
+end;
+
 var
   g16: integer;
   g32: longint;
@@ -124,6 +345,7 @@ begin
   GetIntVec(FarInt, OldFarIntVec);
   SetIntVec(FarInt, Ptr(Seg(IntFarHandler),Ofs(IntFarHandler)));
 
+  ExpectSegOverride := 0;
   asm
     int NearInt
     call word ptr $1234
@@ -202,6 +424,7 @@ begin
 {$endif FPC}
   end;
   testloc(5, 10);
+  testlocallabels;
   Writeln('Ok');
 
   SetIntVec(NearInt, OldNearIntVec);

tests/webtbs/tw35272.pp

@@ -0,0 +1,19 @@
+var
+  b1, b2, b3: longbool;
+begin
+  b1:=longbool(1);
+  b2:=longbool(2);
+  b3:=b1 and b2;
+  if not b3 then
+    halt(1);
+  b3:=b1 xor b2;
+  if b3 then
+    halt(2);
+{$b+}
+  b3:=b1 and b2;
+  if not b3 then
+    halt(3);
+  b3:=b1 xor b2;
+  if b3 then
+    halt(4);
+end.

utils/fpdoc/dw_htmlchm.inc

@@ -192,12 +192,12 @@ begin
         // by unit
         TmpItem := ObjUnitItem.Children.NewItem;
         TmpItem.Text := Element.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
         
         //alpha
         TmpItem := GetAlphaItem(AlphaObjItem.Children, UpperCase(Copy(Element.Name, 1, 2))).Children.NewItem;
         TmpItem.Text := Element.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
         
       end;
       
@@ -208,12 +208,12 @@ begin
         // by unit
         TmpItem := RoutinesUnitItem.Children.NewItem;
         TmpItem.Text := Element.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
         
         // alpha
         TmpItem := GetAlphaItem(AlphaRoutinesItem.Children, UpperCase(Element.Name[1])).Children.NewItem;
         TmpItem.Text := Element.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(Element, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(Element, 0)));
       end;
     end;
   end;
@@ -289,7 +289,7 @@ var
   ParentElement: TPasElement;
   MemberItem: TChmSiteMapItem;
   Stream: TMemoryStream;
-  s: String;
+  RedirectUrl,Urls: String;
 
 begin
   DoLog('Generating Index...');
@@ -305,7 +305,7 @@ begin
         continue;
       ParentItem := Index.Items.NewItem;
       ParentItem.Text := AModule.Name;
-      ParentItem.Local := FixHTMLpath(Allocator.GetFilename(AModule, 0));
+      ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(AModule, 0)));
 
       //  classes
       for j := 0 to AModule.InterfaceSection.Classes.Count-1 do
@@ -313,18 +313,27 @@ begin
         ParentElement := TPasClassType(AModule.InterfaceSection.Classes[j]);
         ParentItem := Index.Items.NewItem;
         ParentItem.Text := ParentELement.Name;
-        ParentItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
+        ParentItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
         for k := 0 to TPasClassType(ParentElement).Members.Count-1 do
         begin
           TmpElement := TPasElement(TPasClassType(ParentElement).Members.Items[k]);
-          if TmpElement is TPasEnumValue then
-             s := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName))
-           else
-             s := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName));
-           if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then
+          if Engine.HidePrivate and(TmpElement.Visibility = visPrivate) then
             continue;
           if Engine.HideProtected and(TmpElement.Visibility = visProtected) then
             continue;
+          Urls:=FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
+          RedirectUrl:='';
+          if TmpElement is TPasEnumValue then
+             RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.Parent.PathName))
+           else
+             RedirectUrl := UTF8Encode(ResolveLinkIDAbs(tmpElement.PathName));
+
+          if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then
+            begin
+              writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
+              urls:=RedirectUrl;
+            end;
+
           TmpItem := ParentItem.Children.NewItem;
           case ElementType(TmpElement) of
             cmtProcedure   : TmpItem.Text := TmpElement.Name + ' procedure';
@@ -336,13 +345,7 @@ begin
             cmtInterface   : TmpItem.Text := TmpElement.Name + ' interface';
             cmtUnknown     : TmpItem.Text := TmpElement.Name;
           end;
-          TmpItem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
-          if (trim(s)<>'') and (tmpitem.local<>s) then
-            begin
-              writeln('Hint: Index: Resolved:',tmpitem.local,' to ',s);
-              tmpitem.local:=s;
-            end;
-
+          TmpItem.addLocal(Urls);
           {
           ParentElement = Class
              TmpElement = Member
@@ -350,11 +353,11 @@ begin
           MemberItem := nil;
           MemberItem := GetAlphaItem(Index.Items, TmpElement.Name);
           // ahh! if MemberItem.Local is empty MemberType is not shown!
-          MemberItem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
+          MemberItem.addLocal(Urls);
 
           TmpItem := MemberItem.Children.NewItem;
           TmpItem.Text := ParentElement.Name;
-          TmpITem.Local := FixHTMLpath(Allocator.GetFilename(TmpElement, 0));
+          TmpItem.AddLocal(Urls);
         end;
       end;
       // routines
@@ -363,7 +366,7 @@ begin
         ParentElement := TPasProcedureType(AModule.InterfaceSection.Functions[j]);
         TmpItem := Index.Items.NewItem;
         TmpItem.Text := ParentElement.Name + ' ' + ParentElement.ElementTypeName;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
       end;
       // consts
       for j := 0 to AModule.InterfaceSection.Consts.Count-1 do
@@ -371,7 +374,7 @@ begin
         ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]);
         TmpItem := Index.Items.NewItem;
         TmpItem.Text := ParentElement.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
       end;
       // types
       for j := 0 to AModule.InterfaceSection.Types.Count-1 do
@@ -379,7 +382,7 @@ begin
         ParentElement := TPasType(AModule.InterfaceSection.Types[j]);
         TmpItem := Index.Items.NewItem;
         TmpItem.Text := ParentElement.Name;
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
         // enums
         if ParentELement is TPasEnumType then
         begin
@@ -390,11 +393,11 @@ begin
             // subitem
             TmpItem := ParentItem.Children.NewItem;
             TmpItem.Text := TmpElement.Name;
-            TmpItem.Local := ParentItem.Local;
+            TmpItem.addLocal(ParentItem.Local);
             // root level
             TmpItem := Index.Items.NewItem;
             TmpItem.Text := TmpElement.Name;
-            TmpItem.Local := ParentItem.Local;
+            TmpItem.addLocal(ParentItem.Local);
           end;
         end;
       end;
@@ -404,7 +407,7 @@ begin
         ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]);
         TmpItem := Index.Items.NewItem;
         TmpItem.Text := ParentElement.Name + ' var';
-        TmpItem.Local := FixHTMLpath(Allocator.GetFilename(ParentElement, 0));
+        TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
       end;
       // declarations
       {

utils/fpdoc/fpdocxmlopts.pas

@@ -389,7 +389,6 @@ begin
     Result:=TMemoryStream.Create;
     P.ParseStream(F,Result);
     Result.Position:=0;
-    TMemoryStream(Result).SaveToFile('/tmp/opts.xml');
   finally
     FreeAndNil(F);
     FreeAndNil(P);