* synchronised with trunk up to r25167 (fixes glib compilation via r25164,

    and occasional crashes in executeprocess on libc platforms via r25167)

git-svn-id: branches/cpstrrtl@25169 -

.gitattributes

@@ -798,6 +798,7 @@ compiler/x86_64/nx64cnv.pas svneol=native#text/plain
 compiler/x86_64/nx64flw.pas svneol=native#text/plain
 compiler/x86_64/nx64inl.pas svneol=native#text/plain
 compiler/x86_64/nx64mat.pas svneol=native#text/plain
+compiler/x86_64/nx64set.pas svneol=native#text/plain
 compiler/x86_64/r8664ari.inc svneol=native#text/plain
 compiler/x86_64/r8664att.inc svneol=native#text/plain
 compiler/x86_64/r8664con.inc svneol=native#text/plain
@@ -1974,6 +1975,8 @@ packages/fcl-base/texts/fptemplate.txt svneol=native#text/plain
 packages/fcl-db/Makefile svneol=native#text/plain
 packages/fcl-db/Makefile.fpc svneol=native#text/plain
 packages/fcl-db/Makefile.fpc.fpcmake svneol=native#text/plain
+packages/fcl-db/examples/dbftool.lpi svneol=native#text/plain
+packages/fcl-db/examples/dbftool.lpr svneol=native#text/plain
 packages/fcl-db/examples/fbadmindemo.pp svneol=native#text/plain
 packages/fcl-db/examples/fbeventstest.pp svneol=native#text/plain
 packages/fcl-db/examples/loadlibdemo.lpi svneol=native#text/plain
@@ -10005,6 +10008,7 @@ tests/tbs/tb0593.pp svneol=native#text/pascal
 tests/tbs/tb0594.pp svneol=native#text/plain
 tests/tbs/tb0595.pp svneol=native#text/plain
 tests/tbs/tb0596.pp svneol=native#text/pascal
+tests/tbs/tb0597.pp svneol=native#text/plain
 tests/tbs/tb205.pp svneol=native#text/plain
 tests/tbs/tbs0594.pp svneol=native#text/pascal
 tests/tbs/ub0060.pp svneol=native#text/plain
@@ -10298,10 +10302,13 @@ tests/test/cg/obj/win32/i386/tcext3.o -text
 tests/test/cg/obj/win32/i386/tcext4.o -text
 tests/test/cg/obj/win32/i386/tcext5.o -text
 tests/test/cg/obj/win32/i386/tcext6.o -text
+tests/test/cg/obj/win64/x86_64/cpptcl1.o -text
+tests/test/cg/obj/win64/x86_64/cpptcl2.o -text
 tests/test/cg/obj/win64/x86_64/ctest.o -text svneol=unset#unset
 tests/test/cg/obj/win64/x86_64/tcext3.o -text svneol=unset#unset
 tests/test/cg/obj/win64/x86_64/tcext4.o -text svneol=unset#unset
 tests/test/cg/obj/win64/x86_64/tcext5.o -text svneol=unset#unset
+tests/test/cg/obj/win64/x86_64/tcext6.o -text
 tests/test/cg/obj/wince/arm/ctest.o -text
 tests/test/cg/obj/wince/arm/tcext3.o -text
 tests/test/cg/obj/wince/arm/tcext4.o -text
@@ -10619,6 +10626,9 @@ tests/test/cg/variants/tvarol9.pp svneol=native#text/plain
 tests/test/cg/variants/tvarol91.pp svneol=native#text/plain
 tests/test/cg/variants/tvarol94.pp svneol=native#text/plain
 tests/test/cg/variants/tvarol96.pp svneol=native#text/plain
+tests/test/cpu16/i8086/tfarptr1.pp svneol=native#text/pascal
+tests/test/cpu16/i8086/tfarptr2.pp svneol=native#text/pascal
+tests/test/cpu16/i8086/tptrsize.pp svneol=native#text/pascal
 tests/test/cpu16/taddint1.pp svneol=native#text/pascal
 tests/test/dumpclass.pp svneol=native#text/plain
 tests/test/dumpmethods.pp svneol=native#text/plain
@@ -13137,6 +13147,7 @@ tests/webtbs/tw17550.pp svneol=native#text/plain
 tests/webtbs/tw17560.pp svneol=native#text/plain
 tests/webtbs/tw1758.pp svneol=native#text/plain
 tests/webtbs/tw17591.pp svneol=native#text/plain
+tests/webtbs/tw17598.pp svneol=native#text/pascal
 tests/webtbs/tw17604.pp svneol=native#text/plain
 tests/webtbs/tw17646.pp svneol=native#text/plain
 tests/webtbs/tw1765.pp svneol=native#text/plain
@@ -13493,6 +13504,8 @@ tests/webtbs/tw2438.pp svneol=native#text/plain
 tests/webtbs/tw2442.pp svneol=native#text/plain
 tests/webtbs/tw2452.pp svneol=native#text/plain
 tests/webtbs/tw2454.pp svneol=native#text/plain
+tests/webtbs/tw24651.pp svneol=native#text/pascal
+tests/webtbs/tw24705.pp svneol=native#text/pascal
 tests/webtbs/tw2473.pp svneol=native#text/plain
 tests/webtbs/tw2480.pp svneol=native#text/plain
 tests/webtbs/tw2481.pp svneol=native#text/plain
@@ -13701,6 +13714,8 @@ tests/webtbs/tw3320.pp svneol=native#text/plain
 tests/webtbs/tw3324.pp svneol=native#text/plain
 tests/webtbs/tw3327.pp svneol=native#text/plain
 tests/webtbs/tw3328.pp svneol=native#text/plain
+tests/webtbs/tw3328a.pp svneol=native#text/plain
+tests/webtbs/tw3328b.pp svneol=native#text/plain
 tests/webtbs/tw3334.pp svneol=native#text/plain
 tests/webtbs/tw3340.pp svneol=native#text/plain
 tests/webtbs/tw3348.pp svneol=native#text/plain

compiler/COPYING.txt

@@ -2,7 +2,7 @@
 		       Version 2, June 1991
 
  Copyright (C) 1989, 1991 Free Software Foundation, Inc.
-                       59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  Everyone is permitted to copy and distribute verbatim copies
  of this license document, but changing it is not allowed.
 

compiler/aasmtai.pas

@@ -568,12 +568,16 @@ interface
           constructor Create_uleb128bit(_value : qword);
           constructor Create_aint(_value : aint);
           constructor Create_pint(_value : pint);
+          constructor Create_pint_unaligned(_value : pint);
           constructor Create_sym(_sym:tasmsymbol);
           constructor Create_type_sym(_typ:taiconst_type;_sym:tasmsymbol);
           constructor Create_sym_offset(_sym:tasmsymbol;ofs:aint);
           constructor Create_rel_sym(_typ:taiconst_type;_sym,_endsym:tasmsymbol);
           constructor Create_rva_sym(_sym:tasmsymbol);
           constructor Createname(const name:string;ofs:aint);
+          constructor Create_type_name(_typ:taiconst_type;const name:string;ofs:aint);
+          constructor Create_nil_codeptr;
+          constructor Create_nil_dataptr;
           constructor ppuload(t:taitype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure derefimpl;override;
@@ -1606,6 +1610,17 @@ implementation
       end;
 
 
+    constructor tai_const.Create_pint_unaligned(_value: pint);
+      begin
+         inherited Create;
+         typ:=ait_const;
+         consttype:=aitconst_ptr_unaligned;
+         value:=_value;
+         sym:=nil;
+         endsym:=nil;
+      end;
+
+
     constructor tai_const.Create_type_sym(_typ:taiconst_type;_sym:tasmsymbol);
       begin
          inherited Create;
@@ -1631,11 +1646,23 @@ implementation
          inherited Create;
          typ:=ait_const;
 {$ifdef i8086}
-         if current_settings.x86memorymodel in x86_far_code_models then
-           consttype:=aitconst_farptr
+         if assigned(_sym) and (_sym.typ=AT_DATA) then
+           begin
+             if current_settings.x86memorymodel in x86_far_data_models then
+               consttype:=aitconst_farptr
+             else
+               consttype:=aitconst_ptr;
+           end
          else
+           begin
+             if current_settings.x86memorymodel in x86_far_code_models then
+               consttype:=aitconst_farptr
+             else
+               consttype:=aitconst_ptr;
+           end;
+{$else i8086}
+         consttype:=aitconst_ptr;
 {$endif i8086}
-           consttype:=aitconst_ptr;
          { sym is allowed to be nil, this is used to write nil pointers }
          sym:=_sym;
          endsym:=nil;
@@ -1671,6 +1698,47 @@ implementation
       end;
 
 
+    constructor tai_const.Create_type_name(_typ:taiconst_type;const name:string;ofs:aint);
+      begin
+         self.create_sym_offset(current_asmdata.RefAsmSymbol(name),ofs);
+         consttype:=_typ;
+      end;
+
+
+    constructor tai_const.Create_nil_codeptr;
+      begin
+        inherited Create;
+        typ:=ait_const;
+{$ifdef i8086}
+        if current_settings.x86memorymodel in x86_far_code_models then
+          consttype:=aitconst_farptr
+        else
+{$endif i8086}
+          consttype:=aitconst_ptr;
+        sym:=nil;
+        endsym:=nil;
+        symofs:=0;
+        value:=0;
+      end;
+
+
+    constructor tai_const.Create_nil_dataptr;
+      begin
+        inherited Create;
+        typ:=ait_const;
+{$ifdef i8086}
+        if current_settings.x86memorymodel in x86_far_data_models then
+          consttype:=aitconst_farptr
+        else
+{$endif i8086}
+          consttype:=aitconst_ptr;
+        sym:=nil;
+        endsym:=nil;
+        symofs:=0;
+        value:=0;
+      end;
+
+
     constructor tai_const.ppuload(t:taitype;ppufile:tcompilerppufile);
       begin
         inherited ppuload(t,ppufile);

compiler/aoptbase.pas

@@ -171,11 +171,11 @@ unit aoptbase;
       Current := tai(Current.Next);
       While Assigned(Current) And
             ((Current.typ In SkipInstr) or
-{$ifdef SPARC}
+{$if defined(SPARC) or defined(MIPS)}
              ((Current.typ=ait_instruction) and
               (taicpu(Current).opcode=A_NOP)
              ) or
-{$endif SPARC}
+{$endif SPARC or MIPS}
              ((Current.typ = ait_label) And
               labelCanBeSkipped(Tai_Label(Current)))) Do
         Current := tai(Current.Next);

compiler/aoptobj.pas

@@ -344,6 +344,18 @@ Unit AoptObj;
       verbose,
       procinfo;
 
+
+    function JumpTargetOp(ai: taicpu): poper; inline;
+      begin
+{$ifdef MIPS}
+        { MIPS branches can have 1,2 or 3 operands, target label is the last one. }
+        result:=ai.oper[ai.ops-1];
+{$else MIPS}
+        result:=ai.oper[0];
+{$endif MIPS}
+      end;
+
+
       { ************************************************************************* }
       { ******************************** TUsedRegs ****************************** }
       { ************************************************************************* }
@@ -1126,8 +1138,8 @@ Unit AoptObj;
 {$ifdef arm}
           (hp.condition=c_None) and
 {$endif arm}
-          (hp.oper[0]^.typ = top_ref) and
-          (hp.oper[0]^.ref^.symbol is TAsmLabel);
+          (JumpTargetOp(hp)^.typ = top_ref) and
+          (JumpTargetOp(hp)^.ref^.symbol is TAsmLabel);
       end;
 
 
@@ -1151,7 +1163,7 @@ Unit AoptObj;
         GetfinalDestination := false;
         if level > 20 then
           exit;
-        p1 := getlabelwithsym(tasmlabel(hp.oper[0]^.ref^.symbol));
+        p1 := getlabelwithsym(tasmlabel(JumpTargetOp(hp)^.ref^.symbol));
         if assigned(p1) then
           begin
             SkipLabels(p1,p1);
@@ -1159,8 +1171,12 @@ Unit AoptObj;
                (taicpu(p1).is_jmp) then
               if { the next instruction after the label where the jump hp arrives}
                  { is unconditional or of the same type as hp, so continue       }
-                 (IsJumpToLabel(taicpu(p1)) or
-                  conditions_equal(taicpu(p1).condition,hp.condition)) or
+                 IsJumpToLabel(taicpu(p1))
+{$ifndef MIPS}
+{ for MIPS, it isn't enough to check the condition; first operands must be same, too. }
+                 or
+                 conditions_equal(taicpu(p1).condition,hp.condition) or
+
                  { the next instruction after the label where the jump hp arrives
                    is the opposite of hp (so this one is never taken), but after
                    that one there is a branch that will be taken, so perform a
@@ -1172,18 +1188,21 @@ Unit AoptObj;
                   (taicpu(p2).is_jmp) and
                    (IsJumpToLabel(taicpu(p2)) or
                    (conditions_equal(taicpu(p2).condition,hp.condition))) and
-                  SkipLabels(p1,p1)) then
+                  SkipLabels(p1,p1))
+{$endif MIPS}
+                 then
                 begin
                   { quick check for loops of the form "l5: ; jmp l5 }
-                  if (tasmlabel(taicpu(p1).oper[0]^.ref^.symbol).labelnr =
-                       tasmlabel(hp.oper[0]^.ref^.symbol).labelnr) then
+                  if (tasmlabel(JumpTargetOp(taicpu(p1))^.ref^.symbol).labelnr =
+                       tasmlabel(JumpTargetOp(hp)^.ref^.symbol).labelnr) then
                     exit;
                   if not GetFinalDestination(taicpu(p1),succ(level)) then
                     exit;
-                  tasmlabel(hp.oper[0]^.ref^.symbol).decrefs;
-                  hp.oper[0]^.ref^.symbol:=taicpu(p1).oper[0]^.ref^.symbol;
-                  tasmlabel(hp.oper[0]^.ref^.symbol).increfs;
+                  tasmlabel(JumpTargetOp(hp)^.ref^.symbol).decrefs;
+                  JumpTargetOp(hp)^.ref^.symbol:=JumpTargetOp(taicpu(p1))^.ref^.symbol;
+                  tasmlabel(JumpTargetOp(hp)^.ref^.symbol).increfs;
                 end
+{$ifndef MIPS}
               else
                 if conditions_equal(taicpu(p1).condition,inverse_cond(hp.condition)) then
                   if not FindAnyLabel(p1,l) then
@@ -1194,8 +1213,8 @@ Unit AoptObj;
       {$endif finaldestdebug}
                       current_asmdata.getjumplabel(l);
                       insertllitem(p1,p1.next,tai_label.Create(l));
-                      tasmlabel(taicpu(hp).oper[0]^.ref^.symbol).decrefs;
-                      hp.oper[0]^.ref^.symbol := l;
+                      tasmlabel(JumpTargetOp(hp)^.ref^.symbol).decrefs;
+                      JumpTargetOp(hp)^.ref^.symbol := l;
                       l.increfs;
       {               this won't work, since the new label isn't in the labeltable }
       {               so it will fail the rangecheck. Labeltable should become a   }
@@ -1209,11 +1228,12 @@ Unit AoptObj;
                         strpnew('next label reused'))));
       {$endif finaldestdebug}
                       l.increfs;
-                      tasmlabel(hp.oper[0]^.ref^.symbol).decrefs;
-                      hp.oper[0]^.ref^.symbol := l;
+                      tasmlabel(JumpTargetOp(hp)^.ref^.symbol).decrefs;
+                      JumpTargetOp(hp)^.ref^.symbol := l;
                       if not GetFinalDestination(hp,succ(level)) then
                         exit;
                     end;
+{$endif not MIPS}
           end;
         GetFinalDestination := true;
       end;
@@ -1263,9 +1283,9 @@ Unit AoptObj;
                               begin
                                 if (hp1.typ = ait_instruction) and
                                    taicpu(hp1).is_jmp and
-                                   (taicpu(hp1).oper[0]^.typ = top_ref) and
-                                   (taicpu(hp1).oper[0]^.ref^.symbol is TAsmLabel) then
-                                   TAsmLabel(taicpu(hp1).oper[0]^.ref^.symbol).decrefs;
+                                   (JumpTargetOp(taicpu(hp1))^.typ = top_ref) and
+                                   (JumpTargetOp(taicpu(hp1))^.ref^.symbol is TAsmLabel) then
+                                   TAsmLabel(JumpTargetOp(taicpu(hp1))^.ref^.symbol).decrefs;
                                 { don't kill start/end of assembler block,
                                   no-line-info-start/end etc }
                                 if hp1.typ<>ait_marker then
@@ -1281,13 +1301,18 @@ Unit AoptObj;
                       { remove jumps to a label coming right after them }
                       if GetNextInstruction(p, hp1) then
                         begin
-                          if FindLabel(tasmlabel(taicpu(p).oper[0]^.ref^.symbol), hp1) and
+                          if FindLabel(tasmlabel(JumpTargetOp(taicpu(p))^.ref^.symbol), hp1) and
         { TODO: FIXME removing the first instruction fails}
                               (p<>blockstart) then
                             begin
+                              tasmlabel(JumpTargetOp(taicpu(p))^.ref^.symbol).decrefs;
+{$if defined(SPARC) or defined(MIPS)}
+                              hp2:=tai(p.next);
+                              asml.remove(hp2);
+                              hp2.free;
+{$endif SPARC or MIPS}
                               hp2:=tai(hp1.next);
                               asml.remove(p);
-                              tasmlabel(taicpu(p).oper[0]^.ref^.symbol).decrefs;
                               p.free;
                               p:=hp2;
                               continue;
@@ -1299,7 +1324,7 @@ Unit AoptObj;
                               if (tai(hp1).typ=ait_instruction) and
                                   IsJumpToLabel(taicpu(hp1)) and
                                   GetNextInstruction(hp1, hp2) and
-                                  FindLabel(tasmlabel(taicpu(p).oper[0]^.ref^.symbol), hp2) then
+                                  FindLabel(tasmlabel(JumpTargetOp(taicpu(p))^.ref^.symbol), hp2) then
                                 begin
                                   if (taicpu(p).opcode=aopt_condjmp)
 {$ifdef arm}
@@ -1309,17 +1334,27 @@ Unit AoptObj;
                                     begin
                                       taicpu(p).condition:=inverse_cond(taicpu(p).condition);
                                       tai_label(hp2).labsym.decrefs;
-                                      taicpu(p).oper[0]^.ref^.symbol:=taicpu(hp1).oper[0]^.ref^.symbol;
+                                      JumpTargetOp(taicpu(p))^.ref^.symbol:=JumpTargetOp(taicpu(hp1))^.ref^.symbol;
                                       { when freeing hp1, the reference count
                                         isn't decreased, so don't increase
 
                                        taicpu(p).oper[0]^.ref^.symbol.increfs;
                                       }
-{$ifdef SPARC}
+{$if defined(SPARC) or defined(MIPS)}
+                                      { Remove delay slot. Initially is is placed immediately after
+                                        branch, but RA can insert regallocs in between. }
                                       hp2:=tai(hp1.next);
-                                      asml.remove(hp2);
-                                      hp2.free;
-{$endif SPARC}
+                                      while assigned(hp2) and (hp2.typ in SkipInstr) do
+                                        hp2:=tai(hp2.next);
+                                      if assigned(hp2) and (hp2.typ=ait_instruction) and
+                                         (taicpu(hp2).opcode=A_NOP) then
+                                        begin
+                                          asml.remove(hp2);
+                                          hp2.free;
+                                        end
+                                      else
+                                        InternalError(2013070301);
+{$endif SPARC or MIPS}
                                       asml.remove(hp1);
                                       hp1.free;
                                       GetFinalDestination(taicpu(p),0);

compiler/arm/aoptcpu.pas

@@ -420,7 +420,8 @@ Implementation
     var
       hp1: tai;
     begin
-      if (p.ops=3) and
+      if (current_settings.cputype in cpu_arm) and
+        (p.ops=3) and
         MatchOperand(p.oper[0]^, p.oper[1]^.reg) and
         GetNextInstructionUsingReg(p, hp1, p.oper[0]^.reg) and
         (not RegModifiedBetween(p.oper[0]^.reg, p, hp1)) and
@@ -499,7 +500,7 @@ Implementation
         { don't apply the optimization if the (new) index register is loaded }
         (p.oper[0]^.reg<>taicpu(hp1).oper[2]^.reg) and
         not(RegModifiedBetween(taicpu(hp1).oper[2]^.reg,p,hp1)) and
-        not(current_settings.cputype in cpu_thumb) then
+        (current_settings.cputype in cpu_arm) then
         begin
           DebugMsg('Peephole Str/LdrAdd/Sub2Str/Ldr Postindex done', p);
           p.oper[1]^.ref^.addressmode:=AM_POSTINDEXED;

compiler/arm/raarmgas.pas

@@ -718,6 +718,68 @@ Unit raarmgas;
               end;
           end;
 
+
+        procedure BuildDirectRef;
+
+          function GetConstLabel(const symname: string; ofs: aint): TAsmLabel;
+            var
+              hp: tai;
+              newconst: tai_const;
+              lab: TAsmLabel;
+            begin
+              if symname<>'' then
+                newconst:=tai_const.Createname(symname,ofs)
+              else
+                newconst:=tai_const.Create_32bit(ofs);
+
+              hp:=tai(current_procinfo.aktlocaldata.First);
+              while assigned(hp) do
+                begin
+                  if hp.typ=ait_const then
+                    begin
+                      if (tai_const(hp).sym=newconst.sym) and
+                         (tai_const(hp).value=newconst.value) and
+                         assigned(hp.Previous) and
+                         (tai(hp.previous).typ=ait_label) then
+                        begin
+                          newconst.Free;
+                          result:=tai_label(hp.Previous).labsym;
+                          exit;
+                        end;
+                    end;
+
+                  hp:=tai(hp.Next);
+                end;
+
+              current_asmdata.getjumplabel(lab);
+              current_procinfo.aktlocaldata.concat(tai_align.create(4));
+              current_procinfo.aktlocaldata.concat(tai_label.create(lab));
+              current_procinfo.aktlocaldata.concat(newconst);
+              result:=lab;
+            end;
+
+          var
+            symtype: TAsmsymtype;
+            sym: string;
+            val: aint;
+          begin
+            case actasmtoken of
+              AS_INTNUM,
+              AS_ID:
+                begin
+                  BuildConstSymbolExpression(true,false,false,val,sym,symtype);
+
+                  if symtype=AT_NONE then
+                    sym:='';
+
+                  reference_reset(oper.opr.ref,4);
+                  oper.opr.ref.base:=NR_PC;
+                  oper.opr.ref.symbol:=GetConstLabel(sym,val);
+                end;
+            end;
+          end;
+
+
       var
         tempreg : tregister;
         ireg : tsuperregister;
@@ -741,6 +803,21 @@ Unit raarmgas;
               BuildConstantOperand(oper);
             end;
 
+          AS_EQUAL:
+            begin
+              case actopcode of
+                A_LDRBT,A_LDRB,A_LDR,A_LDRH,A_LDRSB,A_LDRSH,A_LDRT,
+                A_LDREX,A_LDREXB,A_LDREXD,A_LDREXH:
+                  begin
+                    consume(AS_EQUAL);
+                    oper.InitRef;
+                    BuildDirectRef;
+                  end;
+              else
+                Message(asmr_e_invalid_opcode_and_operand);
+              end;
+            end;
+
           (*
           AS_INTNUM,
           AS_MINUS,

compiler/constexp.pas

@@ -189,6 +189,10 @@ try_qword:
   result.overflow:=true;
 end;
 
+{ workaround for 2.6.x bug }
+{$ifdef VER2_6}
+    {$push} {$Q-}
+{$endif VER2_6}
 function sub_from(const a:Tconstexprint;b:qword):Tconstexprint;
 
 const abs_low_int64=qword(9223372036854775808);   {abs(low(int64)) -> overflow error}
@@ -231,6 +235,10 @@ try_qword:
 ov:
   result.overflow:=true;
 end;
+{ workaround for 2.6.x bug }
+{$ifdef VER2_6}
+    {$pop}
+{$endif VER2_6}
 
 operator + (const a,b:Tconstexprint):Tconstexprint;
 

compiler/dbgdwarf.pas

@@ -2383,7 +2383,7 @@ implementation
                     else
                       begin
                         templist.concat(tai_const.create_8bit(ord(DW_OP_addr)));
-                        templist.concat(tai_const.createname(sym.mangledname,offset));
+                        templist.concat(tai_const.Create_type_name(offsetabstype,sym.mangledname,offset));
                         blocksize:=1+sizeof(puint);
                       end;
                   end;
@@ -2666,7 +2666,7 @@ implementation
                 begin
                   AddConstToAbbrev(ord(DW_FORM_block));
                   current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_uleb128bit(sym.value.len+sizeof(pint)));
-                  current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_pint(sym.value.len));
+                  current_asmdata.asmlists[al_dwarf_info].concat(tai_const.create_pint_unaligned(sym.value.len));
                 end;
               i:=0;
               size:=sym.value.len;
@@ -2838,13 +2838,13 @@ implementation
                  end;
                *)
                templist.concat(tai_const.create_8bit(3));
-               templist.concat(tai_const.create_pint(sym.addroffset));
+               templist.concat(tai_const.create_pint_unaligned(sym.addroffset));
                blocksize:=1+sizeof(puint);
             end;
           toasm :
             begin
               templist.concat(tai_const.create_8bit(3));
-              templist.concat(tai_const.createname(sym.mangledname,0));
+              templist.concat(tai_const.create_type_name(offsetabstype,sym.mangledname,0));
               blocksize:=1+sizeof(puint);
             end;
           tovar:

compiler/defcmp.pas

@@ -659,15 +659,17 @@ implementation
                           if is_pchar(def_from) then
                            begin
                              doconv:=tc_pchar_2_string;
-                             { prefer ansistrings because pchars can overflow shortstrings, }
-                             { but only if ansistrings are the default (JM)                 }
-                             if (is_shortstring(def_to) and
-                                 not(cs_refcountedstrings in current_settings.localswitches)) or
-                                (is_ansistring(def_to) and
-                                 (cs_refcountedstrings in current_settings.localswitches)) then
-                               eq:=te_convert_l1
+                             { prefer ansistrings/unicodestrings because pchars
+                               can overflow shortstrings; don't use l1/l2/l3
+                               because then pchar -> ansistring has the same
+                               preference as conststring -> pchar, and this
+                               breaks webtbs/tw3328.pp }
+                             if is_ansistring(def_to) then
+                               eq:=te_convert_l2
+                             else if is_wide_or_unicode_string(def_to) then
+                               eq:=te_convert_l3
                              else
-                               eq:=te_convert_l2;
+                              eq:=te_convert_l4
                            end
                           else if is_pwidechar(def_from) then
                            begin
@@ -675,6 +677,8 @@ implementation
                              if is_wide_or_unicode_string(def_to) then
                                eq:=te_convert_l1
                              else
+                               { shortstring and ansistring can both result in
+                                 data loss, so don't prefer one over the other }
                                eq:=te_convert_l3;
                            end;
                        end;

compiler/fpcdefs.inc

@@ -58,6 +58,7 @@
   { TODO: add another define in order to disable the div helper for 16-bit divs? }
   {$define cpuneedsdiv32helper}
   {$define VOLATILE_ES}
+  {$define SUPPORT_GET_FRAME}
 {$endif i8086}
 
 {$ifdef i386}
@@ -72,6 +73,7 @@
   {$define fewintregisters}
   {$define cpurox}
   {$define SUPPORT_SAFECALL}
+  {$define SUPPORT_GET_FRAME}
 {$endif i386}
 
 {$ifdef x86_64}
@@ -86,6 +88,7 @@
   {$define cpurox}
   {$define cpurefshaveindexreg}
   {$define SUPPORT_SAFECALL}
+  {$define SUPPORT_GET_FRAME}
 {$endif x86_64}
 
 {$ifdef ia64}
@@ -146,6 +149,7 @@
   {$define cputargethasfixedstack}
   {$define cpurefshaveindexreg}
   {$define SUPPORT_SAFECALL}
+  {$define SUPPORT_GET_FRAME}
   { default to armel }
   {$if not(defined(CPUARM)) and not(defined(CPUARMEB)) and not(defined(FPC_OARM)) and not(defined(FPC_ARMEB)) and not(defined(FPC_ARMHF))}
     {$define FPC_ARMEL}
@@ -207,7 +211,7 @@
   {$else}
     {$error mips64 not yet supported}
   {$endif}
-  { define cpuflags}
+  {$define cpuflags} { Flags are emulated }
   {$define cputargethasfixedstack}
   {$define cpurequiresproperalignment}
   { define cpumm}
@@ -221,6 +225,7 @@
   {$define cpu32bitaddr}
   {$define cpuhighleveltarget}
   {$define symansistr}
+  {$define SUPPORT_GET_FRAME}
 {$endif}
 
 {$ifdef aarch64}

compiler/i386/cgcpu.pas

@@ -293,6 +293,16 @@ unit cgcpu;
 
 
     procedure tcg386.g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);
+
+      procedure increase_fp(a : tcgint);
+        var
+          href : treference;
+        begin
+          reference_reset_base(href,current_procinfo.framepointer,a,0);
+          { normally, lea is a better choice than an add }
+          list.concat(Taicpu.op_ref_reg(A_LEA,TCGSize2OpSize[OS_ADDR],href,current_procinfo.framepointer));
+        end;
+
       var
         stacksize : longint;
       begin
@@ -304,7 +314,7 @@ unit cgcpu;
         { remove stackframe }
         if not nostackframe then
           begin
-            if (current_procinfo.framepointer=NR_STACK_POINTER_REG) then
+            if current_procinfo.framepointer=NR_STACK_POINTER_REG then
               begin
                 stacksize:=current_procinfo.calc_stackframe_size;
                 if (target_info.stackalign>4) and
@@ -314,8 +324,8 @@ unit cgcpu;
                     { if you (think you) know what you are doing              }
                     (po_assembler in current_procinfo.procdef.procoptions)) then
                   stacksize := align(stacksize+sizeof(aint),target_info.stackalign) - sizeof(aint);
-                if (stacksize<>0) then
-                  cg.a_op_const_reg(list,OP_ADD,OS_ADDR,stacksize,current_procinfo.framepointer);
+                if stacksize<>0 then
+                  increase_fp(stacksize);
               end
             else
               list.concat(Taicpu.op_none(A_LEAVE,S_NO));

compiler/i386/n386set.pas

@@ -38,16 +38,7 @@ interface
 implementation
 
     uses
-      systems,
-      verbose,globals,constexp,
-      symconst,symdef,defutil,
-      aasmbase,aasmtai,aasmdata,aasmcpu,
-      cgbase,pass_2,
-      ncon,
-      cpubase,cpuinfo,procinfo,
-      cga,cgutils,cgobj,ncgutil,
-      cgx86;
-
+      globals,cpuinfo;
 
 {*****************************************************************************
                             TI386CASENODE
@@ -60,10 +51,11 @@ implementation
           inc(max_linear_list,3)
         else if current_settings.optimizecputype=cpu_Pentium then
           inc(max_linear_list,6)
-        else if current_settings.optimizecputype in [cpu_Pentium2,cpu_Pentium3] then
-          inc(max_linear_list,9)
         else if current_settings.optimizecputype=cpu_Pentium4 then
-          inc(max_linear_list,14);
+          inc(max_linear_list,14)
+        else
+        { default, also fine for cpu_Pentium2, cpu_Pentium3, cpu_PentiumM }
+          inc(max_linear_list,9);
       end;
 
 

compiler/i386/popt386.pas

@@ -41,7 +41,8 @@ uses
 {$ifdef finaldestdebug}
   cobjects,
 {$endif finaldestdebug}
-  cpuinfo,cpubase,cgutils,daopt386;
+  cpuinfo,cpubase,cgutils,daopt386,
+  cgx86;
 
 
 function isFoldableArithOp(hp1: taicpu; reg: tregister): boolean;
@@ -960,13 +961,13 @@ begin
                             if (base = taicpu(p).oper[1]^.reg) then
                               begin
                                 l := offset;
-                                if (l=1) then
+                                if (l=1) and UseIncDec then
                                   begin
                                     taicpu(p).opcode := A_INC;
                                     taicpu(p).loadreg(0,taicpu(p).oper[1]^.reg);
                                     taicpu(p).ops := 1
                                   end
-                                else if (l=-1) then
+                                else if (l=-1) and UseIncDec then
                                   begin
                                     taicpu(p).opcode := A_DEC;
                                     taicpu(p).loadreg(0,taicpu(p).oper[1]^.reg);
@@ -2121,6 +2122,8 @@ begin
               end;
             case taicpu(p).opcode Of
               A_CALL:
+                { don't do this on modern CPUs, this really hurts them due to
+                  broken call/ret pairing }
                 if (current_settings.optimizecputype < cpu_Pentium2) and
                    not(cs_create_pic in current_settings.moduleswitches) and
                    GetNextInstruction(p, hp1) and

compiler/i8086/cpupara.pas

@@ -204,8 +204,7 @@ unit cpupara;
           pocall_stdcall,
           pocall_cdecl,
           pocall_cppdecl,
-          pocall_mwpascal :
-            result:=[RS_AX,RS_DX,RS_CX];
+          pocall_mwpascal,
           pocall_far16,
           pocall_pascal,
           pocall_oldfpccall :

compiler/i8086/hlcgcpu.pas

@@ -29,6 +29,7 @@ unit hlcgcpu;
 interface
 
   uses
+    globals,
     aasmdata,
     symtype,symdef,parabase,
     cgbase,cgutils,
@@ -42,6 +43,8 @@ interface
      public
       procedure g_copyvaluepara_openarray(list: TAsmList; const ref: treference; const lenloc: tlocation; arrdef: tarraydef; destreg: tregister); override;
       procedure g_releasevaluepara_openarray(list: TAsmList; arrdef: tarraydef; const l: tlocation); override;
+
+      procedure location_force_mem(list:TAsmList;var l:tlocation;size:tdef);override;
     end;
 
   procedure create_hlcodegen;
@@ -51,7 +54,8 @@ implementation
   uses
     globtype,verbose,
     paramgr,
-    cpubase,tgobj,cgobj,cgcpu;
+    cpubase,cpuinfo,tgobj,cgobj,cgcpu,
+    symconst;
 
   { thlcgcpu }
 
@@ -192,6 +196,39 @@ implementation
     end;
 
 
+  procedure thlcgcpu.location_force_mem(list: TAsmList; var l: tlocation; size: tdef);
+    var
+      r,tmpref: treference;
+    begin
+      { handle i8086 6-byte (mixed near + far) method pointers }
+      if (size.typ=procvardef) and (size.size=6) and (l.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+        begin
+          tg.gethltemp(list,size,size.size,tt_normal,r);
+          tmpref:=r;
+
+          if po_far in tprocvardef(size).procoptions then
+            begin
+              cg.a_load_reg_ref(list,OS_32,OS_32,l.register,tmpref);
+              inc(tmpref.offset,4);
+            end
+          else
+            begin
+              cg.a_load_reg_ref(list,OS_16,OS_16,l.register,tmpref);
+              inc(tmpref.offset,2);
+            end;
+          if current_settings.x86memorymodel in x86_far_data_models then
+            cg.a_load_reg_ref(list,OS_32,OS_32,l.registerhi,tmpref)
+          else
+            cg.a_load_reg_ref(list,OS_16,OS_16,l.registerhi,tmpref);
+
+          location_reset_ref(l,LOC_REFERENCE,l.size,0);
+          l.reference:=r;
+        end
+      else
+        inherited;
+    end;
+
+
   procedure create_hlcodegen;
     begin
       hlcg:=thlcgcpu.create;

compiler/i8086/n8086add.pas

@@ -583,7 +583,7 @@ interface
 
     procedure ti8086addnode.second_cmpordinal;
       begin
-        if is_32bit(left.resultdef) then
+        if is_32bit(left.resultdef) or is_farpointer(left.resultdef) or is_hugepointer(left.resultdef) then
           second_cmp32bit
         else
           inherited second_cmpordinal;

compiler/i8086/n8086cnv.pas

@@ -32,6 +32,7 @@ interface
        t8086typeconvnode = class(tx86typeconvnode)
        protected
          procedure second_proc_to_procvar;override;
+         procedure second_nil_to_methodprocvar;override;
        end;
 
 
@@ -131,6 +132,32 @@ implementation
       end;
 
 
+    procedure t8086typeconvnode.second_nil_to_methodprocvar;
+      begin
+        location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+        if current_settings.x86memorymodel in x86_far_data_models then
+          begin
+            location.registerhi:=cg.getintregister(current_asmdata.currasmlist,OS_32);
+            cg.a_load_const_reg(current_asmdata.currasmlist,OS_32,0,location.registerhi);
+          end
+        else
+          begin
+            location.registerhi:=cg.getaddressregister(current_asmdata.currasmlist);
+            cg.a_load_const_reg(current_asmdata.currasmlist,OS_ADDR,0,location.registerhi);
+          end;
+        if (resultdef.typ=procvardef) and (po_far in tprocvardef(resultdef).procoptions) then
+          begin
+            location.register:=cg.getintregister(current_asmdata.currasmlist,OS_32);
+            cg.a_load_const_reg(current_asmdata.currasmlist,OS_32,0,location.register);
+          end
+        else
+          begin
+            location.register:=cg.getaddressregister(current_asmdata.currasmlist);
+            cg.a_load_const_reg(current_asmdata.currasmlist,OS_ADDR,0,location.register);
+          end;
+      end;
+
+
 begin
   ctypeconvnode:=t8086typeconvnode
 end.

compiler/jvm/njvmcal.pas

@@ -124,7 +124,7 @@ implementation
                 begin
                   parent:=tunarynode(p);
                   { skip typeconversions that don't change the node type }
-                  p:=p.actualtargetnode;
+                  p:=actualtargetnode(@p)^;
                 end;
               derefn:
                 begin
@@ -239,8 +239,8 @@ implementation
           local variables (fields, arrays etc are all initialized on creation) }
         verifyout:=
           (cs_check_var_copyout in current_settings.localswitches) and
-          ((left.actualtargetnode.nodetype<>loadn) or
-           (tloadnode(left.actualtargetnode).symtableentry.typ<>localvarsym));
+          ((actualtargetnode(@left)^.nodetype<>loadn) or
+           (tloadnode(actualtargetnode(@left)^).symtableentry.typ<>localvarsym));
 
         { in case of a non-out parameter, pass in the original value (also
           always in case of implicitpointer type, since that pointer points to

compiler/jvm/njvmld.pas

@@ -62,7 +62,7 @@ implementation
 
 uses
   verbose,globals,
-  nbas,nld,ncal,ncon,ninl,nmem,ncnv,
+  nbas,nld,ncal,ncon,ninl,nmem,ncnv,nutils,
   symconst,symsym,symdef,symtable,defutil,jvmdef,
   paramgr,
   pass_1,
@@ -100,7 +100,7 @@ function tjvmassignmentnode.pass_1: tnode;
     { intercept writes to string elements, because Java strings are immutable
       -> detour via StringBuilder
     }
-    target:=left.actualtargetnode;
+    target:=actualtargetnode(@left)^;
     if (target.nodetype=vecn) and
        (is_wide_or_unicode_string(tvecnode(target).left.resultdef) or
         is_ansistring(tvecnode(target).left.resultdef)) then

compiler/jvm/njvmmem.pas

@@ -63,7 +63,8 @@ implementation
       aasmbase,
       symconst,symtype,symtable,symsym,symdef,defutil,jvmdef,
       htypechk,paramgr,
-      nadd,ncal,ncnv,ncon,nld,pass_1,njvmcon,
+      nadd,ncal,ncnv,ncon,nld,nutils,
+      pass_1,njvmcon,
       aasmdata,aasmcpu,pass_2,
       cgutils,hlcgobj,hlcgcpu;
 
@@ -151,7 +152,7 @@ implementation
       var
         target: tnode;
       begin
-        target:=left.actualtargetnode;
+        target:=actualtargetnode(@left)^;
         result:=
           (left.nodetype=derefn);
       end;

compiler/mips/aasmcpu.pas

@@ -56,6 +56,8 @@ type
 
     constructor op_reg_reg_ref(op: tasmop; _op1, _op2: tregister; const _op3: treference);
     constructor op_reg_reg_const(op: tasmop; _op1, _op2: tregister; _op3: aint);
+    { INS and EXT }
+    constructor op_reg_reg_const_const(op: tasmop; _op1,_op2: tregister; _op3,_op4: aint);
     constructor op_reg_const_reg(op: tasmop; _op1: tregister; _op2: aint; _op3: tregister);
 
     { this is for Jmp instructions }
@@ -186,6 +188,17 @@ begin
 end;
 
 
+constructor taicpu.op_reg_reg_const_const(op: tasmop; _op1, _op2: tregister; _op3, _op4: aint);
+begin
+  inherited create(op);
+  ops := 4;
+  loadreg(0, _op1);
+  loadreg(1, _op2);
+  loadconst(2, _op3);
+  loadconst(3, _op4);
+end;
+
+
 constructor taicpu.op_reg_const_reg(op: tasmop; _op1: tregister; _op2: aint;
  _op3: tregister);
 begin
@@ -316,18 +329,6 @@ end;
       A_DMULTU,
       A_MFHI,
       A_MFLO,
-      A_MULTG,
-      A_DMULTG,
-      A_MULTUG,
-      A_DMULTUG,
-      A_DIVG,
-      A_DDIVG,
-      A_DIVUG,
-      A_DDIVUG,
-      A_MODG,
-      A_DMODG,
-      A_MODUG,
-      A_DMODUG,
 
       A_SLL,
       A_SRL,
@@ -397,7 +398,10 @@ end;
       A_SGTU,
       A_SLE,
       A_SLEU,
-      A_SNE];
+      A_SNE,
+      A_EXT,
+      A_INS,
+      A_MFC0];
 
       begin
         result := operand_read;

compiler/mips/aoptcpu.pas

@@ -28,14 +28,179 @@ unit aoptcpu;
   Interface
 
     uses
-      cpubase, aoptobj, aoptcpub, aopt;
+      cgbase, cpubase, aoptobj, aoptcpub, aopt, aasmtai;
 
     Type
       TCpuAsmOptimizer = class(TAsmOptimizer)
+        function TryRemoveMov(var p: tai): boolean;
+        function PeepHoleOptPass1Cpu(var p: tai): boolean; override;
       End;
 
   Implementation
 
+     uses
+       aasmcpu;
+
+
+  function MatchInstruction(const instr: tai; const op: TAsmOp): boolean;
+    begin
+      result :=
+        (instr.typ = ait_instruction) and
+        (taicpu(instr).opcode = op);
+    end;
+
+
+  function MatchOperand(const oper: TOper; reg: TRegister): boolean;
+    begin
+      result:=(oper.typ=top_reg) and (oper.reg=reg);
+    end;
+
+
+  function IsSameReg(this,next: taicpu): boolean;
+    begin
+      result:=(next.oper[0]^.typ=top_reg) and
+        (next.oper[1]^.typ=top_reg) and
+        (next.oper[0]^.reg=next.oper[1]^.reg) and
+        (next.oper[0]^.reg=this.oper[0]^.reg);
+    end;
+
+
+  function TCpuAsmOptimizer.TryRemoveMov(var p: tai): boolean;
+    var
+      next,hp1: tai;
+      alloc,dealloc: tai_regalloc;
+    begin
+      { Fold
+          op   $reg1,...
+          move $reg2,$reg1
+          dealloc $reg1
+        into
+          op   $reg2,...
+      }
+      result:=false;
+      if GetNextInstruction(p,next) and
+         MatchInstruction(next,A_MOVE) and
+         MatchOperand(taicpu(next).oper[1]^,taicpu(p).oper[0]^.reg) then
+        begin
+          dealloc:=FindRegDealloc(taicpu(p).oper[0]^.reg,tai(next.Next));
+          if assigned(dealloc) then
+            begin
+              { taicpu(p).oper[0]^.reg is not used anymore, try to find its allocation
+                and remove it if possible }
+              GetLastInstruction(p,hp1);
+
+              asml.Remove(dealloc);
+              alloc:=FindRegAlloc(taicpu(p).oper[0]^.reg,tai(hp1.Next));
+              if assigned(alloc) then
+                begin
+                  asml.Remove(alloc);
+                  alloc.free;
+                  dealloc.free;
+                end
+              else
+                asml.InsertAfter(dealloc,p);
+
+              { try to move the allocation of the target register }
+              GetLastInstruction(next,hp1);
+              alloc:=FindRegAlloc(taicpu(next).oper[0]^.reg,tai(hp1.Next));
+              if assigned(alloc) then
+                begin
+                  asml.Remove(alloc);
+                  asml.InsertBefore(alloc,p);
+                  { adjust used regs }
+                  IncludeRegInUsedRegs(taicpu(next).oper[0]^.reg,UsedRegs);
+                end;
+
+              { finally get rid of the mov }
+              taicpu(p).loadreg(0,taicpu(next).oper[0]^.reg);
+              asml.remove(next);
+              next.free;
+            end;
+        end;
+    end;
+
+
+  function TCpuAsmOptimizer.PeepHoleOptPass1Cpu(var p: tai): boolean;
+    var
+      next,next2: tai;
+    begin
+      result:=false;
+      case p.typ of
+        ait_instruction:
+          begin
+            case taicpu(p).opcode of
+              A_SRL:
+                begin
+                  { Remove 'andi' in sequences
+                      srl   Rx,Ry,16
+                      andi  Rx,Rx,65535
+
+                      srl   Rx,Ry,24
+                      andi  Rx,Rx,255
+                    since 'srl' clears all relevant upper bits }
+                  if (taicpu(p).oper[2]^.typ=top_const) and
+                    GetNextInstruction(p,next) and
+                    MatchInstruction(next,A_ANDI) and
+                    IsSameReg(taicpu(p),taicpu(next)) and
+                    (taicpu(next).oper[2]^.typ=top_const) and
+                    ((
+                      (taicpu(p).oper[2]^.val>=16) and
+                      (taicpu(next).oper[2]^.val=65535)
+                    ) or (
+                      (taicpu(p).oper[2]^.val>=24) and
+                      (taicpu(next).oper[2]^.val=255)
+                    )) then
+                    begin
+                      asml.remove(next);
+                      next.free;
+                    end
+                  else
+                    TryRemoveMov(p);
+                end;
+
+              A_ANDI:
+                begin
+                  { Remove sign extension after 'andi' if bit 7/15 of const operand is clear }
+                  if (taicpu(p).oper[2]^.typ=top_const) and
+                    GetNextInstruction(p,next) and
+                    MatchInstruction(next,A_SLL) and
+                    GetNextInstruction(next,next2) and
+                    MatchInstruction(next2,A_SRA) and
+                    IsSameReg(taicpu(p),taicpu(next)) and
+                    IsSameReg(taicpu(p),taicpu(next2)) and
+                    (taicpu(next).oper[2]^.typ=top_const) and
+                    (taicpu(next2).oper[2]^.typ=top_const) and
+                    (taicpu(next).oper[2]^.val=taicpu(next2).oper[2]^.val) and
+                    ((
+                      (taicpu(p).oper[2]^.val<=$7fff) and
+                      (taicpu(next).oper[2]^.val=16)
+                    ) or (
+                      (taicpu(p).oper[2]^.val<=$7f) and
+                      (taicpu(next).oper[2]^.val=24)
+                    )) then
+                    begin
+                      asml.remove(next);
+                      asml.remove(next2);
+                      next.free;
+                      next2.free;
+                    end
+                  else
+                    TryRemoveMov(p);
+                end;
+
+              A_ADD,A_ADDU,
+              A_ADDI,A_ADDIU,
+              A_SUB,A_SUBU,
+              A_SRA,A_SRAV,
+              A_SRLV,
+              A_SLL,A_SLLV,
+              A_AND,A_OR,A_XOR,A_ORI,A_XORI:
+                TryRemoveMov(p);
+            end;
+          end;
+      end;
+    end;
+
 begin
   casmoptimizer:=TCpuAsmOptimizer;
 end.

compiler/mips/cgcpu.pas

@@ -72,6 +72,8 @@ type
     { comparison operations }
     procedure a_cmp_const_reg_label(list: tasmlist; size: tcgsize; cmp_op: topcmp; a: tcgint; reg: tregister; l: tasmlabel); override;
     procedure a_cmp_reg_reg_label(list: tasmlist; size: tcgsize; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel); override;
+    procedure a_jmp_flags(list: tasmlist; const f: TResFlags; l: tasmlabel); override;
+    procedure g_flags2reg(list: tasmlist; size: TCgSize; const f: TResFlags; reg: tregister); override;
     procedure a_jmp_always(List: tasmlist; l: TAsmLabel); override;
     procedure a_jmp_name(list: tasmlist; const s: string); override;
     procedure g_overflowCheck(List: tasmlist; const Loc: TLocation; def: TDef); override;
@@ -120,145 +122,11 @@ uses
   procinfo, cpupi;
 
 
-  function f_TOpCG2AsmOp(op: TOpCG; size: tcgsize): TAsmOp;
-  begin
-    if size = OS_32 then
-      case op of
-        OP_ADD:       { simple addition          }
-          f_TOpCG2AsmOp := A_ADDU;
-        OP_AND:       { simple logical and       }
-          f_TOpCG2AsmOp := A_AND;
-        OP_DIV:       { simple unsigned division }
-          f_TOpCG2AsmOp := A_DIVU;
-        OP_IDIV:      { simple signed division   }
-          f_TOpCG2AsmOp := A_DIV;
-        OP_IMUL:      { simple signed multiply   }
-          f_TOpCG2AsmOp := A_MULT;
-        OP_MUL:       { simple unsigned multiply }
-          f_TOpCG2AsmOp := A_MULTU;
-        OP_NEG:       { simple negate            }
-          f_TOpCG2AsmOp := A_NEGU;
-        OP_NOT:       { simple logical not       }
-          f_TOpCG2AsmOp := A_NOT;
-        OP_OR:        { simple logical or        }
-          f_TOpCG2AsmOp := A_OR;
-        OP_SAR:       { arithmetic shift-right   }
-          f_TOpCG2AsmOp := A_SRA;
-        OP_SHL:       { logical shift left       }
-          f_TOpCG2AsmOp := A_SLL;
-        OP_SHR:       { logical shift right      }
-          f_TOpCG2AsmOp := A_SRL;
-        OP_SUB:       { simple subtraction       }
-          f_TOpCG2AsmOp := A_SUBU;
-        OP_XOR:       { simple exclusive or      }
-          f_TOpCG2AsmOp := A_XOR;
-        else
-          InternalError(2007070401);
-      end{ case }
-    else
-      case op of
-        OP_ADD:       { simple addition          }
-          f_TOpCG2AsmOp := A_ADDU;
-        OP_AND:       { simple logical and       }
-          f_TOpCG2AsmOp := A_AND;
-        OP_DIV:       { simple unsigned division }
-          f_TOpCG2AsmOp := A_DIVU;
-        OP_IDIV:      { simple signed division   }
-          f_TOpCG2AsmOp := A_DIV;
-        OP_IMUL:      { simple signed multiply   }
-          f_TOpCG2AsmOp := A_MULT;
-        OP_MUL:       { simple unsigned multiply }
-          f_TOpCG2AsmOp := A_MULTU;
-        OP_NEG:       { simple negate            }
-          f_TOpCG2AsmOp := A_NEGU;
-        OP_NOT:       { simple logical not       }
-          f_TOpCG2AsmOp := A_NOT;
-        OP_OR:        { simple logical or        }
-          f_TOpCG2AsmOp := A_OR;
-        OP_SAR:       { arithmetic shift-right   }
-          f_TOpCG2AsmOp := A_SRA;
-        OP_SHL:       { logical shift left       }
-          f_TOpCG2AsmOp := A_SLL;
-        OP_SHR:       { logical shift right      }
-          f_TOpCG2AsmOp := A_SRL;
-        OP_SUB:       { simple subtraction       }
-          f_TOpCG2AsmOp := A_SUBU;
-        OP_XOR:       { simple exclusive or      }
-          f_TOpCG2AsmOp := A_XOR;
-        else
-          InternalError(2007010701);
-      end;{ case }
-  end;
-
-  function f_TOpCG2AsmOp_ovf(op: TOpCG; size: tcgsize): TAsmOp;
-  begin
-    if size = OS_32 then
-      case op of
-        OP_ADD:       { simple addition          }
-          f_TOpCG2AsmOp_ovf := A_ADD;
-        OP_AND:       { simple logical and       }
-          f_TOpCG2AsmOp_ovf := A_AND;
-        OP_DIV:       { simple unsigned division }
-          f_TOpCG2AsmOp_ovf := A_DIVU;
-        OP_IDIV:      { simple signed division   }
-          f_TOpCG2AsmOp_ovf := A_DIV;
-        OP_IMUL:      { simple signed multiply   }
-          f_TOpCG2AsmOp_ovf := A_MULO;
-        OP_MUL:       { simple unsigned multiply }
-          f_TOpCG2AsmOp_ovf := A_MULOU;
-        OP_NEG:       { simple negate            }
-          f_TOpCG2AsmOp_ovf := A_NEG;
-        OP_NOT:       { simple logical not       }
-          f_TOpCG2AsmOp_ovf := A_NOT;
-        OP_OR:        { simple logical or        }
-          f_TOpCG2AsmOp_ovf := A_OR;
-        OP_SAR:       { arithmetic shift-right   }
-          f_TOpCG2AsmOp_ovf := A_SRA;
-        OP_SHL:       { logical shift left       }
-          f_TOpCG2AsmOp_ovf := A_SLL;
-        OP_SHR:       { logical shift right      }
-          f_TOpCG2AsmOp_ovf := A_SRL;
-        OP_SUB:       { simple subtraction       }
-          f_TOpCG2AsmOp_ovf := A_SUB;
-        OP_XOR:       { simple exclusive or      }
-          f_TOpCG2AsmOp_ovf := A_XOR;
-        else
-          InternalError(2007070403);
-      end{ case }
-    else
-      case op of
-        OP_ADD:       { simple addition          }
-          f_TOpCG2AsmOp_ovf := A_ADD;
-        OP_AND:       { simple logical and       }
-          f_TOpCG2AsmOp_ovf := A_AND;
-        OP_DIV:       { simple unsigned division }
-          f_TOpCG2AsmOp_ovf := A_DIVU;
-        OP_IDIV:      { simple signed division   }
-          f_TOpCG2AsmOp_ovf := A_DIV;
-        OP_IMUL:      { simple signed multiply   }
-          f_TOpCG2AsmOp_ovf := A_MULO;
-        OP_MUL:       { simple unsigned multiply }
-          f_TOpCG2AsmOp_ovf := A_MULOU;
-        OP_NEG:       { simple negate            }
-          f_TOpCG2AsmOp_ovf := A_NEG;
-        OP_NOT:       { simple logical not       }
-          f_TOpCG2AsmOp_ovf := A_NOT;
-        OP_OR:        { simple logical or        }
-          f_TOpCG2AsmOp_ovf := A_OR;
-        OP_SAR:       { arithmetic shift-right   }
-          f_TOpCG2AsmOp_ovf := A_SRA;
-        OP_SHL:       { logical shift left       }
-          f_TOpCG2AsmOp_ovf := A_SLL;
-        OP_SHR:       { logical shift right      }
-          f_TOpCG2AsmOp_ovf := A_SRL;
-        OP_SUB:       { simple subtraction       }
-          f_TOpCG2AsmOp_ovf := A_SUB;
-        OP_XOR:       { simple exclusive or      }
-          f_TOpCG2AsmOp_ovf := A_XOR;
-        else
-          InternalError(2007010703);
-      end;{ case }
-  end;
+const
+  TOpcg2AsmOp: array[TOpCg] of TAsmOp = (
+    A_NONE,A_NONE,A_ADDU,A_AND,A_NONE,A_NONE,A_MULT,A_MULTU,A_NONE,A_NONE,
+    A_OR,A_SRAV,A_SLLV,A_SRLV,A_SUBU,A_XOR,A_NONE,A_NONE
+  );
 
 
 procedure TCGMIPS.make_simple_ref(list: tasmlist; var ref: treference);
@@ -301,6 +169,8 @@ begin
       reference_reset_symbol(tmpref,ref.symbol,ref.offset,ref.alignment);
       if (cs_create_pic in current_settings.moduleswitches) then
         begin
+          if not (pi_needs_got in current_procinfo.flags) then
+            InternalError(2013060102);
           { For PIC global symbols offset must be handled separately.
             Otherwise (non-PIC or local symbols) offset can be encoded
             into relocation even if exceeds 16 bits. }
@@ -510,21 +380,16 @@ begin
       href.refaddr:=addr_low;
       list.concat(taicpu.op_reg_ref(A_ADDIU,NR_PIC_FUNC,href));
     end;
-  { JAL handled as macro provides delay slot and correct restoring of GP. }
-  { Doing it ourselves requires a fixup pass, because GP restore location
-    becomes known only in g_proc_entry, when all code is already generated. }
-
-  { GAS <2.21 is buggy, it doesn't add delay slot in noreorder mode. As a result,
-    the code will crash if dealing with stack frame size >32767 or if calling
-    into shared library.
-    This can be remedied by enabling instruction reordering, but then we also
-    have to emit .set macro/.set nomacro pair and exclude JAL from the
-    list of macro instructions (because noreorder is not allowed after nomacro) }
-  list.concat(taicpu.op_none(A_P_SET_MACRO));
-  list.concat(taicpu.op_none(A_P_SET_REORDER));
-  list.concat(taicpu.op_reg(A_JAL,NR_PIC_FUNC));
-  list.concat(taicpu.op_none(A_P_SET_NOREORDER));
-  list.concat(taicpu.op_none(A_P_SET_NOMACRO));
+  list.concat(taicpu.op_reg(A_JALR,NR_PIC_FUNC));
+  { Delay slot }
+  list.concat(taicpu.op_none(A_NOP));
+  { Restore GP if in PIC mode }
+  if (cs_create_pic in current_settings.moduleswitches) then
+    begin
+      if TMIPSProcinfo(current_procinfo).save_gp_ref.offset=0 then
+        InternalError(2013071001);
+      list.concat(taicpu.op_reg_ref(A_LW,NR_GP,TMIPSProcinfo(current_procinfo).save_gp_ref));
+    end;
 end;
 
 
@@ -557,22 +422,18 @@ begin
   if assigned(current_procinfo) and
      not (pi_do_call in current_procinfo.flags) then
     InternalError(2013022102);
-  // if (cs_create_pic in current_settings.moduleswitches) then
-    begin
-      if (Reg <> NR_PIC_FUNC) then
-        list.concat(taicpu.op_reg_reg(A_MOVE,NR_PIC_FUNC,reg));
-      { See comments in a_call_name }
-      list.concat(taicpu.op_none(A_P_SET_MACRO));
-      list.concat(taicpu.op_none(A_P_SET_REORDER));
-      list.concat(taicpu.op_reg(A_JAL,NR_PIC_FUNC));
-      list.concat(taicpu.op_none(A_P_SET_NOREORDER));
-      list.concat(taicpu.op_none(A_P_SET_NOMACRO));
-  (*  end
-  else
+
+  if (Reg <> NR_PIC_FUNC) then
+    list.concat(taicpu.op_reg_reg(A_MOVE,NR_PIC_FUNC,reg));
+  list.concat(taicpu.op_reg(A_JALR,NR_PIC_FUNC));
+  { Delay slot }
+  list.concat(taicpu.op_none(A_NOP));
+  { Restore GP if in PIC mode }
+  if (cs_create_pic in current_settings.moduleswitches) then
     begin
-      list.concat(taicpu.op_reg(A_JALR, reg));
-      { Delay slot }
-      list.concat(taicpu.op_none(A_NOP)); *)
+      if TMIPSProcinfo(current_procinfo).save_gp_ref.offset=0 then
+        InternalError(2013071002);
+      list.concat(taicpu.op_reg_ref(A_LW,NR_GP,TMIPSProcinfo(current_procinfo).save_gp_ref));
     end;
 end;
 
@@ -754,6 +615,8 @@ begin
   reference_reset_symbol(href,ref.symbol,ref.offset,ref.alignment);
   if (cs_create_pic in current_settings.moduleswitches) then
     begin
+      if not (pi_needs_got in current_procinfo.flags) then
+        InternalError(2013060103);
       { For PIC global symbols offset must be handled separately.
         Otherwise (non-PIC or local symbols) offset can be encoded
         into relocation even if exceeds 16 bits. }
@@ -875,9 +738,10 @@ end;
 
 
 const
-  ops_mul: array[boolean] of TAsmOp = (A_MULTU,A_MULT);
   ops_add: array[boolean] of TAsmOp = (A_ADDU, A_ADD);
   ops_sub: array[boolean] of TAsmOp = (A_SUBU, A_SUB);
+  ops_slt: array[boolean] of TAsmOp = (A_SLTU, A_SLT);
+  ops_slti: array[boolean] of TAsmOp = (A_SLTIU, A_SLTI);
   ops_and: array[boolean] of TAsmOp = (A_AND, A_ANDI);
   ops_or:  array[boolean] of TAsmOp = (A_OR, A_ORI);
   ops_xor: array[boolean] of TasmOp = (A_XOR, A_XORI);
@@ -912,11 +776,12 @@ begin
 
     OP_IMUL,OP_MUL:
       begin
-        list.concat(taicpu.op_reg_reg(ops_mul[op=OP_IMUL], dst, src));
+        list.concat(taicpu.op_reg_reg(TOpcg2AsmOp[op], dst, src));
         list.concat(taicpu.op_reg(A_MFLO, dst));
       end;
   else
-    list.concat(taicpu.op_reg_reg_reg(f_TOpCG2AsmOp(op, size), dst, dst, src));
+    a_op_reg_reg_reg(list, op, size, src, dst, dst);
+    exit;
   end;
   maybeadjustresult(list,op,size,dst);
 end;
@@ -931,9 +796,25 @@ end;
 
 
 procedure TCGMIPS.a_op_reg_reg_reg(list: tasmlist; op: TOpCg; size: tcgsize; src1, src2, dst: tregister);
+var
+  hreg: tregister;
 begin
-
-  list.concat(taicpu.op_reg_reg_reg(f_TOpCG2AsmOp(op, size), dst, src2, src1));
+  if (TOpcg2AsmOp[op]=A_NONE) then
+    InternalError(2013070305);
+  if (op=OP_SAR) then
+    begin
+      if (size in [OS_S8,OS_S16]) then
+        begin
+          { Shift left by 16/24 bits and increase amount of right shift by same value }
+          list.concat(taicpu.op_reg_reg_const(A_SLL, dst, src2, 32-(tcgsize2size[size]*8)));
+          hreg:=GetIntRegister(list,OS_INT);
+          a_op_const_reg_reg(list,OP_ADD,OS_INT,32-(tcgsize2size[size]*8),src1,dst);
+          src1:=hreg;
+        end
+      else if not (size in [OS_32,OS_S32]) then
+        InternalError(2013070306);
+    end;
+  list.concat(taicpu.op_reg_reg_reg(TOpCG2AsmOp[op], dst, src2, src1));
   maybeadjustresult(list,op,size,dst);
 end;
 
@@ -1005,9 +886,24 @@ begin
           end;
       end;
 
-    OP_SHL,OP_SHR,OP_SAR:
-      list.concat(taicpu.op_reg_reg_const(f_TOpCG2AsmOp_ovf(op,size),dst,src,a));
+    OP_SHL:
+      list.concat(taicpu.op_reg_reg_const(A_SLL,dst,src,a));
 
+    OP_SHR:
+      list.concat(taicpu.op_reg_reg_const(A_SRL,dst,src,a));
+
+    OP_SAR:
+      begin
+        if (size in [OS_S8,OS_S16]) then
+          begin
+            list.concat(taicpu.op_reg_reg_const(A_SLL,dst,src,32-(tcgsize2size[size]*8)));
+            inc(a,32-tcgsize2size[size]*8);
+            src:=dst;
+          end
+        else if not (size in [OS_32,OS_S32]) then
+          InternalError(2013070303);
+        list.concat(taicpu.op_reg_reg_const(A_SRA,dst,src,a));
+      end;
   else
     internalerror(2007012601);
   end;
@@ -1044,7 +940,7 @@ begin
       end;
     OP_MUL,OP_IMUL:
       begin
-        list.concat(taicpu.op_reg_reg(ops_mul[op=OP_IMUL], src2, src1));
+        list.concat(taicpu.op_reg_reg(TOpCg2AsmOp[op], src2, src1));
         list.concat(taicpu.op_reg(A_MFLO, dst));
         if setflags then
           begin
@@ -1065,7 +961,7 @@ begin
       end;
     OP_AND,OP_OR,OP_XOR:
       begin
-        list.concat(taicpu.op_reg_reg_reg(f_TOpCG2AsmOp_ovf(op, size), dst, src2, src1));
+        list.concat(taicpu.op_reg_reg_reg(TOpCG2AsmOp[op], dst, src2, src1));
       end;
     else
       internalerror(2007012602);
@@ -1086,8 +982,20 @@ begin
   else
     begin
       tmpreg := GetIntRegister(list,OS_INT);
-      a_load_const_reg(list,OS_INT,a,tmpreg);
-      a_cmp_reg_reg_label(list,size,cmp_op,tmpreg,reg,l);
+      if (a>=simm16lo) and (a<=simm16hi) and
+        (cmp_op in [OC_LT,OC_B,OC_GTE,OC_AE]) then
+        begin
+          list.concat(taicpu.op_reg_reg_const(ops_slti[cmp_op in [OC_LT,OC_GTE]],tmpreg,reg,a));
+          if cmp_op in [OC_LT,OC_B] then
+            a_cmp_reg_reg_label(list,size,OC_NE,NR_R0,tmpreg,l)
+          else
+            a_cmp_reg_reg_label(list,size,OC_EQ,NR_R0,tmpreg,l);
+        end
+      else
+        begin
+          a_load_const_reg(list,OS_INT,a,tmpreg);
+          a_cmp_reg_reg_label(list, size, cmp_op, tmpreg, reg, l);
+        end;
     end;
 end;
 
@@ -1095,22 +1003,46 @@ const
   TOpCmp2AsmCond_z : array[OC_GT..OC_LTE] of TAsmCond=(
     C_GTZ,C_LTZ,C_GEZ,C_LEZ
   );
+  TOpCmp2AsmCond_eqne: array[topcmp] of TAsmCond = (C_NONE,
+   { eq      gt    lt    gte   lte   ne     }
+    C_NONE, C_NE, C_NE, C_EQ, C_EQ, C_NONE,
+   { be    b     ae    a }
+    C_EQ, C_NE, C_EQ, C_NE
+  );
 
 procedure TCGMIPS.a_cmp_reg_reg_label(list: tasmlist; size: tcgsize; cmp_op: topcmp; reg1, reg2: tregister; l: tasmlabel);
 var
   ai : Taicpu;
+  op: TAsmOp;
+  hreg: TRegister;
 begin
-  if ((reg1=NR_R0) or (reg2=NR_R0)) and (cmp_op in [OC_GT,OC_LT,OC_GTE,OC_LTE]) then
+  if not (cmp_op in [OC_EQ,OC_NE]) then
     begin
-      if (reg2=NR_R0) then
+      if ((reg1=NR_R0) or (reg2=NR_R0)) and (cmp_op in [OC_GT,OC_LT,OC_GTE,OC_LTE]) then
         begin
-          ai:=taicpu.op_reg_sym(A_BC,reg1,l);
-          ai.setcondition(inverse_cond(TOpCmp2AsmCond_z[cmp_op]));
+          if (reg2=NR_R0) then
+            begin
+              ai:=taicpu.op_reg_sym(A_BC,reg1,l);
+              ai.setcondition(TOpCmp2AsmCond_z[swap_opcmp(cmp_op)]);
+            end
+          else
+            begin
+              ai:=taicpu.op_reg_sym(A_BC,reg2,l);
+              ai.setcondition(TOpCmp2AsmCond_z[cmp_op]);
+            end;
         end
       else
         begin
-          ai:=taicpu.op_reg_sym(A_BC,reg2,l);
-          ai.setcondition(TOpCmp2AsmCond_z[cmp_op]);
+          hreg:=GetIntRegister(list,OS_INT);
+          op:=ops_slt[cmp_op in [OC_LT,OC_LTE,OC_GT,OC_GTE]];
+          if (cmp_op in [OC_LTE,OC_GT,OC_BE,OC_A]) then   { swap operands }
+            list.concat(taicpu.op_reg_reg_reg(op,hreg,reg1,reg2))
+          else
+            list.concat(taicpu.op_reg_reg_reg(op,hreg,reg2,reg1));
+          if (TOpCmp2AsmCond_eqne[cmp_op]=C_NONE) then
+            InternalError(2013051501);
+          ai:=taicpu.op_reg_reg_sym(A_BC,hreg,NR_R0,l);
+          ai.SetCondition(TOpCmp2AsmCond_eqne[cmp_op]);
         end;
     end
   else
@@ -1143,6 +1075,88 @@ begin
 end;
 
 
+procedure TCGMIPS.a_jmp_flags(list: tasmlist; const f: TResFlags; l: tasmlabel);
+  begin
+    if f.use_const then
+      a_cmp_const_reg_label(list,OS_INT,f.cond,f.value,f.reg1,l)
+    else
+      a_cmp_reg_reg_label(list,OS_INT,f.cond,f.reg2,f.reg1,l);
+  end;
+
+
+procedure TCGMIPS.g_flags2reg(list: tasmlist; size: tcgsize; const f: tresflags; reg: tregister);
+  var
+    left,right: tregister;
+    unsigned: boolean;
+  begin
+    if (f.cond in [OC_EQ,OC_NE]) then
+      begin
+        left:=reg;
+        if f.use_const and (f.value>=0) and (f.value<=65535) then
+          begin
+            if (f.value<>0) then
+              list.concat(taicpu.op_reg_reg_const(A_XORI,reg,f.reg1,f.value))
+            else
+              left:=f.reg1;
+          end
+        else
+          begin
+            if f.use_const then
+              begin
+                right:=GetIntRegister(list,OS_INT);
+                a_load_const_reg(list,OS_INT,f.value,right);
+              end
+            else
+              right:=f.reg2;
+            list.concat(taicpu.op_reg_reg_reg(A_XOR,reg,f.reg1,right));
+          end;
+
+        if f.cond=OC_EQ then
+          list.concat(taicpu.op_reg_reg_const(A_SLTIU,reg,left,1))
+        else
+          list.concat(taicpu.op_reg_reg_reg(A_SLTU,reg,NR_R0,left));
+      end
+    else
+      begin
+        {
+          sle  x,a,b  -->  slt   x,b,a; xori  x,x,1    immediate not possible (or must be at left)
+          sgt  x,a,b  -->  slt   x,b,a                 likewise
+          sge  x,a,b  -->  slt   x,a,b; xori  x,x,1
+          slt  x,a,b  -->  unchanged
+        }
+
+        unsigned:=f.cond in [OC_GT,OC_LT,OC_GTE,OC_LTE];
+        if (f.cond in [OC_GTE,OC_LT,OC_B,OC_AE]) and
+          f.use_const and
+          (f.value>=simm16lo) and
+          (f.value<=simm16hi) then
+          list.Concat(taicpu.op_reg_reg_const(ops_slti[unsigned],reg,f.reg1,f.value))
+        else
+          begin
+            if f.use_const then
+              begin
+                if (f.value=0) then
+                  right:=NR_R0
+                else
+                  begin
+                   right:=GetIntRegister(list,OS_INT);
+                   a_load_const_reg(list,OS_INT,f.value,right);
+                end;
+              end
+            else
+              right:=f.reg2;
+
+            if (f.cond in [OC_LTE,OC_GT,OC_BE,OC_A]) then
+              list.Concat(taicpu.op_reg_reg_reg(ops_slt[unsigned],reg,right,f.reg1))
+            else
+              list.Concat(taicpu.op_reg_reg_reg(ops_slt[unsigned],reg,f.reg1,right));
+          end;
+        if (f.cond in [OC_LTE,OC_GTE,OC_BE,OC_AE]) then
+          list.Concat(taicpu.op_reg_reg_const(A_XORI,reg,reg,1));
+      end;
+  end;
+
+
 procedure TCGMIPS.g_overflowCheck(List: tasmlist; const Loc: TLocation; def: TDef);
 begin
 // this is an empty procedure
@@ -1157,6 +1171,20 @@ end;
 
 { *********** entry/exit code and address loading ************ }
 
+procedure FixupOffsets(p:TObject;arg:pointer);
+var
+  sym: tabstractnormalvarsym absolute p;
+begin
+  if (tsym(p).typ=paravarsym) and
+    (sym.localloc.loc=LOC_REFERENCE) and
+    (sym.localloc.reference.base=NR_FRAME_POINTER_REG) then
+    begin
+      sym.localloc.reference.base:=NR_STACK_POINTER_REG;
+      Inc(sym.localloc.reference.offset,PLongint(arg)^);
+    end;
+end;
+
+
 procedure TCGMIPS.g_proc_entry(list: tasmlist; localsize: longint; nostackframe: boolean);
 var
   lastintoffset,lastfpuoffset,
@@ -1283,28 +1311,20 @@ begin
       list.concat(Taicpu.op_none(A_P_SET_NOMACRO));
     end;
 
-  with TMIPSProcInfo(current_procinfo) do
-    begin
-      href.offset:=0;
-      //if current_procinfo.framepointer<>NR_STACK_POINTER_REG then
-        href.base:=NR_FRAME_POINTER_REG;
+  href.base:=NR_STACK_POINTER_REG;
+
+  for i:=0 to MIPS_MAX_REGISTERS_USED_IN_CALL-1 do
+    if TMIPSProcInfo(current_procinfo).register_used[i] then
+      begin
+        reg:=parasupregs[i];
+        href.offset:=i*sizeof(aint)+LocalSize;
+        list.concat(taicpu.op_reg_ref(A_SW, newreg(R_INTREGISTER,reg,R_SUBWHOLE), href));
+      end;
 
-      for i:=0 to MIPS_MAX_REGISTERS_USED_IN_CALL-1 do
-        if (register_used[i]) then
-          begin
-            reg:=parasupregs[i];
-            if register_offset[i]=-1 then
-              comment(V_warning,'Register parameter has offset -1 in TCGMIPS.g_proc_entry');
-
-            //if current_procinfo.framepointer=NR_STACK_POINTER_REG then
-            //  href.offset:=register_offset[i]+Localsize
-            //else
-            href.offset:=register_offset[i];
-            list.concat(taicpu.op_reg_ref(A_SW, newreg(R_INTREGISTER,reg,R_SUBWHOLE), href));
-        end;
-    end;
   list.concatList(helplist);
   helplist.Free;
+  if current_procinfo.has_nestedprocs then
+    current_procinfo.procdef.parast.SymList.ForEachCall(@FixupOffsets,@LocalSize);
 end;
 
 
@@ -1326,6 +1346,8 @@ begin
      end
    else
      begin
+       if TMIPSProcinfo(current_procinfo).save_gp_ref.offset<>0 then
+         tg.ungettemp(list,TMIPSProcinfo(current_procinfo).save_gp_ref);
        reference_reset(href,0);
        href.base:=NR_STACK_POINTER_REG;
 
@@ -1419,7 +1441,6 @@ var
     begin
       result:=(ref.base<>NR_NO) and (ref.index=NR_NO) and
          (ref.symbol=nil) and
-         (ref.alignment>=sizeof(aint)) and
          (ref.offset>=simm16lo) and (ref.offset+len<=simm16hi);
     end;
 

compiler/mips/cpubase.pas

@@ -124,6 +124,15 @@ unit cpubase;
         'c1t','c1f'
       );
 
+    type
+      TResFlags=record
+        reg1: TRegister;
+        cond: TOpCmp;
+      case use_const: boolean of
+        False: (reg2: TRegister);
+        True: (value: aint);
+      end;
+
 {*****************************************************************************
                                  Constants
 *****************************************************************************}
@@ -222,6 +231,7 @@ unit cpubase;
       NR_FPU_RESULT_REG = NR_F0;
       NR_MM_RESULT_REG  = NR_NO;
 
+      NR_DEFAULTFLAGS = NR_NO;
 
 {*****************************************************************************
                        GCC /ABI linking information

compiler/mips/cpugas.pas

@@ -241,7 +241,9 @@ unit cpugas;
           or (op=A_LA) or ((op=A_BC) and
             not (ai.condition in [C_EQ,C_NE,C_GTZ,C_GEZ,C_LTZ,C_LEZ,C_COP1TRUE,C_COP1FALSE])) {or (op=A_JAL)}
           or (op=A_REM) or (op=A_REMU)
-          or (op=A_DIV) or (op=A_DIVU)
+          { DIV and DIVU are normally macros, but use $zero as first arg to generate a CPU instruction. }
+          or ((op=A_DIV) or (op=A_DIVU) and
+            ((ai.ops<>3) or (ai.oper[0]^.typ<>top_reg) or (ai.oper[0]^.reg<>NR_R0)))
           or (op=A_MULO) or (op=A_MULOU)
           { A_LI is only a macro if the immediate is not in thez 16-bit range }
           or (op=A_LI);

compiler/mips/cpuinfo.pas

@@ -111,7 +111,7 @@ Const
    supported_optimizerswitches = [cs_opt_regvar,cs_opt_loopunroll,cs_opt_nodecse,
                                   cs_opt_reorder_fields,cs_opt_fastmath];
 
-   level1optimizerswitches = [];
+   level1optimizerswitches = [cs_opt_level1];
    level2optimizerswitches = level1optimizerswitches + [cs_opt_regvar,cs_opt_stackframe,cs_opt_nodecse];
    level3optimizerswitches = level2optimizerswitches + [cs_opt_loopunroll];
    level4optimizerswitches = genericlevel4optimizerswitches + level3optimizerswitches + [];

compiler/mips/cpupara.pas

@@ -31,8 +31,6 @@ interface
       symconst,symbase,symsym,symtype,symdef,paramgr,parabase,cgbase,cgutils;
 
     const
-      MIPS_MAX_OFFSET = 20;
-
       { The value below is OK for O32 and N32 calling conventions }
       MIPS_MAX_REGISTERS_USED_IN_CALL = 6;
 
@@ -63,9 +61,6 @@ interface
     type
       tparasupregs = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of tsuperregister;
       tparasupregsused = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of boolean;
-      tparasupregsize = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of tcgsize;
-      tparasuprename = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of shortstring;
-      tparasupregsoffset = array[0..MIPS_MAX_REGISTERS_USED_IN_CALL-1] of longint;
 
     const
 
@@ -79,6 +74,7 @@ interface
         function  create_paraloc_info(p : TAbstractProcDef; side: tcallercallee):longint;override;
         function  create_varargs_paraloc_info(p : TAbstractProcDef; varargspara:tvarargsparalist):longint;override;
         function  get_funcretloc(p : tabstractprocdef; side: tcallercallee; forcetempdef: tdef): tcgpara;override;
+        function  param_use_paraloc(const cgpara: tcgpara): boolean; override;
       private
         intparareg,
         intparasize : longint;
@@ -119,6 +115,16 @@ implementation
       end;
 
 
+    function TMIPSParaManager.param_use_paraloc(const cgpara: tcgpara): boolean;
+      var
+        paraloc: pcgparalocation;
+      begin
+        paraloc:=cgpara.location;
+        if not assigned(paraloc) then
+          internalerror(200410102);
+        result:=(paraloc^.loc=LOC_REFERENCE) and (paraloc^.next=nil);
+      end;
+
 
     { true if a parameter is too large to copy and only the address is pushed }
     function TMIPSParaManager.push_addr_param(varspez:tvarspez;def : tdef;calloption : tproccalloption) : boolean;
@@ -231,7 +237,7 @@ implementation
     procedure TMIPSParaManager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee;paras:tparalist);
       var
         paraloc      : pcgparalocation;
-        i            : integer;
+        i,j          : integer;
         hp           : tparavarsym;
         paracgsize   : tcgsize;
         paralen      : longint;
@@ -242,6 +248,7 @@ implementation
         alignment    : longint;
         tmp          : longint;
         firstparaloc : boolean;
+        reg_and_stack: boolean;
       begin
         fpparareg := 0;
         for i:=0 to paras.count-1 do
@@ -340,6 +347,9 @@ implementation
               can_use_float := false;
 
             firstparaloc:=true;
+            { Is parameter split between stack and registers? }
+            reg_and_stack:=(side=calleeside) and
+              (paralen+intparasize>16) and (intparasize<16);
             while paralen>0 do
               begin
                 paraloc:=hp.paraloc[side].add_location;
@@ -368,11 +378,14 @@ implementation
                     paraloc^.register:=newreg(R_INTREGISTER,parasupregs[0],R_SUBWHOLE);
                     inc(intparasize,align(tcgsize2size[paraloc^.size],sizeof(aint)));
                   end
-                { In case of po_delphi_nested_cc, the parent frame pointer
-                  is always passed on the stack. }
+                { "In case of po_delphi_nested_cc, the parent frame pointer
+                  is always passed on the stack". On other targets it is
+                  used to provide caller-side stack cleanup and prevent stackframe
+                  optimization. For MIPS this does not matter. }
                 else if (intparareg<mips_nb_used_registers) and
+                   (not reg_and_stack) {and
                    (not(vo_is_parentfp in hp.varoptions) or
-                    not(po_delphi_nested_cc in p.procoptions)) then
+                    not(po_delphi_nested_cc in p.procoptions))} then
                   begin
                     if (can_use_float) then
                       begin
@@ -418,8 +431,18 @@ implementation
                   end
                 else
                   begin
+                    if reg_and_stack then
+                      begin
+                        for j:=intparareg to mips_nb_used_registers-1 do
+                          tmipsprocinfo(current_procinfo).register_used[j]:=true;
+                        { all registers used now }
+                        intparareg:=mips_nb_used_registers;
+                      end;
                     paraloc^.loc:=LOC_REFERENCE;
-                    paraloc^.size:=int_cgsize(paralen);
+                    if (paradef.typ=floatdef) then
+                      paraloc^.size:=int_float_cgsize(paralen)
+                    else
+                      paraloc^.size:=int_cgsize(paralen);
                     paraloc^.def:=get_paraloc_def(locdef,paralen,firstparaloc);
 
                     if side=callerside then

compiler/mips/cpupi.pas

@@ -41,9 +41,6 @@ interface
       intregssave,
       floatregssave : byte;
       register_used : tparasupregsused;
-      register_size : tparasupregsize;
-      register_name : tparasuprename;
-      register_offset : tparasupregsoffset;
       computed_local_size : longint;
       save_gp_ref: treference;
       //intparareg,
@@ -66,20 +63,12 @@ implementation
       tgobj,paramgr,symconst;
 
     constructor TMIPSProcInfo.create(aparent: tprocinfo);
-      var
-        i : longint;
       begin
         inherited create(aparent);
         { if (cs_generate_stackframes in current_settings.localswitches) or
            not (cs_opt_stackframe in current_settings.optimizerswitches) then }
           include(flags,pi_needs_stackframe);
-        for i:=low(tparasupregs)  to high(tparasupregs) do
-          begin
-            register_used[i]:=false;
-            register_size[i]:=OS_NO;
-            register_name[i]:='invalid';
-            register_offset[i]:=-1;
-          end;
+
         floatregssave:=12; { f20-f31 }
         intregssave:=10;   { r16-r23,r30,r31 }
         computed_local_size:=-1;
@@ -116,7 +105,10 @@ implementation
           also declared as nostackframe and everything is managed manually. }
         if (pi_do_call in flags) or
            ((pi_is_assembler in flags) and not (po_nostackframe in procdef.procoptions)) then
-          allocate_push_parasize(mips_nb_used_registers*sizeof(aint));
+          begin
+            include(flags,pi_do_call);   // for pi_is_assembler case
+            allocate_push_parasize(mips_nb_used_registers*sizeof(aint));
+          end;
 
         if not (po_nostackframe in procdef.procoptions) then
           tg.setfirsttemp(Align(maxpushedparasize+

compiler/mips/hlcgcpu.pas

@@ -38,6 +38,9 @@ uses
   type
     thlcgmips = class(thlcg2ll)
       function a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; forceresdef: tdef; weak: boolean): tcgpara; override;
+      procedure a_load_subsetreg_reg(list: TAsmList; subsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister);override;
+    protected
+      procedure a_load_regconst_subsetreg_intern(list: TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister; slopt: tsubsetloadopt); override;
   end;
 
   procedure create_hlcodegen;
@@ -45,11 +48,15 @@ uses
 implementation
 
   uses
+    verbose,
     aasmtai,
+    aasmcpu,
     cutils,
     globals,
+    defutil,
     cgobj,
     cpubase,
+    cpuinfo,
     cgcpu;
 
   function thlcgmips.a_call_name(list: TAsmList; pd: tprocdef; const s: TSymStr; forceresdef: tdef; weak: boolean): tcgpara;
@@ -79,6 +86,66 @@ implementation
     end;
 
 
+  procedure thlcgmips.a_load_subsetreg_reg(list: TAsmList; subsetsize, tosize: tdef; const sreg: tsubsetregister; destreg: tregister);
+    var
+      cgsubsetsize,
+      cgtosize: tcgsize;
+    begin
+      cgsubsetsize:=def_cgsize(subsetsize);
+      cgtosize:=def_cgsize(tosize);
+      if (current_settings.cputype<>cpu_mips32r2) then
+        inherited a_load_subsetreg_reg(list,subsetsize,tosize,sreg,destreg)
+      else if (sreg.bitlen>32) then
+        InternalError(2013070201)
+      else if (sreg.bitlen<>32) then
+        begin
+          list.concat(taicpu.op_reg_reg_const_const(A_EXT,destreg,sreg.subsetreg,
+            sreg.startbit,sreg.bitlen));
+          { types with a negative lower bound are always a base type (8, 16, 32 bits) }
+          if (cgsubsetsize in [OS_S8..OS_S128]) then
+            if ((sreg.bitlen mod 8) = 0) then
+              begin
+                cg.a_load_reg_reg(list,tcgsize2unsigned[cgsubsetsize],cgsubsetsize,destreg,destreg);
+                cg.a_load_reg_reg(list,cgsubsetsize,cgtosize,destreg,destreg);
+              end
+            else
+              begin
+                cg.a_op_const_reg(list,OP_SHL,OS_INT,32-sreg.bitlen,destreg);
+                cg.a_op_const_reg(list,OP_SAR,OS_INT,32-sreg.bitlen,destreg);
+              end;
+        end
+      else
+        cg.a_load_reg_reg(list,cgsubsetsize,cgtosize,sreg.subsetreg,destreg);
+    end;
+
+
+  procedure thlcgmips.a_load_regconst_subsetreg_intern(list: TAsmList; fromsize, subsetsize: tdef; fromreg: tregister; const sreg: tsubsetregister; slopt: tsubsetloadopt);
+    begin
+      if (current_settings.cputype<>cpu_mips32r2) then
+        inherited a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,sreg,slopt)
+      else if (sreg.bitlen>32) then
+        InternalError(2013070202)
+      else if (sreg.bitlen<>32) then
+        begin
+          case slopt of
+            SL_SETZERO:
+              fromreg:=NR_R0;
+            SL_SETMAX:
+              begin
+                fromreg:=cg.getintregister(list,OS_INT);
+                cg.a_load_const_reg(list,OS_INT,-1,fromreg);
+              end;
+          end;
+          list.concat(taicpu.op_reg_reg_const_const(A_INS,sreg.subsetreg,fromreg,
+            sreg.startbit,sreg.bitlen));
+        end
+      else if not (slopt in [SL_SETZERO,SL_SETMAX]) then
+        cg.a_load_reg_reg(list,def_cgsize(fromsize),def_cgsize(subsetsize),fromreg,sreg.subsetreg)
+      else
+        inherited a_load_regconst_subsetreg_intern(list,fromsize,subsetsize,fromreg,sreg,slopt);
+    end;
+
+
   procedure create_hlcodegen;
     begin
       hlcg:=thlcgmips.create;

compiler/mips/ncpuadd.pas

@@ -69,119 +69,54 @@ uses
                                tmipsaddnode
 *****************************************************************************}
 const
-  swapped_nodetype: array[ltn..gten] of tnodetype =
+  swapped_nodetype: array[ltn..unequaln] of tnodetype =
     //lt  lte  gt  gte
-    (gtn, gten,ltn,lten);
+    (gtn, gten,ltn,lten, equaln, unequaln);
 
-  ops: array[boolean] of tasmop = (A_SLT,A_SLTU);
-  ops_immed: array[boolean] of tasmop = (A_SLTI,A_SLTIU);
+  nodetype2opcmp: array[boolean,ltn..unequaln] of TOpCmp = (
+    (OC_LT, OC_LTE, OC_GT, OC_GTE, OC_EQ, OC_NE),
+    (OC_B,  OC_BE,  OC_A,  OC_AE,  OC_EQ, OC_NE)
+  );
 
 procedure tmipsaddnode.second_generic_cmp32(unsigned: boolean);
 var
   ntype: tnodetype;
-  tmp_left,tmp_right: TRegister;
 begin
   pass_left_right;
   force_reg_left_right(True, True);
-  location_reset(location,LOC_REGISTER,OS_INT);
-  location.register:=cg.GetIntRegister(current_asmdata.CurrAsmList, OS_INT);
-
-  if nodetype in [equaln,unequaln] then
-    begin
-      tmp_left:=location.register;
-      { XORI needs unsigned immediate in range 0-65535 }
-      if (right.location.loc=LOC_CONSTANT) and (right.location.value>=0) and
-        (right.location.value<=65535) then
-        begin
-          if right.location.value<>0 then
-            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_const(A_XORI,location.register,left.location.register,right.location.value))
-          else
-            tmp_left:=left.location.register;
-        end
-      else
-        begin
-          if (right.location.loc<>LOC_CONSTANT) then
-            tmp_right:=right.location.register
-          else
-            begin
-              tmp_right:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
-              cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,right.location.value,tmp_right);
-            end;
-          current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_XOR,location.register,left.location.register,tmp_right));
-        end;
-
-      if nodetype=equaln then
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_const(A_SLTIU,location.register,tmp_left,1))
-      else
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_SLTU,location.register,NR_R0,tmp_left));
-      exit;
-    end;
+  location_reset(location,LOC_FLAGS,OS_NO);
 
   ntype:=nodetype;
   if nf_swapped in flags then
     ntype:=swapped_nodetype[nodetype];
 
-  {
-    sle  x,a,b  -->  slt   x,b,a; xori  x,x,1    immediate not possible (or must be at left)
-    sgt  x,a,b  -->  slt   x,b,a                 likewise
-    sge  x,a,b  -->  slt   x,a,b; xori  x,x,1
-    slt  x,a,b  -->  unchanged
-  }
-
-  if (ntype in [gten,ltn]) and
-    (right.location.loc=LOC_CONSTANT) and
-    (right.location.value>=simm16lo) and
-    (right.location.value<=simm16hi) then
-    current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(ops_immed[unsigned],location.register,left.location.register,right.location.value))
+  location.resflags.cond:=nodetype2opcmp[unsigned,ntype];
+  location.resflags.reg1:=left.location.register;
+  location.resflags.use_const:=(right.location.loc=LOC_CONSTANT);
+  if location.resflags.use_const then
+    location.resflags.value:=right.location.value
   else
-    begin
-      if (right.location.loc=LOC_CONSTANT) then
-        begin
-          if (right.location.value=0) then
-            tmp_right:=NR_R0
-          else
-            begin
-             tmp_right:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
-             cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,right.location.value,tmp_right);
-          end;
-        end
-      else
-        tmp_right:=right.location.register;
-
-      if (ntype in [lten,gtn]) then
-        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(ops[unsigned],location.register,tmp_right,left.location.register))
-      else
-        current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(ops[unsigned],location.register,left.location.register,tmp_right));
-    end;
-  if (ntype in [lten,gten]) then
-    current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_const(A_XORI,location.register,location.register,1));
+    location.resflags.reg2:=right.location.register;
 end;
 
 
+const
+  cmpops: array[boolean] of TOpCmp = (OC_LT,OC_B);
+
 procedure tmipsaddnode.cmp64_lt(left_reg, right_reg: TRegister64;unsigned: boolean);
-var
-  hreg: tregister;
 begin
-  hreg:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
-  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(ops[unsigned], hreg, left_reg.reghi, right_reg.reghi));
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,NR_R0,hreg,current_procinfo.CurrTrueLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],right_reg.reghi,left_reg.reghi,current_procinfo.CurrTrueLabel);
   cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrFalseLabel);
-  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_SLTU, hreg, left_reg.reglo, right_reg.reglo));
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,NR_R0,hreg,current_procinfo.CurrTrueLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,right_reg.reglo,left_reg.reglo,current_procinfo.CurrTrueLabel);
   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
 end;
 
 
 procedure tmipsaddnode.cmp64_le(left_reg, right_reg: TRegister64;unsigned: boolean);
-var
-  hreg: TRegister;
 begin
-  hreg:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
-  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(ops[unsigned], hreg, right_reg.reghi, left_reg.reghi));
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,NR_R0,hreg,current_procinfo.CurrFalseLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,cmpops[unsigned],left_reg.reghi,right_reg.reghi,current_procinfo.CurrFalseLabel);
   cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,left_reg.reghi,right_reg.reghi,current_procinfo.CurrTrueLabel);
-  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_SLTU, hreg, right_reg.reglo, left_reg.reglo));
-  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,NR_R0,hreg,current_procinfo.CurrFalseLabel);
+  cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_B,left_reg.reglo,right_reg.reglo,current_procinfo.CurrFalseLabel);
   cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
 end;
 
@@ -268,10 +203,7 @@ function tmipsaddnode.pass_1 : tnode;
         if (nodetype in [ltn,lten,gtn,gten,equaln,unequaln]) then
           begin
             if (left.resultdef.typ=floatdef) or (right.resultdef.typ=floatdef) then
-              expectloc:=LOC_JUMP
-            else if ((left.resultdef.typ<>orddef) or
-              (not (torddef(left.resultdef).ordtype in [s64bit,u64bit,scurrency]))) then
-              expectloc:=LOC_REGISTER;
+              expectloc:=LOC_JUMP;
           end;
       end;
   end;

compiler/mips/ncpucnv.pas

@@ -40,7 +40,7 @@ type
     { procedure second_chararray_to_string;override; }
     { procedure second_char_to_string;override; }
     procedure second_int_to_real; override;
-    procedure second_real_to_real; override;
+    { procedure second_real_to_real; override; }
     { procedure second_cord_to_pointer;override; }
     { procedure second_proc_to_procvar;override; }
     { procedure second_bool_to_int;override; }
@@ -71,12 +71,27 @@ uses
 *****************************************************************************}
 
 function tmipseltypeconvnode.first_int_to_real: tnode;
+var
+  fname: string[19];
 begin
   { converting a 64bit integer to a float requires a helper }
   if is_64bitint(left.resultdef) or
      is_currency(left.resultdef) then
     begin
-      result:=inherited first_int_to_real;
+      { hack to avoid double division by 10000, as it's
+        already done by typecheckpass.resultdef_int_to_real }
+      if is_currency(left.resultdef) then
+        left.resultdef := s64inttype;
+      if is_signed(left.resultdef) then
+        fname := 'fpc_int64_to_double'
+      else
+        fname := 'fpc_qword_to_double';
+      result := ccallnode.createintern(fname,ccallparanode.create(
+        left,nil));
+      left:=nil;
+      if (tfloatdef(resultdef).floattype=s32real) then
+        inserttypeconv(result,s32floattype);
+      firstpass(result);
       exit;
     end
   else
@@ -103,15 +118,22 @@ end;
 
 procedure tMIPSELtypeconvnode.second_int_to_real;
 
-  procedure loadsigned;
+  procedure loadsigned(restype: tfloattype);
   begin
-    hlcg.location_force_mem(current_asmdata.CurrAsmList, left.location, left.resultdef);
-    location.Register := cg.getfpuregister(current_asmdata.CurrAsmList, location.size);
-    { Load memory in fpu register }
-    cg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList, OS_F32, OS_F32, left.location.reference, location.Register);
-    tg.ungetiftemp(current_asmdata.CurrAsmList, left.location.reference);
+    location.Register := cg.getfpuregister(current_asmdata.CurrAsmList, tfloat2tcgsize[restype]);
+    if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+      { 32-bit values can be loaded directly }
+      current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_MTC1, left.location.register, location.register))
+    else
+      begin
+        { Load memory in fpu register }
+        hlcg.location_force_mem(current_asmdata.CurrAsmList, left.location, left.resultdef);
+        cg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList, OS_F32, OS_F32, left.location.reference, location.Register);
+        tg.ungetiftemp(current_asmdata.CurrAsmList, left.location.reference);
+      end;
+
     { Convert value in fpu register from integer to float }
-    case tfloatdef(resultdef).floattype of
+    case restype of
       s32real:
         current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CVT_S_W, location.Register, location.Register));
       s64real:
@@ -125,13 +147,12 @@ var
   href:      treference;
   hregister: tregister;
   l1, l2:    tasmlabel;
-  ai : TaiCpu;
   addend: array[boolean] of longword;
   bigendian: boolean;
 begin
   location_reset(location, LOC_FPUREGISTER, def_cgsize(resultdef));
   if is_signed(left.resultdef) then
-    loadsigned
+    loadsigned(tfloatdef(resultdef).floattype)
   else
   begin
     current_asmdata.getdatalabel(l1);
@@ -141,16 +162,8 @@ begin
     hlcg.a_load_loc_reg(current_asmdata.CurrAsmList, left.resultdef, u32inttype, left.location, hregister);
 
     { Always load into 64-bit FPU register }
-    hlcg.location_force_mem(current_asmdata.CurrAsmList, left.location, left.resultdef);
-    location.Register := cg.getfpuregister(current_asmdata.CurrAsmList, OS_F64);
-    cg.a_loadfpu_ref_reg(current_asmdata.CurrAsmList, OS_F32, OS_F32, left.location.reference, location.Register);
-    tg.ungetiftemp(current_asmdata.CurrAsmList, left.location.reference);
-    { Convert value in fpu register from integer to float }
-    current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CVT_D_W, location.Register, location.Register));
-
-    ai := Taicpu.op_reg_reg_sym(A_BC, hregister, NR_R0, l2);
-    ai.setCondition(C_GE);
-    current_asmdata.CurrAsmList.concat(ai);
+    loadsigned(s64real);
+    cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, OS_INT, OC_GTE, 0, hregister, l2);
 
     case tfloatdef(resultdef).floattype of
       { converting dword to s64real first and cut off at the end avoids precision loss }
@@ -188,32 +201,6 @@ begin
 end;
 
 
-procedure tMIPSELtypeconvnode.second_real_to_real;
-const
-  conv_op: array[tfloattype, tfloattype] of tasmop = (
-    {    from:   s32      s64         s80     sc80    c64     cur    f128 }
-    { s32 }  (A_MOV_S,   A_CVT_S_D, A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { s64 }  (A_CVT_D_S, A_MOV_D,   A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { s80 }  (A_NONE,    A_NONE,    A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { sc80 } (A_NONE,    A_NONE,    A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { c64 }  (A_NONE,    A_NONE,    A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { cur }  (A_NONE,    A_NONE,    A_NONE, A_NONE, A_NONE, A_NONE, A_NONE),
-    { f128 } (A_NONE,    A_NONE,    A_NONE, A_NONE, A_NONE, A_NONE, A_NONE)
-    );
-var
-  op: tasmop;
-begin
-  location_reset(location, LOC_FPUREGISTER, def_cgsize(resultdef));
-  location_force_fpureg(current_asmdata.CurrAsmList, left.location, False);
-  { Convert value in fpu register from integer to float }
-  op := conv_op[tfloatdef(resultdef).floattype, tfloatdef(left.resultdef).floattype];
-  if op = A_NONE then
-    internalerror(200401121);
-  location.Register := cg.getfpuregister(current_asmdata.CurrAsmList, location.size);
-  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(op, location.Register, left.location.Register));
-end;
-
-
 procedure tMIPSELtypeconvnode.second_int_to_bool;
 var
   hreg1, hreg2: tregister;
@@ -297,6 +284,11 @@ begin
       cg.a_load_const_reg(current_asmdata.CurrAsmList, OS_INT, 0, hreg1);
       cg.a_label(current_asmdata.CurrAsmList, hlabel);
     end;
+    LOC_FLAGS:
+    begin
+      hreg1:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
+      cg.g_flags2reg(current_asmdata.CurrAsmList,OS_INT,left.location.resflags,hreg1);
+    end
     else
       internalerror(10062);
   end;

compiler/mips/ncpumat.pas

@@ -67,31 +67,23 @@ uses
                              TMipselMODDIVNODE
 *****************************************************************************}
 
+const
+  ops_div: array[boolean] of tasmop = (A_DIVU, A_DIV);
+
 procedure tMIPSELmoddivnode.pass_generate_code;
 var
   power: longint;
-  tmpreg, numerator, divider, resultreg: tregister;
+  tmpreg, numerator, divider: tregister;
+  hl,hl2: tasmlabel;
 begin
   secondpass(left);
   secondpass(right);
-  location_copy(location, left.location);
+  location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+  location.register:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
 
   { put numerator in register }
   hlcg.location_force_reg(current_asmdata.CurrAsmList, left.location, left.resultdef, left.resultdef, True);
-  location_copy(location, left.location);
-  numerator := location.Register;
-
-  if (nodetype = modn) then
-    resultreg := cg.GetIntRegister(current_asmdata.CurrAsmList, OS_INT)
-  else
-  begin
-    if (location.loc = LOC_CREGISTER) then
-    begin
-      location.loc      := LOC_REGISTER;
-      location.Register := cg.GetIntRegister(current_asmdata.CurrAsmList, OS_INT);
-    end;
-    resultreg := location.Register;
-  end;
+  numerator := left.location.Register;
 
   if (nodetype = divn) and
     (right.nodetype = ordconstn) and
@@ -101,9 +93,9 @@ begin
     cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SAR, OS_INT, 31, numerator, tmpreg);
     { if signed, tmpreg=right value-1, otherwise 0 }
     cg.a_op_const_reg(current_asmdata.CurrAsmList, OP_AND, OS_INT, tordconstnode(right).Value.svalue - 1, tmpreg);
-    { add to the left value }
-    cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_ADD, OS_INT, tmpreg, numerator);
-    cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SAR, OS_INT, aword(power), numerator, resultreg);
+    { add left value }
+    cg.a_op_reg_reg(current_asmdata.CurrAsmList, OP_ADD, OS_INT, numerator, tmpreg);
+    cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, OP_SAR, OS_INT, aword(power), tmpreg, location.register);
   end
   else
   begin
@@ -112,29 +104,45 @@ begin
       right.resultdef, right.resultdef, True);
     divider := right.location.Register;
 
-
-    if (nodetype = modn) then
+    { GAS performs division in delay slot:
+
+          bne   denom,$zero,.L1
+          div   $zero,numerator,denom
+          break 7
+     .L1:
+          mflo  result
+
+      We can't yet do the same without prior fixing the spilling code:
+      if registers require spilling, loads can be inserted before 'div',
+      resulting in invalid code.
+    }
+    current_asmdata.CurrAsmList.Concat(taicpu.op_reg_reg_reg(ops_div[is_signed(resultdef)],NR_R0,numerator,divider));
+    { Check for zero denominator, omit if dividing by constant (constants are checked earlier) }
+    if (right.nodetype<>ordconstn) then
     begin
-      if is_signed(right.resultdef) then
-      begin
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_REM, resultreg, numerator, divider));
-      end
-      else
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_REMU, resultreg, numerator, divider));
-    end
-    else
+      current_asmdata.getjumplabel(hl);
+      cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,divider,NR_R0,hl);
+      current_asmdata.CurrAsmList.Concat(taicpu.op_const(A_BREAK,7));
+      cg.a_label(current_asmdata.CurrAsmList,hl);
+    end;
+
+    { Dividing low(longint) by -1 will overflow }
+    if is_signed(right.resultdef) and (cs_check_overflow in current_settings.localswitches) then
     begin
-      if is_signed({left.resultdef}right.resultdef) then
-      begin
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_DIV, resultreg, numerator, divider));
-      end
-      else
-        current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_DIVU, resultreg, numerator, divider));
+      current_asmdata.getjumplabel(hl2);
+      current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_const(A_ADDIU,NR_R1,NR_R0,-1));
+      cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,divider,NR_R1,hl2);
+      current_asmdata.CurrAsmList.concat(taicpu.op_reg_const(A_LUI,NR_R1,$8000));
+      cg.a_cmp_reg_reg_label(current_asmdata.CurrAsmList,OS_INT,OC_NE,numerator,NR_R1,hl2);
+      current_asmdata.CurrAsmList.concat(taicpu.op_const(A_BREAK,6));
+      cg.a_label(current_asmdata.CurrAsmList,hl2);
     end;
+
+   if (nodetype=modn) then
+     current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_MFHI,location.register))
+   else
+     current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_MFLO,location.register));
   end;
-  { set result location }
-  location.loc      := LOC_REGISTER;
-  location.Register := resultreg;
 end;
 
 
@@ -158,7 +166,7 @@ end;
 
 procedure tMIPSELshlshrnode.pass_generate_code;
 var
-  hregister, resultreg, hregister1, hreg64hi, hreg64lo: tregister;
+  hregister, hreg64hi, hreg64lo: tregister;
   op: topcg;
   shiftval: aword;
 begin
@@ -227,15 +235,8 @@ begin
   begin
     { load left operators in a register }
     hlcg.location_force_reg(current_asmdata.CurrAsmList, left.location, left.resultdef, left.resultdef, True);
-    location_copy(location, left.location);
-    resultreg  := location.Register;
-    hregister1 := location.Register;
-    if (location.loc = LOC_CREGISTER) then
-    begin
-      location.loc := LOC_REGISTER;
-      resultreg    := cg.GetIntRegister(current_asmdata.CurrAsmList, OS_INT);
-      location.Register := resultreg;
-    end;
+    location_reset(location,LOC_REGISTER,def_cgsize(resultdef));
+    location.register:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
     { determine operator }
     if nodetype = shln then
       op := OP_SHL
@@ -245,13 +246,13 @@ begin
     if (right.nodetype = ordconstn) then
     begin
       if tordconstnode(right).Value.svalue and 31 <> 0 then
-        cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, op, OS_32, tordconstnode(right).Value.svalue and 31, hregister1, resultreg);
+        cg.a_op_const_reg_reg(current_asmdata.CurrAsmList, op, OS_32, tordconstnode(right).Value.svalue and 31, left.location.register, location.register);
     end
     else
     begin
       { load shift count in a register if necessary }
       hlcg.location_force_reg(current_asmdata.CurrAsmList, right.location, right.resultdef, right.resultdef, True);
-      cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList, op, OS_32, right.location.Register, hregister1, resultreg);
+      cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList, op, OS_32, right.location.Register, left.location.register, location.register);
     end;
   end;
 end;
@@ -290,34 +291,18 @@ begin
       LOC_SUBSETREG,LOC_CSUBSETREG,LOC_SUBSETREF,LOC_CSUBSETREF:
       begin
         hlcg.location_force_reg(current_asmdata.CurrAsmList, left.location, left.resultdef, left.resultdef, True);
+        location_reset(location,LOC_FLAGS,OS_NO);
+        location.resflags.reg2:=NR_R0;
+        location.resflags.cond:=OC_EQ;
         if is_64bit(resultdef) then
           begin
-            r64.reglo:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
-            r64.reghi:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
+            tmpreg:=cg.GetIntRegister(current_asmdata.CurrAsmList,OS_INT);
             { OR low and high parts together }
-            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_OR,r64.reglo,left.location.register64.reglo,left.location.register64.reghi));
-            { x=0 <=> unsigned(x)<1 }
-            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_const(A_SLTIU,r64.reglo,r64.reglo,1));
-            if is_cbool(resultdef) then
-              begin
-                cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,OS_S32,r64.reglo,r64.reglo);
-                cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_32,OS_32,r64.reglo,r64.reghi);
-              end
-            else
-              cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_32,0,r64.reghi);
-            location_reset(location,LOC_REGISTER,OS_64);
-            location.Register64:=r64;
+            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_OR,tmpreg,left.location.register64.reglo,left.location.register64.reghi));
+            location.resflags.reg1:=tmpreg;
           end
         else
-          begin
-            tmpreg := cg.GetIntRegister(current_asmdata.CurrAsmList, OS_INT);
-            { x=0 <=> unsigned(x)<1 }
-            current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_const(A_SLTIU, tmpreg, left.location.Register, 1));
-            if is_cbool(resultdef) then
-              cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_NEG,OS_S32,tmpreg,tmpreg);
-            location_reset(location, LOC_REGISTER, OS_INT);
-            location.Register := tmpreg;
-          end;
+          location.resflags.reg1:=left.location.register;
       end;
       else
         internalerror(2003042401);

compiler/mips/opcode.inc

@@ -94,18 +94,6 @@ A_MFHI,
 A_MTHI,
 A_MFLO,
 A_MTLO,
-A_MULTG,
-A_DMULTG,
-A_MULTUG,
-A_DMULTUG,
-A_DIVG,
-A_DDIVG,
-A_DIVUG,
-A_DDIVUG,
-A_MODG,
-A_DMODG,
-A_MODUG,
-A_DMODUG,
 A_J,
 A_JAL,
 A_JR,
@@ -193,17 +181,6 @@ A_SLEU,
 A_SNE,
 A_SYSCALL,
 A_BREAK,
-A_ADD64SUB,
-A_SUB64SUB,
-A_MUL64SUB,
-A_DIV64SUB,
-A_NEG64SUB,
-A_NOT64SUB,
-A_OR64SUB,
-A_SAR64SUB,
-A_SHL64SUB,
-A_SHR64SUB,
-A_XOR64SUB,
 A_EHB,
 A_EXT,
 A_INS,

compiler/mips/strinst.inc

@@ -94,18 +94,6 @@
 'mthi',
 'mflo',
 'mtlo',
-'multg',
-'dmultg',
-'multug',
-'dmultug',
-'divg',
-'ddivg',
-'divug',
-'ddivug',
-'modg',
-'dmodg',
-'modug',
-'dmodug',
 'j',
 'jal',
 'jr',
@@ -193,17 +181,6 @@
 'sne',
 'syscall',
 'break',
-'add64sub',
-'sub64sub',
-'mul64sub',
-'div64sub',
-'neg64sub',
-'not64sub',
-'or64sub',
-'sar64sub',
-'shl64sub',
-'shr64sub',
-'xor64sub',
 'ehb',
 'ext',
 'ins',

compiler/msg/errord.msg

@@ -3,7 +3,7 @@
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
 #   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 23596
+#   Based on errore.msg of SVN revision 24910 + 1
 #
 #   This file is part of the Free Pascal Compiler
 #   Copyright (c) 1998-2013 by the Free Pascal Development team
@@ -143,7 +143,7 @@ general_f_oserror=01025_F_Betriebsystemfehler: $1
 #
 # Scanner
 #
-# 02092 is the last used one
+# 02094 is the last used one
 #
 % \section{Scanner messages.}
 % This section lists the messages that the scanner emits. The scanner takes
@@ -395,6 +395,12 @@ scan_w_unavailable_system_codepage=02091_W_Die aktuelle System-Codepage "$1" ste
 % the compiler with support for this codepage.
 scan_w_setpeoptflags_not_support=02092_W_SETPEOPTFLAGS wird f�r das Ziel-OS nicht unterst�tzt
 % The \var{\{\$SETPEOPTFLAGS\}} directive is not supported by the target OS.
+scan_e_illegal_peflag=02093_E_Ung�ltiges Argument f�r SETPEFLAGS
+% The given argument for SETPEFLAGS is neither a correct named value nor an
+% ordinal value
+scan_e_illegal_peoptflag=02094_E_Ung�ltiges Argument f�r SETPEOPTFLAGS
+% The given argument for SETPEOPTFLAGS is neither a correct named value nor an
+% ordinal value
 %
 % \end{description}
 # EndOfTeX
@@ -402,7 +408,7 @@ scan_w_setpeoptflags_not_support=02092_W_SETPEOPTFLAGS wird f
 #
 # Parser
 #
-# 03332 is the last used one
+# 03334 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1498,6 +1504,11 @@ parser_e_not_allowed_in_record=03332_E_Sichtbarkeits-Abschnitt "$1" ist in Recor
 % The visibility sections \var(protected) and \var(strict protected) are only
 % useful together with inheritance. Since records do not support that they are
 % forbidden.
+parser_e_proc_dir_not_allowed=03333_E_Prozedurdirektive "$1" ist hier nicht erlaubt
+% This procedure directive is not allowed in the given context. E.g. "static"
+% is not allowed for instance methods or class operators.
+parser_e_no_assembler_in_generic=03334_E_Assemblerbl”cke sind innerhalb von "generics" nicht erlaubt
+% The use of assembler blocks/routines is not allowed inside generics.
 %
 % \end{description}
 # EndOfTeX
@@ -1928,7 +1939,7 @@ type_e_invalid_default_value=04119_E_Der Defaultwert f
 % Parameters declared as structured types, such as files, variants, non-dynamic
 % arrays and TP-style objects, cannot have a default value.
 type_e_type_not_allowed_for_type_helper=04120_E_Typ "$1" kann durch einen Typhelfer nicht erweitert werden
-% Types like procedural variables can not be extended by type helpers
+% Types like procedural variables cannot be extended by type helpers
 %
 % \end{description}
 # EndOfTeX
@@ -2710,7 +2721,7 @@ asmw_e_handlerdata_no_handler=08025_E_".seh_handlerdata"-Direktive ohne vorangeh
 #
 # Executing linker/assembler
 #
-# 09033 is the last used one
+# 09034 is the last used one
 #
 # BeginOfTeX
 %
@@ -2802,6 +2813,9 @@ exec_e_cant_write_resource_file=09032_E_Kann die Resourcedatei "$1" nicht schrei
 % An error occurred resource file cannot be written.
 exec_n_backquote_cat_file_not_found=09033_N_Die Datei "$1" wurde mit dem Kommando cat nicht gefunden
 % The compiler did not find the file that should be expanded into linker parameters
+exec_w_init_file_not_found=09034_W_"$1" nicht gefunden; dies wird wahrscheinlich zu einem Fehler beim Linken f�hren
+% The compiler adds certain startup code files to the linker only when they are found.
+% If they are not found, they are not added and this might cause a linking failure.
 %
 % \end{description}
 # EndOfTeX
@@ -3346,6 +3360,7 @@ diskutiert werden k
 #    3 = 80x86 targets
 #    4 = x86_64
 #    6 = 680x0 targets
+#    8 = 8086 (16-bit) targets
 #    A = ARM
 #    e = in extended debug mode only
 #    F = help for the 'fpc' binary (independent of the target compiler)
@@ -3641,6 +3656,10 @@ p*2Wi_Benutze interne Resourcen (Darwin)
 3*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
 4*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
 A*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
+8*2Wm<x>_Setze Speichermodell
+8*3WmTiny_Winziges (tiny) Speichermodell
+8*3WmSmall_Kleines (small) Speichermodell (Voreinstellung)
+8*3WmMedium_Mittleres (medium) Speichermodell
 3*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)
 4*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)
 p*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)

compiler/msg/errordu.msg

@@ -3,7 +3,7 @@
 #   Latest updates contributed by Karl-Michael Schindler aka mischi
 #   <karl-michael.schindler at web.de>
 #
-#   Based on errore.msg of SVN revision 23596
+#   Based on errore.msg of SVN revision 24910 + 1
 #
 #   This file is part of the Free Pascal Compiler
 #   Copyright (c) 1998-2013 by the Free Pascal Development team
@@ -143,7 +143,7 @@ general_f_oserror=01025_F_Betriebsystemfehler: $1
 #
 # Scanner
 #
-# 02092 is the last used one
+# 02094 is the last used one
 #
 % \section{Scanner messages.}
 % This section lists the messages that the scanner emits. The scanner takes
@@ -395,7 +395,12 @@ scan_w_unavailable_system_codepage=02091_W_Die aktuelle System-Codepage "$1" ste
 % the compiler with support for this codepage.
 scan_w_setpeoptflags_not_support=02092_W_SETPEOPTFLAGS wird für das Ziel-OS nicht unterstützt
 % The \var{\{\$SETPEOPTFLAGS\}} directive is not supported by the target OS.
-%
+scan_e_illegal_peflag=02093_E_Ungültiges Argument für SETPEFLAGS
+% The given argument for SETPEFLAGS is neither a correct named value nor an
+% ordinal value
+scan_e_illegal_peoptflag=02094_E_Ungültiges Argument für SETPEOPTFLAGS
+% The given argument for SETPEOPTFLAGS is neither a correct named value nor an
+% ordinal value
 %
 % \end{description}
 # EndOfTeX
@@ -403,7 +408,7 @@ scan_w_setpeoptflags_not_support=02092_W_SETPEOPTFLAGS wird für das Ziel-OS nic
 #
 # Parser
 #
-# 03332 is the last used one
+# 03334 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1499,6 +1504,11 @@ parser_e_not_allowed_in_record=03332_E_Sichtbarkeits-Abschnitt "$1" ist in Recor
 % The visibility sections \var(protected) and \var(strict protected) are only
 % useful together with inheritance. Since records do not support that they are
 % forbidden.
+parser_e_proc_dir_not_allowed=03333_E_Prozedurdirektive "$1" ist hier nicht erlaubt
+% This procedure directive is not allowed in the given context. E.g. "static"
+% is not allowed for instance methods or class operators.
+parser_e_no_assembler_in_generic=03334_E_Assemblerblöcke sind innerhalb von "generics" nicht erlaubt
+% The use of assembler blocks/routines is not allowed inside generics.
 %
 % \end{description}
 # EndOfTeX
@@ -1929,7 +1939,7 @@ type_e_invalid_default_value=04119_E_Der Defaultwert für einen Parameter des Ty
 % Parameters declared as structured types, such as files, variants, non-dynamic
 % arrays and TP-style objects, cannot have a default value.
 type_e_type_not_allowed_for_type_helper=04120_E_Typ "$1" kann durch einen Typhelfer nicht erweitert werden
-% Types like procedural variables can not be extended by type helpers
+% Types like procedural variables cannot be extended by type helpers
 %
 % \end{description}
 # EndOfTeX
@@ -2711,7 +2721,7 @@ asmw_e_handlerdata_no_handler=08025_E_".seh_handlerdata"-Direktive ohne vorangeh
 #
 # Executing linker/assembler
 #
-# 09033 is the last used one
+# 09034 is the last used one
 #
 # BeginOfTeX
 %
@@ -2803,6 +2813,9 @@ exec_e_cant_write_resource_file=09032_E_Kann die Resourcedatei "$1" nicht schrei
 % An error occurred resource file cannot be written.
 exec_n_backquote_cat_file_not_found=09033_N_Die Datei "$1" wurde mit dem Kommando cat nicht gefunden
 % The compiler did not find the file that should be expanded into linker parameters
+exec_w_init_file_not_found=09034_W_"$1" nicht gefunden; dies wird wahrscheinlich zu einem Fehler beim Linken führen
+% The compiler adds certain startup code files to the linker only when they are found.
+% If they are not found, they are not added and this might cause a linking failure.
 %
 % \end{description}
 # EndOfTeX
@@ -3347,6 +3360,7 @@ diskutiert werden können, usw.):
 #    3 = 80x86 targets
 #    4 = x86_64
 #    6 = 680x0 targets
+#    8 = 8086 (16-bit) targets
 #    A = ARM
 #    e = in extended debug mode only
 #    F = help for the 'fpc' binary (independent of the target compiler)
@@ -3642,6 +3656,10 @@ p*2Wi_Benutze interne Resourcen (Darwin)
 3*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
 4*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
 A*2WI_Die Verwendung der "import"-Abschnitte ein/ausschalten (Windows)
+8*2Wm<x>_Setze Speichermodell
+8*3WmTiny_Winziges (tiny) Speichermodell
+8*3WmSmall_Kleines (small) Speichermodell (Voreinstellung)
+8*3WmMedium_Mittleres (medium) Speichermodell
 3*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)
 4*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)
 p*2WM<x>_Minimale Mac OS X Deployment Version: 10.4, 10.5.1, ... (Darwin)

compiler/msg/errore.msg

@@ -2705,7 +2705,7 @@ asmw_f_too_many_relocations=08026_F_Relocation count for section $1 exceeds 6553
 #
 # Executing linker/assembler
 #
-# 09033 is the last used one
+# 09034 is the last used one
 #
 # BeginOfTeX
 %
@@ -2797,10 +2797,11 @@ exec_e_cant_write_resource_file=09032_E_Can't write resource file "$1"
 % An error occurred resource file cannot be written.
 exec_n_backquote_cat_file_not_found=09033_N_File "$1" not found for backquoted cat command
 % The compiler did not find the file that should be expanded into linker parameters
-%\end{description}
 exec_w_init_file_not_found=09034_W_"$1" not found, this will probably cause a linking failure
 % The compiler adds certain startup code files to the linker only when they are found.
 % If they are not found, they are not added and this might cause a linking failure.
+%
+%\end{description}
 # EndOfTeX
 
 #

compiler/nadd.pas

@@ -38,6 +38,7 @@ interface
        public
           resultrealdef : tdef;
           constructor create(tt : tnodetype;l,r : tnode);override;
+          constructor create_internal(tt:tnodetype;l,r:tnode);
           constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           procedure buildderefimpl;override;
@@ -153,6 +154,13 @@ implementation
       end;
 
 
+    constructor taddnode.create_internal(tt:tnodetype;l,r:tnode);
+      begin
+        create(tt,l,r);
+        include(flags,nf_internal);
+      end;
+
+
     constructor taddnode.ppuload(t: tnodetype; ppufile: tcompilerppufile);
       begin
         inherited ppuload(t, ppufile);
@@ -1638,7 +1646,8 @@ implementation
                  end;
                ltn,lten,gtn,gten:
                  begin
-                    if (cs_extsyntax in current_settings.moduleswitches) then
+                    if (cs_extsyntax in current_settings.moduleswitches) or
+                       (nf_internal in flags) then
                      begin
                        if is_voidpointer(right.resultdef) then
                         inserttypeconv(right,left.resultdef)

compiler/nbas.pas

@@ -143,7 +143,10 @@ interface
          ti_readonly,
          { if this is a managed temp, it doesn't have to be finalised before use
          }
-         ti_nofini
+         ti_nofini,
+         { the value described by this temp. node is const/immutable, this is important for
+           managed types like ansistrings where temp. refs are pointers to the actual value }
+         ti_const
          );
        ttempinfoflags = set of ttempinfoflag;
 

compiler/ncal.pas

@@ -2307,7 +2307,7 @@ implementation
           exit;
 
         { remove possible typecasts }
-        realassignmenttarget:=aktassignmentnode.left.actualtargetnode;
+        realassignmenttarget:=actualtargetnode(@aktassignmentnode.left)^;
 
         { when it is not passed in a parameter it will only be used after the
           function call }
@@ -2327,7 +2327,7 @@ implementation
           point
         }
         if assigned(methodpointer) and
-           realassignmenttarget.isequal(methodpointer.actualtargetnode) then
+           realassignmenttarget.isequal(actualtargetnode(@methodpointer)^) then
           exit;
 
         { when we substitute a function result inside an inlined function,
@@ -3169,7 +3169,7 @@ implementation
                { skip (absolute and other simple) type conversions -- only now,
                  because the checks above have to take type conversions into
                  e.g. class reference types account }
-               hpt:=hpt.actualtargetnode;
+               hpt:=actualtargetnode(@hpt)^;
 
                { R.Init then R will be initialized by the constructor,
                  Also allow it for simple loads }
@@ -3904,12 +3904,27 @@ implementation
                       begin
                         tempnode := ctempcreatenode.create(para.parasym.vardef,para.parasym.vardef.size,
                           tt_persistent,tparavarsym(para.parasym).is_regvar(false));
+
+                        { inherit const }
+                        if tabstractvarsym(para.parasym).varspez=vs_const then
+                          begin
+                            include(tempnode.tempinfo^.flags,ti_const);
+
+                            { apply less strict rules for the temp. to be a register than
+                              ttempcreatenode does
+
+                              this way, dyn. array, ansistrings etc. can be put into registers as well }
+                            if tparavarsym(para.parasym).is_regvar(false) then
+                              include(tempnode.tempinfo^.flags,ti_may_be_in_reg);
+                          end;
+
                         addstatement(inlineinitstatement,tempnode);
 
                         if localvartrashing <> -1 then
                           cnodeutils.maybe_trash_variable(inlineinitstatement,para.parasym,ctemprefnode.create(tempnode));
 
                         addstatement(inlinecleanupstatement,ctempdeletenode.create(tempnode));
+
                         addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),
                             para.left));
                         para.left := ctemprefnode.create(tempnode);
@@ -3956,6 +3971,9 @@ implementation
         { inherit addr_taken flag }
         if (tabstractvarsym(para.parasym).addr_taken) then
           include(tempnode.tempinfo^.flags,ti_addr_taken);
+        { inherit read only }
+        if tabstractvarsym(para.parasym).varspez=vs_const then
+          include(tempnode.tempinfo^.flags,ti_const);
         paraaddr:=caddrnode.create_internal(para.left);
         include(paraaddr.flags,nf_typedaddr);
         addstatement(inlineinitstatement,cassignmentnode.create(ctemprefnode.create(tempnode),

compiler/ncgbas.pas

@@ -415,13 +415,11 @@ interface
         if not(ti_reference in tempinfo^.flags) then
           begin
             { get a (persistent) temp }
-            if is_managed_type(tempinfo^.typedef) then
+            if is_managed_type(tempinfo^.typedef) and
+              not(ti_const in tempinfo^.flags) then
               begin
                 location_reset_ref(tempinfo^.location,LOC_REFERENCE,def_cgsize(tempinfo^.typedef),0);
                 tg.gethltemptyped(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.temptype,tempinfo^.location.reference);
-                { the temp could have been used previously either because the memory location was reused or
-                  because we're in a loop. In case it's used as a function result, that doesn't matter
-                  because it will be finalized when assigned to. }
                 if not(ti_nofini in tempinfo^.flags) then
                   hlcg.g_finalize(current_asmdata.CurrAsmList,tempinfo^.typedef,tempinfo^.location.reference);
               end

compiler/ncgcnv.pas

@@ -115,6 +115,18 @@ interface
                     location.reference.alignment:=newalignment(location.reference.alignment,leftsize-ressize);
                   end;
               end
+{$if not defined(cpu16bitalu) and not defined(cpu8bitalu)}
+            { On targets without 8/16 bit register components, 8/16-bit operations
+              always adjust high bits of result, see 'maybeadjustresult' method in
+              respective cgcpu.pas. Therefore 8/16-bit locations are valid as larger
+              ones (except OS_S8->OS_16 which still needs high 16 bits cleared). }
+            else if (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) and
+              (tcgsize2size[(reg_cgsize(left.location.register))]=sizeof(aint)) and
+              (ressize>leftsize) and
+              (newsize in [OS_32,OS_S32,OS_16,OS_S16]) and
+              not ((newsize=OS_16) and (def_cgsize(left.resultdef)=OS_S8)) then
+              location.size:=newsize
+{$endif}
             else
               hlcg.location_force_reg(current_asmdata.CurrAsmList,location,left.resultdef,resultdef,false);
           end
@@ -180,7 +192,11 @@ interface
 {$if defined(POWERPC) or defined(POWERPC64)}
         resflags.cr := RS_CR0;
         resflags.flag:=F_NE;
-{$else defined(POWERPC) or defined(POWERPC64)}
+{$elseif defined(mips)}
+        resflags.reg1:=NR_NO;
+        resflags.reg2:=NR_NO;
+        resflags.cond:=OC_NONE;
+{$else}
         { Load left node into flag F_NE/F_E }
         resflags:=F_NE;
 {$endif defined(POWERPC) or defined(POWERPC64)}
@@ -652,28 +668,9 @@ interface
       begin
          location_reset(location,LOC_REGISTER,OS_ADDR);
          current_asmdata.getjumplabel(l1);
-         case left.location.loc of
-            LOC_CREGISTER,LOC_REGISTER:
-              begin
-               {$ifdef cpu_uses_separate_address_registers}
-                 if getregtype(left.location.register)<>R_ADDRESSREGISTER then
-                   begin
-                     location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                     cg.a_load_reg_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,
-                              left.location.register,location.register);
-                   end
-                 else
-               {$endif}
-                    location.register := left.location.register;
-              end;
-            LOC_CREFERENCE,LOC_REFERENCE:
-              begin
-                location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,left.location.reference,location.register);
-              end;
-            else
-              internalerror(2002032214);
-         end;
+         location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
+         cg.a_load_loc_reg(current_asmdata.CurrAsmList,OS_ADDR,
+           left.location,location.register);
          cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList,OS_ADDR,OC_NE,0,location.register,l1);
          { FPC_EMPTYCHAR is a widechar -> 2 bytes }
          reference_reset(hr,2);

compiler/ncgflw.pas

@@ -401,7 +401,7 @@ implementation
                  { variable. The start value also doesn't matter.          }
 
                  { loop var }
-                 get_used_regvars(right,usedregvars);
+                 get_used_regvars(left,usedregvars);
                  { loop body }
                  get_used_regvars(t2,usedregvars);
                  { end value (t1) is not necessary (it cannot be a regvar, }
@@ -818,6 +818,8 @@ implementation
          hlcg.a_label(current_asmdata.CurrAsmList,current_procinfo.CurrBreakLabel);
 
          sync_regvars(false);
+         if temptovalue then
+           hlcg.a_reg_sync(current_asmdata.CurrAsmList,t1.location.register);
 
          current_procinfo.CurrContinueLabel:=oldclabel;
          current_procinfo.CurrBreakLabel:=oldblabel;

compiler/ncgld.pas

@@ -72,7 +72,7 @@ implementation
       aasmbase,
       cgbase,pass_2,
       procinfo,
-      cpubase,parabase,
+      cpubase,parabase,cpuinfo,
       tgobj,ncgutil,
       cgobj,hlcgobj,
       ncgbas,ncgflw,
@@ -527,16 +527,40 @@ implementation
                          else
                            hregister:=location.registerhi;
                          { load method address }
-                         reference_reset_base(href,hregister,tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber),sizeof(pint));
-                         location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                         cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,location.register);
+{$ifdef i8086}
+                         if po_far in procdef.procoptions then
+                           begin
+                             reference_reset_base(href,hregister,tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber),4);
+                             location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
+                             cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_32,OS_32,href,location.register);
+                           end
+                         else
+{$endif i8086}
+                           begin
+                             reference_reset_base(href,hregister,tobjectdef(procdef.struct).vmtmethodoffset(procdef.extnumber),sizeof(pint));
+                             location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                             cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_ADDR,OS_ADDR,href,location.register);
+                           end;
                        end
                      else
                        begin
                          { load address of the function }
-                         reference_reset_symbol(href,current_asmdata.RefAsmSymbol(procdef.mangledname),0,sizeof(pint));
-                         location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
-                         cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,location.register);
+{$ifdef i8086}
+                         if po_far in procdef.procoptions then
+                           begin
+                             reference_reset_symbol(href,current_asmdata.RefAsmSymbol(procdef.mangledname),0,sizeof(pint));
+                             location.register:=cg.getintregister(current_asmdata.CurrAsmList,OS_32);
+                             cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,location.register);
+                             href.refaddr:=addr_seg;
+                             cg.a_load_ref_reg(current_asmdata.CurrAsmList,OS_16,OS_16,href,GetNextReg(location.register));
+                           end
+                         else
+{$endif i8086}
+                           begin
+                             reference_reset_symbol(href,current_asmdata.RefAsmSymbol(procdef.mangledname),0,sizeof(pint));
+                             location.register:=cg.getaddressregister(current_asmdata.CurrAsmList);
+                             cg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,href,location.register);
+                           end;
                        end;
 
                      { to get methodpointers stored correctly, code and self register must be swapped on
@@ -588,12 +612,13 @@ implementation
          r64 : tregister64;
          oldflowcontrol : tflowcontrol;
       begin
+        { previously, managed types were handled in firstpass
+          newer FPCs however can identify situations when
+          assignments of managed types require no special code and the
+          value could be just copied so this could should be able also to handle
+          managed types without any special "managing code"}
+
         location_reset(location,LOC_VOID,OS_NO);
-        { managed types should be handled in firstpass }
-        if not(target_info.system in systems_garbage_collected_managed_types) and
-           (is_managed_type(left.resultdef) or
-            is_managed_type(right.resultdef)) then
-          InternalError(2012011901);
 
         otlabel:=current_procinfo.CurrTrueLabel;
         oflabel:=current_procinfo.CurrFalseLabel;
@@ -881,6 +906,37 @@ implementation
                       right.location.register64,left.location)
                   else
 {$endif cpu64bitalu}
+{$ifdef i8086}
+                  { 6-byte method pointer support for the i8086 medium and compact memory models }
+                  if (left.resultdef.typ = procvardef) and (left.resultdef.size = 6) then
+                    begin
+                      case left.location.loc of
+                        LOC_REFERENCE,LOC_CREFERENCE:
+                          begin
+                            href:=left.location.reference;
+                            { proc address }
+                            if po_far in tprocdef(right.resultdef).procoptions then
+                              begin
+                                cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_32,OS_32,right.location.register,href);
+                                inc(href.offset, 4)
+                              end
+                            else
+                              begin
+                                cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_16,OS_16,right.location.register,href);
+                                inc(href.offset, 2);
+                              end;
+                            { object self }
+                            if current_settings.x86memorymodel in x86_far_data_models then
+                              cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_32,OS_32,right.location.registerhi,href)
+                            else
+                              cg.a_load_reg_ref(current_asmdata.CurrAsmList,OS_16,OS_16,right.location.registerhi,href);
+                          end;
+                        else
+                          internalerror(2013072001);
+                      end;
+                    end
+                  else
+{$endif i8086}
                     hlcg.a_load_reg_loc(current_asmdata.CurrAsmList,right.resultdef,left.resultdef,right.location.register,left.location);
                 end;
               LOC_FPUREGISTER,

compiler/ncgmem.pas

@@ -84,9 +84,10 @@ implementation
       symconst,symbase,symtype,symdef,symsym,symtable,defutil,paramgr,
       aasmbase,aasmtai,aasmdata,
       procinfo,pass_2,parabase,
-      pass_1,nld,ncon,nadd,nutils,
+      pass_1,nld,ncon,nadd,ncnv,nutils,
       cgutils,cgobj,hlcgobj,
-      tgobj,ncgutil,objcgutl
+      tgobj,ncgutil,objcgutl,
+      defcmp
       ;
 
 
@@ -218,14 +219,38 @@ implementation
         pd : tprocdef;
         sym : tsym;
         st : tsymtable;
+        hp : pnode;
+        hp2 : tnode;
+        extraoffset : tcgint;
       begin
-         secondpass(left);
          { assume natural alignment, except for packed records }
          if not(resultdef.typ in [recorddef,objectdef]) or
             (tabstractrecordsymtable(tabstractrecorddef(resultdef).symtable).usefieldalignment<>1) then
            location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),resultdef.alignment)
          else
            location_reset_ref(location,LOC_REFERENCE,def_cgsize(resultdef),1);
+
+         { can we fold an add/sub node into the offset of the deref node? }
+         extraoffset:=0;
+         hp:=actualtargetnode(@left);
+         if (hp^.nodetype=subn) and is_constintnode(taddnode(hp^).right) then
+           begin
+             extraoffset:=-tcgint(tordconstnode(taddnode(hp^).right).value);
+             replacenode(hp^,taddnode(hp^).left);
+           end
+         else if (hp^.nodetype=addn) and is_constintnode(taddnode(hp^).right) then
+           begin
+             extraoffset:=tcgint(tordconstnode(taddnode(hp^).right).value);
+             replacenode(hp^,taddnode(hp^).left);
+           end
+         else if (hp^.nodetype=addn) and is_constintnode(taddnode(hp^).left) then
+           begin
+             extraoffset:=tcgint(tordconstnode(taddnode(hp^).left).value);
+             replacenode(hp^,taddnode(hp^).right);
+           end;
+
+         secondpass(left);
+
          if not(left.location.loc in [LOC_CREGISTER,LOC_REGISTER,LOC_CREFERENCE,LOC_REFERENCE,LOC_CONSTANT]) then
            hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
          case left.location.loc of
@@ -257,6 +282,7 @@ implementation
             else
               internalerror(200507031);
          end;
+         location.reference.offset:=location.reference.offset+extraoffset;
          if (cs_use_heaptrc in current_settings.globalswitches) and
             (cs_checkpointer in current_settings.localswitches) and
             not(cs_compilesystem in current_settings.moduleswitches) and
@@ -803,7 +829,7 @@ implementation
       var
          offsetdec,
          extraoffset : aint;
-         t        : tnode;
+         rightp      : pnode;
          otl,ofl  : tasmlabel;
          newsize  : tcgsize;
          mulsize,
@@ -895,6 +921,8 @@ implementation
            begin
               { may happen in case of function results }
               case left.location.loc of
+                LOC_CREGISTER,
+                LOC_CMMREGISTER,
                 LOC_REGISTER,
                 LOC_MMREGISTER:
                   hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
@@ -981,34 +1009,26 @@ implementation
                  not is_packed_array(left.resultdef) then
                 begin
                    extraoffset:=0;
-                   if (right.nodetype=addn) then
+                   rightp:=actualtargetnode(@right);
+                   if rightp^.nodetype=addn then
                      begin
-                        if taddnode(right).right.nodetype=ordconstn then
+                        if taddnode(rightp^).right.nodetype=ordconstn then
                           begin
-                             extraoffset:=tordconstnode(taddnode(right).right).value.svalue;
-                             t:=taddnode(right).left;
-                             taddnode(right).left:=nil;
-                             right.free;
-                             right:=t;
+                            extraoffset:=tordconstnode(taddnode(rightp^).right).value.svalue;
+                            replacenode(rightp^,taddnode(rightp^).left);
                           end
-                        else if taddnode(right).left.nodetype=ordconstn then
+                        else if taddnode(rightp^).left.nodetype=ordconstn then
                           begin
-                             extraoffset:=tordconstnode(taddnode(right).left).value.svalue;
-                             t:=taddnode(right).right;
-                             taddnode(right).right:=nil;
-                             right.free;
-                             right:=t;
+                            extraoffset:=tordconstnode(taddnode(rightp^).left).value.svalue;
+                            replacenode(rightp^,taddnode(rightp^).right);
                           end;
                      end
-                   else if (right.nodetype=subn) then
+                   else if rightp^.nodetype=subn then
                      begin
-                        if taddnode(right).right.nodetype=ordconstn then
+                        if taddnode(rightp^).right.nodetype=ordconstn then
                           begin
-                             extraoffset:=-tordconstnode(taddnode(right).right).value.svalue;
-                             t:=taddnode(right).left;
-                             taddnode(right).left:=nil;
-                             right.free;
-                             right:=t;
+                            extraoffset:=-tordconstnode(taddnode(rightp^).right).value.svalue;
+                            replacenode(rightp^,taddnode(rightp^).left);
                           end;
                      end;
                    inc(location.reference.offset,

compiler/ncgrtti.pas

@@ -1299,7 +1299,7 @@ implementation
     procedure TRTTIWriter.write_rtti_reference(def:tdef;rt:trttitype);
       begin
         if not assigned(def) or is_void(def) or ((rt<>initrtti) and is_objc_class_or_protocol(def)) then
-          current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(nil))
+          current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_nil_dataptr)
         else
           current_asmdata.asmlists[al_rtti].concat(Tai_const.Create_sym(ref_rtti(def,rt)));
       end;

compiler/ncgutil.pas

@@ -1058,11 +1058,11 @@ implementation
             begin
 {$ifdef mips}
               if (destloc.size = paraloc^.Size) and
-                 (paraloc^.Loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER]) then
+                 (paraloc^.Loc in [LOC_FPUREGISTER,LOC_CFPUREGISTER,LOC_REFERENCE,LOC_CREFERENCE]) then
                 begin
                   unget_para(paraloc^);
                   gen_alloc_regloc(list,destloc);
-                  cg.a_loadfpu_reg_reg(list,paraloc^.Size, destloc.size, paraloc^.register, destloc.register);
+                  cg.a_load_cgparaloc_anyreg(list,destloc.size,paraloc^,destloc.register,para.alignment);
                 end
               else if (destloc.size = OS_F32) and
                  (paraloc^.Loc in [LOC_REGISTER,LOC_CREGISTER]) then

compiler/ncnv.pas

@@ -48,7 +48,6 @@ interface
           procedure buildderefimpl;override;
           procedure derefimpl;override;
           function dogetcopy : tnode;override;
-          function actualtargetnode: tnode;override;
           procedure printnodeinfo(var t : text);override;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
@@ -2101,15 +2100,6 @@ implementation
       end;
 
 
-    function ttypeconvnode.actualtargetnode: tnode;
-      begin
-        result:=self;
-        while (result.nodetype=typeconvn) and
-              ttypeconvnode(result).retains_value_location do
-          result:=ttypeconvnode(result).left;
-      end;
-
-
     function ttypeconvnode.pass_typecheck:tnode;
 
       var

compiler/nflw.pas

@@ -1874,6 +1874,8 @@ implementation
         if assigned(left) then
           firstpass(left);
         if (m_non_local_goto in current_settings.modeswitches) and
+            { the owner can be Nil for internal labels }
+            assigned(labsym.owner) and
           (current_procinfo.procdef.parast.symtablelevel<>labsym.owner.symtablelevel) then
           CGMessage(cg_e_labels_cannot_defined_outside_declaration_scope)
       end;

compiler/ninl.pas

@@ -4004,7 +4004,7 @@ implementation
          paras:=tcallparanode(tcallparanode(left).right);
          paras:=ccallparanode.create(cstringconstnode.createstr(current_module.sourcefiles.get_file_name(current_filepos.fileindex)),paras);
          paras:=ccallparanode.create(genintconstnode(fileinfo.line),paras);
-{$if defined(x86) or defined(arm) or defined(jvm)}
+{$ifdef SUPPORT_GET_FRAME}
          paras:=ccallparanode.create(geninlinenode(in_get_frame,false,nil),paras);
 {$else}
          paras:=ccallparanode.create(ccallnode.createinternfromunit('SYSTEM','GET_FRAME',nil),paras);

compiler/nld.pas

@@ -852,7 +852,8 @@ implementation
            right:=nil;
            exit;
          end
-        else if not(target_info.system in systems_garbage_collected_managed_types) then
+        else if not(target_info.system in systems_garbage_collected_managed_types) and
+          not(is_const(left)) then
           begin
             { call helpers for pointer-sized managed types }
             if is_widestring(left.resultdef) then

compiler/node.pas

@@ -367,10 +367,6 @@ interface
          { does the real copying of a node }
          function dogetcopy : tnode;virtual;
 
-         { returns the real loadn/temprefn a node refers to,
-           skipping (absolute) equal type conversions        }
-         function actualtargetnode: tnode;virtual;
-
          procedure insertintolist(l : tnodelist);virtual;
          { writes a node for debugging purpose, shouldn't be called }
          { direct, because there is no test for nil, use printnode  }
@@ -952,12 +948,6 @@ implementation
       end;
 
 
-    function tnode.actualtargetnode: tnode;
-      begin
-        result:=self;
-      end;
-
-
     procedure tnode.insertintolist(l : tnodelist);
       begin
       end;

compiler/nutils.pas

@@ -82,6 +82,7 @@ interface
 
     { tries to simplify the given node after inlining }
     procedure doinlinesimplify(var n : tnode);
+
     { creates an ordinal constant, optionally based on the result from a
       simplify operation: normally the type is the smallest integer type
       that can hold the value, but when inlining the "def" will be used instead,
@@ -118,6 +119,22 @@ interface
       rough estimation how large the tree "node" is }
     function node_count(node : tnode) : dword;
 
+    { returns true, if the value described by node is constant/immutable, this approximation is safe
+      if no dirty tricks like buffer overflows or pointer magic are used }
+    function is_const(node : tnode) : boolean;
+
+    { returns a pointer to the real node a node refers to,
+      skipping (absolute) equal type conversions. Returning
+      a pointer allows the caller to move/remove/replace this
+      node
+    }
+    function actualtargetnode(n : pnode) : pnode;
+
+    { moves src into dest, before doing so, right is set to nil and dest is freed.
+      Because dest and src are var parameters, this can be done inline in an existing
+      node tree }
+    procedure replacenode(var dest,src : tnode);
+
 implementation
 
     uses
@@ -1127,7 +1144,6 @@ implementation
       end;
 
 
-    { rough estimation how large the tree "node" is }
     function node_count(node : tnode) : dword;
       begin
         nodecount:=0;
@@ -1136,4 +1152,35 @@ implementation
       end;
 
 
+    function is_const(node : tnode) : boolean;
+      begin
+        result:=(node.nodetype=temprefn) and (ti_const in ttemprefnode(node).tempinfo^.flags)
+      end;
+
+
+    function actualtargetnode(n : pnode) : pnode;
+      begin
+        result:=n;
+        case n^.nodetype of
+          typeconvn:
+            if ttypeconvnode(n^).retains_value_location then
+              result:=actualtargetnode(@ttypeconvnode(n^).left);
+        end;
+      end;
+
+
+    procedure replacenode(var dest,src : tnode);
+      var
+        t : tnode;
+      begin
+        t:=src;
+        { set src nil before free'ing dest because
+          src could be part of dest }
+        src:=nil;
+        dest.Free;
+        dest:=t;
+      end;
+
+
+
 end.

compiler/ogmap.pas

@@ -61,6 +61,40 @@ implementation
       globals,verbose;
 
 
+    const
+      HexTbl : array[0..15] of char='0123456789abcdef';
+
+    function sizestr(v:aword):string;
+      var
+        tmp:array [0..19] of char;
+        i:longint;
+      begin
+        if v=0 then
+          result:='0x0'
+        else
+          begin
+            i:=high(tmp);
+            while (v>0) do
+              begin
+                tmp[i]:=hextbl[v and $f];
+                v:=v shr 4;
+                dec(i);
+              end;
+            tmp[i]:='x';
+            tmp[i-1]:='0';
+            setstring(result,@tmp[i-1],high(tmp)+2-i);
+          end;
+      end;
+
+    function PadSpaceLeft(const s:string;len:longint):string;
+      begin
+        if length(s)<len then
+          result:=Space(len-length(s))+s
+        else
+          result:=s;
+      end;
+
+
 {****************************************************************************
                                   TExeMap
 ****************************************************************************}
@@ -111,7 +145,7 @@ implementation
             writeln(t,p.name);
             s:='';
           end;
-         Add(PadSpace(s,20)+'0x'+PadSpace(hexstr(p.size,1),16)+p.objsection.objdata.name);
+         Add(PadSpace(s,20)+'0x'+PadSpace(sizestr(p.size),16)+p.objsection.objdata.name);
        end;
 
 
@@ -121,7 +155,7 @@ implementation
        begin
          FImageBase:=abase;
          if FImageBase<>0 then
-           imagebasestr:=' (ImageBase='+HexStr(FImageBase,sizeof(pint)*2)+')'
+           imagebasestr:=' (ImageBase=0x'+HexStr(FImageBase,sizeof(pint)*2)+')'
          else
            imagebasestr:='';
          AddHeader('Memory map'+imagebasestr);
@@ -132,8 +166,8 @@ implementation
      procedure TExeMap.AddMemoryMapExeSection(p:texesection);
        begin
          { .text           0x000018a8     0xd958 }
-         Add(PadSpace(p.name,19)+PadSpace(' 0x'+HexStr(p.mempos+Fimagebase,sizeof(pint)*2),12)+
-             ' 0x'+HexStr(p.size,sizeof(pint)));
+         Add(PadSpace(p.name,15)+PadSpace(' 0x'+HexStr(p.mempos+Fimagebase,sizeof(pint)*2),12)+
+             ' '+PadSpaceLeft(sizestr(p.size),9));
        end;
 
 
@@ -143,20 +177,20 @@ implementation
        begin
          { .text           0x000018a8     0xd958     object.o }
          secname:=p.name;
-         if Length(secname)>18 then
+         if Length(secname)>14 then
            begin
              Add(' '+secname);
              secname:='';
            end;
-         Add(' '+PadSpace(secname,18)+PadSpace(' 0x'+HexStr(p.mempos+FImageBase,sizeof(pint)*2),12)+
-             ' 0x'+HexStr(p.size,sizeof(pint))+' '+p.objdata.name);
+         Add(' '+PadSpace(secname,14)+PadSpace(' 0x'+HexStr(p.mempos+FImageBase,sizeof(pint)*2),12)+
+             ' '+PadSpaceLeft(sizestr(p.size),9)+' '+p.objdata.name);
        end;
 
 
      procedure TExeMap.AddMemoryMapSymbol(p:TObjSymbol);
        begin
          {                 0x00001e30                setup_screens }
-         Add(Space(20)+PadSpace('0x'+HexStr(p.address+Fimagebase,sizeof(pint)*2),25)+' '+p.name);
+         Add(Space(16)+PadSpace('0x'+HexStr(p.address+Fimagebase,sizeof(pint)*2),25)+' '+p.name);
        end;
 
 end.

compiler/optcse.pas

@@ -151,7 +151,7 @@ unit optcse;
           assigned(n.resultdef) and
           (
             { regable expressions }
-            (n.actualtargetnode.flags*[nf_write,nf_modify]=[]) and
+            (actualtargetnode(@n)^.flags*[nf_write,nf_modify]=[]) and
             ((tstoreddef(n.resultdef).is_intregable or tstoreddef(n.resultdef).is_fpuregable) and
             { is_int/fpuregable allows arrays and records to be in registers, cse cannot handle this }
             (not(n.resultdef.typ in [arraydef,recorddef])) and

compiler/options.pas

@@ -2860,9 +2860,9 @@ begin
   def_system_macro('FPC_HAS_MEMBAR');
   def_system_macro('FPC_SETBASE_USED');
 
-{$if defined(x86) or defined(arm) or defined(jvm)}
+{$ifdef SUPPORT_GET_FRAME}
   def_system_macro('INTERNAL_BACKTRACE');
-{$endif}
+{$endif SUPPORT_GET_FRAME}
   def_system_macro('STR_CONCAT_PROCS');
 {$warnings off}
   if pocall_default = pocall_register then

compiler/pstatmnt.pas

@@ -1295,8 +1295,14 @@ implementation
                     not(is_void(p.resultdef)) and
                     { can be nil in case there was an error in the expression }
                     assigned(tcallnode(p).procdefinition) and
-                    not((tcallnode(p).procdefinition.proctypeoption=potype_constructor) and
-                        is_object(tprocdef(tcallnode(p).procdefinition).struct)) then
+                    { allow constructor calls to drop the result if they are
+                      called as instance methods instead of class methods }
+                    not(
+                      (tcallnode(p).procdefinition.proctypeoption=potype_constructor) and
+                      is_class_or_object(tprocdef(tcallnode(p).procdefinition).struct) and
+                      assigned(tcallnode(p).methodpointer) and
+                      (tnode(tcallnode(p).methodpointer).resultdef.typ=objectdef)
+                    ) then
                    Message(parser_e_illegal_expression);
                end;
              code:=p;

compiler/psub.pas

@@ -449,7 +449,7 @@ implementation
                       begin
                         { if vmt>1 then newinstance }
                         addstatement(newstatement,cifnode.create(
-                            caddnode.create(gtn,
+                            caddnode.create_internal(gtn,
                                 ctypeconvnode.create_internal(
                                     load_vmt_pointer_node,
                                     voidpointertype),
@@ -1024,10 +1024,6 @@ implementation
               end;
           end;
 {$endif defined(x86) or defined(arm)}
-{$ifdef MIPS}
-        framepointer:=NR_STACK_POINTER_REG;
-        tg.direction:=1;
-{$endif MIPS}
         { set the start offset to the start of the temp area in the stack }
         set_first_temp_offset;
       end;
@@ -1821,8 +1817,10 @@ implementation
         if tsym(p).typ<>paravarsym then
          exit;
         with tparavarsym(p) do
-          if is_managed_type(vardef) and
-             (varspez in [vs_value,vs_out]) then
+          if (is_managed_type(vardef) and
+             (varspez in [vs_value,vs_out])) or
+             (is_shortstring(vardef) and
+             (varspez=vs_value)) then
             include(current_procinfo.flags,pi_do_call);
       end;
 

compiler/psystem.pas

@@ -96,9 +96,9 @@ implementation
         systemunit.insert(tsyssym.create('Length',in_length_x));
         systemunit.insert(tsyssym.create('New',in_new_x));
         systemunit.insert(tsyssym.create('Dispose',in_dispose_x));
-{$if defined(x86) or defined(arm) or defined(jvm)}
+{$ifdef SUPPORT_GET_FRAME}
         systemunit.insert(tsyssym.create('Get_Frame',in_get_frame));
-{$endif defined(x86) or defined(arm) or defined(jvm)}
+{$endif SUPPORT_GET_FRAME}
         systemunit.insert(tsyssym.create('Unaligned',in_unaligned_x));
         systemunit.insert(tsyssym.create('Aligned',in_aligned_x));
         systemunit.insert(tsyssym.create('ObjCSelector',in_objc_selector_x)); { objc only }

compiler/raatt.pas

@@ -48,6 +48,7 @@ unit raatt;
         AS_RPAREN,AS_COLON,AS_DOT,AS_PLUS,AS_MINUS,AS_STAR,
         AS_SEPARATOR,AS_ID,AS_REGISTER,AS_OPCODE,AS_SLASH,AS_DOLLAR,
         AS_HASH,AS_LSBRACKET,AS_RSBRACKET,AS_LBRACKET,AS_RBRACKET,
+        AS_EQUAL,
         {------------------ Assembler directives --------------------}
         AS_DB,AS_DW,AS_DD,AS_DQ,AS_GLOBAL,
         AS_ALIGN,AS_BALIGN,AS_P2ALIGN,AS_ASCII,
@@ -75,6 +76,7 @@ unit raatt;
         ')',':','.','+','-','*',
         ';','identifier','register','opcode','/','$',
         '#','{','}','[',']',
+        '=',
         '.byte','.word','.long','.quad','.globl',
         '.align','.balign','.p2align','.ascii',
         '.asciz','.lcomm','.comm','.single','.double','.tfloat','.tcfloat',
@@ -651,6 +653,13 @@ unit raatt;
                  c:=current_scanner.asmgetchar;
                  exit;
                end;
+
+             '=' :
+               begin
+                 actasmtoken:=AS_EQUAL;
+                 c:=current_scanner.asmgetchar;
+                 exit;
+               end;
 {$endif arm}
 
              ',' :
@@ -1518,7 +1527,18 @@ unit raatt;
                        begin
                          case sym.typ of
                            staticvarsym :
-                             hs:=tstaticvarsym(sym).mangledname;
+                             begin
+                               { we always assume in asm statements that     }
+                               { that the variable is valid.                 }
+                               tabstractvarsym(sym).varstate:=vs_readwritten;
+                               inc(tabstractvarsym(sym).refs);
+                               { variable can't be placed in a register }
+                               tabstractvarsym(sym).varregable:=vr_none;
+                               { and anything may happen with its address }
+                               tabstractvarsym(sym).addr_taken:=true;
+
+                               hs:=tstaticvarsym(sym).mangledname;
+                             end;
                            localvarsym,
                            paravarsym :
                              Message(asmr_e_no_local_or_para_allowed);

compiler/symdef.pas

@@ -105,6 +105,8 @@ interface
           { regvars }
           function is_intregable : boolean;
           function is_fpuregable : boolean;
+          { def can be put into a register if it is const/immutable }
+          function is_const_intregable : boolean;
           { generics }
           procedure initgeneric;
           { this function can be used to determine whether a def is really a
@@ -1584,7 +1586,8 @@ implementation
         result:=false;
       end;
 
-    function Tstoreddef.rtti_mangledname(rt:trttitype):string;
+
+    function tstoreddef.rtti_mangledname(rt : trttitype) : string;
       var
         prefix : string[4];
       begin
@@ -1792,6 +1795,21 @@ implementation
      end;
 
 
+   function tstoreddef.is_const_intregable : boolean;
+     begin
+       case typ of
+         stringdef:
+           result:=tstringdef(self).stringtype in [st_ansistring,st_unicodestring,st_widestring];
+         arraydef:
+           result:=is_dynamic_array(self);
+         objectdef:
+           result:=is_interface(self);
+         else
+           result:=false;
+       end;
+     end;
+
+
    procedure tstoreddef.initgeneric;
      begin
        if assigned(generictokenbuf) then
@@ -4641,12 +4659,14 @@ implementation
               potype_destructor:
                 s:=s+'destructor ';
               else
-                if (pno_proctypeoption in pno) and
-                   assigned(returndef) and
-                   not(is_void(returndef)) then
-                  s:=s+'function '
-                else
-                  s:=s+'procedure ';
+                if (pno_proctypeoption in pno) then
+                  begin
+                   if assigned(returndef) and
+                     not(is_void(returndef)) then
+                     s:=s+'function '
+                   else
+                     s:=s+'procedure ';
+                  end;
             end;
             if (pno_ownername in pno) and
                (owner.symtabletype in [recordsymtable,objectsymtable]) then

compiler/symsym.pas

@@ -1484,7 +1484,7 @@ implementation
             not(cs_create_pic in current_settings.moduleswitches)
            ) then
           begin
-            if tstoreddef(vardef).is_intregable and
+            if (tstoreddef(vardef).is_intregable and
               { we could keep all aint*2 records in registers, but this causes
                 too much spilling for CPUs with 8-16 registers so keep only
                 parameters and function results of this type in register because they are normally
@@ -1494,7 +1494,12 @@ implementation
               ((typ=paravarsym) or
                 (vo_is_funcret in varoptions) or
                 (tstoreddef(vardef).typ<>recorddef) or
-                (tstoreddef(vardef).size<=sizeof(aint))) then
+                (tstoreddef(vardef).size<=sizeof(aint)))) or
+
+               { const parameters can be put into registers if the def fits into a register }
+               (tstoreddef(vardef).is_const_intregable and
+                (typ=paravarsym) and
+                (varspez=vs_const)) then
               varregable:=vr_intreg
             else
 { $warning TODO: no fpu regvar in staticsymtable yet, need initialization with 0 }

compiler/systems/t_go32v2.pas

@@ -189,7 +189,7 @@ procedure TExternalLinkerGo32v2.SetDefaultInfo;
 begin
   with Info do
    begin
-     ExeCmd[1]:='ld $RES';
+     ExeCmd[1]:='ld $OPT $RES';
    end;
 end;
 
@@ -389,6 +389,7 @@ begin
 { Call linker }
   SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr);
   Replace(cmdstr,'$RES','@'+maybequoted(outputexedir+Info.ResName));
+  Replace(cmdstr,'$OPT',Info.ExtraOptions);
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 
 { Remove ReponseFile }

compiler/systems/t_linux.pas

@@ -1461,12 +1461,14 @@ begin
       Concat('EXESECTION .dynamic');
       Concat('  OBJSECTION .dynamic');
       Concat('ENDEXESECTION');
+{$ifndef mips}
       Concat('EXESECTION .got');
 {$ifdef arm}
       Concat('  OBJSECTION .got.plt');
 {$endif arm}
       Concat('  OBJSECTION .got');
       Concat('ENDEXESECTION');
+{$endif mips}
 {$ifndef arm}
       Concat('EXESECTION .got.plt');
       Concat('  OBJSECTION .got.plt');
@@ -1479,6 +1481,11 @@ begin
       Concat('  PROVIDE _edata');
       Concat('  PROVIDE edata');
       Concat('ENDEXESECTION');
+{$ifdef mips}
+      Concat('EXESECTION .got');
+      Concat('  OBJSECTION .got');
+      Concat('ENDEXESECTION');
+{$endif mips}
       Concat('EXESECTION .bss');
       Concat('  OBJSECTION .dynbss');
       Concat('  OBJSECTION .bss*');

compiler/systems/t_msdos.pas

@@ -87,7 +87,7 @@ procedure TExternalLinkerMsDosTLink.SetDefaultInfo;
 begin
   with Info do
    begin
-     ExeCmd[1]:='tlink $RES';
+     ExeCmd[1]:='tlink $OPT $RES';
    end;
 end;
 
@@ -138,6 +138,7 @@ begin
   { Call linker }
   SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr);
   Replace(cmdstr,'$RES','@'+maybequoted(outputexedir+Info.ResName));
+  Replace(cmdstr,'$OPT',Info.ExtraOptions);
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 
   { Remove ReponseFile }
@@ -196,7 +197,7 @@ procedure TExternalLinkerMsDosALink.SetDefaultInfo;
 begin
   with Info do
    begin
-     ExeCmd[1]:='alink $RES';
+     ExeCmd[1]:='alink $OPT $RES';
    end;
 end;
 
@@ -215,6 +216,7 @@ begin
   { Call linker }
   SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr);
   Replace(cmdstr,'$RES','@'+maybequoted(outputexedir+Info.ResName));
+  Replace(cmdstr,'$OPT',Info.ExtraOptions);
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 
   { Remove ReponseFile }
@@ -294,7 +296,7 @@ procedure TExternalLinkerMsDosWLink.SetDefaultInfo;
 begin
   with Info do
    begin
-     ExeCmd[1]:='wlink $RES';
+     ExeCmd[1]:='wlink $OPT $RES';
    end;
 end;
 
@@ -313,6 +315,7 @@ begin
   { Call linker }
   SplitBinCmd(Info.ExeCmd[1],binstr,cmdstr);
   Replace(cmdstr,'$RES','@'+maybequoted(outputexedir+Info.ResName));
+  Replace(cmdstr,'$OPT',Info.ExtraOptions);
   success:=DoExec(FindUtil(utilsprefix+BinStr),cmdstr,true,false);
 
   { Remove ReponseFile }

compiler/x86/cgx86.pas

@@ -167,6 +167,8 @@ unit cgx86;
 
     function UseAVX: boolean;
 
+    function UseIncDec: boolean;
+
   implementation
 
     uses
@@ -180,6 +182,21 @@ unit cgx86;
         Result:=current_settings.fputype in fpu_avx_instructionsets;
       end;
 
+
+    { modern CPUs prefer add/sub over inc/dec because add/sub break instructions dependencies on flags
+      because they modify all flags }
+    function UseIncDec: boolean;
+      begin
+{$if defined(x86_64)}
+        Result:=cs_opt_size in current_settings.optimizerswitches;
+{$elseif defined(i386)}
+        Result:=(cs_opt_size in current_settings.optimizerswitches) or (current_settings.cputype in [cpu_386]);
+{$elseif defined(i8086)}
+        Result:=(cs_opt_size in current_settings.optimizerswitches) or (current_settings.cputype in [cpu_8086..cpu_386]);
+{$endif}
+      end;
+
+
     const
       TOpCG2AsmOp: Array[topcg] of TAsmOp = (A_NONE,A_MOV,A_ADD,A_AND,A_DIV,
                             A_IDIV,A_IMUL,A_MUL,A_NEG,A_NOT,A_OR,
@@ -1221,8 +1238,13 @@ unit cgx86;
           begin
             op:=get_scalar_mm_op(fromsize,tosize);
 
+            { MOVAPD/MOVAPS are normally faster }
+            if op=A_MOVSD then
+              op:=A_MOVAPD
+            else if op=A_MOVSS then
+              op:=A_MOVAPS
             { VMOVSD/SS is not available with two register operands }
-            if op=A_VMOVSD then
+            else if op=A_VMOVSD then
               op:=A_VMOVAPD
             else if op=A_VMOVSS then
               op:=A_VMOVAPS;
@@ -1233,12 +1255,14 @@ unit cgx86;
             else
               instr:=taicpu.op_reg_reg(op,S_NO,reg1,reg2);
 
-            case get_scalar_mm_op(fromsize,tosize) of
+            case op of
               A_VMOVAPD,
               A_VMOVAPS,
               A_VMOVSS,
               A_VMOVSD,
               A_VMOVQ,
+              A_MOVAPD,
+              A_MOVAPS,
               A_MOVSS,
               A_MOVSD,
               A_MOVQ:
@@ -1589,11 +1613,14 @@ unit cgx86;
           OP_ADD, OP_AND, OP_OR, OP_SUB, OP_XOR:
             if not(cs_check_overflow in current_settings.localswitches) and
                (a = 1) and
-               (op in [OP_ADD,OP_SUB]) then
-              if op = OP_ADD then
-                list.concat(taicpu.op_reg(A_INC,TCgSize2OpSize[size],reg))
-              else
-                list.concat(taicpu.op_reg(A_DEC,TCgSize2OpSize[size],reg))
+               (op in [OP_ADD,OP_SUB]) and
+               UseIncDec then
+               begin
+                 if op = OP_ADD then
+                   list.concat(taicpu.op_reg(A_INC,TCgSize2OpSize[size],reg))
+                 else
+                   list.concat(taicpu.op_reg(A_DEC,TCgSize2OpSize[size],reg))
+               end
             else if (a = 0) then
               if (op <> OP_AND) then
                 exit
@@ -1720,11 +1747,14 @@ unit cgx86;
           OP_ADD, OP_AND, OP_OR, OP_SUB, OP_XOR:
             if not(cs_check_overflow in current_settings.localswitches) and
                (a = 1) and
-               (op in [OP_ADD,OP_SUB]) then
-              if op = OP_ADD then
-                list.concat(taicpu.op_ref(A_INC,TCgSize2OpSize[size],tmpref))
-              else
-                list.concat(taicpu.op_ref(A_DEC,TCgSize2OpSize[size],tmpref))
+               (op in [OP_ADD,OP_SUB]) and
+               UseIncDec then
+               begin
+                 if op = OP_ADD then
+                   list.concat(taicpu.op_ref(A_INC,TCgSize2OpSize[size],tmpref))
+                 else
+                   list.concat(taicpu.op_ref(A_DEC,TCgSize2OpSize[size],tmpref))
+               end
             else if (a = 0) then
               if (op <> OP_AND) then
                 exit
@@ -2311,6 +2341,22 @@ unit cgx86;
 
 
     procedure tcgx86.g_stackpointer_alloc(list : TAsmList;localsize : longint);
+
+      procedure decrease_sp(a : tcgint);
+{$ifdef i8086}
+        begin
+          list.concat(Taicpu.Op_const_reg(A_SUB,S_W,a,NR_STACK_POINTER_REG));
+        end;
+{$else i8086}
+        var
+          href : treference;
+        begin
+          reference_reset_base(href,NR_STACK_POINTER_REG,-a,0);
+          { normally, lea is a better choice than a sub to adjust the stack pointer }
+          list.concat(Taicpu.op_ref_reg(A_LEA,TCGSize2OpSize[OS_ADDR],href,NR_STACK_POINTER_REG));
+        end;
+{$endif i8086}
+
 {$ifdef x86}
 {$ifndef NOTARGETWIN}
       var
@@ -2331,7 +2377,7 @@ unit cgx86;
              begin
                if localsize div winstackpagesize<=5 then
                  begin
-                    list.concat(Taicpu.Op_const_reg(A_SUB,S_L,localsize-4,NR_ESP));
+                    decrease_sp(localsize-4);
                     for i:=1 to localsize div winstackpagesize do
                       begin
                          reference_reset_base(href,NR_ESP,localsize-i*winstackpagesize,4);
@@ -2346,11 +2392,14 @@ unit cgx86;
                     list.concat(Taicpu.op_reg(A_PUSH,S_L,NR_EDI));
                     list.concat(Taicpu.op_const_reg(A_MOV,S_L,localsize div winstackpagesize,NR_EDI));
                     a_label(list,again);
-                    list.concat(Taicpu.op_const_reg(A_SUB,S_L,winstackpagesize-4,NR_ESP));
+                    decrease_sp(winstackpagesize-4);
                     list.concat(Taicpu.op_reg(A_PUSH,S_L,NR_EAX));
-                    list.concat(Taicpu.op_reg(A_DEC,S_L,NR_EDI));
+                    if UseIncDec then
+                      list.concat(Taicpu.op_reg(A_DEC,S_L,NR_EDI))
+                    else
+                      list.concat(Taicpu.op_const_reg(A_SUB,S_L,1,NR_EDI));
                     a_jmp_cond(list,OC_NE,again);
-                    list.concat(Taicpu.op_const_reg(A_SUB,S_L,localsize mod winstackpagesize - 4,NR_ESP));
+                    decrease_sp(localsize mod winstackpagesize-4);
                     reference_reset_base(href,NR_ESP,localsize-4,4);
                     list.concat(Taicpu.op_ref_reg(A_MOV,S_L,href,NR_EDI));
                     ungetcpuregister(list,NR_EDI);
@@ -2368,7 +2417,7 @@ unit cgx86;
              begin
                if localsize div winstackpagesize<=5 then
                  begin
-                    list.concat(Taicpu.Op_const_reg(A_SUB,S_Q,localsize,NR_RSP));
+                    decrease_sp(localsize);
                     for i:=1 to localsize div winstackpagesize do
                       begin
                          reference_reset_base(href,NR_RSP,localsize-i*winstackpagesize+4,4);
@@ -2383,19 +2432,22 @@ unit cgx86;
                     getcpuregister(list,NR_R10);
                     list.concat(Taicpu.op_const_reg(A_MOV,S_Q,localsize div winstackpagesize,NR_R10));
                     a_label(list,again);
-                    list.concat(Taicpu.op_const_reg(A_SUB,S_Q,winstackpagesize,NR_RSP));
+                    decrease_sp(winstackpagesize);
                     reference_reset_base(href,NR_RSP,0,4);
                     list.concat(Taicpu.op_reg_ref(A_MOV,S_L,NR_EAX,href));
-                    list.concat(Taicpu.op_reg(A_DEC,S_Q,NR_R10));
+                    if UseIncDec then
+                      list.concat(Taicpu.op_reg(A_DEC,S_Q,NR_R10))
+                    else
+                      list.concat(Taicpu.op_const_reg(A_SUB,S_Q,1,NR_R10));
                     a_jmp_cond(list,OC_NE,again);
-                    list.concat(Taicpu.op_const_reg(A_SUB,S_Q,localsize mod winstackpagesize,NR_RSP));
+                    decrease_sp(localsize mod winstackpagesize);
                     ungetcpuregister(list,NR_R10);
                  end
              end
            else
 {$endif NOTARGETWIN}
 {$endif x86_64}
-            list.concat(Taicpu.Op_const_reg(A_SUB,tcgsize2opsize[OS_ADDR],localsize,NR_STACK_POINTER_REG));
+            decrease_sp(localsize);
          end;
       end;
 

compiler/x86/cpubase.pas

@@ -35,7 +35,7 @@ interface
 
 uses
   cutils,cclasses,
-  globtype,
+  globtype,globals,
   cgbase
   ;
 
@@ -286,6 +286,9 @@ uses
     function inverse_cond(const c: TAsmCond): TAsmCond; {$ifdef USEINLINE}inline;{$endif USEINLINE}
     function conditions_equal(const c1, c2: TAsmCond): boolean; {$ifdef USEINLINE}inline;{$endif USEINLINE}
 
+    { checks whether two segment registers are normally equal in the current memory model }
+    function segment_regs_equal(r1,r2:tregister):boolean;
+
 {$ifdef i8086}
     { returns the next virtual register }
     function GetNextReg(const r : TRegister) : TRegister;
@@ -553,6 +556,48 @@ implementation
       end;
 
 
+    function segment_regs_equal(r1, r2: tregister): boolean;
+      begin
+        if not is_segment_reg(r1) or not is_segment_reg(r2) then
+          internalerror(2013062301);
+        { every segment register is equal to itself }
+        if r1=r2 then
+          exit(true);
+{$if defined(i8086)}
+        case current_settings.x86memorymodel of
+          mm_tiny:
+            begin
+              { CS=DS=SS }
+              if ((r1=NR_CS) or (r1=NR_DS) or (r1=NR_SS)) and
+                 ((r2=NR_CS) or (r2=NR_DS) or (r2=NR_SS)) then
+                exit(true);
+              { the remaining are distinct from each other }
+              exit(false);
+            end;
+          mm_small,mm_medium:
+            begin
+              { DS=SS }
+              if ((r1=NR_DS) or (r1=NR_SS)) and
+                 ((r2=NR_DS) or (r2=NR_SS)) then
+                exit(true);
+              { the remaining are distinct from each other }
+              exit(false);
+            end;
+          mm_compact,mm_large,mm_huge: internalerror(2013062303);
+          else
+            internalerror(2013062302);
+        end;
+{$elseif defined(i386) or defined(x86_64)}
+        { DS=SS=ES }
+        if ((r1=NR_DS) or (r1=NR_SS) or (r1=NR_ES)) and
+           ((r2=NR_DS) or (r2=NR_SS) or (r2=NR_ES)) then
+          exit(true);
+        { the remaining are distinct from each other }
+        exit(false);
+{$endif}
+      end;
+
+
 {$ifdef i8086}
     function GetNextReg(const r: TRegister): TRegister;
       begin

compiler/x86/nx86add.pas

@@ -143,7 +143,8 @@ unit nx86add;
                  if (op=A_SUB) and
                     (right.location.loc=LOC_CONSTANT) and
                     (right.location.value=1) and
-                    not(cs_check_overflow in current_settings.localswitches) then
+                    not(cs_check_overflow in current_settings.localswitches) and
+                    UseIncDec then
                   begin
                     emit_reg(A_DEC,TCGSize2Opsize[opsize],left.location.register);
                   end

compiler/x86_64/cgcpu.pas

@@ -177,6 +177,16 @@ unit cgcpu;
 
 
     procedure tcgx86_64.g_proc_exit(list : TAsmList;parasize:longint;nostackframe:boolean);
+
+      procedure increase_sp(a : tcgint);
+        var
+          href : treference;
+        begin
+          reference_reset_base(href,NR_STACK_POINTER_REG,a,0);
+          { normally, lea is a better choice than an add }
+          list.concat(Taicpu.op_ref_reg(A_LEA,TCGSize2OpSize[OS_ADDR],href,NR_STACK_POINTER_REG));
+        end;
+
       var
         href : treference;
       begin
@@ -195,7 +205,7 @@ unit cgcpu;
                (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
               begin
                 if (current_procinfo.final_localsize<>0) then
-                  cg.a_op_const_reg(list,OP_ADD,OS_ADDR,current_procinfo.final_localsize,NR_STACK_POINTER_REG);
+                  increase_sp(current_procinfo.final_localsize);
                 if (current_procinfo.procdef.proctypeoption=potype_exceptfilter) then
                   list.concat(Taicpu.op_reg(A_POP,tcgsize2opsize[OS_ADDR],NR_FRAME_POINTER_REG));
               end

compiler/x86_64/cpunode.pas

@@ -43,8 +43,6 @@ unit cpunode;
        ncgset,
        ncgopt,
        ncgobjc,
-       // n386con,n386flw,n386mat,n386mem,
-       // n386set,n386inl,n386opt,
        { the cpu specific node units must be used after the generic ones to
          get the correct class pointer }
        nx86set,
@@ -57,7 +55,8 @@ unit cpunode;
 {$ifndef DISABLE_WIN64_SEH}
        nx64flw,
 {$endif DISABLE_WIN64_SEH}
-       nx64inl
+       nx64inl,
+       nx64set
        ;
 
 end.

compiler/x86_64/nx64set.pas

@@ -0,0 +1,51 @@
+{
+    Copyright (c) 1998-2002 by Florian Klaempfl
+
+    Generate i386 assembler for in set/case nodes
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your 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 FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit nx64set;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+      globtype,
+      node,nset,pass_1,nx86set;
+
+    type
+      tx8664casenode = class(tx86casenode)
+         procedure optimizevalues(var max_linear_list:aint;var max_dist:aword);override;
+      end;
+
+
+implementation
+
+{*****************************************************************************
+                            TI386CASENODE
+*****************************************************************************}
+
+    procedure tx8664casenode.optimizevalues(var max_linear_list:aint;var max_dist:aword);
+      begin
+        inc(max_linear_list,9);
+      end;
+
+begin
+   ccasenode:=tx8664casenode;
+end.

packages/a52/src/a52.pas

@@ -23,7 +23,8 @@
  *
  * You should have received a copy of the GNU General Public License
  * along with this program; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ * MA 02110-1301, USA.
  *)
 
 

packages/amunits/examples/otherlibs/demo.pas

@@ -16,7 +16,8 @@ PROGRAM Main;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  demo.c - Triton demo program
  *

packages/amunits/examples/otherlibs/envprint.pas

@@ -16,7 +16,8 @@ Program EnvPrint;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  envprint.c - Envprint 2.0 GUI created with Triton
  *

packages/amunits/examples/otherlibs/progindex.pas

@@ -16,7 +16,8 @@ program ProgIndex;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  progind.c - Progress indicator demo
  *

packages/amunits/examples/otherlibs/toolmanager1.pas

@@ -16,7 +16,8 @@ Program ToolManager1;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  Toolmanager1.c - Looks like the original ToolManager
  *

packages/amunits/examples/otherlibs/toolmanager2.pas

@@ -16,7 +16,8 @@ Program ToolManager2;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  Toolmanager2.c - Looks like the ToolManager demo 2 of GUIFront
  *

packages/amunits/examples/otherlibs/toolmanager3.pas

@@ -16,7 +16,8 @@ Program ToolManager3;
  *
  *  You should have received a copy of the GNU General Public License
  *  along with this program; if not, write to the Free Software
- *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ *  MA 02110-1301, USA.
  *
  *  Toolmanager3.c - My own creation for a ToolManager GUI
  *

packages/aspell/LICENSE

@@ -2,7 +2,7 @@
 		       Version 2, June 1991
 
  Copyright (C) 1991 Free Software Foundation, Inc.
-    		    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+	51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  Everyone is permitted to copy and distribute verbatim copies
  of this license document, but changing it is not allowed.
 

packages/aspell/LICENSE.ADDON

@@ -9,7 +9,7 @@ distributed under the Library GNU General Public License
 
 If you didn't receive a copy of the file LICENSE, contact:
       Free Software Foundation, Inc.,
-      59 Temple Place - Suite 330
-      Boston, MA 02111
+      51 Franklin Street, Fifth Floor
+      Boston, MA 02110-1301
       USA
 

packages/cairo/src/cairo.pp

@@ -15,7 +15,8 @@ unit Cairo;
  *
  * You should have received a copy of the LGPL along with this library
  * in the file COPYING-LGPL-2.1; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+ * MA 02110-1301, USA.
  * You should have received a copy of the MPL along with this library
  * in the file COPYING-MPL-1.1
  *

packages/chm/src/chmbase.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/chmcmd.lpr

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING, included in this distribution,
@@ -25,7 +25,7 @@ program chmcmd;
 uses
   Classes, Sysutils, chmfilewriter, GetOpts;
 
-Const 
+Const
   CHMCMDVersion = '2.6.0';
 
 Procedure Usage;
@@ -129,7 +129,7 @@ begin
        except
          on e:exception do
            begin
-             Writeln('This HHP CHM project seems corrupt, please check it ',name);
+             Writeln('This HHP CHM project seems corrupt, please check it ',name,' (', e.message,')');
              halt(1);
            end;
        end;

packages/chm/src/chmfiftimain.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., i51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/chmfilewriter.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,
@@ -63,6 +63,10 @@ type
     FSpareString   : TStringIndex;
     FBasePath      : String;     // location of the .hhp file. Needed to resolve relative paths
     FReadmeMessage : String;     // readme message
+    FToc,
+    FIndex         : TCHMSiteMap;
+    FTocStream,
+    FIndexStream   : TMemoryStream;
   protected
     function GetData(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
     procedure LastFileAdded(Sender: TObject);
@@ -79,6 +83,7 @@ type
     procedure SaveToFile(AFileName: String); virtual;
     procedure WriteChm(AOutStream: TStream); virtual;
     function ProjectDir: String;
+    procedure LoadSitemaps;
     procedure AddFileWithContext(contextid:integer;filename:ansistring;contextname:ansistring='');
     procedure Error(errorkind:TChmProjectErrorKind;msg:String;detaillevel:integer=0);
     // though stored in the project file, it is only there for the program that uses the unit
@@ -139,45 +144,32 @@ end;
 
 procedure TChmProject.LastFileAdded(Sender: TObject);
 var
-  IndexStream: TFileStream;
-  TOCStream: TFileStream;
   Writer: TChmWriter;
-  TOCSitemap  : TChmSiteMap;
-  IndexSiteMap: TChmSiteMap;
 begin
   // Assign the TOC and index files
   Writer := TChmWriter(Sender);
   {$ifdef chmindex}
     Writeln('binindex filename ',IndexFileName);
   {$endif}
-  if (IndexFileName <> '') and FileExists(IndexFileName) then begin
-    IndexStream := TFileStream.Create(IndexFileName, fmOpenRead);
-    Writer.AppendIndex(IndexStream);
+  if assigned(FIndexStream) then
+    begin
+    FIndexStream.position:=0;
+    Writer.AppendIndex(FIndexStream);
     if MakeBinaryIndex then
     begin
       {$ifdef chmindex}
         Writeln('into binindex ');
       {$endif}
-      IndexStream.Position := 0;
-      IndexSitemap := TChmSiteMap.Create(stIndex);
-      indexSitemap.LoadFromStream(IndexStream);
-      Writer.AppendBinaryIndexFromSiteMap(IndexSitemap,False);
-      IndexSitemap.Free;
+      Writer.AppendBinaryIndexFromSiteMap(FIndex,False);
     end;
-    IndexStream.Free;
   end;
-  if (TableOfContentsFileName <> '') and FileExists(TableOfContentsFileName) then begin
-    TOCStream := TFileStream.Create(TableOfContentsFileName, fmOpenRead);
-    Writer.AppendTOC(TOCStream);
+  if assigned(FTocStream) then
+    begin
+    Writer.AppendTOC(FTOCStream);
     if MakeBinaryTOC then
     begin
-      TOCStream.Position := 0;
-      TOCSitemap := TChmSiteMap.Create(stTOC);
-      TOCSitemap.LoadFromStream(TOCStream);
-      Writer.AppendBinaryTOCFromSiteMap(TOCSitemap);
-      TOCSitemap.Free;
+      Writer.AppendBinaryTOCFromSiteMap(FToc);
     end;
-    TOCStream.Free;
   end;
   if not assigned(sender) then
     Writer.Free;
@@ -210,6 +202,10 @@ begin
   FTotalFileList.FreeAndClear;
   FTotalFileList.Free;
   fAllowedExtensions.Free;
+  FToc.free;
+  FIndex.free;
+  FTocStream.Free;
+  FIndexStream.Free;
   inherited Destroy;
 end;
 
@@ -401,7 +397,7 @@ procedure addalias(const key,value :string);
 
 var i,j : integer;
     node: TCHMContextNode;
-    keyupper : string;
+    keyupper,valueupper : string;
 begin
  { Defaults other than global }
    MakeBinaryIndex:=True;
@@ -419,7 +415,9 @@ begin
     writeln('alias new node:',key);
    {$endif}
     node:=TCHMContextNode.create;
-    node.URLName:=value;
+    valueupper:=stringReplace(value, '\', '/', [rfReplaceAll]);
+    valueupper:= StringReplace(valueupper, '//', '/', [rfReplaceAll]);
+    node.URLName:=valueupper;
     node.contextname:=key;
   end
  else
@@ -552,7 +550,7 @@ begin
     for j:=0 to strs.count-1 do
       begin
           nd:=TChmContextNode.Create;
-          nd.urlname:=strs[j];
+          nd.urlname:=StringReplace(strs[j],'\', '/', [rfReplaceAll]);
           nd.contextnumber:=0;
           nd.contextname:='';
           Files.AddObject(nd.urlname,nd);
@@ -941,7 +939,6 @@ var
   helplist,
   localfilelist: TStringList;
   i      : integer;
-  x      : TChmSiteMap;
   strrec : TStringIndex;
 begin
 
@@ -974,45 +971,29 @@ begin
      otherfiles.addstrings(localfilelist);
      localfilelist.clear;
    end;
- if FTableOfContentsFileName<>'' then
+ if assigned(FToc) then
    begin
-     if fileexists(FTableOfContentsFileName) then
-       begin
        Error(chmnote,'Scanning TOC file : '+FTableOfContentsFileName+'.',3);
-        x:=TChmSiteMap.Create(sttoc);
         try
-          x.loadfromfile(FTableOfcontentsFilename);
-          scansitemap(x,localfilelist,true);
+          scansitemap(ftoc,localfilelist,true);
           otherfiles.addstrings(localfilelist);
         except
           on e: Exception do
-            error(chmerror,'Error loading TOC file '+FTableOfContentsFileName);
+            error(chmerror,'Error scanning TOC file ('+FTableOfContentsFileName+')');
           end;
-        x.free;
-       end
-     else
-       error(chmerror,'Can''t find TOC file'+FTableOfContentsFileName);
    end;
   LocalFileList.clear;
-  if FIndexFileName<>'' then
-   begin
-     if fileexists(FIndexFileName) then
-       begin
-       Error(chmnote,'Scanning Index file : '+FIndexFileName+'.',3);
-        x:=TChmSiteMap.Create(stindex);
-        try
-          x.loadfromfile(FIndexFileName);
-          scansitemap(x,localfilelist,true);
-          otherfiles.addstrings(localfilelist);
-        except
-          on e: Exception do
-            error(chmerror,'Error loading index file '+FIndexFileName);
-          end;
-        x.free;
-       end
-     else
-       error(chmerror,'Can''t find TOC index file '+FIndexFileName);
-   end;
+  if assigned(FIndex) then
+    begin
+      Error(chmnote,'Scanning Index file : '+FIndexFileName+'.',3);
+      try
+        scansitemap(FIndex,localfilelist,true);
+        otherfiles.addstrings(localfilelist);
+      except
+        on e: Exception do
+          error(chmerror,'Error scanning index file ('+FIndexFileName+')');
+        end;
+    end;
  localfilelist.free;
 end;
 
@@ -1025,8 +1006,10 @@ var
   nd         : TChmContextNode;
   I          : Integer;
 begin
-  // Scan html for "rest" files.
 
+  LoadSiteMaps;
+
+  // Scan html for "rest" files.
   If ScanHtmlContents Then
     ScanHtml;                 // Since this is slowing we opt to skip this step, and only do this on html load.
 
@@ -1056,6 +1039,7 @@ begin
   Writer.IndexName := ExtractFileName(IndexFileName);
   Writer.TocName   := ExtractFileName(TableOfContentsFileName);
   Writer.ReadmeMessage := ReadmeMessage;
+  Writer.DefaultWindow := FDefaultWindow;
   for i:=0 to files.count-1 do
     begin
       nd:=TChmContextNode(files.objects[i]);
@@ -1066,6 +1050,10 @@ begin
     end;
   if FWIndows.Count>0 then
     Writer.Windows:=FWIndows;
+  if FMergeFiles.Count>0 then
+    Writer.Mergefiles:=FMergeFiles;
+  if assigned(ftoc) then
+    Writer.TocSitemap:=ftoc;
 
   // and write!
 
@@ -1078,6 +1066,54 @@ begin
   Writer.Free;
 end;
 
+procedure TChmProject.LoadSitemaps;
+// #IDXHDR (merged files) goes into the system file, and need to keep  TOC sitemap around
+begin
+   if FTableOfContentsFileName<>'' then
+   begin
+     if fileexists(FTableOfContentsFileName) then
+       begin
+         FTocStream:=TMemoryStream.Create;
+         try
+           FTocStream.loadfromfile(FTableOfContentsFilename);
+           writeln(ftableofcontentsfilename, ' ' ,ftocstream.size);
+           FTocStream.Position:=0;
+           FToc:=TChmSiteMap.Create(sttoc);
+           FToc.loadfromstream(FTocStream);
+           ftoc.savetofile('bla.something');
+         except
+          on e:exception do
+            begin
+               error(chmerror,'Error loading TOC file '+FTableOfContentsFileName);
+               freeandnil(ftoc); freeandnil(FTocStream);
+             end;
+           end;
+       end
+     else
+       error(chmerror,'Can''t find TOC file'+FTableOfContentsFileName);
+   end;
+   if FIndexFileName<>'' then
+   begin
+     if fileexists(FIndexFileName) then
+       begin
+        FIndexStream:=TMemoryStream.Create;
+        try
+          FIndexStream.LoadFromFile(FIndexFileName);
+          FIndexStream.Position:=0;
+          FIndex:=TChmSiteMap.Create(stindex);
+          FIndex.loadfromfile(FIndexFileName);
+        except
+          on e: Exception do
+            begin
+              error(chmerror,'Error loading index file '+FIndexFileName);
+              freeandnil(findex); freeandnil(findexstream);
+            end;
+          end;
+       end
+     else
+       error(chmerror,'Can''t find index file '+FIndexFileName);
+   end;
+end;
 
 
 end.

packages/chm/src/chmls.lpr

@@ -1,4 +1,8 @@
 { Copyright (C) <2005> <Andrew Haines> chmls.lpr
+  Mostly rewritten by Marco van de Voort 2009-2012
+
+  An util that concentrates on listing and decompiling various sections
+   of a CHM.
 
   This library is free software; you can redistribute it and/or modify it
   under the terms of the GNU Library General Public License as published by
@@ -12,9 +16,8 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-}
-{
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+
   See the file COPYING, included in this distribution,
   for details about the copyright.
 }
@@ -28,8 +31,10 @@ program chmls;
 
 uses
   Classes, GetOpts, SysUtils, Types,
+  StreamEx,
   chmreader, chmbase, chmsitemap;
 
+{$R-} // CHM spec puts "-1" in dwords etc.
 type
 
   { TListObject }
@@ -49,11 +54,11 @@ type
     procedure OnFileEntry(Name: String; Offset, UncompressedSize, ASection: Integer);
   end;
 
-
-  TCmdEnum = (cmdList,cmdExtract,cmdExtractall,cmdUnblock,cmdextractalias,cmdextracttoc,cmdextractindex,cmdNone);        // One dummy element at the end avoids rangecheck errors.
+Type
+  TCmdEnum = (cmdList,cmdExtract,cmdExtractall,cmdUnblock,cmdextractalias,cmdextracttoc,cmdextractindex,cmdprintidxhdr,cmdprintsystem,cmdprintwindows,cmdprinttopics,cmdNone);        // One dummy element at the end avoids rangecheck errors.
 
 Const
-  CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','');
+  CmdNames : array [TCmdEnum] of String = ('LIST','EXTRACT','EXTRACTALL','UNBLOCK','EXTRACTALIAS','EXTRACTTOC','EXTRACTINDEX','PRINTIDXHDR','PRINTSYSTEM','PRINTWINDOWS','PRINTTOPICS','');
 
 var
   theopts : array[1..4] of TOption;
@@ -89,6 +94,15 @@ begin
   writeln(stderr,'            Extracts the toc (mainly to check binary TOC)');
   writeln(stderr,' extractindex <chmfilename> [filename]');
   writeln(stderr,'            Extracts the index (mainly to check binary index)');
+  writeln(stderr,' printidxhdr <chmfilename>');
+  writeln(stderr,'            prints #IDXHDR in readable format ');
+  writeln(stderr,' printsystem <chmfilename>');
+  writeln(stderr,'            prints #SYSTEM in readable format ');
+  writeln(stderr,' printwindows <chmfilename>');
+  writeln(stderr,'            prints #WINDOWS in readable format ');
+  writeln(stderr,' printtopics <chmfilename>');
+  writeln(stderr,'            prints #TOPICS in readable format ');
+
   Halt(1);
 end;
 
@@ -286,7 +300,7 @@ begin
   if (length(readfrom)>1) and (readfrom[1]<>'/') then
     readfrom:='/'+readfrom;
 
-  fs:=TFileStream.create(chm,fmOpenRead);
+  fs:=TFileStream.create(chm,fmOpenRead or fmShareDenyNone);
   r:=TChmReader.Create(fs,True);
   m:=r.getobject(readfrom);
   if assigned(m) then
@@ -453,7 +467,452 @@ begin
  Files.Free;
 end;
 
-const 
+
+procedure readchunk13(m:TMemoryStream;r:TChmReader);
+
+var i,cnt,cnt2: integer;
+    s : ansistring;
+
+procedure fetchstring;
+
+begin
+  cnt:=m.ReadDWordLE;
+  s:='';
+  if (cnt>0) then
+   s:=r.readstringsentry(cnt);
+end;
+
+
+begin
+  setlength(s,4);
+  for i:=1 to 4 do
+    s[i]:=ansichar(m.readbyte);
+  Writeln('Identifier tag                                :',s);
+  Writeln('Unknown timestamp/checksum                    :',leton(m.readdword));
+  Writeln('Always 1                                      :',leton(m.readdword));
+  Writeln('Number of topic nodes incl. contents & index  :',leton(m.readdword));
+  Writeln('    The following are mostly parameters of the "text/site properties" object of the sitemap contents');
+  Writeln('0 (meaning unknown)                           :',leton(m.readdword));
+  fetchstring;
+  Writeln('Imagelist param index in #strings (0,-1=none) :',cnt);
+  if (cnt>0) then
+      writeln('    = ',s);
+  Writeln('0 (meaning unknown)                           :',leton(m.readdword));
+  cnt:=m.ReadDWordLE;
+  if cnt=1 then
+    s:='Folder'
+  else
+    if cnt=0 then
+      s:='None'
+    else
+      s:='unknown value!';
+  Writeln('imagetype param text/site.                    :',cnt,' = ',s);
+  Writeln('Background value                              :',inttohex(leton(m.readdword),8));
+  Writeln('Foreground value                              :',inttohex(leton(m.readdword),8));
+  fetchstring;
+  Writeln('Font  param index in #strings (0,-1=none)     :',cnt);
+  if (cnt>0) then
+      writeln('    = ',s);
+  Writeln('Windows Styles                                :',inttohex(leton(m.readdword),8));
+  Writeln('ExWindows Styles                              :',inttohex(leton(m.readdword),8));
+  Writeln('Unknown, often -1 or 0                        :',leton(m.readdword));
+  FetchString;
+  Write  ('Framename                                     :',cnt);
+  if (cnt>0) then
+      write('    = ',s);
+  Writeln;
+  FetchString;
+  Writeln('Windowname                                    :',cnt);
+  if (cnt>0) then
+      writeln('    = ',s);
+  Writeln('Number of Information Types                   :',leton(m.readdword));
+  Writeln('Unknown. Often 1. Also 0, 3.                  :',leton(m.readdword));
+  cnt2:=m.ReadDWordLE;
+  Writeln('Number of files in the [MERGE FILES] list     :',cnt2);
+  Writeln('Unknown. Often 0.                             :',leton(m.readdword),'(Non-zero mostly in files with some files in the merge files list)');
+  if cnt2>0 then
+    for i:=0 to cnt2-1 do
+      begin
+        fetchstring;
+        Writeln(' Offset ', cnt, ' = ',s);
+      end;
+end;
+
+procedure PrintIDXHDR(filespec:TStringDynArray);
+
+var s,
+    chm,
+    prefixfn,
+    symbolname : ansistring;
+    i,cnt,cnt2: integer;
+    cl : TList;
+    x : PcontextItem;
+    f : textfile;
+    fs: TFileStream;
+    r : TChmReader;
+    m : TMemorystream;
+
+
+begin
+  symbolname:='helpid';
+  chm:=filespec[0];
+  prefixfn:=changefileext(chm,'');
+  if not Fileexists(chm) then
+    begin
+      writeln(stderr,' Can''t find file ',chm);
+      halt(1);
+    end;
+  fs:=TFileStream.create(chm,fmOpenRead);
+  r:=TCHMReader.create(fs,true);
+  m:=r.getobject('/#IDXHDR');
+  if not assigned(m) then
+    begin
+      writeln(stderr,'This CHM doesn''t contain a #IDXHDR internal file');
+      halt(1);
+    end;
+  m.position:=0;
+  Writeln(' --- #IDXHDR ---');
+  readchunk13(m,r);
+  m.free;
+  r.free;
+end;
+
+
+procedure PrintWindows(filespec:TStringDynArray);
+
+var s,
+    chm,
+    prefixfn,
+    symbolname : ansistring;
+    i,cnt,cnt2: integer;
+    x : PcontextItem;
+    f : textfile;
+    fs: TFileStream;
+    r : TChmReader;
+    m : TMemorystream;
+
+function fetchstring:string;
+
+var xx : longint;
+begin
+  xx:=m.ReadDWordLE;
+  if (xx>0) then
+    result:=r.readstringsentry(xx)+ ' (index value = '+inttostr(xx)+')'
+  else
+    result:='(0)';
+end;
+
+function printstructsize(sz:integer):string;
+
+begin
+ case sz of
+       188 : result:='Compatibility 1.0';
+       196 : result:='Compatibility 1.1 or later';
+      else
+       result:='unknown';
+       end;
+end;
+
+begin
+  chm:=filespec[0];
+  prefixfn:=changefileext(chm,'');
+  if not Fileexists(chm) then
+    begin
+      writeln(stderr,' Can''t find file ',chm);
+      halt(1);
+    end;
+  fs:=TFileStream.create(chm,fmOpenRead);
+  r:=TCHMReader.create(fs,true);
+  m:=r.getobject('/#WINDOWS');
+  if not assigned(m) then
+    begin
+      writeln(stderr,'This CHM doesn''t contain a #WINDOWS internal file. Odd.');
+      halt(1);
+    end;
+  m.position:=0;
+  cnt:=m.ReadDWordLE;
+  Writeln('Entries in #Windows                         : ',Cnt);
+  cnt2:=m.ReadDWordLE;
+  Writeln('Structure size                              : ',cnt2, ' = ',printstructsize(Cnt2));
+  writeln;
+  i:=0;
+  while (i<cnt) do
+    begin
+      cnt2:=m.ReadDWordLE;
+      Writeln('00 Structure size                            : ',cnt2, ' = ',printstructsize(Cnt2));
+
+      Writeln('04 htmlhelp.h indicates "BOOL fUniCodeStrings: ',m.ReadDWordLE);
+      Writeln('08 WindowType                                : ',fetchstring);
+      cnt2:=m.ReadDWordLE;
+      Write  ('0C Which window properties are valid         : ');
+      if (cnt2 and $00002)>0 then Write(' "Navigation pane style"');
+      if (cnt2 and $00004)>0 then Write(' "Window style flags"');
+      if (cnt2 and $00008)>0 then Write(' "Window extended style flags"');
+      if (cnt2 and $00010)>0 then Write(' "Initial window position"');
+      if (cnt2 and $00020)>0 then Write(' "Navigation pane width"');
+      if (cnt2 and $00040)>0 then Write(' "Window show state"');
+      if (cnt2 and $00080)>0 then Write(' "Info types"');
+      if (cnt2 and $00100)>0 then Write(' "Buttons"');
+      if (cnt2 and $00200)>0 then Write(' "Navigation Pane initially closed state"');
+      if (cnt2 and $00400)>0 then Write(' "Tab position"');
+      if (cnt2 and $00800)>0 then Write(' "Tab order"');
+      if (cnt2 and $01000)>0 then Write(' "History count"');
+      if (cnt2 and $02000)>0 then Write(' "Default Pane"');
+      writeln(' ( = ',inttohex(cnt2,8),')');
+      Writeln('10 A bit field of navigation pane styles     : ',inttohex(m.readdwordLE,8));
+      Writeln('14 Title Bar Text                            : ',fetchstring);
+      Writeln('18 Style Flags                               : ',inttohex(m.readdwordLE,8));
+      Writeln('1C Extended Style Flags                      : ',inttohex(m.readdwordLE,8));
+      Writeln('20 Initial position (left,top,right,bottom   : ',m.readdwordLE,' ' ,m.readdwordLE,' ',m.readdwordLE,' ',m.readdwordLE);
+      Writeln('30 Window ShowState                          : ',inttohex(m.readdwordLE,8));
+      Writeln('34 HWND hwndHelp; OUT: window handle"        : ',inttohex(m.readdwordLE,8));
+      Writeln('38 HWND hwndCaller; OUT: who called window"  : ',inttohex(m.readdwordLE,8));
+      Writeln('3C HH_INFOTYPE* paInfoTypes                  : ',inttohex(m.readdwordLE,8));
+      Writeln('40 HWND hwndToolBar;                         : ',inttohex(m.readdwordLE,8));
+      Writeln('44 HWND hwndNavigation;                      : ',inttohex(m.readdwordLE,8));
+      Writeln('48 HWND hwndHTML;                            : ',inttohex(m.readdwordLE,8));
+      Writeln('4C Width of the navigation pane in pixels    : ',inttohex(m.readdwordLE,8));
+      Writeln('50 Topic panel coordinates left,top,right,bottom : ',m.readdwordLE,' ' ,m.readdwordLE,' ',m.readdwordLE,' ',m.readdwordLE);
+      Writeln('60 TOC File                                  : ',fetchstring);
+      Writeln('64 Index File                                : ',fetchstring);
+      Writeln('68 Default File                              : ',fetchstring);
+      Writeln('6C File when Home button is pressed          : ',fetchstring);
+      inc(i);
+
+    end;
+
+  m.free;
+  r.free;
+end;
+
+procedure PrintTopics(filespec:TStringDynArray);
+var s,
+    chm,
+    prefixfn,
+    symbolname : ansistring;
+    i,cnt,cnt2: integer;
+    cl : TList;
+    x : PcontextItem;
+    f : textfile;
+    fs: TFileStream;
+    r : TChmReader;
+    m : TMemorystream;
+    chunktype,
+    chunksize : Word;
+
+    entries : integer;
+begin
+  chm:=filespec[0];
+  prefixfn:=changefileext(chm,'');
+  if not Fileexists(chm) then
+    begin
+      writeln(stderr,' Can''t find file ',chm);
+      halt(1);
+    end;
+  fs:=TFileStream.create(chm,fmOpenRead);
+  r:=TCHMReader.create(fs,true);
+  m:=r.getobject('/#TOPICS');
+  if not assigned(m) then
+    begin
+      writeln(stderr,'This CHM doesn''t contain a #SYSTEM internal file. Odd.');
+      halt(1);
+    end;
+  m.position:=0;
+  entries:=m.size div 16;
+  if entries>0 then
+    for i:=0 to entries-1 do
+      begin
+        writeln('#TOPICS entry : ',i);
+        cnt:=m.ReadDWordLE;
+        writeln(' TOCIDX index:',cnt,5);
+        write  (' Tag name    :');
+        cnt2:=m.ReadDWordLE;
+        if cnt2=-1 then
+          writeln(cnt2)
+        else
+         begin
+           s:=r.ReadStringsEntry(cnt2);
+           writeln(s,'(',cnt2,')');
+         end;
+        write  (' Tag value   :');
+        cnt2:=m.ReadDWordLE;
+        if cnt2=-1 then
+          writeln(cnt2)
+        else
+         begin
+           s:=r.ReadUrlStr(cnt2);
+           writeln(s,'(',cnt2,')');
+         end;
+        cnt2:=m.ReadWordLE;
+        writeln(' contents val:',cnt2, '(2=not in contents, 6 in contents, 0/4 unknown)');
+        cnt2:=m.ReadWordLE;
+        writeln(' unknown val :',cnt2, '(0,2,4,8,10,12,16,32)');
+      end;
+  m.free;
+  r.free;
+end;
+
+procedure PrintSystem(filespec:TStringDynArray);
+
+var s,
+    chm,
+    prefixfn,
+    symbolname : ansistring;
+    i,cnt,cnt2: integer;
+    cl : TList;
+    x : PcontextItem;
+    f : textfile;
+    fs: TFileStream;
+    r : TChmReader;
+    m : TMemorystream;
+    chunktype,
+    chunksize : Word;
+
+procedure fetchstring;
+
+begin
+  cnt:=m.ReadDWordLE;
+  s:='';
+  if (cnt>0) then
+   s:=r.readstringsentry(cnt);
+end;
+
+
+function printnulterminated(sz:word):string;
+begin
+ setlength(result,sz);
+ if sz>0 then
+   begin
+     m.read(result[1],sz);
+   end;
+end;
+
+procedure printentry4(m:TMemoryStream;chsz:dword);
+var q : QWord;
+    ts : TFileTime;
+begin
+  writeln('(4)');
+  if chsz<32 then
+    begin
+      Writeln('   is too small', chsz, ' bytes instead of 32');
+      m.position:=m.position+chsz;
+      exit;
+    end;
+  writeln(' LCID from HHP file                : ',m.readdwordLE );
+  writeln(' One if DBCS in use                : ',m.readdwordLE );
+  writeln(' one if fullttext search is on     : ',m.readdwordLE );
+  writeln(' Non zero if there are KLinks      : ',m.readdwordLE );
+  writeln(' Non zero if there are ALinks      : ',m.readdwordLE );
+  ts.dwlowdatetime:=m.readdwordLE;
+  ts.dwhighdatetime:=m.readdwordLE;
+  writeln(' Timestamp                         : ',ts.dwhighdatetime,':', ts.dwlowdatetime );
+  writeln(' 0/1 except in dsmsdn.chi has 1    : ',m.readdwordLE );
+  writeln(' 0 (unknown)                       : ',m.readdwordLE );
+end;
+
+procedure printentry8(m:TMemoryStream;chsz:dword);
+var q : QWord;
+    ts : TFileTime;
+begin
+  writeln('(8)');
+  if chsz<16 then
+    begin
+      Writeln('   is too small', chsz, ' bytes instead of 16');
+      m.position:=m.position+chsz;
+      exit;
+    end;
+  writeln(' 0 (or 4 in some)                  : ',m.readdwordLE );
+  fetchstring;
+  writeln(' Abbreviation                      : ',cnt,' = ',s);
+  writeln(' 3 or 5 depending on 1st field     : ',m.readdwordLE );
+  fetchstring;
+  writeln(' Abbreviation explanation          : ',cnt,' = ',s);
+  if chsz>16 then
+    writeln('   x size is larger than 16');
+  m.position:=m.position+chsz-16;
+end;
+
+begin
+  symbolname:='helpid';
+  chm:=filespec[0];
+  prefixfn:=changefileext(chm,'');
+  if not Fileexists(chm) then
+    begin
+      writeln(stderr,' Can''t find file ',chm);
+      halt(1);
+    end;
+  fs:=TFileStream.create(chm,fmOpenRead);
+  r:=TCHMReader.create(fs,true);
+  m:=r.getobject('/#SYSTEM');
+  if not assigned(m) then
+    begin
+      writeln(stderr,'This CHM doesn''t contain a #SYSTEM internal file. Odd.');
+      halt(1);
+    end;
+  m.position:=0;
+  cnt:=m.ReadDWordLE;
+  case cnt of
+   2 : s:='Compatibility 1.0';
+   3 : s:='Compatibility 1.1 or later';
+  else
+   s:='unknown';
+   end;
+
+  Writeln(' --- #SYSTEM---');
+
+  while (m.size-m.position)>=8 do
+    begin
+      chunktype := m.readwordle;
+      Chunksize := m.readwordle;
+      if (m.size-m.position)>=chunksize then
+        begin
+          case chunktype of
+            0 : Writeln('(0)  Contents file from [options]  :',printnulterminated(chunksize));
+            1 : Writeln('(1)  Index file from [options]     :',printnulterminated(chunksize));
+            2 : Writeln('(2)  Default topic from [options]  :',printnulterminated(chunksize));
+            3 : Writeln('(3)  Title from [options]          :',printnulterminated(chunksize));
+            4 : printentry4(m,chunksize);
+            5 : Writeln('(5)  Default Window from [options] :',printnulterminated(chunksize));
+            6 : Writeln('(6)  Compiled file from [options]  :',printnulterminated(chunksize));
+            7 : Writeln('(7)  DWord when Binary Index is on :',m.readdwordle, '(= entry in #urltbl has same first dword');
+            8 : printentry8(m,chunksize);
+            9 : Writeln('(9)  CHM compiler version          :',printnulterminated(chunksize));
+            10: begin
+                  writeln('(10) Timestamp (32-bit?)           :',m.readdwordle);
+                  m.position:=m.position+chunksize-4;
+                end;
+            11: Writeln('(11)  DWord when Binary TOC is on   :',m.readdwordle, '(= entry in #urltbl has same first dword');
+            12: begin
+                  writeln('(12) Number of Information files   :',m.readdwordle);
+                  m.position:=m.position+chunksize-4;
+                end;
+            13: begin
+                  cnt:=m.position;
+                  Writeln('(13)');
+                  readchunk13(m,r);
+                  m.position:=chunksize+cnt;
+                end;
+            14: begin
+                  writeln('(14) MS Office related windowing constants ', chunksize,' bytes');
+                  m.position:=m.position+chunksize;
+                end;
+            15: Writeln('(15) Information type checksum     :',m.readdwordle,' (Unknown algorithm & data source)');
+            16: Writeln('(16) Default Font from [options]   :',printnulterminated(chunksize));
+          else
+            begin
+              writeln('Not (yet) handled chunk, type ',chunktype,' of size ',chunksize);
+              m.position:=m.position+chunksize;
+            end;
+
+          end;
+        end;
+    end;
+
+  m.free;
+  r.free;
+end;
+
+const
    siteext : array[TSiteMapType] of string = ('.hhc','.hhk');
 
 procedure extracttocindex(filespec:TStringDynArray;sttype:TSiteMapType);
@@ -604,18 +1063,43 @@ begin
                         else
                           WrongNrParam(cmdnames[cmd],length(localparams));
                        end;
-       cmdextracttoc : begin
+      cmdextracttoc : begin
                         if length(localparams)>0 then
                           extracttocindex(localparams,sttoc)
                         else
                           WrongNrParam(cmdnames[cmd],length(localparams));
                        end;
-       cmdextractindex: begin
+      cmdextractindex: begin
                         if length(localparams)>0 then
                           extracttocindex(localparams,stindex)
 	                        else
                           WrongNrParam(cmdnames[cmd],length(localparams));
                        end;
+
+      cmdprintidxhdr: begin
+                        if length(localparams)=1 then
+                          printidxhdr(localparams)
+	                else
+                          WrongNrParam(cmdnames[cmd],length(localparams));
+                       end;
+      cmdprintsystem   : begin
+                          if length(localparams)=1 then
+                            printsystem(localparams)
+                          else
+                            WrongNrParam(cmdnames[cmd],length(localparams));
+                         end;
+      cmdprintwindows  : begin
+                          if length(localparams)=1 then
+                            printwindows(localparams)
+                          else
+                            WrongNrParam(cmdnames[cmd],length(localparams));
+                         end;
+      cmdprinttopics   : begin
+                          if length(localparams)=1 then
+                            printtopics(localparams)
+                          else
+                            WrongNrParam(cmdnames[cmd],length(localparams));
+                         end;
       end; {case cmd of}
   end
  else

packages/chm/src/chmobjinstconst.inc

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/chmreader.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.modifiedLGPL, included in this distribution,
@@ -109,16 +109,15 @@ type
     fDefaultWindow: String;
   private
     FSearchReader: TChmSearchReader;
+  public
     procedure ReadCommonData;
     function  ReadStringsEntry(APosition: DWord): String;
     function  ReadStringsEntryFromStream ( strm:TStream ) : String;
     function  ReadURLSTR(APosition: DWord): String;
     function  CheckCommonStreams: Boolean;
     procedure ReadWindows(mem:TMemoryStream);
-  public
     constructor Create(AStream: TStream; FreeStreamOnDestroy: Boolean); override;
     destructor Destroy; override;
-  public
     function GetContextUrl(Context: THelpContext): String;
     function LookupTopicByID(ATopicID: Integer; out ATitle: String): String; // returns a url
     function GetTOCSitemap(ForceXML:boolean=false): TChmSiteMap;
@@ -1079,9 +1078,32 @@ begin
 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;
+
 var hdr:PBTreeBlockHeader;
     head,tail : pbyte;
     isseealso,
+    entrydepth,
     nrpairs : Integer;
     i : integer;
     PE : PBtreeBlockEntry;
@@ -1091,8 +1113,8 @@ var hdr:PBTreeBlockHeader;
     seealsostr,
     topic,
     Name : AnsiString;
-    item : TChmSiteMapItem;
 begin
+  //setlength (curitem,10);
   hdr:=PBTreeBlockHeader(p);
   hdr^.Length          :=LEToN(hdr^.Length);
   hdr^.NumberOfEntries :=LEToN(hdr^.NumberOfEntries);
@@ -1102,10 +1124,12 @@ begin
   tail:=p+(2048-hdr^.length);
   head:=p+sizeof(TBtreeBlockHeader);
 
+  itemstack:=TObjectStack.create;
   {$ifdef binindex}
   writeln('previndex  : ',hdr^.IndexOfPrevBlock);
   writeln('nextindex  : ',hdr^.IndexOfNextBlock);
   {$endif}
+  curitemdepth:=0;
   while head<tail do
     begin
       if not ReadWCharString(Head,Tail,Name) Then
@@ -1118,13 +1142,14 @@ begin
       PE :=PBtreeBlockEntry(head);
       NrPairs  :=LEToN(PE^.nrpairs);
       IsSeealso:=LEToN(PE^.isseealso);
+      EntryDepth:=LEToN(PE^.entrydepth);
       CharIndex:=LEToN(PE^.CharIndex);
       {$ifdef binindex}
-        Writeln('seealso:     ',IsSeeAlso);
-        Writeln('entrydepth:  ',LEToN(PE^.entrydepth));
+        Writeln('seealso   :  ',IsSeeAlso);
+        Writeln('entrydepth:  ',EntryDepth);
         Writeln('charindex :  ',charindex );
         Writeln('Nrpairs   :  ',NrPairs);
-        writeln('seealso data : ');
+        Writeln('CharIndex :  ',charindex);
       {$endif}
 
       inc(head,sizeof(TBtreeBlockEntry));
@@ -1133,10 +1158,22 @@ begin
           if not ReadWCharString(Head,Tail,SeeAlsoStr) Then
             Break;
           // have to figure out first what to do with it.
+          // is See Also really mutually exclusive with pairs?
+          // or is the number of pairs equal to the number of seealso
+          // strings?
+          {$ifdef binindex}
+            writeln('seealso: ',seealsostr);
+          {$endif}
+
         end
       else
         begin
          if NrPairs>0 Then
+          begin
+            {$ifdef binindex}
+             writeln('Pairs   : ');
+            {$endif}
+
             for i:=0 to nrpairs-1 do
               begin
                 if head<tail Then
@@ -1151,6 +1188,7 @@ begin
                   end;
               end;
           end;
+         end;
       if nrpairs<>0 Then
         createentry(Name,CharIndex,Topic,Title);
       inc(head,4); // always 1
@@ -1183,9 +1221,10 @@ begin
    SiteMap:=TChmSitemap.Create(StIndex);
    Item   :=Nil;  // cached last created item, in case we need to make
                   // a child.
+
    TryTextual:=True;
    BHdr.LastLstBlock:=0;
-   if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>0) Then
+   if LoadBtreeHeader(index,BHdr) and (BHdr.LastLstBlock>=0) Then
     begin
        if BHdr.BlockSize=defblocksize then
          begin

packages/chm/src/chmsitemap.pas

@@ -12,13 +12,13 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,
   for details about the copyright.
 }
-unit chmsitemap; 
+unit chmsitemap;
 
 {$mode objfpc}{$H+}
 
@@ -26,11 +26,11 @@ interface
 
 uses
   Classes, SysUtils, fasthtmlparser;
-  
+
 type
   TChmSiteMapItems = class; // forward
   TChmSiteMap = class;
-  
+
   { TChmSiteMapItem }
 
   TChmSiteMapItem = class(TPersistent)
@@ -45,6 +45,9 @@ type
     FSeeAlso: String;
     FText: String;
     FURL: String;
+    FMerge : String;
+    FFrameName : String;
+    FWindowName : String;
     procedure SetChildren(const AValue: TChmSiteMapItems);
   public
     constructor Create(AOwner: TChmSiteMapItems);
@@ -60,10 +63,11 @@ type
     property IncreaseImageIndex: Boolean read FIncreaseImageIndex write FIncreaseImageIndex;
     property Comment: String read FComment write FComment;
     property Owner: TChmSiteMapItems read FOwner;
-    //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: Boolean read FMerge write FMerge;
+
+    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;
   end;
 
   { TChmSiteMapItems }
@@ -194,6 +198,7 @@ var
   //TagAttribute,
   TagAttributeName,
   TagAttributeValue: String;
+  isParam,IsMerged : string;
 begin
   //WriteLn('TAG:', AActualTag);
   TagName := GetTagName(ACaseInsensitiveTag);
@@ -241,40 +246,77 @@ begin
          end;
        end
        else begin // we are the properties of the object tag
-         if (FLevel > 0 ) and (smbtOBJECT in FSiteMapBodyTags) then begin
-
-           if LowerCase(GetTagName(AActualTag)) = 'param' then begin
-
-             TagAttributeName := GetVal(AActualTag, 'name');
-             TagAttributeValue := GetVal(AActualTag, 'value');
-
-             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, '') = 0 then begin
-               //end;
+         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;
+                 end;
              end;
-           end;
-         end;
+          end;
        end;
      end;
   //end
@@ -346,7 +388,7 @@ begin
     fs.free;
     end;
 end;
-                    
+
 procedure TChmSiteMap.SaveToStream(AStream: TStream);
 var
   Indent: Integer;
@@ -407,7 +449,7 @@ begin
   WriteString('<meta name="GENERATOR" content="Microsoft&reg; HTML Help Workshop 4.1">');  // Should we change this?
   WriteString('<!-- Sitemap 1.0 -->');
   WriteString('</HEAD><BODY>');
-  
+
   // Site Properties
   WriteString('<OBJECT type="text/site properties">');
   Inc(Indent, 8);

packages/chm/src/chmspecialfiles.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/chmtypes.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,
@@ -240,6 +240,8 @@ type
 
 function PageBookInfoRecordSize(ARecord: PTOCEntryPageBookInfo): Integer;
 
+Const defvalidflags = [valid_Navigation_pane_style,valid_Window_style_flags,valid_Initial_window_position,valid_Navigation_pane_width,valid_Buttons,valid_Tab_position];
+
 implementation
 uses chmbase;
 
@@ -485,22 +487,20 @@ var ind,len,
     arr     : array[0..3] of integer;
     s2      : string;
 begin
-  flags:=[];
   j:=pos('=',txt);
   if j>0 then
     txt[j]:=',';
   ind:=1; len:=length(txt);
   window_type       :=getnext(txt,ind,len);
   Title_bar_text    :=getnext(txt,ind,len);
-  index_file        :=getnext(txt,ind,len);
   Toc_file          :=getnext(txt,ind,len);
+  index_file        :=getnext(txt,ind,len);
   Default_File      :=getnext(txt,ind,len);
   Home_button_file  :=getnext(txt,ind,len);
   Jumpbutton_1_File :=getnext(txt,ind,len);
   Jumpbutton_1_Text :=getnext(txt,ind,len);
   Jumpbutton_2_File :=getnext(txt,ind,len);
   Jumpbutton_2_Text :=getnext(txt,ind,len);
-
   nav_style         :=getnextint(txt,ind,len,flags,valid_navigation_pane_style);
   navpanewidth      :=getnextint(txt,ind,len,flags,valid_navigation_pane_width);
   buttons           :=getnextint(txt,ind,len,flags,valid_buttons);
@@ -588,6 +588,7 @@ end;
 Constructor TCHMWindow.create(s:string='');
 
 begin
+ flags:=defvalidflags;
  if s<>'' then
    load_from_ini(s);
 end;

packages/chm/src/chmwriter.pas

@@ -11,8 +11,8 @@
   for more details.
 
   You should have received a copy of the GNU Library General Public License
-  along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  along with this library; if not, write to the Free Software Foundation, Inc.,
+  51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,
@@ -23,7 +23,7 @@ unit chmwriter;
 { $DEFINE LZX_USETHREADS}
 
 interface
-uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, Avl_Tree{$IFDEF LZX_USETHREADS}, lzxcompressthread{$ENDIF};
+uses Classes, ChmBase, chmtypes, chmspecialfiles, HtmlIndexer, chmsitemap, contnrs, StreamEx, Avl_Tree{$IFDEF LZX_USETHREADS}, lzxcompressthread{$ENDIF};
 
 Const
    DefaultHHC = 'Default.hhc';
@@ -147,11 +147,13 @@ Type
     FURLSTRStream: TMemoryStream;  // the #URLSTR file
     FFiftiMainStream: TMemoryStream;
     FContextStream: TMemoryStream; // the #IVB file
+    FIDXHdrStream : TMemoryStream; // the #IDXHDR and chunk 13 in #SYSTEM
     FTitle: String;
     FHasTOC: Boolean;
     FHasIndex: Boolean;
     FIndexedFiles: TIndexedWordList;
     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
     SpareString   : TStringIndex;
     SpareUrlStr   : TUrlStrIndex;
@@ -159,6 +161,10 @@ Type
     FDefaultWindow: String;
     FTocName      : String;
     FIndexName    : String;
+    FMergeFiles   : TStringList;
+    FTocSM        : TCHMSitemap;
+    FHasKLinks    : Boolean;
+    FNrTopics     : Integer;
   protected
     procedure FileAdded(AStream: TStream; const AEntry: TFileEntryRec); override;
   private
@@ -170,6 +176,8 @@ Type
     procedure WriteSTRINGS;
     procedure WriteTOPICS;
     procedure WriteIVB; // context ids
+    procedure CreateIDXHDRStream;
+    procedure WriteIDXHDR;
     procedure WriteURL_STR_TBL;
     procedure WriteOBJINST;
     procedure WriteFiftiMain;
@@ -178,10 +186,11 @@ Type
     function AddString(AString: String): LongWord;
     function AddURL(AURL: String; TopicsIndex: DWord): LongWord;
     procedure CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
-    function AddTopic(ATitle,AnUrl:AnsiString):integer;
+    function AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
+    procedure ScanSitemap(asitemap:TCHMSiteMap);
     function NextTopicIndex: Integer;
     procedure Setwindows (AWindowList:TObjectList);
-
+    procedure SetMergefiles(src:TStringList);
   public
     constructor Create(AOutStream: TStream; FreeStreamOnDestroy: Boolean); override;
     destructor Destroy; override;
@@ -193,6 +202,7 @@ Type
     procedure AppendIndex(AStream: TStream);
     procedure AppendSearchDB(AName: String; AStream: TStream);
     procedure AddContext(AContext: DWord; ATopic: String);
+    procedure AddDummyALink;
 
     property Title: String read FTitle write FTitle;
     property FullTextSearch: Boolean read FFullTextSearch write FFullTextSearch;
@@ -205,6 +215,8 @@ Type
     property TOCName : String read FTocName write FTocName;
     property IndexName : String read FIndexName write FIndexName;
     property DefaultWindow : string read fdefaultwindow write fdefaultwindow;
+    property MergeFiles :TStringList read FMergeFiles write setmergefiles;
+    property Tocsitemap :TChmSitemap read ftocsm write ftocsm;
   end;
 
 Function CompareStrings(Node1, Node2: Pointer): integer; // also used in filewriter
@@ -932,7 +944,7 @@ begin
 end;
 
 
-procedure TChmWriter.WriteSystem;
+procedure TChmWriter.WriteSYSTEM;
 var
   Entry: TFileEntryRec;
   TmpStr: String;
@@ -941,7 +953,6 @@ const
   VersionStr = 'HHA Version 4.74.8702'; // does this matter?
 begin
 
-
   // this creates the /#SYSTEM file
   Entry.Name := '#SYSTEM';
   Entry.Path := '/';
@@ -977,10 +988,11 @@ begin
   FSection0.WriteWord(NToLE(Word(36))); // size
 
   FSection0.WriteDWord(NToLE(DWord($0409)));
-  FSection0.WriteDWord(1);
-  FSection0.WriteDWord(NToLE(DWord(Ord(FFullTextSearch and FFullTextSearchAvailable))));
-  FSection0.WriteDWord(0);
   FSection0.WriteDWord(0);
+  FSection0.WriteDWord(NToLE(DWord(Ord(FFullTextSearch and FFullTextSearchAvailable))));
+
+  FSection0.WriteDWord(NToLE(Dword(Ord(FHasKLinks))) ); // klinks
+  FSection0.WriteDWord(0); // alinks
 
   // two for a QWord
   FSection0.WriteDWord(0);
@@ -990,8 +1002,6 @@ begin
   FSection0.WriteDWord(0);
 
 
-
-
   ////////////////////////<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
   // 2  default page to load
   if FDefaultPage <> '' then begin
@@ -1077,6 +1087,14 @@ begin
   end;
 
 
+  // 13
+  if FIDXHdrStream.size>0 then
+  begin
+    FSection0.WriteWord(NToLE(Word(13)));
+    FSection0.WriteWord(NToLE(Word(FIDXHdrStream.size)));
+    FSection0.copyfrom(FIDXHdrStream,0);
+  end;
+
   Entry.DecompressedSize := FSection0.Position - Entry.DecompressedOffset;
   FInternalFiles.AddEntry(Entry);
 end;
@@ -1104,11 +1122,14 @@ begin
 end;
 
 procedure TChmWriter.WriteTOPICS;
-//var
-  //FHits: Integer;
 begin
   if FTopicsStream.Size = 0 then
     Exit;
+  if tocname<>'' then
+    AddTopic('',self.TOCName,2);
+  if indexname<>'' then
+    AddTopic('',self.IndexName,2);
+
   FTopicsStream.Position := 0;
   PostAddStreamToArchive('#TOPICS', '/', FTopicsStream);
  // I commented the code below since the result seemed unused
@@ -1116,6 +1137,14 @@ begin
  //   FIndexedFiles.ForEach(@IterateWord,FHits);
 end;
 
+procedure TChmWriter.WriteIDXHDR;
+begin
+  if FIDXHdrStream.Size = 0 then
+    Exit;
+  FIDXHdrStream.Position := 0;
+  PostAddStreamToArchive('#IDXHDR', '/', FIDXHdrStream);
+end;
+
 procedure TChmWriter.WriteIVB;
 begin
   if FContextStream = nil then exit;
@@ -1128,6 +1157,98 @@ begin
   AddStreamToArchive('#IVB', '/', FContextStream);
 end;
 
+const idxhdrmagic ='T#SM';
+
+procedure TChmWriter.CreateIDXHDRStream;
+var i : Integer;
+begin
+   if fmergefiles.count=0 then  // I assume text/site properties could also trigger idxhdr
+     exit;
+
+   FIDXHdrStream.setsize(4096);
+   FIDXHdrStream.position:=0;
+   FIDXHdrStream.write(idxhdrmagic[1],4);     //  0 Magic
+   FIDXHdrStream.writedword(ntole(1));        //  4 Unknown timestamp/checksum
+   FIDXHdrStream.writedword(ntole(1));        //  8 1 (unknown)
+   FIDXHdrStream.writedword(ntole(FNrTopics));        //  C Number of topic nodes including the contents & index files
+   FIDXHdrStream.writedword(ntole(0));        // 10 0 (unknown)
+
+   // 14 Offset in the #STRINGS file of the ImageList param of the "text/site properties" object of the sitemap contents (0/-1 = none)
+   if assigned(ftocsm) and (ftocsm.ImageList<>'') then
+     FIDXHdrStream.writedwordLE(addstring(ftocsm.ImageList))
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 18 0 (unknown)
+   FIDXHdrStream.writedwordLE(0);
+
+   // 1C 1 if the value of the ImageType param of the "text/site properties" object of the sitemap contents is Folder. 0 otherwise.
+   if assigned(ftocsm) and (ftocsm.UseFolderImages) then
+     FIDXHdrStream.writedwordLE(1)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 20 The value of the Background param of the "text/site properties" object of the sitemap contents
+   if assigned(ftocsm) then
+     FIDXHdrStream.writedwordLE(ftocsm.Backgroundcolor)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 24 The value of the Foreground param of the "text/site properties" object of the sitemap contents
+   if assigned(ftocsm) then
+     FIDXHdrStream.writedwordLE(ftocsm.Foregroundcolor)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 28 Offset in the #STRINGS file of the Font param of the "text/site properties" object of the sitemap contents (0/-1 = none)
+   if assigned(ftocsm) and (ftocsm.Font<>'') then
+     FIDXHdrStream.writedwordLE(addstring(ftocsm.font))
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 2C The value of the Window Styles param of the "text/site properties" object of the sitemap contents
+   if assigned(ftocsm) then
+     FIDXHdrStream.writedwordLE(FTocsm.WindowStyles)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 30 The value of the EXWindow Styles param of the "text/site properties" object of the sitemap contents
+   if assigned(ftocsm) then
+     FIDXHdrStream.writedwordLE(FTocSm.ExWindowStyles)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 34 Unknown. Often -1. Sometimes 0.
+   FIDXHdrStream.writedwordLE(0);
+
+   // 38 Offset in the #STRINGS file of the FrameName param of the "text/site properties" object of the sitemap contents (0/-1 = none)
+   if assigned(ftocsm) and (ftocsm.framename<>'') then
+     FIDXHdrStream.writedwordLE(addstring(FTocsm.Framename))
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   // 3C Offset in the #STRINGS file of the WindowName param of the "text/site properties" object of the sitemap contents (0/-1 = none)
+   if assigned(ftocsm) and (ftocsm.windowname<>'') then
+     FIDXHdrStream.writedwordLE(addstring(FTocsm.windowname))
+   else
+     FIDXHdrStream.writedwordLE(0);
+   FIDXHdrStream.writedword(ntole(0));        // 40 Number of information types.
+   FIDXHdrStream.writedword(ntole(0));        // 44 Unknown. Often 1. Also 0, 3.
+   FIDXHdrStream.writedword(ntole(fmergefiles.count));        // 48 Number of files in the [MERGE FILES] list.
+
+   // 4C Unknown. Often 0. Non-zero mostly in files with some files in the merge files list.
+   if fmergefiles.count>0 then
+     FIDXHdrStream.writedwordLE(1)
+   else
+     FIDXHdrStream.writedwordLE(0);
+
+   for i:=0 to FMergefiles.count-1 do
+     FIDXHdrStream.WriteDword(addstring(fmergefiles[i]));
+
+   for i:=0 to 1004-fmergefiles.count-1 do
+    FIDXHdrStream.WriteDword(0);
+end;
+
 procedure TChmWriter.WriteURL_STR_TBL;
 begin
   if FURLSTRStream.Size <> 0 then begin
@@ -1295,8 +1416,8 @@ begin
       for i:=0 to FWindows.Count-1 Do
         begin
           Win:=TChmWindow(FWindows[i]);
-          WindowStream.WriteDword(NToLE(dword(196 )));                   //  0 size of entry.
-          WindowStream.WriteDword(NToLE(dword(0 )));                     //  4 unknown (bool Unicodestrings?)
+          WindowStream.WriteDwordLE (196);                               //  0 size of entry.
+          WindowStream.WriteDwordLE (0);                                 //  4 unknown (bool Unicodestrings?)
           WindowStream.WriteDword(NToLE(addstring(win.window_type )));   //  8 Arg 0, name of window
           WindowStream.WriteDword(NToLE(dword(win.flags )));             //  C valid fields
           WindowStream.WriteDword(NToLE(dword(win.nav_style)));          // 10 arg 10 navigation pane style
@@ -1353,6 +1474,8 @@ begin
   WriteITBITS;
   // This creates and writes the #SYSTEM file to section0
   WriteSystem;
+  if Assigned(FTocSM)  then
+   Scansitemap(FTocSM);
 end;
 
 procedure TChmWriter.WriteFinalCompressedFiles;
@@ -1360,8 +1483,10 @@ begin
   inherited WriteFinalCompressedFiles;
   WriteTOPICS;
   WriteURL_STR_TBL;
-  WriteSTRINGS;
   WriteWINDOWS;
+  CreateIDXHDRStream;
+  WriteIDXHDR;
+  WriteSTRINGS;
   WriteFiftiMain;
 end;
 
@@ -1388,30 +1513,38 @@ begin
   FURLTBLStream := TMemoryStream.Create;
   FFiftiMainStream := TMemoryStream.Create;
   FIndexedFiles := TIndexedWordList.Create;
+  FAVLTopicdedupe  :=TAVLTree.Create(@CompareStrings);  // dedupe filenames in topics.
   FAvlStrings   := TAVLTree.Create(@CompareStrings);    // dedupe strings
   FAvlURLStr    := TAVLTree.Create(@CompareUrlStrs);    // dedupe urltbl + binindex must resolve URL to topicid
   SpareString   := TStringIndex.Create;                 // We need an object to search in avltree
   SpareUrlStr   := TUrlStrIndex.Create;                 //    to avoid create/free circles we keep one in spare
+  FIDXHdrStream := TMemoryStream.Create;                // the #IDXHDR and chunk 13 in #SYSTEM
                                                         //    for searching purposes
   FWindows      := TObjectlist.Create(True);
   FDefaultWindow:= '';
+  FMergeFiles   :=TStringList.Create;
+  FNrTopics     :=0;
 end;
 
 destructor TChmWriter.Destroy;
 begin
   if Assigned(FContextStream) then FContextStream.Free;
+  FMergeFiles.Free;
   FIndexedFiles.Free;
   FStringsStream.Free;
   FTopicsStream.Free;
   FURLSTRStream.Free;
   FURLTBLStream.Free;
   FFiftiMainStream.Free;
+  FIDXHdrStream.Create;
   SpareString.free;
   SpareUrlStr.free;
   FAvlUrlStr.FreeAndClear;
   FAvlUrlStr.Free;
   FAvlStrings.FreeAndClear;
   FAvlStrings.Free;
+  FAVLTopicdedupe.FreeAndClear;
+  FAVLTopicdedupe.free;
   FWindows.Free;
 
   inherited Destroy;
@@ -1431,7 +1564,7 @@ begin
   SpareString.TheString:=AString;
   n:=fAvlStrings.FindKey(SpareString,@CompareStrings);
   if assigned(n) then
-   exit(TStringIndex(n.data).strid);
+    exit(TStringIndex(n.data).strid);
 
   // each entry is a null terminated string
   Pos := DWord(FStringsStream.Position);
@@ -1445,9 +1578,9 @@ begin
   end;
 
   Result := FStringsStream.Position;
-  FStringsStream.WriteBuffer(AString[1], Length(AString));
+  if length(AString)>0 Then
+    FStringsStream.WriteBuffer(AString[1], Length(AString));
   FStringsStream.WriteByte(0);
-
   StrRec:=TStringIndex.Create;
   StrRec.TheString:=AString;
   StrRec.Strid    :=Result;
@@ -1516,46 +1649,44 @@ begin
   FURLTBLStream.WriteDWord(NtoLE(UrlIndex));
 end;
 
-
-
 procedure TChmWriter.CheckFileMakeSearchable(AStream: TStream; AFileEntry: TFileEntryRec);
-
-  var
+var
     TopicEntry: TTopicEntry;
     ATitle: String;
 begin
   if Pos('.ht', AFileEntry.Name) > 0 then
   begin
     ATitle := FIndexedFiles.IndexFile(AStream, NextTopicIndex, FSearchTitlesOnly);
-    if ATitle <> '' then
-      TopicEntry.StringsOffset := AddString(ATitle)
-    else
-      TopicEntry.StringsOffset := $FFFFFFFF;
-    TopicEntry.URLTableOffset := AddURL(AFileEntry.Path+AFileEntry.Name, NextTopicIndex);
-    TopicEntry.InContents := 2;
-    TopicEntry.Unknown := 0;
-    TopicEntry.TocOffset := 0;
-    FTopicsStream.WriteDWord(LEtoN(TopicEntry.TocOffset));
-    FTopicsStream.WriteDWord(LEtoN(TopicEntry.StringsOffset));
-    FTopicsStream.WriteDWord(LEtoN(TopicEntry.URLTableOffset));
-    FTopicsStream.WriteWord(LEtoN(TopicEntry.InContents));
-    FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
-  end;
+    AddTopic(ATitle,AFileEntry.Path+AFileEntry.Name,-1);
+ end;
 end;
 
-function TChmWriter.AddTopic(ATitle,AnUrl:AnsiString):integer;
+function TChmWriter.AddTopic(ATitle,AnUrl:AnsiString;code:integer=-1):integer;
 
 var
     TopicEntry: TTopicEntry;
 
 begin
+    anurl:=StringReplace(anurl, '\', '/', [rfReplaceAll]);
     if ATitle <> '' then
       TopicEntry.StringsOffset := AddString(ATitle)
     else
       TopicEntry.StringsOffset := $FFFFFFFF;
     result:=NextTopicIndex;
     TopicEntry.URLTableOffset := AddURL(AnUrl, Result);
-    TopicEntry.InContents := 2;
+    if code=-1 then
+      begin
+       if ATitle<>'' then
+         TopicEntry.InContents := 6
+       else
+         TopicEntry.InContents := 2;
+       if pos('#',AnUrl)>0 then
+         TopicEntry.InContents := 0;
+      end
+     else
+       TopicEntry.InContents := code;
+
+    inc(FNrTopics);
     TopicEntry.Unknown := 0;
     TopicEntry.TocOffset := 0;
     FTopicsStream.WriteDWord(LEtoN(TopicEntry.TocOffset));
@@ -1565,6 +1696,30 @@ begin
     FTopicsStream.WriteWord(LEtoN(TopicEntry.Unknown));
 end;
 
+procedure TChmWriter.ScanSitemap(asitemap:TCHMSiteMap);
+procedure scanitems(it:TChmSiteMapItems);
+
+var i : integer;
+    x : TChmSiteMapItem;
+    s : string;
+    strrec : TStringIndex;
+
+begin
+  for i:=0 to it.count -1 do
+    begin
+      x:=it.item[i];
+//      if sanitizeurl(fbasepath,x.local,S) then   // sanitize, remove stuff etc.
+//        begin
+//          writeln(x.text,' : ',x.local,' ',x.url,' ' ,x.merge);
+
+      if assigned(x.children) and (x.children.count>0) then
+        scanitems(x.children);
+    end;
+end;
+begin
+ scanitems(asitemap.items);
+end;
+
 function TChmWriter.NextTopicIndex: Integer;
 begin
   Result := FTopicsStream.Size div 16;
@@ -1807,28 +1962,40 @@ Var
   blocknplusentries : Integer;  // The other blocks indexed on creation.
   datastream,mapstream,propertystream : TMemoryStream;
 
-procedure preparecurrentblock;
-
+procedure preparecurrentblock(force:boolean);
 var p: PBTreeBlockHeader;
-
 begin
+  {$ifdef binindex}
+  writeln('prepcurblock ' ,Entries,' ',lastblock,' ' ,blocknr,' ',indexstream.position);
+  {$endif}
   p:=@curblock[0];
+  fillchar(p^,sizeof(TBtreeBlockHeader),#0);
   p^.Length:=NToLE(Defblocksize-curind);
   p^.NumberOfEntries:=Entries;
-  p^.IndexOfPrevBlock:=lastblock;
+  p^.IndexOfPrevBlock:=cardinal(lastblock); // lastblock can be -1, avoid rangecheck
   p^.IndexOfNextBlock:=Blocknr;
+  if force and (blocknr=0) then   // only one listblock -> no indexblocks.
+    p^.IndexOfNextBlock:=dword(-1);
   IndexStream.Write(curblock[0],Defblocksize);
+  fillchar(curblock[0],DefBlockSize,#0);
   MapStream.Write(NToLE(MapEntries),sizeof(dword));
   MapStream.Write(NToLE(BlockNr),Sizeof(DWord));
   MapEntries:=TotalEntries;
   curind:=sizeof(TBtreeBlockHeader);   // index into current block;
   lastblock:=blocknr;
   inc(blocknr);
+  Entries:=0;
+  {$ifdef binindex}
+  writeln('prepcurblock post' , indexstream.position);
+  {$endif}
 end;
 
 procedure prepareindexblockn(listingblocknr:integer);
 var p:PBTreeIndexBlockHeader;
 begin
+  {$ifdef binindex}
+  writeln('prepindexblockn');
+  {$endif}
   p:=@Blockn[IndexBlockNr];
   p^.Length:=defblocksize-BlockInd;
   p^.NumberOfEntries:=BlockEntries;
@@ -1838,18 +2005,21 @@ begin
   BlockEntries:=0;
   BlockInd:=0;
   if Indexblocknr>=length(blockn) then
-    setlength(blockn,length(blockn)+1);  // larger increments also possible. #blocks is kept independantly.
+    begin
+      setlength(blockn,length(blockn)+1);  // larger increments also possible. #blocks is kept independantly.
+      fillchar(blockn[0][0],sizeof(blockn[0]),#0);
+    end;
   p:=@Blockn[IndexBlockNr];
   p^.IndexOfChildBlock:=ListingBlockNr;
   blockind:=sizeof(TBTreeIndexBlockHeader);
 end;
 
-procedure finalizeindexblockn(p:pbyte;var ind:integer;Entries:integer);
+procedure finalizeindexblockn(p:pbyte;var ind:integer;xEntries:integer);
 var ph:PBTreeIndexBlockHeader;
 begin
   ph:=PBTreeIndexBlockHeader(p);
   ph^.Length:=defblocksize-Ind;
-  ph^.NumberOfEntries:=Entries;
+  ph^.NumberOfEntries:=xEntries;
 // p^.IndexOfChildBlock  // already entered on block creation, since of first entry, not last.
 //  inc(Ind);
 end;
@@ -1858,6 +2028,10 @@ procedure CurEntryToIndex(entrysize:integer);
 var p,pentry : pbyte;
     indexentrysize : integer;
 begin
+  {$ifdef binindex}
+  writeln('curentrytoindex ', entrysize);
+  {$endif}
+
   indexentrysize:=entrysize-sizeof(dword);         // index entry is 4 bytes shorter, and only the last dword differs
   if (blockind+indexentrysize)>=Defblocksize then
     prepareindexblockn(blocknr);
@@ -1877,6 +2051,7 @@ var p      : pbyte;
     i      : Integer;
 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
@@ -1886,7 +2061,7 @@ begin
  // else
 //    seealso:=2;
   WriteWord(p,seealso);          // =0 not a see also 2 =seealso
-  WriteWord(p,2);                // Entrydepth.  We can't know it, so write 2.
+  WriteWord(p,0);                // 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.
@@ -1897,19 +2072,29 @@ begin
   WriteDword(p,mod13value);      //a value that increments with 13.
   mod13value:=mod13value+13;
   entrysize:=p-pbyte(@testblock[0]);
+  {$ifdef binindex}
+    writeln(curind, ' ',entrysize, ' ',defblocksize);
+  {$endif}
   if (curind+entrysize)>=Defblocksize then
     begin
-      preparecurrentblock;
+      {$ifdef binindex}
+      writeln('larger!');
+      {$endif}
+      preparecurrentblock(False);
       EntrytoIndex:=true;
     end;
   if EntryToIndex Then
     begin
+      {$ifdef binindex}
+      writeln('entrytoindex');
+      {$endif}
       CurEntryToIndex(entrysize);
       EntryToIndex:=False;
     end;
   move(testblock[0],curblock[curind],entrysize);
   inc(curind,entrysize);
   datastream.write(DataEntry,Sizeof(DataEntry));
+  inc(Entries);
 end;
 
 procedure MoveIndexEntry(nr:integer;bytes:integer;childblock:integer);
@@ -1931,7 +2116,10 @@ begin
       FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
       inc(blocknplusindex);
       if blocknplusindex>=length(blocknplus1) then
-        setlength(blocknplus1,length(blocknplus1)+1);
+        begin
+          setlength(blocknplus1,length(blocknplus1)+1);
+          fillchar(blocknplus1[length(blocknplus1)-1][0],sizeof(blocknplus1[0]),#0);
+        end;
       blockInd:=Sizeof(TBTreeIndexBlockHeader);
       pdword(@blocknplus1[blocknplusindex][0])[4]:=NToLE(ChildBlock);  /// init 2nd level index to first 1st level index block
       end;
@@ -2035,17 +2223,28 @@ begin
   indexblocknr:=0;   // nr of first index block.
   BlockEntries:=0;   // entries into current block;
   MapEntries  :=0;   // entries before the current listing block, for MAP file
+  TreeDepth   :=0;
 
+  fillchar(testblock[0],DefBlockSize,#0);
+  fillchar(curblock[0],DefBlockSize,#0);
   curind      :=sizeof(TBTreeBlockHeader);      // index into current listing block;
   blockind    :=sizeof(TBtreeIndexBlockHeader); // index into current index block
 
   Setlength(blockn,1);
+  fillchar(blockn[0][0],sizeof(blockn[0]),#0);
   pdword(@blockn[0][4])^:=NToLE(0);  /// init first listingblock nr to 0 in the first index block
   EntryToIndex   := True;
+  {$ifdef binindex}
+  writeln('items:',asitemap.items.count);
+  {$endif}
   for i:=0 to ASiteMap.Items.Count-1 do
     begin
       item := TChmSiteMapItem(ASiteMap.Items.Item[i]);
       key  :=Item.Text;
+       {$ifdef binindex}
+        writeln('item: ',i,' ',key);
+       {$endif}
+
       {$ifdef chm_windowsbinindex}
       // append 2 to all index level 0 entries. This
       // so we can see if Windows loads the binary or textual index.
@@ -2054,10 +2253,10 @@ begin
       CombineWithChildren(Item,Key,length(key),true);
       {$endif}
     end;
-  PrepareCurrentBlock;     // flush last listing block.
+  PrepareCurrentBlock(True);     // flush last listing block.
+
   Listingblocks:=blocknr;   // blocknr is from now on the number of the first block in blockn.
                             // we still need the # of listingblocks for the header though
-
   {$ifdef binindex}
     writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
   {$endif}
@@ -2067,70 +2266,75 @@ begin
   // and repeat until we have no entries left.
 
   // First we finalize the current set of blocks
-
-  if  Blockind<>sizeof(TBtreeIndexBlockHeader) Then
-    begin
-      {$ifdef binindex}
-        writeln('finalizing level 1 index');
-      {$endif}
-      FinalizeIndexBlockN(@blockn[indexblocknr][0],blockind,blockentries); // also increasing indexblocknr
-      inc(IndexBlockNr);
-    end;
-  {$ifdef binindex}
-    writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
-  {$endif}
-
-
-  while (Indexblocknr>1) do
+  if blocknr>1 then
     begin
+      if  Blockind<>sizeof(TBtreeIndexBlockHeader) Then
+        begin
+          {$ifdef binindex}
+            writeln('finalizing level 1 index');
+          {$endif}
+          FinalizeIndexBlockN(@blockn[indexblocknr][0],blockind,blockentries); // also increasing indexblocknr
+          inc(IndexBlockNr);
+        end;
       {$ifdef binindex}
-        printloopvars(1);
+        writeln('binindex: listingblocks : '+inttostr(listingblocks),' indexblocks: ',indexblocknr,' entries:',blockentries);
       {$endif}
 
-      blockind      :=sizeof(TBtreeIndexBlockHeader);
-      pdword(@blockn[0][4])^:=NToLE(Listingblocks);  /// init 2nd level index to first 1st level index block
-      blocknplusindex     :=0;
-      blocknplusentries   :=0;
-      if length(blocknplus1)<1 then
-        Setlength(blocknplus1,1);
 
-      EntryToIndex        :=True;
-      {$ifdef binindex}
-        printloopvars(2);
-      {$endif}
-      for i:=0 to Indexblocknr-1 do
+      while (Indexblocknr>1) do
         begin
-          Entrybytes:=ScanIndexBlock(@blockn[i][0]);
-//          writeln('after scan ,',i, ' bytes: ',entrybytes,' blocknr:',blocknr,' indexblocknr:',indexblocknr,' to:',blocknr+i);
-          MoveIndexEntry(i,Entrybytes,blocknr+i);
-          indexStream.Write(blockn[i][0],defblocksize);
-        end;
+          {$ifdef binindex}
+            printloopvars(1);
+          {$endif}
 
-      {$ifdef binindex}
-        printloopvars(3);
-      {$endif}
+          blockind      :=sizeof(TBtreeIndexBlockHeader);
+          pdword(@blockn[0][4])^:=NToLE(Listingblocks);  /// init 2nd level index to first 1st level index block
+          blocknplusindex     :=0;
+          blocknplusentries   :=0;
+          if length(blocknplus1)<1 then
+            begin
+              Setlength(blocknplus1,1);
+              fillchar(blocknplus1[0][0],sizeof(blocknplus1[0]),#0);
+            end;
+
+          EntryToIndex        :=True;
+          {$ifdef binindex}
+            printloopvars(2);
+          {$endif}
+          for i:=0 to Indexblocknr-1 do
+            begin
+              Entrybytes:=ScanIndexBlock(@blockn[i][0]);
+    //          writeln('after scan ,',i, ' bytes: ',entrybytes,' blocknr:',blocknr,' indexblocknr:',indexblocknr,' to:',blocknr+i);
+              MoveIndexEntry(i,Entrybytes,blocknr+i);
+              indexStream.Write(blockn[i][0],defblocksize);
+            end;
 
-      If Blockind<>sizeof(TBtreeIndexBlockHeader) Then
-        begin
           {$ifdef binindex}
-            logentry('finalizing');
+            printloopvars(3);
           {$endif}
-          FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
-          inc(blocknplusindex);
-        end;
 
-      inc(blocknr,indexblocknr);
+          If Blockind<>sizeof(TBtreeIndexBlockHeader) Then
+            begin
+              {$ifdef binindex}
+                logentry('finalizing');
+              {$endif}
+              FinalizeIndexBlockn(@blocknplus1[blocknplusindex][0],blockind,blocknplusentries);
+              inc(blocknplusindex);
+            end;
 
-      indexblocknr:=blocknplusindex;
-      blockn:=copy(blocknplus1); setlength(blocknplus1,1);
-      {$ifdef binindex}
-        printloopvars(5);
-      {$endif}
+          inc(blocknr,indexblocknr);
 
-      inc(TreeDepth);
+          indexblocknr:=blocknplusindex;
+          blockn:=copy(blocknplus1); setlength(blocknplus1,1);
+          {$ifdef binindex}
+            printloopvars(5);
+          {$endif}
+
+          inc(TreeDepth);
+        end;
+      indexStream.Write(blockn[0][0],defblocksize);
+      inc(blocknr);
     end;
-  indexStream.Write(blockn[0][0],defblocksize);
-  inc(blocknr);
   // Fixup header.
   hdr.ident[0]:=chr($3B); hdr.ident[1]:=chr($29);
   hdr.flags          :=NToLE(word($2));           // bit $2 is always 1, bit $0400 1 if dir? (always on)
@@ -2141,7 +2345,7 @@ begin
   hdr.indexrootblock :=NToLE(dword(blocknr-1));    // Index of the root block in the file.
   hdr.unknown1       :=NToLE(dword(-1));           // always -1
   hdr.nrblock        :=NToLE(blocknr);      // Number of blocks
-  hdr.treedepth      :=NToLE(TreeDepth);    // The depth of the tree of blocks (1 if no index blocks, 2 one level of index blocks, ...)
+  hdr.treedepth      :=NToLE(word(TreeDepth));    // The depth of the tree of blocks (1 if no index blocks, 2 one level of index blocks, ...)
   hdr.nrkeywords     :=NToLE(Totalentries); // number of keywords in the file.
   hdr.codepage       :=NToLE(dword(1252));         // Windows code page identifier (usually 1252 - Windows 3.1 US (ANSI))
   hdr.lcid           :=NToLE(0);            //  ???? LCID from the HHP file.
@@ -2165,6 +2369,7 @@ begin
   PropertyStream.Free;
   MapStream.Free;
   DataStream.Free;
+  FHasKLinks:=TotalEntries>0;
 end;
 
 procedure TChmWriter.AppendBinaryTOCStream(AStream: TStream);
@@ -2187,6 +2392,7 @@ begin
 end;
 
 begin
+  AddDummyALink;
   stadd('BTree',IndexStream);
   stadd('Data', DataStream);
   stadd('Map' , MapStream);
@@ -2226,7 +2432,17 @@ begin
   FContextStream.WriteDWord(Offset);
 end;
 
-procedure TChmWriter.SetWindows(AWindowList:TObjectList);
+procedure TChmWriter.AddDummyALink;
+var stream  : TMemoryStream;
+begin
+    stream:=tmemorystream.create;
+    stream.WriteDWord(0);
+    stream.position:=0;
+    AddStreamToArchive('Property','/$WWAssociativeLinks/',stream,True);
+    stream.free;
+end;
+
+procedure TChmWriter.Setwindows(AWindowList: TObjectList);
 
 var i : integer;
     x : TCHMWindow;
@@ -2240,6 +2456,13 @@ begin
     end;
 end;
 
+procedure TChmWriter.SetMergefiles(src:TStringList);
+var i : integer;
+begin
+  FMergeFiles.Clear;
+  for i:=0 to Src.count -1 do
+      FMergefiles.add(src[i]);
+end;
 
 end.
 

packages/chm/src/fasthtmlparser.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/htmlindexer.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/htmlutil.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,

packages/chm/src/itolitlsreader.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.modifiedLGPL, included in this distribution,

packages/chm/src/itolitlstypes.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.modifiedLGPL, included in this distribution,

packages/chm/src/itsftransform.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
 }
 {
   See the file COPYING.modifiedLGPL, included in this distribution,

packages/chm/src/lzxcompressthread.pas

@@ -12,7 +12,7 @@
 
   You should have received a copy of the GNU Library General Public License
   along with this library; if not, write to the Free Software Foundation,
-  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
 }
 {
   See the file COPYING.FPC, included in this distribution,