* synchronised with trunk up till r28402

git-svn-id: branches/hlcgllvm@28403 -

.gitattributes

@@ -3110,6 +3110,7 @@ packages/fcl-web/src/base/websession.pp svneol=native#text/plain
 packages/fcl-web/src/base/webutil.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/Makefile svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/Makefile.fpc svneol=native#text/plain
+packages/fcl-web/src/jsonrpc/fpdispextdirect.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/fpextdirect.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/fpjsonrpc.pp svneol=native#text/plain
 packages/fcl-web/src/jsonrpc/readme.txt svneol=native#text/plain
@@ -4127,14 +4128,18 @@ packages/hash/examples/crctest.pas svneol=native#text/plain
 packages/hash/examples/hmd5.pp svneol=native#text/plain
 packages/hash/examples/hsha1.pp svneol=native#text/plain
 packages/hash/examples/md5.ref svneol=native#text/plain
+packages/hash/examples/md5performancetest.pas svneol=native#text/plain
 packages/hash/examples/mdtest.pas svneol=native#text/plain
+packages/hash/examples/sha1performancetest.pas svneol=native#text/plain
 packages/hash/examples/sha1test.pp svneol=native#text/plain
 packages/hash/fpmake.pp svneol=native#text/plain
 packages/hash/src/crc.pas svneol=native#text/plain
 packages/hash/src/hmac.pp svneol=native#text/plain
 packages/hash/src/md5.pp svneol=native#text/plain
+packages/hash/src/md5i386.inc svneol=native#text/plain
 packages/hash/src/ntlm.pas svneol=native#text/plain
 packages/hash/src/sha1.pp svneol=native#text/plain
+packages/hash/src/sha1i386.inc svneol=native#text/plain
 packages/hash/src/unixcrypt.pas svneol=native#text/plain
 packages/hash/src/uuid.pas svneol=native#text/plain
 packages/hash/tests/tests.pp svneol=native#text/plain
@@ -5096,6 +5101,24 @@ packages/libndsfpc/examples/graphics/Backgrounds/rotation/Makefile.fpc svneol=na
 packages/libndsfpc/examples/graphics/Backgrounds/rotation/Rotation.pp svneol=native#text/plain
 packages/libndsfpc/examples/graphics/Backgrounds/rotation/data/drunkenlogo.bin -text svneol=unset#application/octet-stream
 packages/libndsfpc/examples/graphics/Backgrounds/rotation/data/palette.bin -text
+packages/libndsfpc/examples/graphics/Effects/Makefile svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Effects/Makefile.fpc svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Effects/windows/Makefile svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Effects/windows/Makefile.fpc svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Effects/windows/gfx/drunkenlogo.grit svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Effects/windows/gfx/drunkenlogo.png -text svneol=unset#image/png
+packages/libndsfpc/examples/graphics/Effects/windows/windows.pp svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/Makefile svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/Makefile.fpc svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/Makefile svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/Makefile.fpc svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/backgrounds.pp svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/gfx/devkitlogo.grit svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/gfx/devkitlogo.png -text svneol=unset#image/png
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/gfx/drunkenlogo.grit svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/gfx/drunkenlogo.png -text svneol=unset#image/png
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/inc/devkitlogo.inc svneol=native#text/plain
+packages/libndsfpc/examples/graphics/Ext_Palettes/backgrounds/inc/drunkenlogo.inc svneol=native#text/plain
 packages/libndsfpc/examples/graphics/Makefile svneol=native#text/plain
 packages/libndsfpc/examples/graphics/Makefile.fpc svneol=native#text/plain
 packages/libndsfpc/examples/graphics/Printing/Makefile svneol=native#text/plain
@@ -5244,6 +5267,7 @@ packages/libndsfpc/src/nds/arm9/sprite.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/arm9/trig_lut.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/arm9/video.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/arm9/videoGL.inc svneol=native#text/plain
+packages/libndsfpc/src/nds/arm9/window.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/bios.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/card.inc svneol=native#text/plain
 packages/libndsfpc/src/nds/debug.inc svneol=native#text/plain
@@ -6240,7 +6264,6 @@ packages/paszlib/src/zipper.pp svneol=native#text/plain
 packages/paszlib/src/ziputils.pas svneol=native#text/plain
 packages/paszlib/src/zstream.pp svneol=native#text/plain
 packages/paszlib/src/zuncompr.pas svneol=native#text/plain
-packages/paszlib/tests/tconend.pp svneol=native#text/plain
 packages/paszlib/tests/tczipper.pp svneol=native#text/plain
 packages/pcap/Makefile svneol=native#text/plain
 packages/pcap/Makefile.fpc svneol=native#text/plain
@@ -7857,6 +7880,7 @@ rtl/android/mipsel/dllprt0.as svneol=native#text/plain
 rtl/android/mipsel/prt0.as svneol=native#text/plain
 rtl/arm/arm.inc svneol=native#text/plain
 rtl/arm/armdefines.inc svneol=native#text/plain
+rtl/arm/divide.inc svneol=native#text/plain
 rtl/arm/int64p.inc svneol=native#text/plain
 rtl/arm/makefile.cpu svneol=native#text/plain
 rtl/arm/math.inc svneol=native#text/plain
@@ -9643,6 +9667,8 @@ tests/tbf/tb0244.pp svneol=native#text/plain
 tests/tbf/tb0245.pp svneol=native#text/plain
 tests/tbf/tb0246.pp svneol=native#text/plain
 tests/tbf/tb0247.pp svneol=native#text/plain
+tests/tbf/tb0248.pp svneol=native#text/plain
+tests/tbf/tb0249.pp svneol=native#text/plain
 tests/tbf/ub0115.pp svneol=native#text/plain
 tests/tbf/ub0149.pp svneol=native#text/plain
 tests/tbf/ub0158a.pp svneol=native#text/plain
@@ -10881,11 +10907,14 @@ tests/test/cpu16/i8086/tfarptr1.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tfarptr2.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tfarptr3.pp svneol=native#text/plain
 tests/test/cpu16/i8086/tfarptr4.pp svneol=native#text/plain
+tests/test/cpu16/i8086/tfarptr5.pp svneol=native#text/plain
 tests/test/cpu16/i8086/thugeptr1.pp svneol=native#text/plain
 tests/test/cpu16/i8086/thugeptr1a.pp svneol=native#text/plain
 tests/test/cpu16/i8086/thugeptr1b.pp svneol=native#text/plain
 tests/test/cpu16/i8086/thugeptr2.pp svneol=native#text/plain
 tests/test/cpu16/i8086/thugeptr2a.pp svneol=native#text/plain
+tests/test/cpu16/i8086/thugeptr5.pp svneol=native#text/plain
+tests/test/cpu16/i8086/thugeptr5a.pp svneol=native#text/plain
 tests/test/cpu16/i8086/tintr1.pp svneol=native#text/plain
 tests/test/cpu16/i8086/tintr2.pp svneol=native#text/plain
 tests/test/cpu16/i8086/tmmc.pp svneol=native#text/plain
@@ -12376,6 +12405,7 @@ tests/test/units/math/tmask.pp svneol=native#text/plain
 tests/test/units/math/tmask2.pp svneol=native#text/plain
 tests/test/units/math/tnaninf.pp svneol=native#text/plain
 tests/test/units/math/tpower.pp svneol=native#text/pascal
+tests/test/units/math/troundm.pp svneol=native#text/plain
 tests/test/units/math/tsincos.pp svneol=native#text/pascal
 tests/test/units/math/ttrig1.pp svneol=native#text/plain
 tests/test/units/matrix/tinv1.pp svneol=native#text/pascal
@@ -12795,6 +12825,7 @@ tests/webtbf/tw26176.pp svneol=native#text/plain
 tests/webtbf/tw26193.pp svneol=native#text/plain
 tests/webtbf/tw26363.pp svneol=native#text/plain
 tests/webtbf/tw26363a.pp svneol=native#text/plain
+tests/webtbf/tw26456.pp svneol=native#text/plain
 tests/webtbf/tw2650.pp svneol=native#text/plain
 tests/webtbf/tw2657.pp svneol=native#text/plain
 tests/webtbf/tw2670.pp svneol=native#text/plain
@@ -14020,6 +14051,7 @@ tests/webtbs/tw26408.pp svneol=native#text/pascal
 tests/webtbs/tw2643.pp svneol=native#text/plain
 tests/webtbs/tw2645.pp svneol=native#text/plain
 tests/webtbs/tw2647.pp svneol=native#text/plain
+tests/webtbs/tw26482.pp svneol=native#text/plain
 tests/webtbs/tw2649.pp svneol=native#text/plain
 tests/webtbs/tw2651.pp svneol=native#text/plain
 tests/webtbs/tw2656.pp svneol=native#text/plain

compiler/aggas.pas

@@ -763,7 +763,8 @@ implementation
                        asmwrite(ReplaceForbiddenAsmSymbolChars(tai_datablock(hp).sym.name));
                        asmwrite(',');
                        asmwrite(tostr(tai_datablock(hp).size)+',');
-                       asmwrite('_data.bss_');
+                       asmwrite('_data.bss_,');
+                       asmwriteln(tostr(last_align));
                      end;
                  end
                else

compiler/arm/aoptcpu.pas

@@ -30,7 +30,7 @@ Unit aoptcpu;
 
 Interface
 
-uses cgbase, cpubase, aasmtai, aasmcpu,aopt, aoptobj;
+uses cgbase, cgutils, cpubase, aasmtai, aasmcpu,aopt, aoptobj;
 
 Type
   TCpuAsmOptimizer = class(TAsmOptimizer)
@@ -49,7 +49,8 @@ Type
       change in program flow.
       If there is none, it returns false and
       sets p1 to nil                                                     }
-    Function GetNextInstructionUsingReg(Current: tai; Var Next: tai;reg : TRegister): Boolean;
+    Function GetNextInstructionUsingReg(Current: tai; Out Next: tai; reg: TRegister): Boolean;
+    Function GetNextInstructionUsingRef(Current: tai; Out Next: tai; const ref: TReference; StopOnStore: Boolean = true): Boolean;
 
     { outputs a debug message into the assembler file }
     procedure DebugMsg(const s: string; p: tai);
@@ -79,7 +80,7 @@ Implementation
     cutils,verbose,globtype,globals,
     systems,
     cpuinfo,
-    cgobj,cgutils,procinfo,
+    cgobj,procinfo,
     aasmbase,aasmdata;
 
   function CanBeCond(p : tai) : boolean;
@@ -317,15 +318,39 @@ Implementation
          RegLoadedWithNewValue(reg,p);
     end;
 
-
   function TCpuAsmOptimizer.GetNextInstructionUsingReg(Current: tai;
-    var Next: tai; reg: TRegister): Boolean;
+    Out Next: tai; reg: TRegister): Boolean;
+    begin
+      Next:=Current;
+      repeat
+        Result:=GetNextInstruction(Next,Next);
+      until not (Result) or
+            not(cs_opt_level3 in current_settings.optimizerswitches) or
+            (Next.typ<>ait_instruction) or
+            RegInInstruction(reg,Next) or
+            is_calljmp(taicpu(Next).opcode) or
+            RegModifiedByInstruction(NR_PC,Next);
+    end;
+
+  function TCpuAsmOptimizer.GetNextInstructionUsingRef(Current: tai;
+    Out Next: tai; const ref: TReference; StopOnStore: Boolean = true): Boolean;
     begin
       Next:=Current;
       repeat
         Result:=GetNextInstruction(Next,Next);
-      until not(cs_opt_level3 in current_settings.optimizerswitches) or not(Result) or (Next.typ<>ait_instruction) or (RegInInstruction(reg,Next)) or
-        (is_calljmp(taicpu(Next).opcode)) or (RegInInstruction(NR_PC,Next));
+        if Result and
+           (Next.typ=ait_instruction) and
+           (taicpu(Next).opcode in [A_LDR, A_STR]) and
+           RefsEqual(taicpu(Next).oper[1]^.ref^,ref) then
+            {We've found an instruction LDR or STR with the same reference}
+            exit;
+      until not(Result) or
+            (Next.typ<>ait_instruction) or
+            not(cs_opt_level3 in current_settings.optimizerswitches) or
+            is_calljmp(taicpu(Next).opcode) or
+            (StopOnStore and (taicpu(Next).opcode in [A_STR, A_STM])) or
+            RegModifiedByInstruction(NR_PC,Next);
+      Result:=false;
     end;
 
 {$ifdef DEBUG_AOPTCPU}
@@ -609,10 +634,13 @@ Implementation
                     }
                     if (taicpu(p).oper[1]^.ref^.addressmode=AM_OFFSET) and
                        (taicpu(p).oppostfix=PF_None) and
-                       GetNextInstruction(p,hp1) and
-                       MatchInstruction(hp1, A_LDR, [taicpu(p).condition, C_None], [PF_None]) and
-                       RefsEqual(taicpu(p).oper[1]^.ref^,taicpu(hp1).oper[1]^.ref^) and
-                       (taicpu(hp1).oper[1]^.ref^.addressmode=AM_OFFSET) then
+                       (taicpu(p).condition=C_None) and
+                       GetNextInstructionUsingRef(p,hp1,taicpu(p).oper[1]^.ref^) and
+                       MatchInstruction(hp1, A_LDR, [taicpu(p).condition], [PF_None]) and
+                       (taicpu(hp1).oper[1]^.ref^.addressmode=AM_OFFSET) and
+                       not(RegModifiedBetween(taicpu(p).oper[0]^.reg, p, hp1)) and
+                       ((taicpu(hp1).oper[1]^.ref^.index=NR_NO) or not (RegModifiedBetween(taicpu(hp1).oper[1]^.ref^.index, p, hp1))) and
+                       ((taicpu(hp1).oper[1]^.ref^.base=NR_NO) or not (RegModifiedBetween(taicpu(hp1).oper[1]^.ref^.base, p, hp1))) then
                       begin
                         if taicpu(hp1).oper[0]^.reg=taicpu(p).oper[0]^.reg then
                           begin
@@ -1583,13 +1611,14 @@ Implementation
                               and reg1,reg0,2^n-1
                               mov reg2,reg1, lsl imm1
                               =>
-                              mov reg2,reg1, lsl imm1
+                              mov reg2,reg0, lsl imm1
                               if imm1>i
                             }
-                            else if i>32-taicpu(hp1).oper[2]^.shifterop^.shiftimm then
+                            else if (i>32-taicpu(hp1).oper[2]^.shifterop^.shiftimm) and
+                                    not(RegModifiedBetween(taicpu(p).oper[1]^.reg, p, hp1)) then
                               begin
                                 DebugMsg('Peephole AndLsl2Lsl done', p);
-                                taicpu(hp1).oper[1]^.reg:=taicpu(p).oper[0]^.reg;
+                                taicpu(hp1).oper[1]^.reg:=taicpu(p).oper[1]^.reg;
                                 GetNextInstruction(p, hp1);
                                 asml.Remove(p);
                                 p.free;
@@ -2435,7 +2464,10 @@ Implementation
             { first instruction might not change the register used as index }
             ((taicpu(hp1).oper[1]^.ref^.index=NR_NO) or
              not(RegModifiedByInstruction(taicpu(hp1).oper[1]^.ref^.index,p))
-            ) then
+            ) and
+            { if we modify the basereg AND the first instruction used that reg, we can not schedule }
+            ((taicpu(hp1).oper[1]^.ref^.addressmode = AM_OFFSET) or
+             not(instructionLoadsFromReg(taicpu(hp1).oper[1]^.ref^.base,p))) then
             begin
               hp3:=tai(p.Previous);
               hp5:=tai(p.next);

compiler/arm/cgcpu.pas

@@ -93,7 +93,6 @@ unit cgcpu;
         function handle_load_store(list:TAsmList;op: tasmop;oppostfix : toppostfix;reg:tregister;ref: treference):treference; virtual;
 
         procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-        procedure g_stackpointer_alloc(list : TAsmList;size : longint);override;
 
         procedure a_loadmm_reg_reg(list: TAsmList; fromsize, tosize : tcgsize;reg1, reg2: tregister;shuffle : pmmshuffle); override;
         procedure a_loadmm_ref_reg(list: TAsmList; fromsize, tosize : tcgsize;const ref: treference; reg: tregister;shuffle : pmmshuffle); override;
@@ -2896,12 +2895,6 @@ unit cgcpu;
       end;
 
 
-    procedure tbasecgarm.g_stackpointer_alloc(list: TAsmList; size: longint);
-      begin
-        internalerror(200807237);
-      end;
-
-
     function get_scalar_mm_op(fromsize,tosize : tcgsize) : tasmop;
       const
         convertop : array[OS_F32..OS_F128,OS_F32..OS_F128] of tasmop = (

compiler/arm/narmadd.pas

@@ -403,6 +403,8 @@ interface
         oldnodetype : tnodetype;
         dummyreg : tregister;
         l: tasmlabel;
+      const
+        lt_zero_swapped: array[boolean] of tnodetype = (ltn, gtn);
       begin
         unsigned:=not(is_signed(left.resultdef)) or
                   not(is_signed(right.resultdef));
@@ -411,20 +413,34 @@ interface
 
         { pass_left_right moves possible consts to the right, the only
           remaining case with left consts (currency) can take this path too (KB) }
-        if (nodetype in [equaln,unequaln]) and
-          (right.nodetype=ordconstn) and (tordconstnode(right).value=0) then
+        if (right.nodetype=ordconstn) and
+           (tordconstnode(right).value=0) and
+           ((nodetype in [equaln,unequaln]) or
+            (not(GenerateThumbCode) and is_signed(left.resultdef) and (nodetype = lt_zero_swapped[nf_swapped in Flags]))
+           ) then
           begin
             location_reset(location,LOC_FLAGS,OS_NO);
-            location.resflags:=getresflags(unsigned);
             if not(left.location.loc in [LOC_CREGISTER,LOC_REGISTER]) then
               hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
-            dummyreg:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
-            cg.a_reg_alloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
 
-            if GenerateThumbCode then
-              cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_32,left.location.register64.reglo,left.location.register64.reghi,dummyreg)
+            cg.a_reg_alloc(current_asmdata.CurrAsmList,NR_DEFAULTFLAGS);
+            { Optimize for the common case of int64 < 0 }
+            if nodetype in [ltn, gtn] then
+              begin
+                {Just check for the MSB in reghi to be set or not, this is independed from nf_swapped}
+                location.resflags:=F_NE;
+                current_asmdata.CurrAsmList.concat(taicpu.op_reg_const(A_TST,left.location.register64.reghi, $80000000));
+              end
             else
-              current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ORR,dummyreg,left.location.register64.reglo,left.location.register64.reghi),PF_S));
+              begin
+                location.resflags:=getresflags(unsigned);
+                dummyreg:=cg.getintregister(current_asmdata.CurrAsmList,location.size);
+
+                if GenerateThumbCode then
+                  cg.a_op_reg_reg_reg(current_asmdata.CurrAsmList,OP_OR,OS_32,left.location.register64.reglo,left.location.register64.reghi,dummyreg)
+                else
+                  current_asmdata.CurrAsmList.concat(setoppostfix(taicpu.op_reg_reg_reg(A_ORR,dummyreg,left.location.register64.reglo,left.location.register64.reghi),PF_S));
+              end;
           end
         else
           begin

compiler/arm/rgcpu.pas

@@ -290,6 +290,10 @@ unit rgcpu;
         if abs(spilltemp.offset)>4095 then
           exit;
 
+        { ldr can't set the flags }
+        if taicpu(instr).oppostfix=PF_S then
+          exit;
+
         if GenerateThumbCode and
           (abs(spilltemp.offset)>1020) then
           exit;

compiler/avr/cgcpu.pas

@@ -99,14 +99,12 @@ unit cgcpu;
           tmpreg : tregister) : treference;
 
         procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
-        procedure g_stackpointer_alloc(list : TAsmList;size : longint);override;
         procedure emit_mov(list: TAsmList;reg2: tregister; reg1: tregister);
 
         procedure a_adjust_sp(list: TAsmList; value: longint);
         function GetLoad(const ref : treference) : tasmop;
         function GetStore(const ref: treference): tasmop;
 
-        procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister); override;
       protected
         procedure a_op_reg_reg_internal(list: TAsmList; Op: TOpCG; size: TCGSize; src, srchi, dst, dsthi: TRegister);
         procedure a_op_const_reg_internal(list : TAsmList; Op: TOpCG; size: TCGSize; a: tcgint; reg, reghi: TRegister);
@@ -1378,12 +1376,6 @@ unit cgcpu;
       end;
 
 
-    procedure tcgavr.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister);
-      begin
-        Comment(V_Error,'tcgarm.a_bit_scan_reg_reg method not implemented');
-      end;
-
-
     procedure tcgavr.a_jmp_name(list : TAsmList;const s : string);
       var
         ai : taicpu;
@@ -1883,12 +1875,6 @@ unit cgcpu;
       end;
 
 
-    procedure tcgavr.g_stackpointer_alloc(list: TAsmList; size: longint);
-      begin
-        internalerror(201201071);
-      end;
-
-
     procedure tcgavr.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
       begin
         //internalerror(2011021324);

compiler/cclasses.pas

@@ -508,14 +508,14 @@ type
          destructor Destroy; override;
          procedure Clear;
          { finds an entry by key }
-         function Find(Key: Pointer; KeyLen: Integer): PHashSetItem;
+         function Find(Key: Pointer; KeyLen: Integer): PHashSetItem;virtual;
          { finds an entry, creates one if not exists }
          function FindOrAdd(Key: Pointer; KeyLen: Integer;
-           var Found: Boolean): PHashSetItem;
+           var Found: Boolean): PHashSetItem;virtual;
          { finds an entry, creates one if not exists }
-         function FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;
+         function FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;virtual;
          { returns Data by given Key }
-         function Get(Key: Pointer; KeyLen: Integer): TObject;
+         function Get(Key: Pointer; KeyLen: Integer): TObject;virtual;
          { removes an entry, returns False if entry wasn't there }
          function Remove(Entry: PHashSetItem): Boolean;
          property Count: LongWord read FCount;

compiler/cgobj.pas

@@ -248,7 +248,7 @@ unit cgobj;
           procedure a_loadaddr_ref_reg(list : TAsmList;const ref : treference;r : tregister);virtual; abstract;
 
           { bit scan instructions }
-          procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister); virtual; abstract;
+          procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister); virtual;
 
           { Multiplication with doubling result size.
             dstlo or dsthi may be NR_NO, in which case corresponding half of result is discarded. }
@@ -413,7 +413,7 @@ unit cgobj;
 
              @param(size Number of bytes to allocate)
           }
-          procedure g_stackpointer_alloc(list : TAsmList;size : longint);virtual; abstract;
+          procedure g_stackpointer_alloc(list : TAsmList;size : longint);virtual;
           {# Emits instruction for allocating the locals in entry
              code of a routine. This is one of the first
              routine called in @var(genentrycode).
@@ -2516,6 +2516,18 @@ implementation
       end;
 
 
+    procedure tcg.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: tcgsize; src, dst: TRegister);
+      begin
+        internalerror(2014070601);
+      end;
+
+
+    procedure tcg.g_stackpointer_alloc(list: TAsmList; size: longint);
+      begin
+        internalerror(2014070602);
+      end;
+
+
     procedure tcg.a_mul_reg_reg_pair(list: TAsmList; size: TCgSize; src1,src2,dstlo,dsthi: TRegister);
       begin
         internalerror(2014060801);

compiler/defutil.pas

@@ -331,21 +331,6 @@ interface
     { returns true of def is a methodpointer }
     function is_methodpointer(def : tdef) : boolean;
 
-    {# returns the appropriate int type for pointer arithmetic with the given pointer type.
-       When adding or subtracting a number to/from a pointer, this function returns the
-       int type to which that number has to be converted, before the operation can be performed.
-       Normally, this is sinttype, except on i8086, where it takes into account the
-       special i8086 pointer types (near, far, huge). }
-    function get_int_type_for_pointer_arithmetic(p : tdef) : tdef;
-
-{$ifdef i8086}
-    {# Returns true if p is a far pointer def }
-    function is_farpointer(p : tdef) : boolean;
-
-    {# Returns true if p is a huge pointer def }
-    function is_hugepointer(p : tdef) : boolean;
-{$endif i8086}
-
 implementation
 
     uses
@@ -1440,29 +1425,4 @@ implementation
         result:=(def.typ=procvardef) and (po_methodpointer in tprocvardef(def).procoptions);
       end;
 
-
-    function get_int_type_for_pointer_arithmetic(p : tdef) : tdef;
-      begin
-{$ifdef i8086}
-        if is_hugepointer(p) then
-          result:=s32inttype
-        else
-{$endif i8086}
-          result:=sinttype;
-      end;
-
-{$ifdef i8086}
-    { true if p is a far pointer def }
-    function is_farpointer(p : tdef) : boolean;
-      begin
-        result:=(p.typ=pointerdef) and (tcpupointerdef(p).x86pointertyp=x86pt_far);
-      end;
-
-    { true if p is a huge pointer def }
-    function is_hugepointer(p : tdef) : boolean;
-      begin
-        result:=(p.typ=pointerdef) and (tcpupointerdef(p).x86pointertyp=x86pt_huge);
-      end;
-{$endif i8086}
-
 end.

compiler/fmodule.pas

@@ -44,7 +44,7 @@ interface
     uses
        cutils,cclasses,cfileutl,
        globtype,finput,ogbase,
-       symbase,symsym,
+       symbase,symconst,symsym,symcpu,
        wpobase,
        aasmbase,aasmtai,aasmdata;
 
@@ -142,7 +142,7 @@ interface
         checkforwarddefs,
         deflist,
         symlist       : TFPObjectList;
-        ptrdefs       : THashSet; { list of pointerdefs created in this module so we can reuse them (not saved/restored) }
+        ptrdefs       : tPtrDefHashSet; { list of pointerdefs created in this module so we can reuse them (not saved/restored) }
         arraydefs     : THashSet; { list of single-element-arraydefs created in this module so we can reuse them (not saved/restored) }
 {$ifdef llvm}
         llvmdefs      : THashSet; { defs added for llvm-specific reasons (not saved/restored) }
@@ -570,7 +570,7 @@ implementation
         derefdataintflen:=0;
         deflist:=TFPObjectList.Create(false);
         symlist:=TFPObjectList.Create(false);
-        ptrdefs:=THashSet.Create(64,true,false);
+        ptrdefs:=cPtrDefHashSet.Create;
         arraydefs:=THashSet.Create(64,true,false);
 {$ifdef llvm}
         llvmdefs:=THashSet.Create(64,true,false);
@@ -753,7 +753,7 @@ implementation
         symlist.free;
         symlist:=TFPObjectList.Create(false);
         ptrdefs.free;
-        ptrdefs:=THashSet.Create(64,true,false);
+        ptrdefs:=cPtrDefHashSet.Create;
         arraydefs.free;
         arraydefs:=THashSet.Create(64,true,false);
 {$ifdef llvm}

compiler/i386/n386add.pas

@@ -229,8 +229,7 @@ interface
 
     procedure ti386addnode.second_cmp64bit;
       var
-        hregister,
-        hregister2 : tregister;
+        hlab       : tasmlabel;
         href       : treference;
         unsigned   : boolean;
 
@@ -247,10 +246,12 @@ interface
            case nodetype of
               ltn,gtn:
                 begin
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   if (hlab<>current_procinfo.CurrTrueLabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
                    { cheat a little bit for the negative test }
                    toggleflag(nf_swapped);
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   if (hlab<>current_procinfo.CurrFalseLabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
                    toggleflag(nf_swapped);
                 end;
               lten,gten:
@@ -260,13 +261,15 @@ interface
                      nodetype:=ltn
                    else
                      nodetype:=gtn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                   if (hlab<>current_procinfo.CurrTrueLabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
                    { cheat for the negative test }
                    if nodetype=ltn then
                      nodetype:=gtn
                    else
                      nodetype:=ltn;
-                   cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                   if (hlab<>current_procinfo.CurrFalseLabel) then
+                     cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
                    nodetype:=oldnodetype;
                 end;
               equaln:
@@ -309,24 +312,46 @@ interface
                   ((right.resultdef.typ=orddef) and
                    (torddef(right.resultdef).ordtype=u64bit));
 
+        { we have LOC_JUMP as result }
+        location_reset(location,LOC_JUMP,OS_NO);
+
+        { Relational compares against constants having low dword=0 can omit the
+          second compare based on the fact that any unsigned value is >=0 }
+        hlab:=nil;
+        if (right.location.loc=LOC_CONSTANT) and
+           (lo(right.location.value64)=0) then
+          begin
+            case getresflags(true) of
+              F_AE: hlab:=current_procinfo.CurrTrueLabel;
+              F_B:  hlab:=current_procinfo.CurrFalseLabel;
+            end;
+          end;
+
+        if (right.location.loc=LOC_CONSTANT) and
+           (left.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+          begin
+            tcgx86(cg).make_simple_ref(current_asmdata.CurrAsmList,left.location.reference);
+            href:=left.location.reference;
+            inc(href.offset,4);
+            emit_const_ref(A_CMP,S_L,aint(hi(right.location.value64)),href);
+            firstjmp64bitcmp;
+            if assigned(hlab) then
+              cg.a_jmp_always(current_asmdata.CurrAsmList,hlab)
+            else
+              begin
+                emit_const_ref(A_CMP,S_L,aint(lo(right.location.value64)),left.location.reference);
+                secondjmp64bitcmp;
+              end;
+            location_freetemp(current_asmdata.CurrAsmList,left.location);
+            exit;
+          end;
+
         { left and right no register?  }
         { then one must be demanded    }
-        if (left.location.loc<>LOC_REGISTER) then
+        if not (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
          begin
-           if (right.location.loc<>LOC_REGISTER) then
-            begin
-              { we can reuse a CREGISTER for comparison }
-              if (left.location.loc<>LOC_CREGISTER) then
-               begin
-                 hregister:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
-                 hregister2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
-                 cg64.a_load64_loc_reg(current_asmdata.CurrAsmList,left.location,joinreg64(hregister,hregister2));
-                 location_freetemp(current_asmdata.CurrAsmList,left.location);
-                 location_reset(left.location,LOC_REGISTER,left.location.size);
-                 left.location.register64.reglo:=hregister;
-                 left.location.register64.reghi:=hregister2;
-               end;
-            end
+           if not (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+             hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true)
            else
             begin
               location_swap(left.location,right.location);
@@ -334,51 +359,44 @@ interface
             end;
          end;
 
-        { at this point, left.location.loc should be LOC_REGISTER }
-        if right.location.loc=LOC_REGISTER then
-         begin
-           emit_reg_reg(A_CMP,S_L,right.location.register64.reghi,left.location.register64.reghi);
-           firstjmp64bitcmp;
-           emit_reg_reg(A_CMP,S_L,right.location.register64.reglo,left.location.register64.reglo);
-           secondjmp64bitcmp;
-         end
+        { at this point, left.location.loc should be LOC_[C]REGISTER }
+        case right.location.loc of
+          LOC_REGISTER,
+          LOC_CREGISTER :
+            begin
+              emit_reg_reg(A_CMP,S_L,right.location.register64.reghi,left.location.register64.reghi);
+              firstjmp64bitcmp;
+              emit_reg_reg(A_CMP,S_L,right.location.register64.reglo,left.location.register64.reglo);
+              secondjmp64bitcmp;
+            end;
+          LOC_CREFERENCE,
+          LOC_REFERENCE :
+            begin
+              tcgx86(cg).make_simple_ref(current_asmdata.CurrAsmList,right.location.reference);
+              href:=right.location.reference;
+              inc(href.offset,4);
+              emit_ref_reg(A_CMP,S_L,href,left.location.register64.reghi);
+              firstjmp64bitcmp;
+              emit_ref_reg(A_CMP,S_L,right.location.reference,left.location.register64.reglo);
+              secondjmp64bitcmp;
+              location_freetemp(current_asmdata.CurrAsmList,right.location);
+            end;
+          LOC_CONSTANT :
+            begin
+              current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(hi(right.location.value64)),left.location.register64.reghi));
+              firstjmp64bitcmp;
+              if assigned(hlab) then
+                cg.a_jmp_always(current_asmdata.CurrAsmList,hlab)
+              else
+                begin
+                  current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(lo(right.location.value64)),left.location.register64.reglo));
+                  secondjmp64bitcmp;
+                end;
+            end;
         else
-         begin
-           case right.location.loc of
-             LOC_CREGISTER :
-               begin
-                 emit_reg_reg(A_CMP,S_L,right.location.register64.reghi,left.location.register64.reghi);
-                 firstjmp64bitcmp;
-                 emit_reg_reg(A_CMP,S_L,right.location.register64.reglo,left.location.register64.reglo);
-                 secondjmp64bitcmp;
-               end;
-             LOC_CREFERENCE,
-             LOC_REFERENCE :
-               begin
-                 tcgx86(cg).make_simple_ref(current_asmdata.CurrAsmList,right.location.reference);
-                 href:=right.location.reference;
-                 inc(href.offset,4);
-                 emit_ref_reg(A_CMP,S_L,href,left.location.register64.reghi);
-                 firstjmp64bitcmp;
-                 emit_ref_reg(A_CMP,S_L,right.location.reference,left.location.register64.reglo);
-                 secondjmp64bitcmp;
-                 cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
-                 location_freetemp(current_asmdata.CurrAsmList,right.location);
-               end;
-             LOC_CONSTANT :
-               begin
-                 current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(hi(right.location.value64)),left.location.register64.reghi));
-                 firstjmp64bitcmp;
-                 current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(lo(right.location.value64)),left.location.register64.reglo));
-                 secondjmp64bitcmp;
-               end;
-             else
-               internalerror(200203282);
-           end;
-         end;
+          internalerror(200203282);
+        end;
 
-        { we have LOC_JUMP as result }
-        location_reset(location,LOC_JUMP,OS_NO)
       end;
 
 

compiler/i386/symcpu.pas

@@ -207,5 +207,7 @@ begin
   cconstsym:=tcpuconstsym;
   cenumsym:=tcpuenumsym;
   csyssym:=tcpusyssym;
+
+  cPtrDefHashSet:=tx86PtrDefHashSet;
 end.
 

compiler/i8086/n8086add.pas

@@ -39,11 +39,13 @@ interface
          function first_addhugepointer: tnode;
          function first_cmppointer: tnode; override;
          function first_cmphugepointer: tnode;
+         function first_cmpfarpointer: tnode;
          procedure second_addordinal; override;
          procedure second_add64bit;override;
          procedure second_addfarpointer;
          procedure second_cmp64bit;override;
          procedure second_cmp32bit;
+         procedure second_cmpfarpointer;
          procedure second_cmpordinal;override;
          procedure second_mul(unsigned: boolean);
        end;
@@ -53,7 +55,7 @@ interface
     uses
       globtype,systems,
       cutils,verbose,globals,constexp,pass_1,
-      symconst,symdef,symtype,paramgr,defutil,
+      symconst,symdef,symtype,symcpu,paramgr,defutil,
       aasmbase,aasmtai,aasmdata,aasmcpu,
       cgbase,procinfo,
       ncal,ncon,nset,cgutils,tgobj,
@@ -314,7 +316,7 @@ interface
 
     function ti8086addnode.first_addpointer: tnode;
       begin
-        if is_hugepointer(left.resultdef) xor is_hugepointer(right.resultdef) then
+        if is_hugepointer(left.resultdef) or is_hugepointer(right.resultdef) then
           result:=first_addhugepointer
         else
           result:=inherited;
@@ -327,17 +329,22 @@ interface
       begin
         result:=nil;
 
-        case nodetype of
-          addn:
-            procname:='fpc_hugeptr_add_longint';
-          subn:
-            procname:='fpc_hugeptr_sub_longint';
-          else
-            internalerror(2014070301);
-        end;
+        if (nodetype=subn) and is_hugepointer(left.resultdef) and is_hugepointer(right.resultdef) then
+          procname:='fpc_hugeptr_sub_hugeptr'
+        else
+          begin
+            case nodetype of
+              addn:
+                procname:='fpc_hugeptr_add_longint';
+              subn:
+                procname:='fpc_hugeptr_sub_longint';
+              else
+                internalerror(2014070301);
+            end;
 
-        if cs_hugeptr_arithmetic_normalization in current_settings.localswitches then
-          procname:=procname+'_normalized';
+            if cs_hugeptr_arithmetic_normalization in current_settings.localswitches then
+              procname:=procname+'_normalized';
+          end;
 
         if is_hugepointer(left.resultdef) then
           result := ccallnode.createintern(procname,
@@ -357,6 +364,8 @@ interface
       begin
         if is_hugepointer(left.resultdef) or is_hugepointer(right.resultdef) then
           result:=first_cmphugepointer
+        else if is_farpointer(left.resultdef) or is_farpointer(right.resultdef) then
+          result:=first_cmpfarpointer
         else
           result:=inherited;
       end;
@@ -370,7 +379,7 @@ interface
 
         if not (cs_hugeptr_comparison_normalization in current_settings.localswitches) then
           begin
-            expectloc:=LOC_FLAGS;
+            expectloc:=LOC_JUMP;
             exit;
           end;
 
@@ -400,6 +409,22 @@ interface
       end;
 
 
+    function ti8086addnode.first_cmpfarpointer: tnode;
+      begin
+        { = and <> are handled as a 32-bit comparison }
+        if nodetype in [equaln,unequaln] then
+          begin
+            result:=nil;
+            expectloc:=LOC_JUMP;
+          end
+        else
+          begin
+            result:=nil;
+            expectloc:=LOC_FLAGS;
+          end;
+      end;
+
+
     procedure ti8086addnode.second_addfarpointer;
       var
         tmpreg : tregister;
@@ -786,7 +811,8 @@ interface
         unsigned:=((left.resultdef.typ=orddef) and
                    (torddef(left.resultdef).ordtype=u32bit)) or
                   ((right.resultdef.typ=orddef) and
-                   (torddef(right.resultdef).ordtype=u32bit));
+                   (torddef(right.resultdef).ordtype=u32bit)) or
+                  is_hugepointer(left.resultdef);
 
         { left and right no register?  }
         { then one must be demanded    }
@@ -859,9 +885,60 @@ interface
         location_reset(location,LOC_JUMP,OS_NO)
       end;
 
+
+    procedure ti8086addnode.second_cmpfarpointer;
+      begin
+        { handle = and <> as a 32-bit comparison }
+        if nodetype in [equaln,unequaln] then
+          begin
+            second_cmp32bit;
+            exit;
+          end;
+
+        pass_left_right;
+
+        { <, >, <= and >= compare the 16-bit offset only }
+        if (right.location.loc=LOC_CONSTANT) and
+           (left.location.loc in [LOC_REFERENCE, LOC_CREFERENCE])
+        then
+          begin
+            emit_const_ref(A_CMP, S_W, word(right.location.value), left.location.reference);
+            location_freetemp(current_asmdata.CurrAsmList,left.location);
+          end
+        else
+          begin
+            { left location is not a register? }
+            if left.location.loc<>LOC_REGISTER then
+             begin
+               { if right is register then we can swap the locations }
+               if right.location.loc=LOC_REGISTER then
+                begin
+                  location_swap(left.location,right.location);
+                  toggleflag(nf_swapped);
+                end
+               else
+                begin
+                  { maybe we can reuse a constant register when the
+                    operation is a comparison that doesn't change the
+                    value of the register }
+                  hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,u16inttype,true);
+                end;
+              end;
+
+            emit_generic_code(A_CMP,OS_16,true,false,false);
+            location_freetemp(current_asmdata.CurrAsmList,right.location);
+            location_freetemp(current_asmdata.CurrAsmList,left.location);
+          end;
+        location_reset(location,LOC_FLAGS,OS_NO);
+        location.resflags:=getresflags(true);
+      end;
+
+
     procedure ti8086addnode.second_cmpordinal;
       begin
-        if is_32bit(left.resultdef) or is_farpointer(left.resultdef) or is_hugepointer(left.resultdef) then
+        if is_farpointer(left.resultdef) then
+          second_cmpfarpointer
+        else if is_32bit(left.resultdef) or is_hugepointer(left.resultdef) then
           second_cmp32bit
         else
           inherited second_cmpordinal;

compiler/i8086/n8086inl.pas

@@ -51,7 +51,7 @@ implementation
     symconst,
     defutil,
     aasmbase,aasmtai,aasmdata,aasmcpu,
-    symtype,symdef,
+    symtype,symdef,symcpu,
     cgbase,pass_2,
     cpuinfo,cpubase,paramgr,
     nbas,ncon,ncal,ncnv,nld,ncgutil,

compiler/i8086/n8086mem.pas

@@ -44,21 +44,23 @@ interface
 
        { tx86vecnode doesn't work for i8086, so we inherit tcgvecnode }
        ti8086vecnode = class(tcgvecnode)
+        protected
+         function first_arraydef: tnode;override;
          procedure update_reference_reg_mul(maybe_const_reg: tregister; regsize: tdef; l: aint);override;
        end;
 
 implementation
 
     uses
-      systems,globals,
+      systems,globals,constexp,
       cutils,verbose,
-      symbase,symconst,symdef,symtable,symsym,symcpu,
+      symbase,symconst,symdef,symtable,symsym,symx86,symcpu,
       parabase,paramgr,
       aasmtai,aasmdata,
-      nld,ncon,nadd,
+      nld,ncon,nadd,ncal,ncnv,
       cgutils,cgobj,
       defutil,hlcgobj,
-      pass_2,ncgutil;
+      pass_1,pass_2,ncgutil;
 
 {*****************************************************************************
                              TI8086ADDRNODE
@@ -171,6 +173,46 @@ implementation
                              TI8086VECNODE
 *****************************************************************************}
 
+    function ti8086vecnode.first_arraydef: tnode;
+      var
+        arraydef: tcpuarraydef;
+        procname:string;
+      begin
+        if tcpuarraydef(left.resultdef).is_huge then
+          begin
+            arraydef:=tcpuarraydef(left.resultdef);
+
+            if not (ado_IsConvertedPointer in arraydef.arrayoptions) then
+              internalerror(2014080701);
+
+            if left.nodetype<>typeconvn then
+              internalerror(2014080702);
+
+            procname:='fpc_hugeptr_add_longint';
+            if cs_hugeptr_arithmetic_normalization in current_settings.localswitches then
+              procname:=procname+'_normalized';
+
+            if arraydef.elementdef.size>1 then
+              right:=caddnode.create(muln,right,
+                cordconstnode.create(arraydef.elementdef.size,s32inttype,true));
+
+            result:=ccallnode.createintern(procname,
+              ccallparanode.create(right,
+              ccallparanode.create(ttypeconvnode(left).left,nil)));
+            inserttypeconv_internal(result,getx86pointerdef(arraydef.elementdef,x86pt_huge));
+            result:=cderefnode.create(result);
+
+            ttypeconvnode(left).left:=nil;
+            ttypeconvnode(left).free;
+            left := nil;
+            right := nil;
+            firstpass(result);
+          end
+        else
+          result:=inherited;
+      end;
+
+
     procedure ti8086vecnode.update_reference_reg_mul(maybe_const_reg: tregister; regsize: tdef; l: aint);
       var
         saveseg: TRegister;

compiler/i8086/n8086tcon.pas

@@ -42,7 +42,7 @@ interface
 implementation
 
 uses
-  ncnv,defcmp,defutil,aasmtai;
+  ncnv,defcmp,defutil,aasmtai,symcpu;
 
     { ti8086typedconstbuilder }
 

compiler/i8086/symcpu.pas

@@ -57,6 +57,8 @@ type
 
   tcpupointerdef = class(tx86pointerdef)
     class function default_x86_data_pointer_type: tx86pointertyp; override;
+    function pointer_arithmetic_int_type:tdef; override;
+    function pointer_subtraction_result_type:tdef; override;
   end;
   tcpupointerdefclass = class of tcpupointerdef;
 
@@ -76,7 +78,19 @@ type
   end;
   tcpuclassrefdefclass = class of tcpuclassrefdef;
 
+  { tcpuarraydef }
+
   tcpuarraydef = class(tarraydef)
+   private
+    huge: Boolean;
+   protected
+    procedure ppuload_platform(ppufile: tcompilerppufile); override;
+    procedure ppuwrite_platform(ppufile: tcompilerppufile); override;
+   public
+    constructor create_from_pointer(def:tpointerdef);override;
+    function getcopy: tstoreddef; override;
+    function GetTypeName:string;override;
+    property is_huge: Boolean read huge write huge;
   end;
   tcpuarraydefclass = class of tcpuarraydef;
 
@@ -196,11 +210,16 @@ const
 
   function is_proc_far(p: tabstractprocdef): boolean;
 
+  {# Returns true if p is a far pointer def }
+  function is_farpointer(p : tdef) : boolean;
+
+  {# Returns true if p is a huge pointer def }
+  function is_hugepointer(p : tdef) : boolean;
 
 implementation
 
   uses
-    globals, cpuinfo, verbose;
+    globals, cpuinfo, verbose, fmodule;
 
 
   function is_proc_far(p: tabstractprocdef): boolean;
@@ -213,6 +232,68 @@ implementation
       internalerror(2014041301);
   end;
 
+  { true if p is a far pointer def }
+  function is_farpointer(p : tdef) : boolean;
+    begin
+      result:=(p.typ=pointerdef) and (tcpupointerdef(p).x86pointertyp=x86pt_far);
+    end;
+
+  { true if p is a huge pointer def }
+  function is_hugepointer(p : tdef) : boolean;
+    begin
+      result:=(p.typ=pointerdef) and (tcpupointerdef(p).x86pointertyp=x86pt_huge);
+    end;
+
+{****************************************************************************
+                               tcpuarraydef
+****************************************************************************}
+
+  constructor tcpuarraydef.create_from_pointer(def: tpointerdef);
+    begin
+      if tcpupointerdef(def).x86pointertyp=x86pt_huge then
+        begin
+          huge:=true;
+          { use -1 so that the elecount will not overflow }
+          self.create(0,high(asizeint)-1,s32inttype);
+          arrayoptions:=[ado_IsConvertedPointer];
+          setelementdef(def.pointeddef);
+        end
+      else
+        begin
+          huge:=false;
+          inherited create_from_pointer(def);
+        end;
+    end;
+
+
+  function tcpuarraydef.getcopy: tstoreddef;
+    begin
+      result:=inherited;
+      tcpuarraydef(result).huge:=huge;
+    end;
+
+
+  function tcpuarraydef.GetTypeName: string;
+    begin
+      Result:=inherited;
+      if is_huge then
+        Result:='Huge '+Result;
+    end;
+
+
+  procedure tcpuarraydef.ppuload_platform(ppufile: tcompilerppufile);
+    begin
+      inherited;
+      huge:=(ppufile.getbyte<>0);
+    end;
+
+
+  procedure tcpuarraydef.ppuwrite_platform(ppufile: tcompilerppufile);
+    begin
+      inherited;
+      ppufile.putbyte(byte(huge));
+    end;
+
 
 {****************************************************************************
                              tcpuprocdef
@@ -311,6 +392,28 @@ implementation
       end;
 
 
+    function tcpupointerdef.pointer_arithmetic_int_type:tdef;
+      begin
+        if x86pointertyp=x86pt_huge then
+          result:=s32inttype
+        else
+          result:=inherited;
+      end;
+
+
+    function tcpupointerdef.pointer_subtraction_result_type:tdef;
+      begin
+        case x86pointertyp of
+          x86pt_huge:
+            result:=s32inttype;
+          x86pt_far:
+            result:=u16inttype;
+          else
+            result:=inherited;
+        end;
+      end;
+
+
 {****************************************************************************
                              tcpuabsolutevarsym
 ****************************************************************************}
@@ -367,5 +470,7 @@ begin
   cconstsym:=tcpuconstsym;
   cenumsym:=tcpuenumsym;
   csyssym:=tcpusyssym;
+
+  cPtrDefHashSet:=tx86PtrDefHashSet;
 end.
 

compiler/jvm/pjvm.pas

@@ -505,6 +505,7 @@ implementation
         methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
         finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
         insert_self_and_vmt_para(methoddef);
+        insert_funcret_para(methoddef);
         methoddef.synthetickind:=tsk_jvm_procvar_invoke;
         methoddef.calcparas;
 
@@ -539,6 +540,7 @@ implementation
             methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
             finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
             insert_self_and_vmt_para(methoddef);
+            insert_funcret_para(methoddef);
             { can't be final/static/private/protected, and must be virtual
               since it's an interface method }
             methoddef.procoptions:=methoddef.procoptions-[po_staticmethod,po_finalmethod];
@@ -680,6 +682,7 @@ implementation
         { since it was a bare copy, insert the self parameter (we can't just
           copy the vmt parameter from the constructor, that's different) }
         insert_self_and_vmt_para(wrapperpd);
+        insert_funcret_para(wrapperpd);
         wrapperpd.calcparas;
         { implementation: call through to the constructor
           Exception: if the current class is abstract, do not call the

compiler/m68k/cgcpu.pas

@@ -19,7 +19,6 @@
 
  ****************************************************************************
 }
-{$WARNINGS OFF}
 unit cgcpu;
 
 {$i fpcdefs.inc}
@@ -109,6 +108,7 @@ unit cgcpu;
      tcg64f68k = class(tcg64f32)
        procedure a_op64_reg_reg(list : TAsmList;op:TOpCG; size: tcgsize; regsrc,regdst : tregister64);override;
        procedure a_op64_const_reg(list : TAsmList;op:TOpCG; size: tcgsize; value : int64;regdst : tregister64);override;
+       procedure a_op64_ref_reg(list : TAsmList;op:TOpCG;size : tcgsize;const ref : treference;reg : tregister64);override;
      end;
 
      { This function returns true if the reference+offset is valid.
@@ -245,6 +245,7 @@ unit cgcpu;
         address_regs: array of TSuperRegister;
       begin
         inherited init_register_allocators;
+        address_regs:=nil;
         rg[R_INTREGISTER]:=trgcpu.create(R_INTREGISTER,R_SUBWHOLE,
           [RS_D0,RS_D1,RS_D2,RS_D3,RS_D4,RS_D5,RS_D6,RS_D7],
           first_int_imreg,[]);
@@ -751,7 +752,11 @@ unit cgcpu;
            list.concat(taicpu.op_reg(A_CLR,S_L,register))
         else
          begin
-           if (longint(a) >= low(shortint)) and (longint(a) <= high(shortint)) then
+           { Prefer MOV3Q if applicable, it allows replacement spilling for register }
+           if (current_settings.cputype in [cpu_isa_b,cpu_isa_c]) and
+             ((longint(a)=-1) or ((longint(a)>0) and (longint(a)<8))) then
+             list.concat(taicpu.op_const_reg(A_MOV3Q,S_L,longint(a),register))
+           else if (longint(a) >= low(shortint)) and (longint(a) <= high(shortint)) then
               list.concat(taicpu.op_const_reg(A_MOVEQ,S_L,longint(a),register))
            else
              begin
@@ -786,11 +791,18 @@ unit cgcpu;
         hreg : tregister;
         href : treference;
       begin
+        a:=longint(a);
         href:=ref;
         fixref(list,href);
+        if (a=0) then
+          list.concat(taicpu.op_ref(A_CLR,tcgsize2opsize[tosize],href))
+        else if (tcgsize2opsize[tosize]=S_L) and
+           (current_settings.cputype in [cpu_isa_b,cpu_isa_c]) and
+           ((a=-1) or ((a>0) and (a<8))) then
+          list.concat(taicpu.op_const_ref(A_MOV3Q,S_L,a,href))
         { for coldfire we need to go through a temporary register if we have a
           offset, index or symbol given }
-        if (current_settings.cputype in cpu_coldfire) and
+        else if (current_settings.cputype in cpu_coldfire) and
             (
               (href.offset<>0) or
               { TODO : check whether we really need this second condition }
@@ -923,7 +935,7 @@ unit cgcpu;
            size:=tosize;
          list.concat(taicpu.op_ref_reg(A_MOVE,TCGSize2OpSize[size],href,register));
          { extend the value in the register }
-         sign_extend(list, fromsize, register);
+         sign_extend(list, size, register);
       end;
 
 
@@ -1398,6 +1410,13 @@ unit cgcpu;
 
     procedure tcg68k.a_cmp_reg_reg_label(list : TAsmList;size : tcgsize;cmp_op : topcmp;reg1,reg2 : tregister;l : tasmlabel);
       begin
+         if (current_settings.cputype in cpu_coldfire-[cpu_isa_b,cpu_isa_c]) then
+           begin
+             sign_extend(list,size,reg1);
+             sign_extend(list,size,reg2);
+             size:=OS_INT;
+           end;
+
          list.concat(taicpu.op_reg_reg(A_CMP,tcgsize2opsize[size],reg1,reg2));
          { emit the actual jump to the label }
          a_jmp_cond(list,cmp_op,l);
@@ -1568,7 +1587,28 @@ unit cgcpu;
     end;
 
     procedure tcg68k.g_overflowcheck(list: TAsmList; const l:tlocation; def:tdef);
+      var
+        hl : tasmlabel;
+        ai : taicpu;
+        cond : TAsmCond;
       begin
+        if not(cs_check_overflow in current_settings.localswitches) then
+          exit;
+        current_asmdata.getjumplabel(hl);
+        if not ((def.typ=pointerdef) or
+               ((def.typ=orddef) and
+                (torddef(def).ordtype in [u64bit,u16bit,u32bit,u8bit,uchar,
+                                          pasbool8,pasbool16,pasbool32,pasbool64]))) then
+          cond:=C_VC
+        else
+          cond:=C_CC;
+        ai:=Taicpu.Op_Sym(A_Bxx,S_NO,hl);
+        ai.SetCondition(cond);
+        ai.is_jmp:=true;
+        list.concat(ai);
+
+        a_call_name(list,'FPC_OVERFLOW',false);
+        a_label(list,hl);
       end;
 
     procedure tcg68k.g_proc_entry(list: TAsmList; localsize: longint; nostackframe:boolean);
@@ -1582,13 +1622,13 @@ unit cgcpu;
             if (localsize < 0) then
               internalerror(2006122601);
 
-            { Not to complicate the code generator too much, and since some }
-            { of the systems only support this format, the localsize cannot }
-            { exceed 32K in size.                                           }
             if (localsize > high(smallint)) then
-              CGMessage(cg_e_localsize_too_big);
-
-            list.concat(taicpu.op_reg_const(A_LINK,S_W,NR_FRAME_POINTER_REG,-localsize));
+              begin
+                list.concat(taicpu.op_reg_const(A_LINK,S_W,NR_FRAME_POINTER_REG,0));
+                list.concat(taicpu.op_const_reg(A_SUBA,S_L,localsize,NR_STACK_POINTER_REG));
+              end
+            else
+              list.concat(taicpu.op_reg_const(A_LINK,S_W,NR_FRAME_POINTER_REG,-localsize));
           end;
       end;
 
@@ -1601,9 +1641,6 @@ unit cgcpu;
         if not nostackframe then
           begin
             list.concat(taicpu.op_reg(A_UNLK,S_NO,NR_FRAME_POINTER_REG));
-            parasize := parasize - target_info.first_parm_offset; { i'm still not 100% confident that this is
-                                                                    correct here, but at least it looks less
-                                                                    hacky, and makes some sense (KB) }
 
             { if parasize is less than zero here, we probably have a cdecl function.
               According to the info here: http://www.makestuff.eu/wordpress/gcc-68000-abi/
@@ -1612,7 +1649,7 @@ unit cgcpu;
               caller side free, which looks like a PITA to support. We have to figure this 
               out later. More info welcomed. (KB) }
 
-            if (parasize > 0) then
+            if (parasize > 0) and not (current_procinfo.procdef.proccalloption in clearstack_pocalls) then
               begin
                 if current_settings.cputype=cpu_mc68020 then
                   list.concat(taicpu.op_const(A_RTD,S_NO,parasize))
@@ -1727,9 +1764,16 @@ unit cgcpu;
             include(current_procinfo.flags,pi_has_saved_regs);
 
             { Copy registers to temp }
+            { NOTE: virtual registers allocated here won't be translated --> no higher-level stuff. }
             href:=current_procinfo.save_regs_ref;
+            if (href.offset<low(smallint)) and (current_settings.cputype in cpu_coldfire) then
+              begin
+                list.concat(taicpu.op_reg_reg(A_MOVE,S_L,href.base,NR_A0));
+                list.concat(taicpu.op_const_reg(A_ADDA,S_L,href.offset,NR_A0));
+                reference_reset_base(href,NR_A0,0,sizeof(pint));
+              end;
             if size = sizeof(aint) then
-              a_load_reg_ref(list, OS_32, OS_32, hreg, href)
+              list.concat(taicpu.op_reg_ref(A_MOVE,S_L,hreg,href))
             else
               list.concat(taicpu.op_regset_ref(A_MOVEM,S_L,dataregs,addrregs,href));
           end;
@@ -1780,8 +1824,14 @@ unit cgcpu;
 
         { Restore registers from temp }
         href:=current_procinfo.save_regs_ref;
+        if (href.offset<low(smallint)) and (current_settings.cputype in cpu_coldfire) then
+          begin
+            list.concat(taicpu.op_reg_reg(A_MOVE,S_L,href.base,NR_A0));
+            list.concat(taicpu.op_const_reg(A_ADDA,S_L,href.offset,NR_A0));
+            reference_reset_base(href,NR_A0,0,sizeof(pint));
+          end;
         if size = sizeof(aint) then
-          a_load_ref_reg(list, OS_32, OS_32, href, hreg)
+          list.concat(taicpu.op_ref_reg(A_MOVE,S_L,href,hreg))
         else
           list.concat(taicpu.op_ref_regset(A_MOVEM,S_L,href,dataregs,addrregs));
 
@@ -1926,7 +1976,7 @@ unit cgcpu;
                   begin
                     { offset in the wrapper needs to be adjusted for the stored
                       return address }
-                    reference_reset_base(href,reference.index,reference.offset-sizeof(pint),sizeof(pint));
+                    reference_reset_base(href,reference.index,reference.offset+sizeof(pint),sizeof(pint));
                     { plain 68k could use SUBI on href directly, but this way it works on Coldfire too
                       and it's probably smaller code for the majority of cases (if ioffset small, the
                       load will use MOVEQ) (KB) }
@@ -2100,6 +2150,34 @@ unit cgcpu;
       end;
 
 
+    procedure tcg64f68k.a_op64_ref_reg(list : TAsmList;op:TOpCG;size : tcgsize;const ref : treference;reg : tregister64);
+      var
+        tempref : treference;
+      begin
+        case op of
+          OP_NEG,OP_NOT:
+            begin
+              a_load64_ref_reg(list,ref,reg);
+              a_op64_reg_reg(list,op,size,reg,reg);
+            end;
+
+          OP_AND,OP_OR:
+            begin
+              tempref:=ref;
+              tcg68k(cg).fixref(list,tempref);
+              inc(tempref.offset,4);
+              list.concat(taicpu.op_ref_reg(topcg2tasmop[op],S_L,tempref,reg.reglo));
+              dec(tempref.offset,4);
+              list.concat(taicpu.op_ref_reg(topcg2tasmop[op],S_L,tempref,reg.reghi));
+            end;
+        else
+          { XOR does not allow reference for source; ADD/SUB do not allow reference for
+            high dword, although low dword can still be handled directly. }
+          inherited a_op64_ref_reg(list,op,size,ref,reg);
+        end;
+      end;
+
+
     procedure tcg64f68k.a_op64_const_reg(list : TAsmList;op:TOpCG;size: tcgsize; value : int64;regdst : tregister64);
       var
         lowvalue : cardinal;

compiler/m68k/cpupara.pas

@@ -52,9 +52,8 @@ unit cpupara;
           function get_volatile_registers_address(calloption:tproccalloption):tcpuregisterset;override;
          private
           function parse_loc_string_to_register(var locreg: tregister; const s : string): boolean;
-          procedure init_values(var curintreg, curfloatreg: tsuperregister; var cur_stack_offset: aword);
           function create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist;
-                                               var curintreg, curfloatreg: tsuperregister; var cur_stack_offset: aword):longint;
+                                                var cur_stack_offset: aword):longint;
        end;
 
   implementation
@@ -135,13 +134,6 @@ unit cpupara;
         end;
       end;
 
-    procedure tcpuparamanager.init_values(var curintreg, curfloatreg: tsuperregister; var cur_stack_offset: aword);
-      begin
-        cur_stack_offset:=8;
-        curintreg:=RS_D0;
-        curfloatreg:=RS_FP0;
-      end;
-
     function tcpuparamanager.ret_in_param(def:tdef;pd:tabstractprocdef):boolean;
       begin
         if handle_common_ret_in_param(def,pd,result) then
@@ -227,17 +219,15 @@ unit cpupara;
     function tcpuparamanager.create_paraloc_info(p : tabstractprocdef; side: tcallercallee):longint;
       var
         cur_stack_offset: aword;
-        curintreg, curfloatreg: tsuperregister;
       begin
-        init_values(curintreg,curfloatreg,cur_stack_offset);
-
-        result:=create_paraloc_info_intern(p,side,p.paras,curintreg,curfloatreg,cur_stack_offset);
+        cur_stack_offset:=0;
+        result:=create_paraloc_info_intern(p,side,p.paras,cur_stack_offset);
 
         create_funcretloc_info(p,side);
       end;
 
     function tcpuparamanager.create_paraloc_info_intern(p : tabstractprocdef; side: tcallercallee; paras: tparalist;
-                               var curintreg, curfloatreg: tsuperregister; var cur_stack_offset: aword):longint;
+                               var cur_stack_offset: aword):longint;
       var
         paraloc      : pcgparalocation;
         hp           : tparavarsym;
@@ -245,12 +235,10 @@ unit cpupara;
         paralen      : aint;
         paradef      : tdef;
         i            : longint;
-        stack_offset : longint;
         firstparaloc : boolean;
 
       begin
         result:=0;
-        stack_offset:=cur_stack_offset;
 
         for i:=0 to paras.count-1 do
           begin
@@ -327,23 +315,24 @@ unit cpupara;
                 else
                   paraloc^.size:=int_cgsize(paralen);
 
-                paraloc^.reference.offset:=stack_offset;
+                paraloc^.reference.offset:=cur_stack_offset;
                 if (side = callerside) then
                   paraloc^.reference.index:=NR_STACK_POINTER_REG
                 else
                   begin
                     paraloc^.reference.index:=NR_FRAME_POINTER_REG;
+                    inc(paraloc^.reference.offset,target_info.first_parm_offset);
                     { M68K is a big-endian target }
                     if (paralen<tcgsize2size[OS_INT]) then
                       inc(paraloc^.reference.offset,4-paralen);
                   end;
-                inc(stack_offset,align(paralen,4));
+                inc(cur_stack_offset,align(paralen,4));
                 paralen := 0;
 
                 firstparaloc:=false;
               end;
           end;
-         result:=stack_offset;
+         result:=cur_stack_offset;
       end;
 
 
@@ -402,14 +391,13 @@ unit cpupara;
     function tcpuparamanager.create_varargs_paraloc_info(p : tabstractprocdef; varargspara:tvarargsparalist):longint;
       var
         cur_stack_offset: aword;
-        curintreg, curfloatreg: tsuperregister;
       begin
-        init_values(curintreg,curfloatreg,cur_stack_offset);
+        cur_stack_offset:=0;
 
-        result:=create_paraloc_info_intern(p,callerside,p.paras,curintreg,curfloatreg,cur_stack_offset);
+        result:=create_paraloc_info_intern(p,callerside,p.paras,cur_stack_offset);
         if (p.proccalloption in cstylearrayofconst) then
           { just continue loading the parameters in the registers }
-          result:=create_paraloc_info_intern(p,callerside,varargspara,curintreg,curfloatreg,cur_stack_offset)
+          result:=create_paraloc_info_intern(p,callerside,varargspara,cur_stack_offset)
         else
           internalerror(200410231);
       end;

compiler/m68k/n68kadd.pas

@@ -32,23 +32,13 @@ interface
     type
        t68kaddnode = class(tcgaddnode)
        private
-          function cmp64_lt(left_reg,right_reg:tregister64):tregister;
-          function cmp64_le(left_reg,right_reg:tregister64):tregister;
-          function cmp64_eq(left_reg,right_reg:tregister64):tregister;
-          function cmp64_ne(left_reg,right_reg:tregister64):tregister;
-          function cmp64_ltu(left_reg,right_reg:tregister64):tregister;
-          function cmp64_leu(left_reg,right_reg:tregister64):tregister;
-
           function getresflags(unsigned: boolean) : tresflags;
-          function getres64_register(unsigned:boolean;left_reg,right_reg:tregister64):tregister;
        protected
           procedure second_addfloat;override;
           procedure second_cmpfloat;override;
           procedure second_cmpordinal;override;
           procedure second_cmpsmallset;override;
           procedure second_cmp64bit;override;
-       public
-          function pass_1:tnode;override;
        end;
 
 
@@ -62,198 +52,12 @@ implementation
       cpuinfo,pass_1,pass_2,regvars,
       cpupara,cgutils,procinfo,
       ncon,nset,
-      ncgutil,tgobj,rgobj,rgcpu,cgobj,hlcgobj,cg64f32;
+      ncgutil,tgobj,rgobj,rgcpu,cgobj,cgcpu,hlcgobj,cg64f32;
 
 {*****************************************************************************
                                   Helpers
 *****************************************************************************}
 
-    function t68kaddnode.cmp64_lt(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64_1,labelcmp64_2 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        current_asmdata.getjumplabel(labelcmp64_1);
-        current_asmdata.getjumplabel(labelcmp64_2);
-
-        { check whether left_reg.reghi is less than right_reg.reghi }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,right_reg.reghi,left_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_LT,S_NO,labelcmp64_2));
-
-        { are left_reg.reghi and right_reg.reghi equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64_1));
-
-        { is left_reg.reglo less than right_reg.reglo? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,right_reg.reglo,left_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_2));
-
-        current_asmdata.currasmlist.concat(Taicpu.op_sym(A_BRA,S_NO,labelcmp64_1));
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_2);
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_1);
-        result:=tmpreg;
-      end;
-
-    function t68kaddnode.cmp64_le(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64_1,labelcmp64_2 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        current_asmdata.getjumplabel(labelcmp64_1);
-        current_asmdata.getjumplabel(labelcmp64_2);
-
-        { check whether right_reg.reghi is less than left_reg.reghi }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reghi,right_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_LT,S_NO,labelcmp64_1));
-
-        { are left_reg.reghi and right_reg.reghi equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64_2));
-
-        { is right_reg.reglo less than left_reg.reglo? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reglo,right_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_1));
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_2);
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_1);
-        result:=tmpreg;
-      end;
-
-    function t68kaddnode.cmp64_eq(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-        current_asmdata.getjumplabel(labelcmp64);
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        { is the high order longword equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reghi,right_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64));
-
-        { is the low order longword equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reglo,right_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64));
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64);
-        result:=tmpreg;
-      end;
-
-    function t68kaddnode.cmp64_ne(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-        current_asmdata.getjumplabel(labelcmp64);
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        { is the high order longword equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reghi,right_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64));
-
-        { is the low order longword equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reglo,right_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64));
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64);
-        result:=tmpreg;
-      end;
-
-    function t68kaddnode.cmp64_ltu(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64_1,labelcmp64_2 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        current_asmdata.getjumplabel(labelcmp64_1);
-        current_asmdata.getjumplabel(labelcmp64_2);
-
-        { check whether left_reg.reghi is less than right_reg.reghi }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,right_reg.reghi,left_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_2));
-
-        { are left_reg.reghi and right_reg.reghi equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64_1));
-
-        { is left_reg.reglo less than right_reg.reglo? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,right_reg.reglo,left_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_2));
-
-        current_asmdata.currasmlist.concat(Taicpu.op_sym(A_BRA,S_NO,labelcmp64_1));
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_2);
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_1);
-        result:=tmpreg;
-      end;
-
-    function t68kaddnode.cmp64_leu(left_reg,right_reg:tregister64):tregister;
-      var
-        labelcmp64_1,labelcmp64_2 : tasmlabel;
-        tmpreg : tregister;
-      begin
-        tmpreg:=cg.getintregister(current_asmdata.currasmlist,OS_INT);
-
-        { load the value for "false" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,0,tmpreg);
-
-        current_asmdata.getjumplabel(labelcmp64_1);
-        current_asmdata.getjumplabel(labelcmp64_2);
-
-        { check whether right_reg.reghi is less than left_reg.reghi }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reghi,right_reg.reghi));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_1));
-
-        { are left_reg.reghi and right_reg.reghi equal? }
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_NE,S_NO,labelcmp64_2));
-
-        { is right_reg.reglo less than left_reg.reglo? }
-        current_asmdata.currasmlist.concat(taicpu.op_reg_reg(A_CMP,S_L,left_reg.reglo,right_reg.reglo));
-        current_asmdata.currasmlist.concat(taicpu.op_cond_sym(A_BXX,C_CS,S_NO,labelcmp64_1));
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_2);
-
-        { load the value for "true" }
-        cg.a_load_const_reg(current_asmdata.currasmlist,OS_INT,1,tmpreg);
-
-        cg.a_label(current_asmdata.currasmlist,labelcmp64_1);
-        result:=tmpreg;
-      end;
-
     function t68kaddnode.getresflags(unsigned : boolean) : tresflags;
       begin
          case nodetype of
@@ -297,66 +101,6 @@ implementation
          end;
       end;
 
-    function t68kaddnode.getres64_register(unsigned:boolean;left_reg,right_reg:tregister64):tregister;
-      begin
-        case nodetype of
-          equaln:
-            result:=cmp64_eq(left_reg,right_reg);
-          unequaln:
-            result:=cmp64_ne(left_reg,right_reg);
-          else
-            if not unsigned then
-            begin
-              if nf_swapped in flags then
-                case nodetype of
-                  ltn:
-                    result:=cmp64_lt(right_reg,left_reg);
-                  lten:
-                    result:=cmp64_le(right_reg,left_reg);
-                  gtn:
-                    result:=cmp64_lt(left_reg,right_reg);
-                  gten:
-                    result:=cmp64_le(left_reg,right_reg);
-                end
-              else
-                case nodetype of
-                  ltn:
-                    result:=cmp64_lt(left_reg,right_reg);
-                  lten:
-                    result:=cmp64_le(left_reg,right_reg);
-                  gtn:
-                    result:=cmp64_lt(right_reg,left_reg);
-                  gten:
-                    result:=cmp64_le(right_reg,left_reg);
-                end;
-            end
-            else
-            begin
-              if nf_swapped in Flags then
-                case nodetype of
-                  ltn:
-                    result:=cmp64_ltu(right_reg,left_reg);
-                  lten:
-                    result:=cmp64_leu(right_reg,left_reg);
-                  gtn:
-                    result:=cmp64_ltu(left_reg,right_reg);
-                  gten:
-                    result:=cmp64_leu(left_reg,right_reg);
-                end
-              else
-                case nodetype of
-                  ltn:
-                    result:=cmp64_ltu(left_reg,right_reg);
-                  lten:
-                    result:=cmp64_leu(left_reg,right_reg);
-                  gtn:
-                    result:=cmp64_ltu(right_reg,left_reg);
-                  gten:
-                    result:=cmp64_leu(right_reg,left_reg);
-                end;
-            end;
-        end;
-      end;
 
 {*****************************************************************************
                                 AddFloat
@@ -500,111 +244,92 @@ implementation
     procedure t68kaddnode.second_cmpordinal;
      var
       unsigned : boolean;
-      useconst : boolean;
       tmpreg : tregister;
       opsize : topsize;
       cmpsize : tcgsize;
+      href: treference;
      begin
-       pass_left_right;
-       { set result location }
-       location_reset(location,LOC_JUMP,OS_NO);
-
-       { ToDo : set "allowconstants" to True, but this seems to upset Coldfire
-                a bit for the CMP instruction => check manual and implement
-                exception accordingly below }
-       { load values into registers (except constants) }
-       force_reg_left_right(true, false);
-
        { determine if the comparison will be unsigned }
        unsigned:=not(is_signed(left.resultdef)) or
                    not(is_signed(right.resultdef));
+       { this puts constant operand (if any) to the right }
+       pass_left_right;
+       { tentatively assume left size (correct for possible TST, will fix later) }
+       cmpsize:=def_cgsize(left.resultdef);
+       opsize:=tcgsize2opsize[cmpsize];
 
-        // get the constant on the right if there is one
-        if (left.location.loc = LOC_CONSTANT) then
-          swapleftright;
-        // can we use an immediate, or do we have to load the
-        // constant in a register first?
-        if (right.location.loc = LOC_CONSTANT) then
-          begin
-{$ifdef extdebug}
-            if (right.location.size in [OS_64,OS_S64]) and (hi(right.location.value64)<>0) and ((hi(right.location.value64)<>-1) or unsigned) then
-              internalerror(2002080301);
-{$endif extdebug}
-            if (nodetype in [equaln,unequaln]) then
-              if (unsigned and
-                  (right.location.value > high(word))) or
-                 (not unsigned and
-                  (longint(right.location.value) < low(smallint)) or
-                   (longint(right.location.value) > high(smallint))) then
-                { we can then maybe use a constant in the 'othersigned' case
-                 (the sign doesn't matter for // equal/unequal)}
-                unsigned := not unsigned;
-
-            if (unsigned and
-                ((right.location.value) <= high(word))) or
-               (not(unsigned) and
-                (longint(right.location.value) >= low(smallint)) and
-                (longint(right.location.value) <= high(smallint))) then
-               useconst := true
-            else
-              begin
-                useconst := false;
-                tmpreg := cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
-                cg.a_load_const_reg(current_asmdata.CurrAsmList,OS_INT,
-                  aword(right.location.value),tmpreg);
-               end
-          end
-        else
-          useconst := false;
-        location.loc := LOC_FLAGS;
-        location.resflags := getresflags(unsigned);
-        if tcgsize2size[right.location.size]=tcgsize2size[left.location.size] then
-          cmpsize:=left.location.size
-        else
-          { ToDo : zero/sign extend??? }
-          if tcgsize2size[right.location.size]<tcgsize2size[left.location.size] then
-            cmpsize:=left.location.size
-          else
-            cmpsize:=right.location.size;
-        opsize:=tcgsize2opsize[cmpsize];
-        if opsize=S_NO then
-          internalerror(2013090301);
-        { Attention: The RIGHT(!) operand is substracted from and must be a
-                     register! }
-        if (right.location.loc = LOC_CONSTANT) then
-          if useconst then
-            current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,opsize,
-              longint(right.location.value),left.location.register))
-          else
-            begin
-              current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,opsize,
-                tmpreg,left.location.register));
-            end
-        else
-          current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,opsize,
-            right.location.register,left.location.register));
-     end;
+       { set result location }
+       location_reset(location,LOC_FLAGS,OS_NO);
 
+       { see if we can optimize into TST }
+       if (right.location.loc=LOC_CONSTANT) and (right.location.value=0) then
+         begin
+           { Unsigned <0 or >=0 should not reach pass2, most likely }
+           case left.location.loc of
+             LOC_REFERENCE,
+             LOC_CREFERENCE:
+               begin
+                 href:=left.location.reference;
+                 tcg68k(cg).fixref(current_asmdata.CurrAsmList,href);
+                 current_asmdata.CurrAsmList.concat(taicpu.op_ref(A_TST,opsize,href));
+                 location_freetemp(current_asmdata.CurrAsmList,left.location);
+               end;
+           else
+             hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+             current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_TST,opsize,left.location.register));
+           end;
+           location.resflags := getresflags(unsigned);
+           exit;
+         end;
 
-    function t68kaddnode.pass_1:tnode;
-      var
-        ld,rd : tdef;
-      begin
-        result:=inherited pass_1;
+       { Coldfire supports byte/word compares only starting with ISA_B,
+         !!see remark about Qemu weirdness in tcg68k.a_cmp_const_reg_label }
+       if (opsize<>S_L) and (current_settings.cputype in cpu_coldfire{-[cpu_isa_b,cpu_isa_c]}) then
+         begin
+           { 1) Extension is needed for LOC_REFERENCE, but what about LOC_REGISTER ? Perhaps after fixing cg we can assume
+                that high bits of registers are correct.
+             2) Assuming that extension depends only on source signedness --> destination OS_32 is acceptable. }
+           hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,cgsize_orddef(OS_32),false);
+           if (right.location.loc<>LOC_CONSTANT) then
+             hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,cgsize_orddef(OS_32),false);
+           opsize:=S_L;
+         end
+       else if not (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+         begin
+           if not (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+             hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true)
+           else
+             begin
+               location_swap(left.location,right.location);
+               toggleflag(nf_swapped);
+             end;
+         end;
+       { left is now in register }
+       case right.location.loc of
+         LOC_CONSTANT:
+           current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,opsize,
+             longint(right.location.value),left.location.register));
+         LOC_REFERENCE,
+         LOC_CREFERENCE:
+           begin
+             href:=right.location.reference;
+             tcg68k(cg).fixref(current_asmdata.CurrAsmList,href);
+             current_asmdata.CurrAsmList.concat(taicpu.op_ref_reg(A_CMP,opsize,href,
+               left.location.register));
+           end;
+         LOC_REGISTER,
+         LOC_CREGISTER:
+           current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,opsize,
+             right.location.register,left.location.register));
+       else
+         hlcg.location_force_reg(current_asmdata.CurrAsmList,right.location,right.resultdef,right.resultdef,true);
+         current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,opsize,
+           right.location.register,left.location.register));
+       end;
 
-        { for 64 bit operations we return the resulting value in a register }
-        if not assigned(result) then
-          begin
-            rd:=right.resultdef;
-            ld:=left.resultdef;
-            if (nodetype in [ltn,lten,gtn,gten,equaln,unequaln]) and
-                (
-                  ((ld.typ=orddef) and (torddef(ld).ordtype in [u64bit,s64bit,scurrency])) or
-                  ((rd.typ=orddef) and (torddef(rd).ordtype in [u64bit,s64bit,scurrency]))
-                ) then
-              expectloc:=LOC_REGISTER;
-          end;
-      end;
+       { update location because sides could have been swapped }
+       location.resflags:=getresflags(unsigned);
+     end;
 
 
 {*****************************************************************************
@@ -613,123 +338,167 @@ implementation
 
     procedure t68kaddnode.second_cmp64bit;
       var
+        hlab: tasmlabel;
         unsigned : boolean;
-        tmp_left_reg : tregister;
+        href: treference;
+
+      procedure firstjmp64bitcmp;
+        var
+          oldnodetype : tnodetype;
+        begin
+          case nodetype of
+            ltn,gtn:
+              begin
+                if (hlab<>current_procinfo.CurrTrueLabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                { cheat a little bit for the negative test }
+                toggleflag(nf_swapped);
+                if (hlab<>current_procinfo.CurrFalseLabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                toggleflag(nf_swapped);
+              end;
+            lten,gten:
+              begin
+                oldnodetype:=nodetype;
+                if nodetype=lten then
+                  nodetype:=ltn
+                else
+                  nodetype:=gtn;
+                if (hlab<>current_procinfo.CurrTrueLabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrTrueLabel);
+                { cheat for the negative test }
+                if nodetype=ltn then
+                  nodetype:=gtn
+                else
+                  nodetype:=ltn;
+                if (hlab<>current_procinfo.CurrFalseLabel) then
+                  cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(unsigned),current_procinfo.CurrFalseLabel);
+                nodetype:=oldnodetype;
+              end;
+            equaln:
+              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+            unequaln:
+              cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+          end;
+        end;
+
+      procedure secondjmp64bitcmp;
+        begin
+          case nodetype of
+            ltn,gtn,lten,gten:
+              begin
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,getresflags(true),current_procinfo.CurrTrueLabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              end;
+            equaln:
+              begin
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrFalseLabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
+              end;
+            unequaln:
+              begin
+                cg.a_jmp_flags(current_asmdata.CurrAsmList,F_NE,current_procinfo.CurrTrueLabel);
+                cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
+              end;
+          end;
+        end;
+
       begin
+        { This puts constant operand (if any) to the right }
         pass_left_right;
-        force_reg_left_right(false,false);
 
         unsigned:=not(is_signed(left.resultdef)) or
                   not(is_signed(right.resultdef));
 
-        location_reset(location,LOC_REGISTER,OS_INT);
-        location.register:=getres64_register(unsigned,left.location.register64,right.location.register64);
-
-        { keep the below code for now, as we could optimize the =/<> code later
-          on based on it }
-
-      // writeln('second_cmp64bit');
-//      pass_left_right;
+        location_reset(location,LOC_JUMP,OS_NO);
 
+        { Relational compares against constants having low dword=0 can omit the
+          second compare based on the fact that any unsigned value is >=0 }
+        hlab:=nil;
+        if (right.location.loc=LOC_CONSTANT) and
+           (lo(right.location.value64)=0) then
+          begin
+            case getresflags(true) of
+              F_AE: hlab:=current_procinfo.CurrTrueLabel;
+              F_B:  hlab:=current_procinfo.CurrFalseLabel;
+            end;
+          end;
 
-//     load_left_right(true,false);
-(*
-        case nodetype of
-          ltn,lten,
-          gtn,gten:
-           begin
-             emit_cmp64_hi;
-             firstjmp64bitcmp;
-             emit_cmp64_lo;
-             secondjmp64bitcmp;
-           end;
-          equaln,unequaln:
-           begin
-             // instead of doing a complicated compare, do
-             // (left.hi xor right.hi) or (left.lo xor right.lo)
-             // (somewhate optimized so that no superfluous 'mr's are
-             //  generated)
-                  if (left.location.loc = LOC_CONSTANT) then
-                    swapleftright;
-                  if (right.location.loc = LOC_CONSTANT) then
-                    begin
-                      if left.location.loc = LOC_REGISTER then
-                        begin
-                          tempreg64.reglo := left.location.register64.reglo;
-                          tempreg64.reghi := left.location.register64.reghi;
-                        end
-                      else
-                        begin
-                          if (aword(right.location.valueqword) <> 0) then
-                            tempreg64.reglo := cg.getintregister(current_asmdata.CurrAsmList)
-                          else
-                            tempreg64.reglo := left.location.register64.reglo;
-                          if ((right.location.valueqword shr 32) <> 0) then
-                            tempreg64.reghi := cg.getintregister(current_asmdata.CurrAsmList)
-                          else
-                            tempreg64.reghi := left.location.register64.reghi;
-                        end;
-
-                      if (aword(right.location.valueqword) <> 0) then
-                        { negative values can be handled using SUB, }
-                        { positive values < 65535 using XOR.        }
-                        if (longint(right.location.valueqword) >= -32767) and
-                           (longint(right.location.valueqword) < 0) then
-                          cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,OS_INT,
-                            aword(right.location.valueqword),
-                            left.location.register64.reglo,tempreg64.reglo)
-                        else
-                          cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_INT,
-                            aword(right.location.valueqword),
-                            left.location.register64.reglo,tempreg64.reglo);
-
-                      if ((right.location.valueqword shr 32) <> 0) then
-                        if (longint(right.location.valueqword shr 32) >= -32767) and
-                           (longint(right.location.valueqword shr 32) < 0) then
-                          cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,OS_INT,
-                            aword(right.location.valueqword shr 32),
-                            left.location.register64.reghi,tempreg64.reghi)
-                        else
-                          cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_XOR,OS_INT,
-                            aword(right.location.valueqword shr 32),
-                            left.location.register64.reghi,tempreg64.reghi);
-                    end
-                  else
-                    begin
-                       tempreg64.reglo := cg.getintregister(current_asmdata.CurrAsmList);
-                       tempreg64.reghi := cg.getintregister(current_asmdata.CurrAsmList);
-                       cg64.a_op64_reg_reg_reg(current_asmdata.CurrAsmList,OP_XOR,
-                         left.location.register64,right.location.register64,
-                         tempreg64);
-                    end;
-
-                  cg.a_reg_alloc(current_asmdata.CurrAsmList,R_0);
-                  current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg_reg(A_OR_,R_0,
-                    tempreg64.reglo,tempreg64.reghi));
-                  cg.a_reg_dealloc(current_asmdata.CurrAsmList,R_0);
-                  if (tempreg64.reglo <> left.location.register64.reglo) then
-                    cg.ungetregister(current_asmdata.CurrAsmList,tempreg64.reglo);
-                  if (tempreg64.reghi <> left.location.register64.reghi) then
-                    cg.ungetregister(current_asmdata.CurrAsmList,tempreg64.reghi);
-
-                  location_reset(location,LOC_FLAGS,OS_NO);
-                  location.resflags := getresflags;
+        if (right.location.loc=LOC_CONSTANT) and (right.location.value64=0) and
+          (nodetype in [equaln,unequaln]) then
+          begin
+            case left.location.loc of
+              LOC_REFERENCE,
+              LOC_CREFERENCE:
+                begin
+                  href:=left.location.reference;
+                  tcg68k(cg).fixref(current_asmdata.CurrAsmList,href);
+                  current_asmdata.CurrAsmList.concat(taicpu.op_ref(A_TST,S_L,href));
+                  firstjmp64bitcmp;
+                  inc(href.offset,4);
+                  current_asmdata.CurrAsmList.concat(taicpu.op_ref(A_TST,S_L,href));
+                  secondjmp64bitcmp;
+                  location_freetemp(current_asmdata.CurrAsmList,left.location);
                 end;
-              else
-                internalerror(2002072803);
+            else
+              hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true);
+              current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_TST,S_L,left.location.register64.reglo));
+              firstjmp64bitcmp;
+              current_asmdata.CurrAsmList.concat(taicpu.op_reg(A_TST,S_L,left.location.register64.reghi));
+              secondjmp64bitcmp;
             end;
+            exit;
+          end;
 
+        { left and right no register?  }
+        { then one must be demanded    }
+        if not (left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+          begin
+            if not (right.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
+              hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,left.resultdef,true)
+            else
+              begin
+                location_swap(left.location,right.location);
+                toggleflag(nf_swapped);
+              end;
+          end;
 
-        { set result location }
-        { (emit_compare sets it to LOC_FLAGS for compares, so set the }
-        {  real location only now) (JM)                               }
-        if cmpop and
-           not(nodetype in [equaln,unequaln]) then
-          location_reset(location,LOC_JUMP,OS_NO);
-*)
-  //     location_reset(location,LOC_JUMP,OS_NO);
-       // writeln('second_cmp64_exit');
-     end;
+        { left is now in register }
+        case right.location.loc of
+          LOC_REGISTER,LOC_CREGISTER:
+            begin
+              current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,S_L,right.location.register64.reghi,left.location.register64.reghi));
+              firstjmp64bitcmp;
+              current_asmdata.CurrAsmList.concat(taicpu.op_reg_reg(A_CMP,S_L,right.location.register64.reglo,left.location.register64.reglo));
+              secondjmp64bitcmp;
+            end;
+          LOC_REFERENCE,LOC_CREFERENCE:
+            begin
+              href:=right.location.reference;
+              tcg68k(cg).fixref(current_asmdata.CurrAsmList,href);
+              current_asmdata.CurrAsmList.concat(taicpu.op_ref_reg(A_CMP,S_L,href,left.location.register64.reghi));
+              firstjmp64bitcmp;
+              inc(href.offset,4);
+              current_asmdata.CurrAsmList.concat(taicpu.op_ref_reg(A_CMP,S_L,href,left.location.register64.reglo));
+              secondjmp64bitcmp;
+              location_freetemp(current_asmdata.CurrAsmList,right.location);
+            end;
+          LOC_CONSTANT:
+            begin
+              current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(hi(right.location.value64)),left.location.register64.reghi));
+              firstjmp64bitcmp;
+              if assigned(hlab) then
+                cg.a_jmp_always(current_asmdata.CurrAsmList,hlab)
+              else
+                begin
+                  current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_CMP,S_L,aint(lo(right.location.value64)),left.location.register64.reglo));
+                  secondjmp64bitcmp;
+                end;
+            end;
+        else
+          InternalError(2014072501);
+        end;
+      end;
 
 
 begin

compiler/m68k/n68kcal.pas

@@ -34,6 +34,7 @@ interface
          procedure gen_syscall_para(para: tcallparanode); override;
         public
          procedure do_syscall;override;
+         procedure pop_parasize(pop_size: longint);override;
        end;
 
 
@@ -50,6 +51,13 @@ implementation
       cg64f32,cgcpu,cpupi,procinfo;
 
 
+    procedure tm68kcallnode.pop_parasize(pop_size: longint);
+      begin
+        if pop_size<>0 then
+          current_asmdata.CurrAsmList.concat(taicpu.op_const_reg(A_ADD,S_L,pop_size,NR_SP));
+      end;
+
+
     procedure tm68kcallnode.gen_syscall_para(para: tcallparanode);
       begin
         { lib parameter has no special type but proccalloptions must be a syscall }

compiler/m68k/n68kmat.pas

@@ -70,8 +70,7 @@ implementation
     procedure tm68knotnode.second_boolean;
       var
         hreg: tregister;
-         opsize : tcgsize;
-         loc : tcgloc;
+        opsize : tcgsize;
       begin
         if not handle_locjump then
           begin
@@ -154,10 +153,8 @@ implementation
 
 
   procedure tm68kmoddivnode.emit_mod_reg_reg(signed: boolean;denum,num : tregister);
-      var tmpreg : tregister;
-          continuelabel : tasmlabel;
-          signlabel : tasmlabel;
-          reg_d0,reg_d1 : tregister;
+    var
+      tmpreg : tregister;
     begin
      if current_settings.cputype=cpu_MC68020 then
        begin

compiler/m68k/ra68kmot.pas

@@ -220,7 +220,7 @@ const
         if lower(s)='sp' then
           actasmregister:=NR_STACK_POINTER_REG;
         if lower(s)='fp' then
-          actasmregister:=NR_STACK_POINTER_REG;
+          actasmregister:=NR_FRAME_POINTER_REG;
         if actasmregister<>NR_NO then
           begin
             result:=true;
@@ -1343,7 +1343,6 @@ const
                    end;
    { // A constant expression, or a Variable ref. // }
      AS_ID:  begin
-              Oper.InitRef;
               if actasmpattern[1] = '@' then
               { // Label or Special symbol reference // }
               begin
@@ -1510,6 +1509,7 @@ const
                          case actasmtoken of
                           AS_REGISTER:
                             begin
+                              r:=actasmregister;
                               if getregtype(r)=R_ADDRESSREGISTER then
                                 include(addrregset,getsupreg(r))
                               else if getregtype(r)=R_INTREGISTER then

compiler/m68k/rgcpu.pas

@@ -27,14 +27,150 @@ unit rgcpu;
   interface
 
      uses
-       aasmbase,aasmtai,aasmdata,
-       cpubase,
+       aasmbase,aasmtai,aasmdata,aasmsym,aasmcpu,
+       cgbase,cgutils,cpubase,
        rgobj;
 
      type
        trgcpu = class(trgobj)
+         procedure do_spill_read(list: TAsmList; pos: tai; const spilltemp: treference; tempreg: tregister; orgsupreg: tsuperregister); override;
+         procedure do_spill_written(list: TAsmList; pos: tai; const spilltemp: treference; tempreg: tregister; orgsupreg: tsuperregister); override;
+         function do_spill_replace(list : TAsmList;instr : tai_cpu_abstract_sym; orgreg : tsuperregister;const spilltemp : treference) : boolean; override;
        end;
 
   implementation
 
+    uses
+      cutils,cgobj,verbose,globtype,globals,cpuinfo;
+
+    { returns True if source operand of MOVE can be replaced with spilltemp when its destination is ref^. }
+    function isvalidmovedest(ref: preference): boolean; inline;
+      begin
+        { The following is for Coldfire, for other CPUs it maybe can be relaxed. }
+        result:=(ref^.symbol=nil) and (ref^.scalefactor<=1) and
+          (ref^.index=NR_NO) and (ref^.base<>NR_NO) and (ref^.offset>=low(smallint)) and
+          (ref^.offset<=high(smallint));
+      end;
+
+
+    procedure trgcpu.do_spill_read(list: TAsmList; pos: tai; const spilltemp: treference; tempreg: tregister; orgsupreg: tsuperregister);
+      var
+        helpins  : tai;
+        tmpref   : treference;
+        helplist : tasmlist;
+        hreg     : tregister;
+      begin
+        if (abs(spilltemp.offset)>32767) and (current_settings.cputype in cpu_coldfire) then
+          begin
+            helplist:=tasmlist.create;
+
+            if getregtype(tempreg)=R_INTREGISTER then
+              hreg:=tempreg
+            else
+              hreg:=cg.getintregister(helplist,OS_ADDR);
+{$ifdef DEBUG_SPILLING}
+            helplist.concat(tai_comment.Create(strpnew('Spilling: Read, large offset')));
+{$endif}
+
+            helplist.concat(taicpu.op_const_reg(A_MOVE,S_L,spilltemp.offset,hreg));
+            reference_reset_base(tmpref,spilltemp.base,0,sizeof(aint));
+            tmpref.index:=hreg;
+
+            helpins:=spilling_create_load(tmpref,tempreg);
+            helplist.concat(helpins);
+            list.insertlistafter(pos,helplist);
+            helplist.free;
+          end
+        else
+          inherited;
+      end;
+
+
+    procedure trgcpu.do_spill_written(list: TAsmList; pos: tai; const spilltemp: treference; tempreg: tregister; orgsupreg: tsuperregister);
+      var
+        tmpref   : treference;
+        helplist : tasmlist;
+        hreg     : tregister;
+      begin
+        if (abs(spilltemp.offset)>32767) and (current_settings.cputype in cpu_coldfire) then
+          begin
+            helplist:=tasmlist.create;
+
+            if getregtype(tempreg)=R_INTREGISTER then
+              hreg:=getregisterinline(helplist,[R_SUBWHOLE])
+            else
+              hreg:=cg.getintregister(helplist,OS_ADDR);
+{$ifdef DEBUG_SPILLING}
+            helplist.concat(tai_comment.Create(strpnew('Spilling: Write, large offset')));
+{$endif}
+
+            helplist.concat(taicpu.op_const_reg(A_MOVE,S_L,spilltemp.offset,hreg));
+            reference_reset_base(tmpref,spilltemp.base,0,sizeof(aint));
+            tmpref.index:=hreg;
+
+            helplist.concat(spilling_create_store(tempreg,tmpref));
+            if getregtype(tempreg)=R_INTREGISTER then
+              ungetregisterinline(helplist,hreg);
+
+            list.insertlistafter(pos,helplist);
+            helplist.free;
+          end
+        else
+          inherited;
+    end;
+
+
+    function trgcpu.do_spill_replace(list : TAsmList;instr : tai_cpu_abstract_sym; orgreg : tsuperregister;const spilltemp : treference) : boolean;
+      var
+        opidx: longint;
+      begin
+        result:=false;
+        opidx:=-1;
+        if (abs(spilltemp.offset)>32767) and (current_settings.cputype in cpu_coldfire) then
+          exit;
+        case instr.ops of
+          1:
+            begin
+              if (instr.oper[0]^.typ=top_reg) and (getregtype(instr.oper[0]^.reg)=regtype) and
+                ((instr.opcode=A_TST) or (instr.opcode=A_CLR)) then
+                begin
+                  if get_alias(getsupreg(instr.oper[0]^.reg))<>orgreg then
+                    InternalError(2014080101);
+                  opidx:=0;
+                end;
+            end;
+          2:
+            begin
+              if (instr.oper[0]^.typ=top_reg) and (getregtype(instr.oper[0]^.reg)=regtype) and
+                (get_alias(getsupreg(instr.oper[0]^.reg))=orgreg) then
+                begin
+                  { source can be replaced if dest is register... }
+                  if ((instr.oper[1]^.typ=top_reg) and (instr.opcode in [A_MOVE,A_ADD,A_SUB,A_AND,A_OR,A_CMP])) or
+                    {... or a "simple" reference in case of MOVE }
+                    ((instr.opcode=A_MOVE) and (instr.oper[1]^.typ=top_ref) and isvalidmovedest(instr.oper[1]^.ref)) then
+                    opidx:=0;
+                end
+              else if (instr.oper[1]^.typ=top_reg) and (getregtype(instr.oper[1]^.reg)=regtype) and
+                (get_alias(getsupreg(instr.oper[1]^.reg))=orgreg) and
+                (
+                  (instr.opcode in [A_MOVE,A_ADD,A_SUB,A_AND,A_OR]) and
+                  (instr.oper[0]^.typ=top_reg)
+                ) or
+                (instr.opcode in [A_ADDQ,A_SUBQ,A_MOV3Q]) then
+                opidx:=1;
+            end;
+        end;
+
+        if (opidx<0) then
+          exit;
+        instr.oper[opidx]^.typ:=top_ref;
+        new(instr.oper[opidx]^.ref);
+        instr.oper[opidx]^.ref^:=spilltemp;
+        case taicpu(instr).opsize of
+          S_B: inc(instr.oper[opidx]^.ref^.offset,3);
+          S_W: inc(instr.oper[opidx]^.ref^.offset,2);
+        end;
+        result:=true;
+      end;
+
 end.

compiler/mips/aoptcpu.pas

@@ -178,7 +178,7 @@ unit aoptcpu;
         Result:=GetNextInstruction(Next,Next);
       until {not(cs_opt_level3 in current_settings.optimizerswitches) or} not(Result) or (Next.typ<>ait_instruction) or (RegInInstruction(reg,Next)) or
         (is_calljmp(taicpu(Next).opcode));
-      if Result and is_calljmp(taicpu(next).opcode) then
+      if Result and (next.typ=ait_instruction) and is_calljmp(taicpu(next).opcode) then
         begin
           result:=false;
           next:=nil;
@@ -385,6 +385,7 @@ unit aoptcpu;
                     TryRemoveMov(p,A_MOVE);
                 end;
 
+              A_LB,A_LBU,A_LH,A_LHU,A_LW,
               A_ADD,A_ADDU,
               A_ADDI,A_ADDIU,
               A_SUB,A_SUBU,
@@ -394,11 +395,13 @@ unit aoptcpu;
               A_AND,A_OR,A_XOR,A_ORI,A_XORI:
                 TryRemoveMov(p,A_MOVE);
 
+              A_LWC1,
               A_ADD_s, A_SUB_s, A_MUL_s, A_DIV_s,
               A_ABS_s, A_NEG_s, A_SQRT_s,
               A_CVT_s_w, A_CVT_s_l, A_CVT_s_d:
                 TryRemoveMov(p,A_MOV_s);
 
+              A_LDC1,
               A_ADD_d, A_SUB_d, A_MUL_d, A_DIV_d,
               A_ABS_d, A_NEG_d, A_SQRT_d,
               A_CVT_d_w, A_CVT_d_l, A_CVT_d_s:

compiler/mips/cgcpu.pas

@@ -88,9 +88,6 @@ type
     procedure g_intf_wrapper(list: tasmlist; procdef: tprocdef; const labelname: string; ioffset: longint); override;
     procedure g_external_wrapper(list : TAsmList; procdef: tprocdef; const externalname: string);override;
     procedure g_profilecode(list: TAsmList);override;
-    { Transform unsupported methods into Internal errors }
-    procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister); override;
-    procedure g_stackpointer_alloc(list : TAsmList;localsize : longint);override;
   end;
 
   TCg64MPSel = class(tcg64f32)
@@ -1239,7 +1236,7 @@ begin
     begin
       if reg in (rg[R_FPUREGISTER].used_in_proc-paramanager.get_volatile_registers_fpu(pocall_stdcall)) then
         begin
-          fmask:=fmask or (1 shl ord(reg));
+          fmask:=fmask or (longword(1) shl ord(reg));
           href.offset:=nextoffset;
           lastfpuoffset:=nextoffset;
           helplist.concat(taicpu.op_reg_ref(A_SWC1,newreg(R_FPUREGISTER,reg,R_SUBFS),href));
@@ -1269,7 +1266,7 @@ begin
     begin
       if reg in saveregs then
         begin
-          mask:=mask or (1 shl ord(reg));
+          mask:=mask or (longword(1) shl ord(reg));
           href.offset:=nextoffset;
           lastintoffset:=nextoffset;
           if (reg=RS_FRAME_POINTER_REG) then
@@ -1285,8 +1282,8 @@ begin
   //list.concat(Taicpu.Op_reg_reg_const(A_ADDIU,NR_FRAME_POINTER_REG,NR_STACK_POINTER_REG,current_procinfo.para_stack_size));
   list.concat(Taicpu.op_none(A_P_SET_NOMIPS16));
   list.concat(Taicpu.op_reg_const_reg(A_P_FRAME,current_procinfo.framepointer,LocalSize,NR_R31));
-  list.concat(Taicpu.op_const_const(A_P_MASK,mask,-(LocalSize-lastintoffset)));
-  list.concat(Taicpu.op_const_const(A_P_FMASK,Fmask,-(LocalSize-lastfpuoffset)));
+  list.concat(Taicpu.op_const_const(A_P_MASK,aint(mask),-(LocalSize-lastintoffset)));
+  list.concat(Taicpu.op_const_const(A_P_FMASK,aint(Fmask),-(LocalSize-lastfpuoffset)));
   list.concat(Taicpu.op_none(A_P_SET_NOREORDER));
   if (cs_create_pic in current_settings.moduleswitches) and
      (pi_needs_got in current_procinfo.flags) then
@@ -1763,15 +1760,6 @@ procedure TCGMIPS.g_adjust_self_value(list:TAsmList;procdef: tprocdef;ioffset: t
     InternalError(2013020102);
   end;
 
-procedure TCGMIPS.g_stackpointer_alloc(list : TAsmList;localsize : longint);
-  begin
-    Comment(V_Error,'TCgMPSel.g_stackpointer_alloc method not implemented');
-  end;
-
-procedure TCGMIPS.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister);
-  begin
-    Comment(V_Error,'TCgMPSel.a_bit_scan_reg_reg method not implemented');
-  end;
 
 {****************************************************************************
                                TCG64_MIPSel

compiler/msg/errore.msg

@@ -3418,6 +3418,7 @@ new features, etc.):
 #
 option_help_pages=11025_[
 **0*_Put + after a boolean switch option to enable it, - to disable it
+**1@<x>_Read compiler options from <x> in addition to the default fpc.cfg
 **1a_The compiler does not delete the generated assembler file
 **2al_List sourcecode lines in assembler file
 **2an_List node info in assembler file (-dEXTDEBUG compiler)
@@ -3436,7 +3437,7 @@ option_help_pages=11025_[
 3*2Anasmelf_ELF32 (Linux) file using Nasm
 3*2Anasmwin32_Win32 object file using Nasm
 3*2Anasmwdosx_Win32/WDOSX object file using Nasm
-3*2Anasmdarwin macho32 object file using Nasm (experimental)
+3*2Anasmdarwin_macho32 object file using Nasm (experimental)
 3*2Awasm_Obj file using Wasm (Watcom)
 3*2Anasmobj_Obj file using Nasm
 3*2Amasm_Obj file using Masm (Microsoft)
@@ -3591,7 +3592,7 @@ J*2Cv_Var/out parameter copy-out checking
 F*1P<x>_Target CPU / compiler related options:
 F*2PB_Show default compiler binary
 F*2PP_Show default target cpu
-F*2P<x>_Set target CPU (arm,i386,m68k,mips,mipsel,powerpc,powerpc64,sparc,x86_64
+F*2P<x>_Set target CPU (arm,i386,m68k,mips,mipsel,powerpc,powerpc64,sparc,x86_64)
 **1R<x>_Assembler reading style:
 **2Rdefault_Use default assembler for target
 3*2Ratt_Read AT&T style assembler

compiler/msgidx.inc

@@ -994,7 +994,7 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 71955;
+  MsgTxtSize = 72030;
 
   MsgIdxMax : array[1..20] of longint=(
     26,99,339,123,89,57,126,27,202,64,

compiler/msgtxt.inc

@@ -1,7 +1,7 @@
 {$ifdef Delphi}
-const msgtxt : array[0..000299] of string[240]=(
+const msgtxt : array[0..000300] of string[240]=(
 {$else Delphi}
-const msgtxt : array[0..000299,1..240] of char=(
+const msgtxt : array[0..000300,1..240] of char=(
 {$endif Delphi}
   '01000_T_Compiler: $1'#000+
   '01001_D_Compiler OS: $1'#000+
@@ -1257,399 +1257,401 @@ const msgtxt : array[0..000299,1..240] of char=(
   '                 http://www.freepascal.org'#000+
   '11025_**0*_Put + after a boolean switch option to enable it, - to',' di'+
   'sable it'#010+
+  '**1@<x>_Read compiler options from <x> in addition to the default fpc.'+
+  'cfg'#010+
   '**1a_The compiler does not delete the generated assembler file'#010+
   '**2al_List sourcecode lines in assembler file'#010+
-  '**2an_List node info in assembler file (-dEXTDEBUG compiler)'#010+
-  '**2ao_Add an extra option to external assembler call (igno','red for in'+
-  'ternal)'#010+
+  '**2an_List node info in assembler file (-dEXT','DEBUG compiler)'#010+
+  '**2ao_Add an extra option to external assembler call (ignored for inte'+
+  'rnal)'#010+
   '*L2ap_Use pipes instead of creating temporary assembler files'#010+
   '**2ar_List register allocation/release info in assembler file'#010+
-  '**2at_List temp allocation/release info in assembler file'#010+
+  '**2at_List temp allocati','on/release info in assembler file'#010+
   '**1A<x>_Output format:'#010+
-  '**2Adefault_Use d','efault assembler'#010+
+  '**2Adefault_Use default assembler'#010+
   '3*2Aas_Assemble using GNU AS'#010+
   '3*2Amacho_Mach-O (Darwin, Intel 32 bit) using internal writer'#010+
   '8*2Anasm_Assemble using Nasm'#010+
-  '8*2Anasmobj_Assemble using Nasm'#010+
+  '8*2Anasmobj_Assemble using Na','sm'#010+
   '3*2Anasm_Assemble using Nasm'#010+
-  '3*2Anasmcoff_COFF (Go32v2) file using Nasm',#010+
+  '3*2Anasmcoff_COFF (Go32v2) file using Nasm'#010+
   '3*2Anasmelf_ELF32 (Linux) file using Nasm'#010+
   '3*2Anasmwin32_Win32 object file using Nasm'#010+
   '3*2Anasmwdosx_Win32/WDOSX object file using Nasm'#010+
-  '3*2Anasmdarwin macho32 object file using Nasm (experimental)'#010+
+  '3*2Anasmdarwin_macho32 object f','ile using Nasm (experimental)'#010+
   '3*2Awasm_Obj file using Wasm (Watcom)'#010+
-  '3*2Ana','smobj_Obj file using Nasm'#010+
+  '3*2Anasmobj_Obj file using Nasm'#010+
   '3*2Amasm_Obj file using Masm (Microsoft)'#010+
   '3*2Atasm_Obj file using Tasm (Borland)'#010+
   '3*2Aelf_ELF (Linux) using internal writer'#010+
-  '3*2Acoff_COFF (Go32v2) using internal writer'#010+
-  '3*2Apecoff_PE-COFF (Win32) using internal write','r'#010+
+  '3*2Acoff_COFF (Go3','2v2) using internal writer'#010+
+  '3*2Apecoff_PE-COFF (Win32) using internal writer'#010+
   '3*2Ayasm_Assmeble using Yasm (experimental)'#010+
   '4*2Aas_Assemble using GNU AS'#010+
   '4*2Agas_Assemble using GNU GAS'#010+
   '4*2Agas-darwin_Assemble darwin Mach-O64 using GNU GAS'#010+
-  '4*2Amasm_Win64 object file using ml64 (Microsoft)'#010+
-  '4*2Apecoff_PE-COFF (Win64) usi','ng internal writer'#010+
+  '4*2Ama','sm_Win64 object file using ml64 (Microsoft)'#010+
+  '4*2Apecoff_PE-COFF (Win64) using internal writer'#010+
   '4*2Aelf_ELF (Linux-64bit) using internal writer'#010+
   '4*2Ayasm_Assemble using Yasm (experimental)'#010+
   '4*2Anasm_Assemble  using Nasm (experimental)'#010+
-  '4*2Anasmwin64_Assemble Win64 object file using Nasm (experimental)'#010+
-  '4*2Anasmelf_Assem','ble Linux-64bit object file using Nasm (experimenta'+
-  'l)'#010+
+  '4*2Anasmwi','n64_Assemble Win64 object file using Nasm (experimental)'#010+
+  '4*2Anasmelf_Assemble Linux-64bit object file using Nasm (experimental)'+
+  #010+
   '4*2Anasmdarwin_Assemble darwin macho64 object file using Nasm (experim'+
   'ental)'#010+
   '6*2Aas_Unix o-file using GNU AS'#010+
-  '6*2Agas_GNU Motorola assembler'#010+
+  '6*2','Agas_GNU Motorola assembler'#010+
   '6*2Amit_MIT Syntax (old GAS)'#010+
-  '6*2Amot_Standard ','Motorola assembler'#010+
+  '6*2Amot_Standard Motorola assembler'#010+
   'A*2Aas_Assemble using GNU AS'#010+
   'P*2Aas_Assemble using GNU AS'#010+
   'S*2Aas_Assemble using GNU AS'#010+
   '**1b_Generate browser info'#010+
-  '**2bl_Generate local symbol info'#010+
+  '**2bl_Generate local symbol info'#010,
   '**1B_Build all modules'#010+
   '**1C<x>_Code generation options:'#010+
-  '**2C3_Turn on ieee',' error checking for constants'#010+
+  '**2C3_Turn on ieee error checking for constants'#010+
   '**2Ca<x>_Select ABI, see fpc -i for possible values'#010+
   '**2Cb_Generate code for a big-endian variant of the target architectur'+
   'e'#010+
-  '**2Cc<x>_Set default calling convention to <x>'#010+
-  '**2CD_Create also dynamic library (not ','supported)'#010+
+  '**2Cc<x>_Set',' default calling convention to <x>'#010+
+  '**2CD_Create also dynamic library (not supported)'#010+
   '**2Ce_Compilation with emulated floating point opcodes'#010+
   '**2Cf<x>_Select fpu instruction set to use, see fpc -i for possible va'+
   'lues'#010+
-  '**2CF<x>_Minimal floating point constant precision (default, 32, 64)'#010+
+  '**2CF<x>_Minimal floating',' point constant precision (default, 32, 64)'+
+  #010+
   '**2Cg_Generate PIC code'#010+
-  '**2Ch<','n>_<n> bytes heap (between 1023 and 67107840)'#010+
+  '**2Ch<n>_<n> bytes heap (between 1023 and 67107840)'#010+
   '**2Ci_IO-checking'#010+
   'A*2CI<x>_Select instruction set on ARM: ARM or THUMB'#010+
   '**2Cn_Omit linking stage'#010+
-  'P*2CN_Generate nil-pointer checks (AIX-only)'#010+
+  'P*2CN_Generate nil-point','er checks (AIX-only)'#010+
   '**2Co_Check overflow of integer operations'#010+
-  '**2CO_Chec','k for possible overflow of integer operations'#010+
+  '**2CO_Check for possible overflow of integer operations'#010+
   '**2Cp<x>_Select instruction set, see fpc -i for possible values'#010+
   '**2CP<x>=<y>_ packing settings'#010+
-  '**3CPPACKSET=<y>_ <y> set allocation: 0, 1 or DEFAULT or NORMAL, 2, 4 '+
-  'and 8'#010+
+  '**3CPPACKSET=<y>_ <y> set',' allocation: 0, 1 or DEFAULT or NORMAL, 2, '+
+  '4 and 8'#010+
   '**2Cr_Range checking'#010+
-  '**','2CR_Verify object method call validity'#010+
+  '**2CR_Verify object method call validity'#010+
   '**2Cs<n>_Set stack checking size to <n>'#010+
   '**2Ct_Stack checking (for testing only, see manual)'#010+
-  '8*2CT<x>_Target-specific code generation options'#010+
+  '8*2CT<x>_Target-specific code gener','ation options'#010+
   '3*2CT<x>_Target-specific code generation options'#010+
-  '4*2CT<x>_Ta','rget-specific code generation options'#010+
+  '4*2CT<x>_Target-specific code generation options'#010+
   'p*2CT<x>_Target-specific code generation options'#010+
   'P*2CT<x>_Target-specific code generation options'#010+
-  'J*2CT<x>_Target-specific code generation options'#010+
+  'J*2CT<x>_Target-specific code ','generation options'#010+
   'A*2CT<x>_Target-specific code generation options'#010+
-  'p*3CTs','malltoc_ Generate smaller TOCs at the expense of execution spe'+
-  'ed (AIX)'#010+
+  'p*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed'+
+  ' (AIX)'#010+
   'P*3CTsmalltoc_ Generate smaller TOCs at the expense of execution speed'+
   ' (AIX)'#010+
-  'J*3CTautogetterprefix=X_  Automatically create getters for properties '+
-  'with prefix X (empty s','tring disables)'#010+
+  'J*3CTautogetterpre','fix=X_  Automatically create getters for propertie'+
+  's with prefix X (empty string disables)'#010+
   'J*3CTautosetterprefix=X_  Automatically create setters for properties '+
   'with prefix X (empty string disables)'#010+
-  '8*3CTcld_                 Emit a CLD instruction before using the x86 '+
-  'string instructions'#010+
-  '3*3CTcld_                 ','Emit a CLD instruction before using the x8'+
+  '8*3CTcld_                 Emit a CLD instr','uction before using the x8'+
   '6 string instructions'#010+
+  '3*3CTcld_                 Emit a CLD instruction before using the x86 '+
+  'string instructions'#010+
   '4*3CTcld_                 Emit a CLD instruction before using the x86 '+
   'string instructions'#010+
-  'J*3CTcompactintarrayinit_ Generate smaller (but potentially slower) co'+
-  'de for initializ','ing integer array constants'#010+
+  'J*3CTcompact','intarrayinit_ Generate smaller (but potentially slower) '+
+  'code for initializing integer array constants'#010+
   'J*3CTenumfieldinit_       Initialize enumeration fields in constructor'+
   's to enumtype(0), after calling inherited constructors'#010+
-  'J*3CTinitlocals_          Initialize local variables that trigger a JV'+
-  'M bytecode verifi','cation error if used uninitialized (slows down code'+
+  'J*3CTinitloca','ls_          Initialize local variables that trigger a '+
+  'JVM bytecode verification error if used uninitialized (slows down code'+
   ')'#010+
   'J*3CTlowercaseprocstart_  Lowercase the first character of procedure/f'+
   'unction/method names'#010+
-  'A*3CTthumbinterworking_ Generate Thumb interworking-safe code if possi'+
-  'ble'#010+
-  'J*2Cv_Var/out paramete','r copy-out checking'#010+
+  'A*3CTthumbinterworking','_ Generate Thumb interworking-safe code if pos'+
+  'sible'#010+
+  'J*2Cv_Var/out parameter copy-out checking'#010+
   '**2CX_Create also smartlinked library'#010+
   '**1d<x>_Defines the symbol <x>'#010+
   '**1D_Generate a DEF file'#010+
   '**2Dd<x>_Set description to <x>'#010+
-  '**2Dv<x>_Set DLL version to <x>'#010+
+  '**2Dv<x>_Set DLL ver','sion to <x>'#010+
   '*O2Dw_PM application'#010+
   '**1e<x>_Set path to executable'#010+
-  '**1E_Same ','as -Cn'#010+
+  '**1E_Same as -Cn'#010+
   '**1fPIC_Same as -Cg'#010+
   '**1F<x>_Set file names and paths:'#010+
   '**2Fa<x>[,y]_(for a program) load units <x> and [y] before uses is par'+
   'sed'#010+
-  '**2Fc<x>_Set input codepage to <x>'#010+
+  '**2Fc<x>_Set input codepage to ','<x>'#010+
   '**2FC<x>_Set RC compiler binary name to <x>'#010+
-  '**2Fd_Disable the compiler',#039's internal directory cache'#010+
+  '**2Fd_Disable the compiler'#039's internal directory cache'#010+
   '**2FD<x>_Set the directory where to search for compiler utilities'#010+
   '**2Fe<x>_Redirect error output to <x>'#010+
-  '**2Ff<x>_Add <x> to framework path (Darwin only)'#010+
+  '**2Ff<x>_Add <x> to framework path',' (Darwin only)'#010+
   '**2FE<x>_Set exe/unit output path to <x>'#010+
-  '**2Fi<x>_Add <x> t','o include path'#010+
+  '**2Fi<x>_Add <x> to include path'#010+
   '**2Fl<x>_Add <x> to library path'#010+
   '**2FL<x>_Use <x> as dynamic linker'#010+
   '**2Fm<x>_Load unicode conversion table from <x>.txt in the compiler di'+
   'r'#010+
-  '**2FM<x>_Set the directory where to search for unicode binary files'#010+
-  '**2Fo<x>_Add <x> ','to object path'#010+
+  '**2FM<x>_Se','t the directory where to search for unicode binary files'#010+
+  '**2Fo<x>_Add <x> to object path'#010+
   '**2Fr<x>_Load error message file <x>'#010+
   '**2FR<x>_Set resource (.res) linker to <x>'#010+
   '**2Fu<x>_Add <x> to unit path'#010+
-  '**2FU<x>_Set unit output path to <x>, overrides -FE'#010+
-  '**2FW<x>_Store generated whole-program optimization feedback in',' <x>'#010+
+  '**2FU<x>_Set unit output path to <x>, ove','rrides -FE'#010+
+  '**2FW<x>_Store generated whole-program optimization feedback in <x>'#010+
   '**2Fw<x>_Load previously stored whole-program optimization feedback fr'+
   'om <x>'#010+
   '*g1g_Generate debug information (default format for target)'#010+
-  '*g2gc_Generate checks for pointers'#010+
-  '*g2gh_Use heaptrace unit (for memory leak/corruption debugging)',#010+
+  '*g2gc_Generate checks fo','r pointers'#010+
+  '*g2gh_Use heaptrace unit (for memory leak/corruption debugging)'#010+
   '*g2gl_Use line info unit (show more info with backtraces)'#010+
   '*g2go<x>_Set debug information options'#010+
   '*g3godwarfsets_ Enable DWARF '#039'set'#039' type debug information (bre'+
-  'aks gdb < 6.5)'#010+
-  '*g3gostabsabsincludes_ Store absolute/full include file paths in ','Sta'+
-  'bs'#010+
+  'aks gd','b < 6.5)'#010+
+  '*g3gostabsabsincludes_ Store absolute/full include file paths in Stabs'+
+  #010+
   '*g3godwarfmethodclassprefix_ Prefix method names in DWARF with class n'+
   'ame'#010+
   '*g2gp_Preserve case in stabs symbol names'#010+
   '*g2gs_Generate Stabs debug information'#010+
-  '*g2gt_Trash local variables (to detect uninitialized uses)'#010+
-  '*g2gv_Generates prog','rams traceable with Valgrind'#010+
+  '*g2gt','_Trash local variables (to detect uninitialized uses)'#010+
+  '*g2gv_Generates programs traceable with Valgrind'#010+
   '*g2gw_Generate DWARFv2 debug information (same as -gw2)'#010+
   '*g2gw2_Generate DWARFv2 debug information'#010+
-  '*g2gw3_Generate DWARFv3 debug information'#010+
+  '*g2gw3_Generate DWARFv3 debug informati','on'#010+
   '*g2gw4_Generate DWARFv4 debug information (experimental)'#010+
-  '**1i_Informati','on'#010+
+  '**1i_Information'#010+
   '**2iD_Return compiler date'#010+
   '**2iV_Return short compiler version'#010+
   '**2iW_Return full compiler version'#010+
   '**2iSO_Return compiler OS'#010+
   '**2iSP_Return compiler host processor'#010+
-  '**2iTO_Return target OS'#010+
+  '*','*2iTO_Return target OS'#010+
   '**2iTP_Return target processor'#010+
-  '**1I<x>_Add <x> to i','nclude path'#010+
+  '**1I<x>_Add <x> to include path'#010+
   '**1k<x>_Pass <x> to the linker'#010+
   '**1l_Write logo'#010+
   '**1M<x>_Set language mode to <x>'#010+
   '**2Mfpc_Free Pascal dialect (default)'#010+
-  '**2Mobjfpc_FPC mode with Object Pascal support'#010+
+  '**2Mobjfpc_FPC mode with Object Pasc','al support'#010+
   '**2Mdelphi_Delphi 7 compatibility mode'#010+
-  '**2Mtp_TP/BP 7.0 compati','bility mode'#010+
+  '**2Mtp_TP/BP 7.0 compatibility mode'#010+
   '**2Mmacpas_Macintosh Pascal dialects compatibility mode'#010+
   '**1n_Do not read the default config files'#010+
-  '**1o<x>_Change the name of the executable produced to <x>'#010+
+  '**1o<x>_Change the name of the executable produced to <x','>'#010+
   '**1O<x>_Optimizations:'#010+
   '**2O-_Disable optimizations'#010+
-  '**2O1_Level 1 optimiz','ations (quick and debugger friendly)'#010+
+  '**2O1_Level 1 optimizations (quick and debugger friendly)'#010+
   '**2O2_Level 2 optimizations (-O1 + quick optimizations)'#010+
   '**2O3_Level 3 optimizations (-O2 + slow optimizations)'#010+
-  '**2O4_Level 4 optimizations (-O3 + optimizations which might have unex'+
-  'pected side effects)'#010+
-  '*','*2Oa<x>=<y>_Set alignment'#010+
+  '**2O4_Level 4 opti','mizations (-O3 + optimizations which might have un'+
+  'expected side effects)'#010+
+  '**2Oa<x>=<y>_Set alignment'#010+
   '**2Oo[NO]<x>_Enable or disable optimizations, see fpc -i for possible '+
   'values'#010+
-  '**2Op<x>_Set target cpu for optimizing, see fpc -i for possible values'+
-  #010+
-  '**2OW<x>_Generate whole-program optimization feedback for optimiza','ti'+
-  'on <x>, see fpc -i for possible values'#010+
+  '**2Op<x>_Set target cpu for optimizing, see fpc -i for possible',' valu'+
+  'es'#010+
+  '**2OW<x>_Generate whole-program optimization feedback for optimization'+
+  ' <x>, see fpc -i for possible values'#010+
   '**2Ow<x>_Perform whole-program optimization <x>, see fpc -i for possib'+
   'le values'#010+
   '**2Os_Optimize for size rather than speed'#010+
-  '**1pg_Generate profile code for gprof (defines FPC_PROFILE)'#010+
-  'F*1P<x>_Target CP','U / compiler related options:'#010+
+  '**1','pg_Generate profile code for gprof (defines FPC_PROFILE)'#010+
+  'F*1P<x>_Target CPU / compiler related options:'#010+
   'F*2PB_Show default compiler binary'#010+
   'F*2PP_Show default target cpu'#010+
   'F*2P<x>_Set target CPU (arm,i386,m68k,mips,mipsel,powerpc,powerpc64,sp'+
-  'arc,x86_64'#010+
+  'a','rc,x86_64)'#010+
   '**1R<x>_Assembler reading style:'#010+
-  '**2Rdefault_Use default assembl','er for target'#010+
+  '**2Rdefault_Use default assembler for target'#010+
   '3*2Ratt_Read AT&T style assembler'#010+
   '3*2Rintel_Read Intel style assembler'#010+
   '6*2RMOT_Read motorola style assembler'#010+
   '**1S<x>_Syntax options:'#010+
-  '**2S2_Same as -Mobjfpc'#010+
+  '**2S2_Same as -Mob','jfpc'#010+
   '**2Sc_Support operators like C (*=,+=,/= and -=)'#010+
-  '**2Sa_Turn on asserti','ons'#010+
+  '**2Sa_Turn on assertions'#010+
   '**2Sd_Same as -Mdelphi'#010+
   '**2Se<x>_Error options. <x> is a combination of the following:'#010+
   '**3*_<n> : Compiler halts after the <n> errors (default is 1)'#010+
-  '**3*_w : Compiler also halts after warnings'#010+
+  '**3*_w : Comp','iler also halts after warnings'#010+
   '**3*_n : Compiler also halts after notes'#010+
-  '**3','*_h : Compiler also halts after hints'#010+
+  '**3*_h : Compiler also halts after hints'#010+
   '**2Sg_Enable LABEL and GOTO (default in -Mtp and -Mdelphi)'#010+
-  '**2Sh_Use reference counted strings (ansistring by default) instead of'+
-  ' shortstrings'#010+
-  '**2Si_Turn on inlining of procedures/functions declared as ','"inline"'#010+
+  '**2Sh_Use reference counted strings (ansistring by default) instead ','o'+
+  'f shortstrings'#010+
+  '**2Si_Turn on inlining of procedures/functions declared as "inline"'#010+
   '**2Sk_Load fpcylix unit'#010+
   '**2SI<x>_Set interface style to <x>'#010+
   '**3SIcom_COM compatible interface (default)'#010+
   '**3SIcorba_CORBA compatible interface'#010+
-  '**2Sm_Support macros like C (global)'#010+
+  '**2Sm_Support ','macros like C (global)'#010+
   '**2So_Same as -Mtp'#010+
-  '**2Ss_Constructor name must be in','it (destructor must be done)'#010+
+  '**2Ss_Constructor name must be init (destructor must be done)'#010+
   '**2Sx_Enable exception keywords (default in Delphi/ObjFPC modes)'#010+
   '**2Sy_@<pointer> returns a typed pointer, same as $T+'#010+
-  '**1s_Do not call assembler and linker'#010+
+  '**1s_Do not call ','assembler and linker'#010+
   '**2sh_Generate script to link on host'#010+
-  '**2st_Generate s','cript to link on target'#010+
+  '**2st_Generate script to link on target'#010+
   '**2sr_Skip register allocation phase (use with -alr)'#010+
   '**1T<x>_Target operating system:'#010+
   '3*2Tdarwin_Darwin/Mac OS X'#010+
-  '3*2Temx_OS/2 via EMX (including EMX/RSX extender)'#010+
+  '3*2Temx_OS/2 via EMX (includ','ing EMX/RSX extender)'#010+
   '3*2Tfreebsd_FreeBSD'#010+
-  '3*2Tgo32v2_Version 2 of DJ Delori','e DOS extender'#010+
+  '3*2Tgo32v2_Version 2 of DJ Delorie DOS extender'#010+
   '3*2Tiphonesim_ iPhoneSimulator from iOS SDK 3.2+ (older versions: -Tda'+
   'rwin)'#010+
   '3*2Tlinux_Linux'#010+
   '3*2Tnativent_Native NT API (experimental)'#010+
-  '3*2Tnetbsd_NetBSD'#010+
+  '3*2Tnetbsd_NetBS','D'#010+
   '3*2Tnetware_Novell Netware Module (clib)'#010+
-  '3*2Tnetwlibc_Novell Netware Modu','le (libc)'#010+
+  '3*2Tnetwlibc_Novell Netware Module (libc)'#010+
   '3*2Topenbsd_OpenBSD'#010+
   '3*2Tos2_OS/2 / eComStation'#010+
   '3*2Tsunos_SunOS/Solaris'#010+
   '3*2Tsymbian_Symbian OS'#010+
   '3*2Tsolaris_Solaris'#010+
-  '3*2Twatcom_Watcom compatible DOS extender'#010+
+  '3*2Twatcom_Watcom compatible DOS extender',#010+
   '3*2Twdosx_WDOSX DOS extender'#010+
   '3*2Twin32_Windows 32 Bit'#010+
-  '3*2Twince_Windows CE',#010+
+  '3*2Twince_Windows CE'#010+
   '4*2Tdarwin_Darwin/Mac OS X'#010+
   '4*2Tlinux_Linux'#010+
   '4*2Twin64_Win64 (64 bit Windows systems)'#010+
   '6*2Tamiga_Commodore Amiga'#010+
   '6*2Tatari_Atari ST/STe/TT'#010+
   '6*2Tlinux_Linux'#010+
-  '6*2Tpalmos_PalmOS'#010+
+  '6*2Tpalmos_P','almOS'#010+
   'A*2Tdarwin_Darwin/iPhoneOS/iOS'#010+
   'A*2Tlinux_Linux'#010+
   'A*2Twince_Windows CE'#010+
-  'P','*2Tamiga_AmigaOS'#010+
+  'P*2Tamiga_AmigaOS'#010+
   'P*2Tdarwin_Darwin/Mac OS X'#010+
   'P*2Tlinux_Linux'#010+
   'P*2Tmacos_Mac OS (classic)'#010+
   'P*2Tmorphos_MorphOS'#010+
   'S*2Tsolaris_Solaris'#010+
   'S*2Tlinux_Linux'#010+
-  '**1u<x>_Undefines the symbol <x>'#010+
+  '**1u<x>_Undefines the ','symbol <x>'#010+
   '**1U_Unit options:'#010+
-  '**2Un_Do not check where the unit name matche','s the file name'#010+
+  '**2Un_Do not check where the unit name matches the file name'#010+
   '**2Ur_Generate release unit files (never automatically recompiled)'#010+
   '**2Us_Compile a system unit'#010+
-  '**1v<x>_Be verbose. <x> is a combination of the following letters:'#010+
-  '**2*_e : Show errors (default)       0 : Show nothing (except ','errors'+
-  ')'#010+
+  '**1v<x>_Be verbose. <x> is a combination of the follow','ing letters:'#010+
+  '**2*_e : Show errors (default)       0 : Show nothing (except errors)'#010+
   '**2*_w : Show warnings               u : Show unit info'#010+
   '**2*_n : Show notes                  t : Show tried/used files'#010+
-  '**2*_h : Show hints                  c : Show conditionals'#010+
-  '**2*_i : Show general info           d : Show debug in','fo'#010+
+  '**2*_h : Show hints                  c',' : Show conditionals'#010+
+  '**2*_i : Show general info           d : Show debug info'#010+
   '**2*_l : Show linenumbers            r : Rhide/GCC compatibility mode'#010+
   '**2*_s : Show time stamps            q : Show message numbers'#010+
-  '**2*_a : Show everything             x : Executable info (Win32 only)'#010+
-  '**2*_b : Write file names messages ','  p : Write tree.log with parse t'+
-  'ree'#010+
+  '**2*_a : Show everything      ','       x : Executable info (Win32 only'+
+  ')'#010+
+  '**2*_b : Write file names messages   p : Write tree.log with parse tre'+
+  'e'#010+
   '**2*_    with full path              v : Write fpcdebug.txt with'#010+
-  '**2*_                                    lots of debugging info'#010+
+  '**2*_                                    lots of debugging info',#010+
   '**2*_m<x>,<y> : Do not show messages numbered <x> and <y>'#010+
-  'F*1V<x>_Append '#039,'-<x>'#039' to the used compiler binary name (e.g. '+
-  'for version)'#010+
+  'F*1V<x>_Append '#039'-<x>'#039' to the used compiler binary name (e.g. f'+
+  'or version)'#010+
   '**1W<x>_Target-specific options (targets)'#010+
   '3*2WA_Specify native type application (Windows)'#010+
-  '4*2WA_Specify native type application (Windows)'#010+
-  'A*2WA_Specify native type application (Windo','ws)'#010+
+  '4*2WA_Specify nat','ive type application (Windows)'#010+
+  'A*2WA_Specify native type application (Windows)'#010+
   '3*2Wb_Create a bundle instead of a library (Darwin)'#010+
   'P*2Wb_Create a bundle instead of a library (Darwin)'#010+
   'p*2Wb_Create a bundle instead of a library (Darwin)'#010+
-  'A*2Wb_Create a bundle instead of a library (Darwin)'#010+
-  '4*2Wb_Create a bundle instea','d of a library (Darwin)'#010+
+  'A*2Wb','_Create a bundle instead of a library (Darwin)'#010+
+  '4*2Wb_Create a bundle instead of a library (Darwin)'#010+
   '3*2WB_Create a relocatable image (Windows, Symbian)'#010+
   '3*2WBxxxx_Set image base to xxxx (Windows, Symbian)'#010+
-  '4*2WB_Create a relocatable image (Windows)'#010+
+  '4*2WB_Create a relocatable image (Win','dows)'#010+
   '4*2WBxxxx_Set image base to xxxx (Windows)'#010+
-  'A*2WB_Create a relocatable',' image (Windows, Symbian)'#010+
+  'A*2WB_Create a relocatable image (Windows, Symbian)'#010+
   'A*2WBxxxx_Set image base to xxxx (Windows, Symbian)'#010+
   '3*2WC_Specify console type application (EMX, OS/2, Windows)'#010+
-  '4*2WC_Specify console type application (EMX, OS/2, Windows)'#010+
-  'A*2WC_Specify console type application (Wi','ndows)'#010+
+  '4*2WC_Specify console type ','application (EMX, OS/2, Windows)'#010+
+  'A*2WC_Specify console type application (Windows)'#010+
   'P*2WC_Specify console type application (Classic Mac OS)'#010+
   '3*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
-  '4*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
-  'A*2WD_Use DEFFILE to export functions of DLL or EXE (','Windows)'#010+
+  '4*2WD_Use DEFFILE to export functions of',' DLL or EXE (Windows)'#010+
+  'A*2WD_Use DEFFILE to export functions of DLL or EXE (Windows)'#010+
   '3*2We_Use external resources (Darwin)'#010+
   '4*2We_Use external resources (Darwin)'#010+
   'A*2We_Use external resources (Darwin)'#010+
   'P*2We_Use external resources (Darwin)'#010+
-  'p*2We_Use external resources (Darwin)'#010+
-  '3*2WF_Specify full-screen type applicatio','n (EMX, OS/2)'#010+
+  'p*2W','e_Use external resources (Darwin)'#010+
+  '3*2WF_Specify full-screen type application (EMX, OS/2)'#010+
   '3*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+
   '4*2WG_Specify graphic type application (EMX, OS/2, Windows)'#010+
-  'A*2WG_Specify graphic type application (Windows)'#010+
+  'A*2WG_Specify graphic type appl','ication (Windows)'#010+
   'P*2WG_Specify graphic type application (Classic Mac OS)'#010+
-  '3','*2Wi_Use internal resources (Darwin)'#010+
+  '3*2Wi_Use internal resources (Darwin)'#010+
   '4*2Wi_Use internal resources (Darwin)'#010+
   'A*2Wi_Use internal resources (Darwin)'#010+
   'P*2Wi_Use internal resources (Darwin)'#010+
-  'p*2Wi_Use internal resources (Darwin)'#010+
-  '3*2WI_Turn on/off the usage of import sections (Win','dows)'#010+
+  'p*2Wi_Use inte','rnal resources (Darwin)'#010+
+  '3*2WI_Turn on/off the usage of import sections (Windows)'#010+
   '4*2WI_Turn on/off the usage of import sections (Windows)'#010+
   'A*2WI_Turn on/off the usage of import sections (Windows)'#010+
   '8*2Wm<x>_Set memory model'#010+
-  '8*3WmTiny_Tiny memory model'#010+
+  '8*3WmTiny_Tiny memo','ry model'#010+
   '8*3WmSmall_Small memory model (default)'#010+
-  '8*3WmMedium_Medium memory ','model'#010+
+  '8*3WmMedium_Medium memory model'#010+
   '8*3WmCompact_Compact memory model'#010+
   '8*3WmLarge_Large memory model'#010+
   '3*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
   'n)'#010+
-  '4*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
-  'n)'#010+
-  'p*2WM<x>_Minimum Mac OS ','X deployment version: 10.4, 10.5.1, ... (Dar'+
+  '4*2WM<x>_Minimum Mac O','S X deployment version: 10.4, 10.5.1, ... (Dar'+
   'win)'#010+
+  'p*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
+  'n)'#010+
   'P*2WM<x>_Minimum Mac OS X deployment version: 10.4, 10.5.1, ... (Darwi'+
   'n)'#010+
-  '3*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
-  '4*2WN_Do not generate relocation code, needed fo','r debugging (Windows'+
+  '3*2WN_Do not generate relocation code, need','ed for debugging (Windows'+
   ')'#010+
+  '4*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
   'A*2WN_Do not generate relocation code, needed for debugging (Windows)'#010+
   'A*2Wpxxxx_Specify the controller type, see fpc -i for possible values'#010+
-  'V*2Wpxxxx_Specify the controller type, see fpc -i for possible values'#010+
-  '3*2WP<x>','_Minimum iOS deployment version: 3.0, 5.0.1, ... (iphonesim)'+
-  #010+
+  'V*2','Wpxxxx_Specify the controller type, see fpc -i for possible value'+
+  's'#010+
+  '3*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (iphonesim)'#010+
   'A*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (Darwin)'#010+
-  '3*2WR_Generate relocation code (Windows)'#010+
+  '3*2WR_Generate relocation code (Window','s)'#010+
   '4*2WR_Generate relocation code (Windows)'#010+
-  'A*2WR_Generate relocation code ','(Windows)'#010+
+  'A*2WR_Generate relocation code (Windows)'#010+
   '8*2Wt<x>_Set the target executable format'#010+
   '8*3Wtexe_Create a DOS .EXE file (default)'#010+
   '8*3Wtcom_Create a DOS .COM file (requires tiny memory model)'#010+
-  'P*2WT_Specify MPW tool type application (Classic Mac OS)'#010+
-  '**2WX_Enable executable stac','k (Linux)'#010+
+  'P*2WT_Spec','ify MPW tool type application (Classic Mac OS)'#010+
+  '**2WX_Enable executable stack (Linux)'#010+
   '**1X_Executable options:'#010+
   '**2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Lin'+
   'ux)'#010+
-  '**2Xd_Do not search default library path (sometimes required for cross'+
-  '-compiling when not using -XR)'#010+
+  '**2Xd_Do not search default library path (sometimes requ','ired for cro'+
+  'ss-compiling when not using -XR)'#010+
   '**2Xe_Use external linker'#010+
-  '**2X','g_Create debuginfo in a separate file and add a debuglink sectio'+
-  'n to executable'#010+
+  '**2Xg_Create debuginfo in a separate file and add a debuglink section '+
+  'to executable'#010+
   '**2XD_Try to link units dynamically      (defines FPC_LINK_DYNAMIC)'#010+
-  '**2Xi_Use internal linker'#010+
+  '**2Xi_Use interna','l linker'#010+
   '**2Xm_Generate link map'#010+
-  '**2XM<x>_Set the name of the '#039'main'#039' progra','m routine (default'+
-  ' is '#039'main'#039')'#010+
+  '**2XM<x>_Set the name of the '#039'main'#039' program routine (default i'+
+  's '#039'main'#039')'#010+
   'F*2Xp<x>_First search for the compiler binary in the directory <x>'#010+
   '**2XP<x>_Prepend the binutils names with the prefix <x>'#010+
-  '**2Xr<x>_Set the linker'#039's rlink-path to <x> (needed for cross comp'+
-  'ile, see the ld manua','l for more information) (BeOS, Linux)'#010+
+  '**2Xr<x>_Set',' the linker'#039's rlink-path to <x> (needed for cross co'+
+  'mpile, see the ld manual for more information) (BeOS, Linux)'#010+
   '**2XR<x>_Prepend <x> to all linker search paths (BeOS, Darwin, FreeBSD'+
   ', Linux, Mac OS, Solaris)'#010+
-  '**2Xs_Strip all symbols from executable'#010+
-  '**2XS_Try to link units statically (default, defines FPC_LINK_STAT','IC'+
-  ')'#010+
+  '**2Xs_Strip all symbols from ex','ecutable'#010+
+  '**2XS_Try to link units statically (default, defines FPC_LINK_STATIC)'#010+
   '**2Xt_Link with static libraries (-static is passed to linker)'#010+
   '**2XX_Try to smartlink units             (defines FPC_LINK_SMART)'#010+
   '**1*_'#010+
   '**1?_Show this help'#010+
-  '**1h_Shows this help without waiting'
+  '**1h_S','hows this help without waiting'
 );

compiler/nadd.pas

@@ -73,6 +73,10 @@ interface
           { full 64 bit multiplies.                                }
           function use_generic_mul64bit: boolean; virtual;
 
+          { shall be overriden if the target cpu supports
+            an fma instruction
+          }
+          function use_fma : boolean; virtual;
           { This routine calls internal runtime library helpers
             for all floating point arithmetic in the case
             where the emulation switches is on. Otherwise
@@ -80,18 +84,22 @@ interface
             the code generation phase.
           }
           function first_addfloat : tnode; virtual;
-         private
-           { checks whether a muln can be calculated as a 32bit }
-           { * 32bit -> 64 bit                                  }
-           function try_make_mul32to64: boolean;
-           { Match against the ranges, i.e.:
-             var a:1..10;
-             begin
-               if a>0 then
-                 ...
-             always evaluates to true. (DM)
-           }
-           function cmp_of_disjunct_ranges(var res : boolean) : boolean;
+       private
+          { checks whether a muln can be calculated as a 32bit }
+          { * 32bit -> 64 bit                                  }
+          function try_make_mul32to64: boolean;
+
+          { Match against the ranges, i.e.:
+            var a:1..10;
+            begin
+              if a>0 then
+                ...
+            always evaluates to true. (DM)
+          }
+          function cmp_of_disjunct_ranges(var res : boolean) : boolean;
+
+          { tries to replace the current node by a fma node }
+          function try_fma(ld,rd : tdef) : tnode;
        end;
        taddnodeclass = class of taddnode;
 
@@ -1013,6 +1021,14 @@ implementation
         change      : boolean;
 {$endif}
 
+        function maybe_cast_ordconst(var n: tnode; adef: tdef): boolean;
+          begin
+            result:=(tordconstnode(n).value>=torddef(adef).low) and
+              (tordconstnode(n).value<=torddef(adef).high);
+            if result then
+              inserttypeconv(n,adef);
+          end;
+
       begin
          result:=nil;
          rlow:=0;
@@ -1420,6 +1436,18 @@ implementation
                      inserttypeconv(right,nd);
                    end;
                end
+             { don't extend (sign-mismatched) comparisons if either side is a constant
+               whose value is within range of opposite side }
+             else if is_integer(ld) and is_integer(rd) and
+                     (nodetype in [equaln,unequaln,gtn,gten,ltn,lten]) and
+                     (is_signed(ld)<>is_signed(rd)) and
+                     (
+                       ((lt=ordconstn) and maybe_cast_ordconst(left,rd)) or
+                       ((rt=ordconstn) and maybe_cast_ordconst(right,ld))
+                     ) then
+               begin
+                 { done here }
+               end
              { is there a signed 64 bit type ? }
              else if ((torddef(rd).ordtype=s64bit) or (torddef(ld).ordtype=s64bit)) then
                begin
@@ -1697,9 +1725,10 @@ implementation
                       begin
                         hp:=getcopy;
                         include(hp.flags,nf_has_pointerdiv);
-                        result:=cmoddivnode.create(divn,hp,cordconstnode.create(tpointerdef(rd).pointeddef.size,sinttype,false));
+                        result:=cmoddivnode.create(divn,hp,
+                          cordconstnode.create(tpointerdef(rd).pointeddef.size,tpointerdef(rd).pointer_subtraction_result_type,false));
                       end;
-                    resultdef:=sinttype;
+                    resultdef:=tpointerdef(rd).pointer_subtraction_result_type;
                     exit;
                  end;
                else
@@ -1966,9 +1995,11 @@ implementation
               end
             else
               resultdef:=right.resultdef;
-            inserttypeconv(left,get_int_type_for_pointer_arithmetic(rd));
+            inserttypeconv(left,tpointerdef(right.resultdef).pointer_arithmetic_int_type);
             if nodetype=addn then
               begin
+                if (rt=niln) then
+                  CGMessage3(type_e_operator_not_supported_for_types,node2opstr(nodetype),ld.typename,'NIL');
                 if not(cs_extsyntax in current_settings.moduleswitches) or
                    (not (is_pchar(ld) or is_chararray(ld) or is_open_chararray(ld) or is_widechar(ld) or is_widechararray(ld) or is_open_widechararray(ld)) and
                     not(cs_pointermath in current_settings.localswitches) and
@@ -1978,7 +2009,7 @@ implementation
                    (tpointerdef(rd).pointeddef.size>1) then
                    begin
                      left:=caddnode.create(muln,left,
-                       cordconstnode.create(tpointerdef(rd).pointeddef.size,get_int_type_for_pointer_arithmetic(rd),true));
+                       cordconstnode.create(tpointerdef(rd).pointeddef.size,tpointerdef(right.resultdef).pointer_arithmetic_int_type,true));
                      typecheckpass(left);
                    end;
               end
@@ -1997,7 +2028,7 @@ implementation
              else
                resultdef:=left.resultdef;
 
-             inserttypeconv(right,get_int_type_for_pointer_arithmetic(ld));
+             inserttypeconv(right,tpointerdef(left.resultdef).pointer_arithmetic_int_type);
              if nodetype in [addn,subn] then
                begin
                  if (lt=niln) then
@@ -2014,7 +2045,7 @@ implementation
                    if (tpointerdef(ld).pointeddef.size>1) then
                    begin
                      right:=caddnode.create(muln,right,
-                       cordconstnode.create(tpointerdef(ld).pointeddef.size,get_int_type_for_pointer_arithmetic(ld),true));
+                       cordconstnode.create(tpointerdef(ld).pointeddef.size,tpointerdef(left.resultdef).pointer_arithmetic_int_type,true));
                      typecheckpass(right);
                    end
                  end else
@@ -2022,7 +2053,7 @@ implementation
                       (tarraydef(ld).elementdef.size>1) then
                      begin
                        right:=caddnode.create(muln,right,
-                         cordconstnode.create(tarraydef(ld).elementdef.size,get_int_type_for_pointer_arithmetic(ld),true));
+                         cordconstnode.create(tarraydef(ld).elementdef.size,tpointerdef(left.resultdef).pointer_arithmetic_int_type,true));
                        typecheckpass(right);
                      end;
                end
@@ -2589,6 +2620,127 @@ implementation
       end;
 
 
+    function taddnode.use_fma : boolean;
+      begin
+        result:=false;
+      end;
+
+
+    function taddnode.try_fma(ld,rd : tdef) : tnode;
+      var
+        inlinennr : Integer;
+      begin
+        result:=nil;
+        if (cs_opt_fastmath in current_settings.optimizerswitches) and
+          use_fma and
+          (nodetype in [addn,subn]) and
+          (rd.typ=floatdef) and (ld.typ=floatdef) and
+          (is_single(rd) or is_double(rd)) and
+          equal_defs(rd,ld) and
+          { transforming a*b+c into fma(a,b,c) makes only sense if c can be
+            calculated easily. Consider a*b+c*d which results in
+
+            fmul
+            fmul
+            fadd
+
+            and in
+
+            fmul
+            fma
+
+            when using the fma optimization. On a super scalar architecture, the first instruction
+            sequence requires clock_cycles(fmul)+clock_cycles(fadd) clock cycles because the fmuls can be executed in parallel.
+            The second sequence requires clock_cycles(fmul)+clock_cycles(fma) because the fma has to wait for the
+            result of the fmul. Since typically clock_cycles(fma)>clock_cycles(fadd) applies, the first sequence is better.
+          }
+          (((left.nodetype=muln) and (node_complexity(right)<3)) or
+           ((right.nodetype=muln) and (node_complexity(left)<3)) or
+           ((left.nodetype=inlinen) and
+            (tinlinenode(left).inlinenumber=in_sqr_real) and
+             (node_complexity(right)<3)) or
+           ((right.nodetype=inlinen) and
+            (tinlinenode(right).inlinenumber=in_sqr_real) and
+            (node_complexity(left)<3))
+          ) then
+          begin
+            case tfloatdef(ld).floattype of
+              s32real:
+               inlinennr:=in_fma_single;
+              s64real:
+               inlinennr:=in_fma_double;
+              s80real:
+               inlinennr:=in_fma_extended;
+              s128real:
+               inlinennr:=in_fma_float128;
+              else
+                internalerror(2014042601);
+            end;
+            if left.nodetype=muln then
+              begin
+                if nodetype=subn then
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(cunaryminusnode.create(right),
+                    ccallparanode.create(taddnode(left).right,
+                    ccallparanode.create(taddnode(left).left,nil
+                    ))))
+                else
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(right,
+                    ccallparanode.create(taddnode(left).right,
+                    ccallparanode.create(taddnode(left).left,nil
+                    ))));
+                right:=nil;
+                taddnode(left).right:=nil;
+                taddnode(left).left:=nil;
+              end
+            else if right.nodetype=muln then
+              begin
+                if nodetype=subn then
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(left,
+                    ccallparanode.create(cunaryminusnode.create(taddnode(right).right),
+                    ccallparanode.create(taddnode(right).left,nil
+                    ))))
+                else
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(left,
+                    ccallparanode.create(taddnode(right).right,
+                    ccallparanode.create(taddnode(right).left,nil
+                    ))));
+                left:=nil;
+                taddnode(right).right:=nil;
+                taddnode(right).left:=nil;
+              end
+            else if (left.nodetype=inlinen) and (tinlinenode(left).inlinenumber=in_sqr_real) then
+              begin
+                if nodetype=subn then
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(cunaryminusnode.create(right),
+                    ccallparanode.create(tinlinenode(left).left.getcopy,
+                    ccallparanode.create(tinlinenode(left).left.getcopy,nil
+                    ))))
+                else
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(right,
+                    ccallparanode.create(tinlinenode(left).left.getcopy,
+                    ccallparanode.create(tinlinenode(left).left.getcopy,nil
+                    ))));
+                right:=nil;
+              end
+            { we get here only if right is a sqr node }
+            else if (right.nodetype=inlinen) and (tinlinenode(right).inlinenumber=in_sqr_real) then
+              begin
+                if nodetype=subn then
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(left,
+                    ccallparanode.create(cunaryminusnode.create(tinlinenode(right).left.getcopy),
+                    ccallparanode.create(tinlinenode(right).left.getcopy,nil
+                    ))))
+                else
+                  result:=cinlinenode.create(inlinennr,false,ccallparanode.create(left,
+                    ccallparanode.create(tinlinenode(right).left.getcopy,
+                    ccallparanode.create(tinlinenode(right).left.getcopy,nil
+                    ))));
+                left:=nil;
+              end;
+          end;
+      end;
+
+
     function taddnode.first_add64bitint: tnode;
       var
         procname: string[31];
@@ -3086,6 +3238,10 @@ implementation
                 expectloc:=LOC_FPUREGISTER
               else
                 expectloc:=LOC_FLAGS;
+
+              result:=try_fma(ld,rd);
+              if assigned(result) then
+                exit;
             end
 
          { pointer comperation and subtraction }

compiler/nbas.pas

@@ -258,7 +258,7 @@ interface
 
        { Create a blocknode and statement node for multiple statements
          generated internally by the parser }
-       function  internalstatements(var laststatement:tstatementnode):tblocknode;
+       function  internalstatements(out laststatement:tstatementnode):tblocknode;
        function  laststatement(block:tblocknode):tstatementnode;
        procedure addstatement(var laststatement:tstatementnode;n:tnode);
 
@@ -282,7 +282,7 @@ implementation
                                      Helpers
 *****************************************************************************}
 
-    function internalstatements(var laststatement:tstatementnode):tblocknode;
+    function internalstatements(out laststatement:tstatementnode):tblocknode;
       begin
         { create dummy initial statement }
         laststatement := cstatementnode.create(cnothingnode.create,nil);

compiler/ncgcnv.pas

@@ -120,12 +120,12 @@ interface
             { 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). }
+              ones (except signed->unsigned, which still needs high 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
+               (tcgsize2size[(reg_cgsize(left.location.register))]=sizeof(aint)) and
+               (ressize>leftsize) and
+               (newsize in [OS_32,OS_S32,OS_16,OS_S16]) and
+               (not is_signed(left.resultdef) or is_signed(resultdef)) then
               location.size:=newsize
 {$endif}
             else

compiler/ncgcon.pas

@@ -498,7 +498,7 @@ implementation
               end
             else
               begin
-                location.value:=swapendian(Pcardinal(value_set)^);
+                location.value:=aint(swapendian(Pcardinal(value_set)^));
                 location.value:=aint(
                                    reverse_byte (location.value         and $ff)         or
                                   (reverse_byte((location.value shr  8) and $ff) shl  8) or

compiler/nflw.pas

@@ -460,7 +460,7 @@ implementation
         if hp.resultdef.typ<>pointerdef then
           internalerror(2010061904);
         inserttypeconv(hp,
-          carraydef.create_from_pointer(tpointerdef(hp.resultdef).pointeddef));
+          carraydef.create_from_pointer(tpointerdef(hp.resultdef)));
         hp:=cvecnode.create(hp,ctemprefnode.create(innerloopcounter));
         addstatement(innerloopbodystatement,
           cassignmentnode.create(hloopvar,hp));

compiler/nmem.pas

@@ -106,6 +106,9 @@ interface
        tsubscriptnodeclass = class of tsubscriptnode;
 
        tvecnode = class(tbinarynode)
+       protected
+          function first_arraydef: tnode; virtual;
+       public
           constructor create(l,r : tnode);virtual;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
@@ -833,7 +836,7 @@ implementation
     function tvecnode.pass_typecheck:tnode;
       var
          hightree: tnode;
-         htype,elementdef : tdef;
+         htype,elementdef,elementptrdef : tdef;
          newordtyp: tordtype;
          valid : boolean;
       begin
@@ -946,8 +949,10 @@ implementation
                else
                  {Convert indexes into dynamically allocated strings to aword.}
                  inserttypeconv(right,uinttype);
+             pointerdef:
+               inserttypeconv(right,tpointerdef(left.resultdef).pointer_arithmetic_int_type);
              else
-               {Others, i.e. pointer indexes to aint.}
+               {Others, (are there any?) indexes to aint.}
                inserttypeconv(right,sinttype);
            end;
 
@@ -1014,7 +1019,7 @@ implementation
                   ) then
                 begin
                   { convert pointer to array }
-                  htype:=carraydef.create_from_pointer(tpointerdef(left.resultdef).pointeddef);
+                  htype:=carraydef.create_from_pointer(tpointerdef(left.resultdef));
                   inserttypeconv(left,htype);
                   if right.nodetype=rangen then
                     resultdef:=htype
@@ -1029,19 +1034,23 @@ implementation
                 case tstringdef(left.resultdef).stringtype of
                   st_unicodestring,
                   st_widestring :
-                    elementdef:=cwidechartype;
-                  st_ansistring :
-                    elementdef:=cansichartype;
-                  st_longstring :
-                    elementdef:=cansichartype;
+                    begin
+                      elementdef:=cwidechartype;
+                      elementptrdef:=widecharpointertype;
+                    end;
+                  st_ansistring,
+                  st_longstring,
                   st_shortstring :
-                    elementdef:=cansichartype;
+                    begin
+                      elementdef:=cansichartype;
+                      elementptrdef:=charpointertype;
+                    end;
                   else
                     internalerror(2013112902);
                 end;
                 if right.nodetype=rangen then
                   begin
-                    htype:=carraydef.create_from_pointer(elementdef);
+                    htype:=carraydef.create_from_pointer(tpointerdef(elementptrdef));
                     resultdef:=htype;
                   end
                 else
@@ -1100,17 +1109,32 @@ implementation
            tcallnode.gen_high_tree }
          if (right.nodetype=rangen) then
            CGMessagePos(right.fileinfo,parser_e_illegal_expression)
-         else if (not is_packed_array(left.resultdef)) or
-            ((tarraydef(left.resultdef).elepackedbitsize mod 8) = 0) then
-           if left.expectloc=LOC_CREFERENCE then
-             expectloc:=LOC_CREFERENCE
-           else
-             expectloc:=LOC_REFERENCE
+         else if left.resultdef.typ=arraydef then
+           result:=first_arraydef
          else
-           if left.expectloc=LOC_CREFERENCE then
-             expectloc:=LOC_CSUBSETREF
-           else
-             expectloc:=LOC_SUBSETREF;
+           begin
+             if left.expectloc=LOC_CREFERENCE then
+               expectloc:=LOC_CREFERENCE
+             else
+               expectloc:=LOC_REFERENCE
+           end;
+      end;
+
+
+    function tvecnode.first_arraydef: tnode;
+      begin
+        result:=nil;
+        if (not is_packed_array(left.resultdef)) or
+           ((tarraydef(left.resultdef).elepackedbitsize mod 8) = 0) then
+          if left.expectloc=LOC_CREFERENCE then
+            expectloc:=LOC_CREFERENCE
+          else
+            expectloc:=LOC_REFERENCE
+        else
+          if left.expectloc=LOC_CREFERENCE then
+            expectloc:=LOC_CSUBSETREF
+          else
+            expectloc:=LOC_SUBSETREF;
       end;
 
 

compiler/options.pas

@@ -374,8 +374,11 @@ procedure Toption.WriteHelpPages;
 
   function PadEnd(s:string;i:longint):string;
   begin
-    while (length(s)<i) do
-     s:=s+' ';
+    if length(s) >= i then
+     S := S + ' '
+    else
+     while (length(s)<i) do
+      s:=s+' ';
     PadEnd:=s;
   end;
 
@@ -492,7 +495,7 @@ begin
         if opt='*' then
          opt:=''
         else
-        if opt=' ' then
+        if (opt=' ') or (opt[1]='@') then
          opt:=PadEnd(opt,outline)
         else
          opt:=PadEnd('-'+opt,outline);

compiler/pgenutil.pas

@@ -590,6 +590,8 @@ uses
               found:=searchsym_in_class(tobjectdef(genericdef.owner.defowner),tobjectdef(genericdef.owner.defowner),ugenname,srsym,st,[])
             else
               found:=searchsym_in_record(tabstractrecorddef(genericdef.owner.defowner),ugenname,srsym,st);
+            if not found then
+              found:=searchsym(ugenname,srsym,st);
           end
         else
           found:=searchsym(ugenname,srsym,st);

compiler/ppcgen/cgppc.pas

@@ -33,7 +33,6 @@ unit cgppc;
 
     type
       tcgppcgen = class(tcg)
-        procedure a_load_const_cgpara(list: TAsmList; size: tcgsize; a: tcgint; const paraloc : tcgpara); override;
         procedure a_loadaddr_ref_cgpara(list : TAsmList;const r : treference;const paraloc : tcgpara); override;
 
         procedure a_call_reg(list : TAsmList;reg: tregister); override;
@@ -63,10 +62,6 @@ unit cgppc;
 
         procedure g_maybe_got_init(list: TAsmList); override;
 
-        { Transform unsupported methods into Internal errors }
-        procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister); override;
-        procedure g_stackpointer_alloc(list : TAsmList;localsize : longint);override;
-
         procedure get_aix_toc_sym(list: TAsmList; const symname: string; const flags: tindsymflags; out ref: treference; force_direct_toc: boolean);
         procedure g_load_check_simple(list: TAsmList; const ref: treference; size: aint);
         procedure g_external_wrapper(list: TAsmList; pd: TProcDef; const externalname: string); override;
@@ -195,29 +190,6 @@ unit cgppc;
       end;
 
 
-    procedure tcgppcgen.a_load_const_cgpara(list: TAsmList; size: tcgsize; a: tcgint; const
-      paraloc: tcgpara);
-    var
-      ref: treference;
-    begin
-      paraloc.check_simple_location;
-      paramanager.allocparaloc(list,paraloc.location);
-      case paraloc.location^.loc of
-        LOC_REGISTER, LOC_CREGISTER:
-          a_load_const_reg(list, size, a, paraloc.location^.register);
-        LOC_REFERENCE:
-          begin
-            reference_reset(ref,paraloc.alignment);
-            ref.base := paraloc.location^.reference.index;
-            ref.offset := paraloc.location^.reference.offset;
-            a_load_const_ref(list, size, a, ref);
-          end;
-      else
-        internalerror(2002081101);
-      end;
-    end;
-
-
     procedure tcgppcgen.a_loadaddr_ref_cgpara(list : TAsmList;const r : treference;const paraloc : tcgpara);
       var
         ref: treference;
@@ -603,17 +575,6 @@ unit cgppc;
        end;
 
 
-  procedure tcgppcgen.g_stackpointer_alloc(list : TAsmList;localsize : longint);
-    begin
-      Comment(V_Error,'tcgppcgen.g_stackpointer_alloc method not implemented');
-    end;
-
-  procedure tcgppcgen.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister);
-    begin
-      Comment(V_Error,'tcgppcgen.a_bit_scan_reg_reg method not implemented');
-    end;
-
-
   procedure tcgppcgen.g_overflowcheck(list: TAsmList; const l: tlocation; def: tdef);
     var
       hl : tasmlabel;

compiler/ppu.pas

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

compiler/rgobj.pas

@@ -2191,7 +2191,7 @@ unit rgobj;
         if not spilled then
           exit;
 
-{$if defined(x86) or defined(mips) or defined(sparc) or defined(arm)}
+{$if defined(x86) or defined(mips) or defined(sparc) or defined(arm) or defined(m68k)}
         { Try replacing the register with the spilltemp. This is useful only
           for the i386,x86_64 that support memory locations for several instructions
 
@@ -2206,7 +2206,7 @@ unit rgobj;
                     mustbespilled:=false;
                 end;
             end;
-{$endif defined(x86) or defined(mips) or defined(sparc) or defined(arm)}
+{$endif defined(x86) or defined(mips) or defined(sparc) or defined(arm) or defined(m68k)}
 
         {
           There are registers that need are spilled. We generate the

compiler/sparc/cgcpu.pas

@@ -90,9 +90,6 @@ interface
         procedure g_adjust_self_value(list:TAsmList;procdef: tprocdef;ioffset: tcgint);override;
         procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
         procedure g_external_wrapper(list : TAsmList; procdef: tprocdef; const externalname: string);override;
-        { Transform unsupported methods into Internal errors }
-        procedure a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister); override;
-        procedure g_stackpointer_alloc(list : TAsmList;localsize : longint);override;
        private
         use_unlimited_pic_mode : boolean;
       end;
@@ -1362,16 +1359,6 @@ implementation
       end;
 
 
-    procedure tcgsparc.g_stackpointer_alloc(list : TAsmList;localsize : longint);
-      begin
-        Comment(V_Error,'tcgsparc.g_stackpointer_alloc method not implemented');
-      end;
-
-    procedure tcgsparc.a_bit_scan_reg_reg(list: TAsmList; reverse: boolean; size: TCGSize; src, dst: TRegister);
-      begin
-        Comment(V_Error,'tcgsparc.a_bit_scan_reg_reg method not implemented');
-      end;
-
 {****************************************************************************
                                TCG64Sparc
 ****************************************************************************}

compiler/symcreat.pas

@@ -1037,7 +1037,8 @@ implementation
       i: longint;
     begin
       { add generic flag if required }
-      if df_generic in newstruct.defoptions then
+      if assigned(newstruct) and
+         (df_generic in newstruct.defoptions) then
         include(pd.defoptions,df_generic);
       { associate the procdef with a procsym in the owner }
       if not(pd.proctypeoption in [potype_class_constructor,potype_class_destructor]) then

compiler/symdef.pas

@@ -227,6 +227,16 @@ interface
             override ppuwrite_platform instead }
           procedure ppuwrite(ppufile:tcompilerppufile);override;final;
           function  GetTypeName:string;override;
+          {# returns the appropriate int type for pointer arithmetic with the given pointer type.
+             When adding or subtracting a number to/from a pointer, this function returns the
+             int type to which that number has to be converted, before the operation can be performed.
+             Normally, this is sinttype, except on i8086, where it takes into account the
+             special i8086 pointer types (near, far, huge). }
+          function pointer_arithmetic_int_type:tdef;virtual;
+          {# returns the int type produced when subtracting two pointers of the given type.
+             Normally, this is sinttype, except on i8086, where it takes into account the
+             special i8086 pointer types (near, far, huge). }
+          function pointer_subtraction_result_type:tdef;virtual;
        end;
        tpointerdefclass = class of tpointerdef;
 
@@ -249,6 +259,8 @@ interface
           constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           destructor destroy; override;
+          procedure buildderefimpl;override;
+          procedure derefimpl;override;
           procedure check_forwards; virtual;
           function find_procdef_bytype(pt:tproctypeoption): tprocdef;
           function GetSymtable(t:tGetSymtable):TSymtable;override;
@@ -294,7 +306,6 @@ interface
             override ppuwrite_platform instead }
           procedure ppuwrite(ppufile:tcompilerppufile);override;final;
           procedure buildderef;override;
-          procedure buildderefimpl;override;
           procedure deref;override;
           function  size:asizeint;override;
           function  alignment : shortint;override;
@@ -401,7 +412,6 @@ interface
           function GetTypeName:string;override;
           procedure buildderef;override;
           procedure deref;override;
-          procedure buildderefimpl;override;
           procedure derefimpl;override;
           procedure resetvmtentries;
           procedure copyvmtentries(objdef:tobjectdef);
@@ -470,7 +480,7 @@ interface
           function elesize : asizeint;
           function elepackedbitsize : asizeint;
           function elecount : asizeuint;
-          constructor create_from_pointer(def:tdef);virtual;
+          constructor create_from_pointer(def:tpointerdef);virtual;
           constructor create(l,h:asizeint;def:tdef);virtual;
           constructor ppuload(ppufile:tcompilerppufile);
           destructor destroy; override;
@@ -3170,6 +3180,18 @@ implementation
       end;
 
 
+    function tpointerdef.pointer_arithmetic_int_type:tdef;
+      begin
+        result:=ptrsinttype;
+      end;
+
+
+    function tpointerdef.pointer_subtraction_result_type:tdef;
+      begin
+        result:=ptrsinttype;
+      end;
+
+
 {****************************************************************************
                               TCLASSREFDEF
 ****************************************************************************}
@@ -3390,12 +3412,12 @@ implementation
         inherited;
       end;
 
-    constructor tarraydef.create_from_pointer(def:tdef);
+    constructor tarraydef.create_from_pointer(def:tpointerdef);
       begin
          { use -1 so that the elecount will not overflow }
          self.create(0,high(asizeint)-1,ptrsinttype);
          arrayoptions:=[ado_IsConvertedPointer];
-         setelementdef(def);
+         setelementdef(def.pointeddef);
       end;
 
 
@@ -3687,6 +3709,23 @@ implementation
         inherited destroy;
       end;
 
+
+    procedure tabstractrecorddef.buildderefimpl;
+      begin
+         inherited buildderefimpl;
+         if not (df_copied_def in defoptions) then
+           tstoredsymtable(symtable).buildderefimpl;
+      end;
+
+
+    procedure tabstractrecorddef.derefimpl;
+      begin
+        inherited derefimpl;
+        if not (df_copied_def in defoptions) then
+          tstoredsymtable(symtable).derefimpl;
+      end;
+
+
     procedure tabstractrecorddef.check_forwards;
       begin
         { the defs of a copied def are defined for the original type only }
@@ -4043,14 +4082,6 @@ implementation
       end;
 
 
-    procedure trecorddef.buildderefimpl;
-      begin
-         inherited buildderefimpl;
-         if not (df_copied_def in defoptions) then
-           tstoredsymtable(symtable).buildderefimpl;
-      end;
-
-
     procedure trecorddef.deref;
       begin
          inherited deref;
@@ -4494,7 +4525,7 @@ implementation
                   { in case of bare proc, don't copy self, vmt or framepointer
                     parameters }
                   if (copytyp=pc_bareproc) and
-                     (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result]*pvs.varoptions)<>[]) then
+                     (([vo_is_self,vo_is_vmt,vo_is_parentfp,vo_is_result,vo_is_funcret]*pvs.varoptions)<>[]) then
                     continue;
                   npvs:=cparavarsym.create(pvs.realname,pvs.paranr,pvs.varspez,
                     pvs.vardef,pvs.varoptions);
@@ -5229,24 +5260,29 @@ implementation
           tprocdef(result).deprecatedmsg:=stringdup(deprecatedmsg^);
         { will have to be associated with appropriate procsym }
         tprocdef(result).procsym:=nil;
+        { don't create aliases for bare copies, nor copy the funcretsym as
+          the function result parameter will be inserted again if necessary
+          (e.g. if the calling convention is changed) }
         if copytyp<>pc_bareproc then
-          tprocdef(result).aliasnames.concatListcopy(aliasnames);
-        if assigned(funcretsym) then
           begin
-            if funcretsym.owner=parast then
-              begin
-                j:=parast.symlist.indexof(funcretsym);
-                if j<0 then
-                  internalerror(2011040606);
-                tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
-              end
-            else if funcretsym.owner=localst then
+            tprocdef(result).aliasnames.concatListcopy(aliasnames);
+            if assigned(funcretsym) then
               begin
-                { nothing to do, will be inserted for the new procdef while
-                  parsing its body (by pdecsub.insert_funcret_local) }
-              end
-            else
-              internalerror(2011040605);
+                if funcretsym.owner=parast then
+                  begin
+                    j:=parast.symlist.indexof(funcretsym);
+                    if j<0 then
+                      internalerror(2011040606);
+                    tprocdef(result).funcretsym:=tsym(tprocdef(result).parast.symlist[j]);
+                  end
+                else if funcretsym.owner=localst then
+                  begin
+                    { nothing to do, will be inserted for the new procdef while
+                      parsing its body (by pdecsub.insert_funcret_local) }
+                  end
+                else
+                  internalerror(2011040605);
+              end;
           end;
         { will have to be associated with a new struct }
         tprocdef(result).struct:=nil;
@@ -6207,19 +6243,9 @@ implementation
       end;
 
 
-    procedure tobjectdef.buildderefimpl;
-      begin
-         inherited buildderefimpl;
-         if not (df_copied_def in defoptions) then
-           tstoredsymtable(symtable).buildderefimpl;
-      end;
-
-
     procedure tobjectdef.derefimpl;
       begin
          inherited derefimpl;
-         if not (df_copied_def in defoptions) then
-           tstoredsymtable(symtable).derefimpl;
          { the procdefs are not owned by the class helper procsyms, so they
            are not stored/restored either -> re-add them here }
          if (objecttype=odt_objcclass) or

compiler/symsym.pas

@@ -444,6 +444,14 @@ interface
           function GetCopy:tmacro;
        end;
 
+       { tPtrDefHashSet }
+
+       tPtrDefHashSet = class(THashSet)
+       public
+         constructor Create;virtual;
+       end;
+       tPtrDefHashSetClass = class of tPtrDefHashSet;
+
     var
        generrorsym : tsym;
 
@@ -461,6 +469,7 @@ interface
        cconstsym: tconstsymclass;
        cenumsym: tenumsymclass;
        csyssym: tsyssymclass;
+       cPtrDefHashSet : tPtrDefHashSetClass = tPtrDefHashSet;
 
     { generate internal static field name based on regular field name }
     function internal_static_field_name(const fieldname: TSymStr): TSymStr;
@@ -2699,4 +2708,14 @@ implementation
         Result:=p;
       end;
 
+
+{****************************************************************************
+                             tPtrDefHashSet
+ ****************************************************************************}
+
+    constructor tPtrDefHashSet.Create;
+      begin
+        inherited Create(64,true,false);
+      end;
+
 end.

compiler/symtable.pas

@@ -3329,7 +3329,9 @@ implementation
               end;
           end;
         { now search in the extended type itself }
-        if classh.extendeddef.typ in [recorddef,objectdef] then
+        { Note: the extendeddef might be Nil if we are currently parsing the
+                extended type itself and the identifier was not found }
+        if assigned(classh.extendeddef) and (classh.extendeddef.typ in [recorddef,objectdef]) then
           begin
             srsymtable:=tabstractrecorddef(classh.extendeddef).symtable;
             srsym:=tsym(srsymtable.FindWithHash(hashedid));
@@ -3472,7 +3474,7 @@ implementation
         sym:=tsym(systemunit.Find(s));
         if not assigned(sym) or
            (sym.typ<>typesym) then
-          cgmessage1(cg_f_unknown_system_type,s);
+          message1(cg_f_unknown_system_type,s);
         result:=ttypesym(sym);
       end;
 
@@ -3487,7 +3489,7 @@ implementation
         else
           begin
             if sym.typ<>typesym then
-              cgmessage1(cg_f_unknown_system_type,s);
+              message1(cg_f_unknown_system_type,s);
             result:=ttypesym(sym);
           end;
       end;
@@ -3503,7 +3505,7 @@ implementation
           srsym:=tsym(systemunit.Find(upper(s)));
         if not assigned(srsym) or
            (srsym.typ<>procsym) then
-          cgmessage1(cg_f_unknown_compilerproc,s);
+          message1(cg_f_unknown_compilerproc,s);
         result:=tprocdef(tprocsym(srsym).procdeflist[0]);
     end;
 
@@ -3523,7 +3525,7 @@ implementation
         else
           begin
             if throwerror then
-              cgmessage2(cg_f_unknown_type_in_unit,typename,unitname);
+              message2(cg_f_unknown_type_in_unit,typename,unitname);
             result:=nil;
           end;
       end;

compiler/systems/i_linux.pas

@@ -170,6 +170,7 @@ unit i_linux;
             name         : 'Linux for m68k';
             shortname    : 'Linux';
             flags        : [tf_needs_symbol_size,tf_needs_symbol_type,tf_files_case_sensitive,
+                            tf_smartlink_sections,
                             tf_requires_proper_alignment, { Coldfire seems to need this at least (KB) }
                             tf_smartlink_library,tf_has_winlike_resources];
             cpu          : cpu_m68k;

compiler/systems/t_linux.pas

@@ -151,8 +151,7 @@ begin
 end;
 
 {$ifdef m68k}
-  { experimental, is this correct? }
-  const defdynlinker='/lib/ld-linux.so.2';
+  const defdynlinker='/lib/ld.so.1';
 {$endif m68k}
 
 {$ifdef i386}

compiler/systems/t_nds.pas

@@ -243,20 +243,19 @@ begin
     begin
       if apptype=app_arm9 then //ARM9
       begin
-        add('OUTPUT_FORMAT("elf32-littlearm", "elf32-bigarm", "elf32-littlearm")');
-        add('OUTPUT_ARCH(arm)');
-        add('ENTRY(_start)');
-        add('');
         add('MEMORY {');
-        add('');
         add('	rom	: ORIGIN = 0x08000000, LENGTH = 32M');
         add('	ewram	: ORIGIN = 0x02000000, LENGTH = 4M - 4k');
         add('	dtcm	: ORIGIN = 0x0b000000, LENGTH = 16K');
-        add('	vectors : ORIGIN = 0x01000000, LENGTH = 256');
-        add('	itcm    : ORIGIN = 0x01000100, LENGTH = 32K - 256');
+        add('	vectors	: ORIGIN = 0x01000000, LENGTH = 256');
+        add('	itcm	: ORIGIN = 0x01000100, LENGTH = 32K - 256');
         add('}');
         add('');
-        add('__vectors_start = ORIGIN(vectors);');
+        add('OUTPUT_ARCH(arm)');
+        add('OUTPUT_FORMAT("elf32-littlearm", "elf32-bigarm", "elf32-littlearm")');
+        add('ENTRY(_start)');
+        add('');
+        add('__vectors_start	=	ORIGIN(vectors);');
         add('__itcm_start	=	ORIGIN(itcm);');
         add('__ewram_end	=	ORIGIN(ewram) + LENGTH(ewram);');
         add('__eheap_end	=	ORIGIN(ewram) + LENGTH(ewram);');
@@ -276,7 +275,7 @@ begin
         add('		__text_start = . ;');
         add('		KEEP (*(.init))');
         add('		. = ALIGN(4);  /* REQUIRED. LD is flaky without it. */');
-        add('		} >ewram = 0xff');
+        add('	} >ewram = 0xff');
         add('');
         add('	.plt : { *(.plt) } >ewram = 0xff');
         add('');
@@ -312,36 +311,40 @@ begin
         add('		. = ALIGN(4);   /* REQUIRED. LD is flaky without it. */');
         add('	} >ewram = 0xff');
         add('');
-        add('  .ARM.extab   : { *(.ARM.extab* .gnu.linkonce.armextab.*) } >ewram');
-        add('   __exidx_start = .;');
-        add('  .ARM.exidx   : { *(.ARM.exidx* .gnu.linkonce.armexidx.*) } >ewram');
-        add('   __exidx_end = .;');
-        add('  /* Ensure the __preinit_array_start label is properly aligned.  We');
-        add('     could instead move the label definition inside the section, but');
-        add('     the linker would then create the section even if it turns out to');
-        add('     be empty, which isn''t pretty.  */');
-        add('  . = ALIGN(32 / 8);');
-        add('  PROVIDE (__preinit_array_start = .);');
-        add('  .preinit_array     : { KEEP (*(.preinit_array)) } >ewram = 0xff');
-        add('  PROVIDE (__preinit_array_end = .);');
-        add('  PROVIDE (__init_array_start = .);');
-        add('  .init_array     :');
-        add('  {');
-        add('       KEEP (*(SORT(.init_array.*)))');
-        add('       KEEP (*(.init_array))');
-        add('  } >ewram = 0xff');        
-        add('  PROVIDE (__init_array_end = .);');
-        add('  PROVIDE (__fini_array_start = .);');
-        add('  .fini_array     :');
-        add('  {');
-        add('       KEEP (*(.fini_array))');
-        add('       KEEP (*(SORT(.fini_array.*)))');
-        add('  } >ewram = 0xff');
-        add('  PROVIDE (__fini_array_end = .);');
+        add('	.ARM.extab   : { *(.ARM.extab* .gnu.linkonce.armextab.*) } >ewram');
+        add(' 	__exidx_start = .;');
+        add('	ARM.exidx   : { *(.ARM.exidx* .gnu.linkonce.armexidx.*) } >ewram');
+        add(' 	__exidx_end = .;');
+        add('');
+        add('	/*	Ensure the __preinit_array_start label is properly aligned.  We');
+        add('		could instead move the label definition inside the section, but');
+        add('		the linker would then create the section even if it turns out to');
+        add('		be empty, which isn''t pretty.  */');
+        add('');
+        add('	. = ALIGN(32 / 8);');
+        add('');
+        add('	PROVIDE (__preinit_array_start = .);');
+        add('	.preinit_array     : { KEEP (*(.preinit_array)) } >ewram = 0xff');
+        add('	PROVIDE (__preinit_array_end = .);');
+        add('	PROVIDE (__init_array_start = .);');
+        add('	.init_array     :');
+        add('	{');
+        add('		KEEP (*(SORT(.init_array.*)))');
+        add('		KEEP (*(.init_array))');
+        add('	} >ewram = 0xff');
+        add('	PROVIDE (__init_array_end = .);');
+        add('	PROVIDE (__fini_array_start = .);');
+        add('	.fini_array     :');
+        add('	{');
+        add('		KEEP (*(.fini_array))');
+        add('		KEEP (*(SORT(.fini_array.*)))');
+        add('	} >ewram = 0xff');
+        add('');
+        add('	PROVIDE (__fini_array_end = .);');
         add('');
         add('	.ctors :');
         add('	{');
-        add('	/* gcc uses crtbegin.o to find the start of the constructors, so');
+        add('	/*	gcc uses crtbegin.o to find the start of the constructors, so');
         add('		we make sure it is first.  Because this is a wildcard, it');
         add('		doesn''t matter if the user does not actually link against');
         add('		crtbegin.o; the linker won''t look for a file to match a');
@@ -392,7 +395,6 @@ begin
         add('		*(.data)');
         add('		*(.data.*)');
         add('		*(.gnu.linkonce.d*)');
-        add('		*(.fpc*)');
         add('		CONSTRUCTORS');
         add('		. = ALIGN(4);');
         add('		__data_end = ABSOLUTE(.) ;');
@@ -408,7 +410,7 @@ begin
         add('		*(.dtcm.*)');
         add('		. = ALIGN(4);');
         add('		__dtcm_end = ABSOLUTE(.);');
-        add('	} >dtcm = 0xff');
+        add('	} >dtcm  = 0xff');
         add('');
         add('');
         add('	__itcm_lma = __dtcm_lma + SIZEOF(.dtcm);');
@@ -420,29 +422,27 @@ begin
         add('		. = ALIGN(4);');
         add('		__itcm_end = ABSOLUTE(.);');
         add('	} >itcm = 0xff');
+        add('	');
+        add('	__vectors_lma = __itcm_lma + SIZEOF(.itcm);');
         add('');
-
-        add(' __vectors_lma = __itcm_lma + SIZEOF(.itcm);');
-        add(' .vectors __vectors_start : AT (__vectors_lma)');
-        add(' {');
-        add('   *(.vectors)');
-        add('   *vectors.*(.text)');
-        add('   . = ALIGN(4);');
-        add('   __vectors_end = ABSOLUTE(.);');
-        add(' } >vectors = 0xff');
-        add('');
-        add(' .sbss __dtcm_end (NOLOAD):');
+        add('	.vectors __vectors_start : AT (__vectors_lma)');
+        add('	{');
+        add('		*(.vectors)');
+        add('		*vectors.*(.text)');
+        add('		. = ALIGN(4);');
+        add('		__vectors_end = ABSOLUTE(.);');
+        add('	} >vectors = 0xff');
+        add('	');
+        add('	.sbss __dtcm_end (NOLOAD): ');
         add('	{');
         add('		__sbss_start = ABSOLUTE(.);');
         add('		__sbss_start__ = ABSOLUTE(.);');
         add('		*(.sbss)');
         add('		. = ALIGN(4);    /* REQUIRED. LD is flaky without it. */');
         add('		__sbss_end = ABSOLUTE(.);');
-        add('	} >dtcm');
-        add('');
-        add('');
+        add('	} >dtcm ');
         add('');
-        add('	.bss __bss_vma (NOLOAD):');
+        add('	.bss __bss_vma (NOLOAD): ');
         add('	{');
         add('		__bss_start = ABSOLUTE(.);');
         add('		__bss_start__ = ABSOLUTE(.);');
@@ -453,7 +453,8 @@ begin
         add('		. = ALIGN(4);    /* REQUIRED. LD is flaky without it. */');
         add('		__bss_end__ = ABSOLUTE(.) ;');
         add('		__end__ = ABSOLUTE(.) ;');
-        add('	} AT>ewram');
+        add('	} AT>ewram ');
+        add('');
         add('');
         add('');
         add('	/* Stabs debugging sections.  */');
@@ -492,6 +493,7 @@ begin
         add('	.stack 0x80000 : { _stack = .; *(.stack) }');
         add('	/* These must appear regardless of  .  */');
         add('}');
+        add('');
       end;
       if apptype=app_arm7 then
       begin
@@ -501,12 +503,13 @@ begin
         add('');
         add('MEMORY {');
         add('');
-        add('	rom	  : ORIGIN = 0x08000000, LENGTH = 32M');
-        add('	iwram : ORIGIN = 0x037f8000, LENGTH = 96K');
+        add('	rom	: ORIGIN = 0x08000000, LENGTH = 32M');
+        add('	iwram	: ORIGIN = 0x037f8000, LENGTH = 96K	');
         add('}');
         add('');
         add('__iwram_start	=	ORIGIN(iwram);');
         add('__iwram_top	=	ORIGIN(iwram)+ LENGTH(iwram);');
+        add('');
         add('__sp_irq	=	__iwram_top - 0x100;');
         add('__sp_svc	=	__sp_irq - 0x100;');
         add('__sp_usr	=	__sp_svc - 0x100;');
@@ -527,9 +530,8 @@ begin
         add('');
         add('	.text :   /* ALIGN (4): */');
         add('	{');
-        add('');
-        add('   *(.text .stub .text.* .gnu.linkonce.t.*)');
-        add('   KEEP (*(.text.*personality*))');        
+        add('		*(.text .stub .text.* .gnu.linkonce.t.*)');
+        add('		KEEP (*(.text.*personality*))');
         add('		/* .gnu.warning sections are handled specially by elf32.em.  */');
         add('		*(.gnu.warning)');
         add('		*(.glue_7t) *(.glue_7) *(.vfp11_veneer)');
@@ -612,30 +614,16 @@ begin
         add('	.jcr            : { KEEP (*(.jcr)) } >iwram = 0');
         add('	.got            : { *(.got.plt) *(.got) } >iwram = 0');
         add('');
-        add('');
-        add('	.iwram ALIGN(4) :');
-        add('	{');
-        add('		__iwram_start = ABSOLUTE(.) ;');
-        add('		*(.iwram)');
-        add('		*iwram.*(.text)');
-        add('		. = ALIGN(4);   /* REQUIRED. LD is flaky without it. */');
-        add('		__iwram_end = ABSOLUTE(.) ;');
-        add('	} >iwram = 0xff');
-        add('');
-        add('');
         add('	.data ALIGN(4) : 	{');
         add('		__data_start = ABSOLUTE(.);');
         add('		*(.data)');
         add('		*(.data.*)');
         add('		*(.gnu.linkonce.d*)');
-        add('		*(.fpc*)');
         add('		CONSTRUCTORS');
         add('		. = ALIGN(4);');
         add('		__data_end = ABSOLUTE(.) ;');
         add('	} >iwram = 0xff');
         add('');
-        add('');
-        add('');
         add('	.bss ALIGN(4) :');
         add('	{');
         add('		__bss_start = ABSOLUTE(.);');

compiler/utils/ppuutils/ppudump.pp

@@ -2865,6 +2865,8 @@ begin
              writeln([space,'            Range : ',arrdef.RangeLow,' to ',arrdef.RangeHigh]);
              write  ([space,'          Options : ']);
              readarraydefoptions(arrdef);
+             if tsystemcpu(ppufile.header.cpu)=cpu_i8086 then
+               writeln([space,'             Huge : ',(getbyte<>0)]);
              readsymtable('symbols', arrdef);
            end;
 

compiler/wpoinfo.pas

@@ -142,7 +142,7 @@ implementation
     begin
       { load start of definition section, which holds the amount of defs }
       if ppufile.readentry<>ibcreatedobjtypes then
-        cgmessage(unit_f_ppu_read_error);
+        message(unit_f_ppu_read_error);
 
       { don't load the wpo info from the units if we are not generating
         a wpo feedback file (that would just take time and memory)

compiler/x86/nx86add.pas

@@ -47,6 +47,7 @@ unit nx86add;
         procedure second_addfloatsse;
         procedure second_addfloatavx;
       public
+        function use_fma : boolean;override;
         procedure second_addfloat;override;
 {$ifndef i8086}
         procedure second_addsmallset;override;
@@ -273,6 +274,15 @@ unit nx86add;
     procedure tx86addnode.prepare_x87_locations(out refnode: tnode);
       begin
         refnode:=nil;
+
+        { later on, no mm registers are allowed, so transfer everything to memory here
+          below it is loaded into an fpu register if neede }
+        if left.location.loc in [LOC_CMMREGISTER,LOC_MMREGISTER] then
+          hlcg.location_force_mem(current_asmdata.CurrAsmList,left.location,left.resultdef);
+
+        if right.location.loc in [LOC_CMMREGISTER,LOC_MMREGISTER] then
+          hlcg.location_force_mem(current_asmdata.CurrAsmList,right.location,right.resultdef);
+
         case ord(left.location.loc=LOC_FPUREGISTER)+ord(right.location.loc=LOC_FPUREGISTER) of
           0:
             begin
@@ -1072,6 +1082,18 @@ unit nx86add;
       end;
 
 
+    function tx86addnode.use_fma : boolean;
+      begin
+{$ifndef i8086}
+        { test if the result stays in an xmm register, fiddeling with fpu registers and fma makes no sense }
+        Result:=use_vectorfpu(resultdef) and
+          ((cpu_capabilities[current_settings.cputype]*[CPUX86_HAS_FMA,CPUX86_HAS_FMA4])<>[]);
+{$else i8086}
+        Result:=inherited use_fma;
+{$endif i8086}
+      end;
+
+
     procedure tx86addnode.second_cmpfloatvector;
       var
         op : tasmop;

compiler/x86/symx86.pas

@@ -26,7 +26,7 @@ unit symx86;
 interface
 
 uses
-  globtype,
+  globtype, cclasses,
   symconst, symtype,symdef,symsym;
 
 type
@@ -45,10 +45,62 @@ type
   end;
   tx86pointerdefclass = class of tx86pointerdef;
 
+  tx86PtrDefKey = packed record
+    def: tdef;
+    x86typ:tx86pointertyp;
+  end;
+
+  { tx86PtrDefHashSet }
+
+  tx86PtrDefHashSet = class(TPtrDefHashSet)
+   private
+    class procedure Key2FullKey(Key: Pointer; out FullKey: tx86PtrDefKey);
+   public
+    function Find(Key: Pointer; KeyLen: Integer): PHashSetItem;override;
+    function FindOrAdd(Key: Pointer; KeyLen: Integer;
+      var Found: Boolean): PHashSetItem;override;
+    function FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;override;
+    function Get(Key: Pointer; KeyLen: Integer): TObject;override;
+  end;
+
+  { returns a pointerdef for def, reusing an existing one in case it exists
+    in the current module }
+  function getx86pointerdef(def: tdef;x86typ:tx86pointertyp): tpointerdef;
+
 implementation
 
   uses
-    globals, verbose;
+    globals, verbose,
+    symbase, fmodule;
+
+  function getx86pointerdef(def: tdef;x86typ:tx86pointertyp): tpointerdef;
+    var
+      res: PHashSetItem;
+      oldsymtablestack: tsymtablestack;
+      key: tx86PtrDefKey;
+    begin
+      if not assigned(current_module) then
+        internalerror(2011071101);
+      key.def:=def;
+      key.x86typ:=x86typ;
+      res:=current_module.ptrdefs.FindOrAdd(@key,sizeof(key));
+      if not assigned(res^.Data) then
+        begin
+          { since these pointerdefs can be reused anywhere in the current
+            unit, add them to the global/staticsymtable }
+          oldsymtablestack:=symtablestack;
+          { do not simply push/pop current_module.localsymtable, because
+            that can have side-effects (e.g., it removes helpers) }
+          symtablestack:=nil;
+          res^.Data:=tx86pointerdefclass(cpointerdef).createx86(def,x86typ);
+          if assigned(current_module.localsymtable) then
+            current_module.localsymtable.insertdef(tdef(res^.Data))
+          else
+            current_module.globalsymtable.insertdef(tdef(res^.Data));
+          symtablestack:=oldsymtablestack;
+        end;
+      result:=tpointerdef(res^.Data);
+    end;
 
 {****************************************************************************
                              tx86pointerdef
@@ -136,5 +188,69 @@ implementation
     end;
 
 
+{****************************************************************************
+                             tx86PtrDefHashSet
+****************************************************************************}
+
+    class procedure tx86PtrDefHashSet.Key2FullKey(Key: Pointer; out FullKey: tx86PtrDefKey);
+      type
+        pdef=^tdef;
+      begin
+        FullKey.def:=pdef(Key)^;
+        FullKey.x86typ:=tx86pointerdefclass(cpointerdef).default_x86_data_pointer_type;
+      end;
+
+    function tx86PtrDefHashSet.Find(Key: Pointer; KeyLen: Integer): PHashSetItem;
+      var
+        FullKey: tx86PtrDefKey;
+      begin
+        if KeyLen=SizeOf(tdef) then
+          begin
+            Key2FullKey(Key, FullKey);
+            Result:=inherited Find(@FullKey, SizeOf(FullKey));
+          end
+        else
+          Result:=inherited Find(Key, KeyLen);
+      end;
+
+    function tx86PtrDefHashSet.FindOrAdd(Key: Pointer; KeyLen: Integer; var Found: Boolean): PHashSetItem;
+      var
+        FullKey: tx86PtrDefKey;
+      begin
+        if KeyLen=SizeOf(tdef) then
+          begin
+            Key2FullKey(Key, FullKey);
+            Result:=inherited FindOrAdd(@FullKey, SizeOf(FullKey), Found);
+          end
+        else
+          Result:=inherited FindOrAdd(Key, KeyLen, Found);
+      end;
+
+    function tx86PtrDefHashSet.FindOrAdd(Key: Pointer; KeyLen: Integer): PHashSetItem;
+      var
+        FullKey: tx86PtrDefKey;
+      begin
+        if KeyLen=SizeOf(tdef) then
+          begin
+            Key2FullKey(Key, FullKey);
+            Result:=inherited FindOrAdd(@FullKey, SizeOf(FullKey));
+          end
+        else
+          Result:=inherited FindOrAdd(Key, KeyLen);
+      end;
+
+    function tx86PtrDefHashSet.Get(Key: Pointer; KeyLen: Integer): TObject;
+      var
+        FullKey: tx86PtrDefKey;
+      begin
+        if KeyLen=SizeOf(tdef) then
+          begin
+            Key2FullKey(Key, FullKey);
+            Result:=inherited Get(@FullKey, SizeOf(FullKey));
+          end
+        else
+          Result:=inherited Get(Key, KeyLen);
+      end;
+
 end.
 

compiler/x86_64/symcpu.pas

@@ -207,5 +207,7 @@ begin
   cconstsym:=tcpuconstsym;
   cenumsym:=tcpuenumsym;
   csyssym:=tcpusyssym;
+
+  cPtrDefHashSet:=tx86PtrDefHashSet;
 end.
 

ide/wconstse.inc

@@ -99,11 +99,11 @@
     msg_cutting = 'Cutting';
     { Help system }
 
-    msg_nohelpfilesinstalled1 = 'To keep the size of the FPC download reasonably low, it comes without html formatted docs';
-    msg_nohelpfilesinstalled2 = 'which are necessary for the IDE.';
-    msg_nohelpfilesinstalled3 = 'To get these docs, go to http://www.freepascal.org/down/docs/docs.var and get one';
-    msg_nohelpfilesinstalled4 = 'of the html doc archives and unpack the enclosed contents into your FPC directory.';
-    msg_nohelpfilesinstalled5 = 'Add fpctoc.html via Help|Files ... to the IDE help file system.';
+    msg_nohelpfilesinstalled1 = 'To keep the size of the FPC download reasonably low, the CHM help files';
+    msg_nohelpfilesinstalled2 = 'which are necessary for the IDE help to function, are omitted.';
+    msg_nohelpfilesinstalled3 = 'To get these docs, go to ftp://ftp.freepascal.org/pub/fpc/dist/ and get doc-chm.zip';
+    msg_nohelpfilesinstalled4 = 'for your version. Extract the CHM files and add them to the IDE using Help|Files,';
+    msg_nohelpfilesinstalled5 = 'add toc.chm first.';
     msg_helpindex = 'Help index';
     msg_nohelpavailabelforthistopic = 'No help available for this topic.';
     msg_pagenotavailable = 'Page not available';

installer/winshell.pas

@@ -9,6 +9,8 @@ interface
 
 uses
   Windows;
+type
+  INT = WINT;
 const
   { GetCurrentPlatform constants }
   pfAll = %11111111;
@@ -337,7 +339,7 @@ begin
         end;
       if link^.vtbl^.QueryInterface (link, IID_IShellLinkDataList, DL) = S_OK then
         begin
-          flags:=-1;
+          flags:= DWORD(-1);
           if DL^.vtbl^.GetFlags(DL,flags)=S_OK then
             begin
               writeln('Link flag is ',hexstr(flags,8));

packages/Makefile.fpc.fpcmake

@@ -65,6 +65,7 @@ dirs_go32v2=rtl-console fv graph unzip gdbint
 dirs_amiga=amunits
 dirs_morphos=rtl-console fv opengl sdl
 dirs_wii=libogcfpc
+dirs_arm_nds=libndsfpc
 
 [install]
 fpcpackage=y

packages/fcl-base/src/fileinfo.pp

@@ -194,7 +194,8 @@ begin
     Inc(I);
     end;
   // This will read the info.
-  FVersionInfo.FixedInfo;
+  if assigned(FVersionInfo) then
+    FVersionInfo.FixedInfo;
 end;
 
 procedure TVersionInfo.Load(Const Instance: THandle);

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

@@ -354,6 +354,13 @@ begin
     CheckError('Close', FStatus);
 {$IfDef LinkDynamically}
   ReleaseIBase60;
+{$ELSE}
+  // Shutdown embedded subsystem with timeout 300ms (Firebird 2.5+)
+  // Required before unloading library; has no effect on non-embedded client
+  if (pointer(fb_shutdown)<>nil) and (fb_shutdown(300,1)<>0) then
+  begin
+    //todo: log error; still try to unload library below as the timeout may have been insufficient
+  end;
 {$EndIf}
 end;
 
@@ -1607,29 +1614,41 @@ end;
 
 class function TIBConnectionDef.DefaultLibraryName: String;
 begin
+{$IFDEF LinkDynamically}
   If UseEmbeddedFirebird then
     Result:=fbembedlib
   else
-    Result:=fbclib
+    Result:=fbclib;
+{$ELSE}
+  Result:='';
+{$ENDIF}
 end;
 
 class function TIBConnectionDef.LoadFunction: TLibraryLoadFunction;
 begin
+{$IFDEF LinkDynamically}
   Result:=@InitialiseIBase60;
+{$ELSE}
+  Result:=nil;
+{$ENDIF}
 end;
 
 class function TIBConnectionDef.UnLoadFunction: TLibraryUnLoadFunction;
 begin
+{$IFDEF LinkDynamically}
   Result:=@ReleaseIBase60
+{$ELSE}
+  Result:=nil;
+{$ENDIF}
 end;
 
 class function TIBConnectionDef.LoadedLibraryName: string;
 begin
-  {$IfDef LinkDynamically}
+{$IFDEF LinkDynamically}
   Result:=IBaseLoadedLibrary;
-  {$else}
+{$ELSE}
   Result:='';
-  {$endif}
+{$ENDIF}
 end;
 
 initialization

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

@@ -1,5 +1,15 @@
 unit oracleconnection;
 
+{
+    Copyright (c) 2006-2014 by Joost van der Sluis, FPC contributors
+
+    Oracle RDBMS connector using the OCI protocol
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+ **********************************************************************}
+
 {$mode objfpc}{$H+}
 
 {$Define LinkDynamically}
@@ -7,7 +17,7 @@ unit oracleconnection;
 interface
 
 uses
-  Classes, SysUtils, db,dbconst, sqldb, bufdataset,
+  Classes, SysUtils, db, dbconst, sqldb, bufdataset,
 {$IfDef LinkDynamically}
   ocidyn,
 {$ELSE}
@@ -58,8 +68,8 @@ type
     FOciUserSession : POCISession;
     FUserMem        : pointer;
     procedure HandleError;
-    procedure GetParameters(cursor : TSQLCursor; AParams : TParams);
-    procedure SetParameters(cursor : TSQLCursor; AParams : TParams);
+    procedure GetParameters(cursor : TSQLCursor; ATransaction : TSQLTransaction; AParams : TParams);
+    procedure SetParameters(cursor : TSQLCursor; ATransaction : TSQLTransaction; AParams : TParams);
   protected
     // - Connect/disconnect
     procedure DoInternalConnect; override;
@@ -112,6 +122,9 @@ implementation
 uses
   math, StrUtils, FmtBCD;
 
+const
+  ObjectQuote='"'; //beginning and ending quote for objects such as table names. Note: can be different from quotes around field names
+
 ResourceString
   SErrEnvCreateFailed = 'The creation of an Oracle environment failed.';
   SErrHandleAllocFailed = 'The allocation of the error handle failed.';
@@ -322,7 +335,6 @@ procedure TOracleConnection.HandleError;
 var errcode : sb4;
     buf     : array[0..1023] of char;
     E       : EOraDatabaseError;
-
 begin
   OCIErrorGet(FOciError,1,nil,errcode,@buf[0],1024,OCI_HTYPE_ERROR);
 
@@ -335,7 +347,7 @@ begin
   Raise E;
 end;
 
-procedure TOracleConnection.GetParameters(cursor: TSQLCursor; AParams: TParams);
+procedure TOracleConnection.GetParameters(cursor: TSQLCursor; ATransaction : TSQLTransaction; AParams: TParams);
 var
     i    : integer;
     odt  : TODateTime;
@@ -463,8 +475,8 @@ end;
 
 function TOracleConnection.AllocateCursorHandle: TSQLCursor;
 
-var Cursor : TOracleCursor;
-
+var
+  Cursor : TOracleCursor;
 begin
   Cursor:=TOracleCursor.Create;
   Result := cursor;
@@ -556,6 +568,7 @@ begin
     end;
     if FStatementType in [stUpdate,stDelete,stInsert,stDDL] then
       FSelectable:=false;
+
     if assigned(AParams) then
       begin
       setlength(ParamBuffers,AParams.Count);
@@ -576,7 +589,8 @@ begin
           ftFMTBcd, ftBCD :
             begin OFieldType := SQLT_VNU; OFieldSize := 22; end;
           ftBlob :
-            begin OFieldType := SQLT_LVB; OFieldSize := 65535; end;
+            //begin OFieldType := SQLT_LVB; OFieldSize := 65535; end;
+            begin OFieldType := SQLT_BLOB; OFieldSize := sizeof(pointer); ODescType := OCI_DTYPE_LOB; end;
           ftMemo :
             begin OFieldType := SQLT_LVC; OFieldSize := 65535; end;
         else
@@ -617,13 +631,13 @@ begin
     end;
 end;
 
-procedure TOracleConnection.SetParameters(cursor : TSQLCursor; AParams : TParams);
+procedure TOracleConnection.SetParameters(cursor : TSQLCursor; ATransaction : TSQLTransaction; AParams : TParams);
 
-var i              : integer;
+var i         : integer;
     year, month, day, hour, min, sec, msec : word;
-    s              : string;
-    blobbuf        : string;
-    bloblen        : ub4;
+    s         : string;
+    LobBuffer : string;
+    LobLength : ub4;
 
 begin
   with cursor as TOracleCursor do for i := 0 to High(ParamBuffers) do with AParams[i] do
@@ -659,14 +673,21 @@ begin
         ftFmtBCD, ftBCD   : begin
                             FmtBCD2Nvu(asFmtBCD,parambuffers[i].buffer);
                             end;
-        ftBlob, ftMemo    : begin
-                            blobbuf := AsBlob; // todo: use AsBytes
-                            bloblen := length(blobbuf);
-                            if bloblen > 65531 then bloblen := 65531;
-                            PInteger(ParamBuffers[i].Buffer)^ := bloblen;
-                            Move(blobbuf[1], (ParamBuffers[i].Buffer+sizeof(integer))^, bloblen);
-                            //if OciLobWrite(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, ParamBuffers[i].buffer, @bloblen, 1, @blobbuf[1], bloblen, OCI_ONE_PIECE, nil, nil, 0, SQLCS_IMPLICIT) = OCI_ERROR then
-                            //  HandleError;
+        ftBlob            : begin
+                            LobBuffer := AsBlob; // todo: use AsBytes
+                            LobLength := length(LobBuffer);
+                            // create empty temporary LOB with zero length
+                            if OciLobCreateTemporary(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, ParamBuffers[i].Buffer, OCI_DEFAULT, OCI_DEFAULT, OCI_TEMP_BLOB, False, OCI_DURATION_SESSION) = OCI_ERROR then
+                              HandleError;
+                            if (LobLength > 0) and (OciLobWrite(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, ParamBuffers[i].Buffer, @LobLength, 1, @LobBuffer[1], LobLength, OCI_ONE_PIECE, nil, nil, 0, SQLCS_IMPLICIT) = OCI_ERROR) then
+                              HandleError;
+                            end;
+        ftMemo            : begin
+                            LobBuffer := AsString;
+                            LobLength := length(LobBuffer);
+                            if LobLength > 65531 then LobLength := 65531;
+                            PInteger(ParamBuffers[i].Buffer)^ := LobLength;
+                            Move(LobBuffer[1], (ParamBuffers[i].Buffer+sizeof(integer))^, LobLength);
                             end;
         else
           DatabaseErrorFmt(SUnsupportedParameter,[DataType],self);
@@ -751,8 +772,17 @@ begin
 end;
 
 procedure TOracleConnection.Execute(cursor: TSQLCursor; ATransaction: TSQLTransaction; AParams: TParams);
+  procedure FreeParameters;
+  var i: integer;
+  begin
+    with cursor as TOracleCursor do
+      for i:=0 to high(ParamBuffers) do
+        if ParamBuffers[i].DescType = OCI_DTYPE_LOB then
+          if OciLobFreeTemporary(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, ParamBuffers[i].Buffer) = OCI_ERROR then
+            HandleError;
+  end;
 begin
-  if Assigned(AParams) and (AParams.Count > 0) then SetParameters(cursor, AParams);
+  if Assigned(AParams) and (AParams.Count > 0) then SetParameters(cursor, ATransaction, AParams);
   if cursor.FStatementType = stSelect then
     begin
     if OCIStmtExecute(TOracleTrans(ATransaction.Handle).FOciSvcCtx,(cursor as TOracleCursor).FOciStmt,FOciError,0,0,nil,nil,OCI_DEFAULT) = OCI_ERROR then
@@ -762,8 +792,9 @@ begin
     begin
     if OCIStmtExecute(TOracleTrans(ATransaction.Handle).FOciSvcCtx,(cursor as TOracleCursor).FOciStmt,FOciError,1,0,nil,nil,OCI_DEFAULT) = OCI_ERROR then
       HandleError;
-    if Assigned(AParams) and (AParams.Count > 0) then GetParameters(cursor, AParams);
+    if Assigned(AParams) and (AParams.Count > 0) then GetParameters(cursor, ATransaction, AParams);
     end;
+  FreeParameters;
 end;
 
 function TOracleConnection.RowsAffected(cursor: TSQLCursor): TRowsCount;
@@ -880,7 +911,12 @@ begin
                                   OFieldSize:=sizeof(double);
                                   end;
                                 end;
-        SQLT_LNG,
+        SQLT_LNG              : begin
+                                FieldType := ftString;
+                                FieldSize := MaxSmallint; // OFieldSize is zero for LONG data type
+                                OFieldSize:= MaxSmallint+1;
+                                OFieldType:=SQLT_STR;
+                                end;
         OCI_TYPECODE_CHAR,
         OCI_TYPECODE_VARCHAR,
         OCI_TYPECODE_VARCHAR2 : begin
@@ -1032,17 +1068,20 @@ end;
 
 procedure TOracleConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef; ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
 var LobLocator: pointer;
-    len: ub4;
+    LobCharSetForm: ub1;
+    LobLength: ub4;
 begin
   LobLocator := (cursor as TOracleCursor).FieldBuffers[FieldDef.FieldNo-1].Buffer;
   //if OCILobLocatorIsInit(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, LobLocator, @is_init) = OCI_ERROR then
   //  HandleError;
-  if OciLobGetLength(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, LobLocator, @len) = OCI_ERROR then
+  // For character LOBs, it is the number of characters, for binary LOBs and BFILEs it is the number of bytes
+  if OciLobGetLength(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, LobLocator, @LobLength) = OCI_ERROR then
+    HandleError;
+  if OCILobCharSetForm(FOciEnvironment, FOciError, LobLocator, @LobCharSetForm) = OCI_ERROR then
     HandleError;
-  // Len - For character LOBs, it is the number of characters, for binary LOBs and BFILEs it is the number of bytes
-  ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, len);
-  ABlobBuf^.BlobBuffer^.Size := len;
-  if OciLobRead(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, LobLocator, @len, 1, ABlobBuf^.BlobBuffer^.Buffer, len, nil, nil, 0, SQLCS_IMPLICIT) = OCI_ERROR then
+  ReAllocMem(ABlobBuf^.BlobBuffer^.Buffer, LobLength);
+  ABlobBuf^.BlobBuffer^.Size := LobLength;
+  if (LobLength > 0) and (OciLobRead(TOracleTrans(ATransaction.Handle).FOciSvcCtx, FOciError, LobLocator, @LobLength, 1, ABlobBuf^.BlobBuffer^.Buffer, LobLength, nil, nil, 0, LobCharSetForm) = OCI_ERROR) then
     HandleError;
 end;
 
@@ -1059,6 +1098,12 @@ begin
   if not assigned(Transaction) then
     DatabaseError(SErrConnTransactionnSet);
 
+  // Get table name into canonical format
+  if (length(TableName)>2) and (TableName[1]=ObjectQuote) and (TableName[length(TableName)]=ObjectQuote) then
+    TableName := AnsiDequotedStr(TableName, ObjectQuote)
+  else
+    TableName := UpperCase(TableName); //ANSI SQL: the name of an identifier (such as table names) are implicitly converted to uppercase, unless double quotes are used when referring to the identifier.
+
   qry := tsqlquery.Create(nil);
   qry.transaction := Transaction;
   qry.database := Self;
@@ -1066,7 +1111,6 @@ begin
     begin
     ReadOnly := True;
     sql.clear;
-
     sql.add('SELECT '+
               'i.INDEX_NAME,  '+
               'c.COLUMN_NAME, '+
@@ -1076,7 +1120,7 @@ begin
               'i.OWNER=c.INDEX_OWNER AND '+
               'i.INDEX_NAME=c.INDEX_NAME AND '+
               'p.INDEX_NAME(+)=i.INDEX_NAME AND '+
-              'Upper(c.TABLE_NAME) = ''' +  UpperCase(TableName) +''' '+
+              'c.TABLE_NAME = ''' + TableName + ''' '+
             'ORDER by i.INDEX_NAME,c.COLUMN_POSITION');
     open;
     end;
@@ -1084,8 +1128,8 @@ begin
     begin
     Name := trim(qry.fields[0].asstring);
     Fields := trim(qry.Fields[1].asstring);
-    If UpperCase(qry.fields[2].asString)='P' then options := options + [ixPrimary];
-    If UpperCase(qry.fields[2].asString)='U' then options := options + [ixUnique];
+    If UpperCase(qry.fields[2].asstring)='P' then options := options + [ixPrimary];
+    If UpperCase(qry.fields[2].asstring)='U' then options := options + [ixUnique];
     qry.next;
     while (name = qry.fields[0].asstring) and (not qry.eof) do
       begin
@@ -1099,14 +1143,15 @@ end;
 
 function TOracleConnection.GetSchemaInfoSQL(SchemaType: TSchemaType;
   SchemaObjectName, SchemaPattern: string): string;
-var s : string;
-
+var
+  s : string;
 begin
   case SchemaType of
     stTables     : s := 'SELECT '+
                           '''' + DatabaseName + ''' as catalog_name, '+
                           'sys_context( ''userenv'', ''current_schema'' ) as schema_name, '+
-                          'TABLE_NAME '+
+                          'TABLE_NAME,'+
+                          'TABLE_TYPE '+
                         'FROM USER_CATALOG ' +
                         'WHERE '+
                           'TABLE_TYPE<>''SEQUENCE'' '+
@@ -1115,20 +1160,22 @@ begin
     stSysTables  : s := 'SELECT '+
                           '''' + DatabaseName + ''' as catalog_name, '+
                           'OWNER as schema_name, '+
-                          'TABLE_NAME '+
+                          'TABLE_NAME,'+
+                          'TABLE_TYPE '+
                         'FROM ALL_CATALOG ' +
                         'WHERE '+
                           'TABLE_TYPE<>''SEQUENCE'' '+
                         'ORDER BY TABLE_NAME';
     stColumns    : s := 'SELECT '+
+                          'OWNER as schema_name, '+
                           'COLUMN_NAME, '+
                           'DATA_TYPE as column_datatype, '+
                           'CHARACTER_SET_NAME, '+
                           'NULLABLE as column_nullable, '+
                           'DATA_LENGTH as column_length, '+
                           'DATA_PRECISION as column_precision, '+
-                          'DATA_SCALE as column_scale '+
-                          {DATA_DEFAULT is type LONG; no support for that in oracleconnection so removed this from query}
+                          'DATA_SCALE as column_scale, '+
+                          'DATA_DEFAULT as column_default '+
                         'FROM ALL_TAB_COLUMNS '+
                         'WHERE Upper(TABLE_NAME) = '''+UpperCase(SchemaObjectName)+''' '+
                         'ORDER BY COLUMN_NAME';

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

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Pascal Classes Library (FCL).
-    Copyright (c) 2006 by the Free Pascal development team
+    Copyright (c) 2006-2014 by the Free Pascal development team
 
     SQLite3 connection for SQLDB
 
@@ -97,7 +97,7 @@ type
     function GetInsertID: int64;
     // See http://www.sqlite.org/c3ref/create_collation.html for detailed information
     // If eTextRep=0 a default UTF-8 compare function is used (UTF8CompareCallback)
-    // Warning: UTF8CompareCallback needs a wide string manager on linux such as cwstring
+    // Warning: UTF8CompareCallback needs a wide string manager on Linux such as cwstring
     // Warning: CollationName has to be a UTF-8 string
     procedure CreateCollation(const CollationName: string; eTextRep: integer; Arg: Pointer=nil; Compare: xCompare=nil);
     procedure LoadExtension(LibraryFile: string);
@@ -524,18 +524,26 @@ begin
   Delete(S,1,P);
 end;
 
+// Parses string-formatted date into TDateTime value
+// Expected format: '2013-12-31 ' (without ')
 Function ParseSQLiteDate(S : ShortString) : TDateTime;
 
 Var
   Year, Month, Day : Integer;
+
 begin
- Result:=0;
- If TryStrToInt(NextWord(S,'-'),Year) then
-   if TryStrToInt(NextWord(S,'-'),Month) then
-     if TryStrToInt(NextWord(S,' '),Day) then
+  Result:=0;
+  If TryStrToInt(NextWord(S,'-'),Year) then
+    if TryStrToInt(NextWord(S,'-'),Month) then
+      if TryStrToInt(NextWord(S,' '),Day) then
         Result:=EncodeDate(Year,Month,Day);
 end;
 
+// Parses string-formatted time into TDateTime value
+// Expected formats
+// 23:59
+// 23:59:59
+// 23:59:59.999
 Function ParseSQLiteTime(S : ShortString; Interval: boolean) : TDateTime;
 
 Var
@@ -545,16 +553,28 @@ begin
   Result:=0;
   If TryStrToInt(NextWord(S,':'),Hour) then
     if TryStrToInt(NextWord(S,':'),Min) then
+    begin
       if TryStrToInt(NextWord(S,'.'),Sec) then
-        begin
-        MSec:=StrToIntDef(S,0);
-        if Interval then
-          Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
-        else
-          Result:=EncodeTime(Hour,Min,Sec,MSec);
-        end;
+      begin // 23:59:59 or 23:59:59.999
+      MSec:=StrToIntDef(S,0);
+      if Interval then
+        Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
+      else
+        Result:=EncodeTime(Hour,Min,Sec,MSec);
+      end;
+    end
+    else //23:59
+    begin
+      Sec:=0;
+      MSec:=0;
+      if Interval then
+        Result:=EncodeTimeInterval(Hour,Min,Sec,MSec)
+      else
+        Result:=EncodeTime(Hour,Min,Sec,MSec);
+    end;
 end;
 
+// Parses string-formatted date/time into TDateTime value
 Function ParseSQLiteDateTime(S : String) : TDateTime;
 
 var
@@ -564,7 +584,9 @@ var
 begin
   DS:='';
   TS:='';
-  P:=Pos(' ',S);
+  P:=Pos('T',S); //allow e.g. YYYY-MM-DDTHH:MM
+  if P=0 then
+    P:=Pos(' ',S); //allow e.g. YYYY-MM-DD HH:MM
   If (P<>0) then
     begin
     DS:=Copy(S,1,P-1);
@@ -612,17 +634,17 @@ begin
     ftDateTime,
     ftDate,
     ftTime:  if st1 = sttext then 
-               begin
+               begin { Stored as string }
                setlength(str1,sqlite3_column_bytes(st,fnum));
                move(sqlite3_column_text(st,fnum)^,str1[1],length(str1));
                case FieldDef.datatype of
                  ftDateTime: PDateTime(Buffer)^:=ParseSqliteDateTime(str1);
                  ftDate    : PDateTime(Buffer)^:=ParseSqliteDate(str1);
-                 ftTime    : PDateTime(Buffer)^:=ParseSQLiteTime(str1,true);
+                 ftTime    : PDateTime(Buffer)^:=ParseSqliteTime(str1,true);
                end; {case}
                end
              else
-               begin
+               begin { Assume stored as double }
                PDateTime(buffer)^ := sqlite3_column_double(st,fnum);
                if PDateTime(buffer)^ > 1721059.5 {Julian 01/01/0000} then
                   PDateTime(buffer)^ := PDateTime(buffer)^ + JulianEpoch; //backward compatibility hack

packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -321,7 +321,7 @@ begin
       FieldtypeDefinitions[ftMemo]     := 'CLOB';
       FieldtypeDefinitions[ftWideString] := 'NVARCHAR2(10)';
       FieldtypeDefinitions[ftFixedWideChar] := 'NCHAR(10)';
-      //FieldtypeDefinitions[ftWideMemo] := 'NCLOB';
+      FieldtypeDefinitions[ftWideMemo] := 'NCLOB';
       end;
     ssPostgreSQL:
       begin

packages/fcl-fpcunit/src/latextestreport.pp

@@ -23,11 +23,14 @@ uses
 
 type
    
+  { TLatexResultsWriter }
+
   TLatexResultsWriter = class(TCustomResultsWriter)
   private
     FDoc: TStringList;
     FSuiteHeaderIdx: TFPList;
     FTempFailure: TTestFailure;
+    function TimeFormat(ATiming: TDateTime): String;
   protected
     class function EscapeText(const S: string): String; virtual;
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override;
@@ -53,6 +56,21 @@ function GetSuiteAsLatex(aSuite: TTestSuite): string;
 
 implementation
 
+uses dateutils;
+
+function TLatexResultsWriter.TimeFormat(ATiming: TDateTime): String;
+Var
+  M : Int64;
+
+begin
+  Result:='ss.zzz';
+  M:=MinutesBetween(ATiming,0);
+  if M>60 then
+    Result:='hh:mm:'+Result
+  else if M>1 then
+   Result:='mm:'+Result;
+end;
+
 class function TLatexResultsWriter.EscapeText(const S: string): String;
 var
   i: integer;
@@ -161,7 +179,7 @@ begin
   inherited;
   S:=StringOfChar(' ',ALevel*2)+ '  '+ '\item[-] ';
   if Not SkipTiming then
-    S:=S+FormatDateTime('ss.zzz', ATiming);
+    S:=S+FormatDateTime(TimeFormat(ATiming), ATiming);
   S:=S+ '  ' + EscapeText(ATest.TestName);
   FDoc.Add(S);
   if Assigned(FTempFailure) then

packages/fcl-fpcunit/src/plaintestreport.pp

@@ -23,11 +23,14 @@ uses
 
 type
 
+  { TPlainResultsWriter }
+
   TPlainResultsWriter = class(TCustomResultsWriter)
   private
     FDoc: TStringList;
     FSuiteHeaderIdx: TFPList;
     FTempFailure: TTestFailure;
+    function TimeFormat(ATiming: TDateTime): String;
   protected
     procedure WriteTestHeader(ATest: TTest; ALevel: integer; ACount: integer); override;
     procedure WriteTestFooter(ATest: TTest; ALevel: integer; ATiming: TDateTime); override;
@@ -50,6 +53,7 @@ function TestResultAsPlain(aTestResult: TTestResult): string;
 
 implementation
 
+uses dateutils;
 
 {TPlainResultsWriter}
 
@@ -110,7 +114,7 @@ begin
   inherited;
   S:='  ' + StringOfChar(' ',ALevel*2);
   if Not SkipTiming then
-    S:=S + FormatDateTime('ss.zzz', ATiming) + '  ';
+    S:=S + FormatDateTime(TimeFormat(ATiming), ATiming) + '  ';
   S:=S + ATest.TestName;
   FDoc.Add(S);
   if Assigned(FTempFailure) then
@@ -139,6 +143,20 @@ begin
   FTempFailure := nil;
 end;
 
+Function TPlainResultsWriter.TimeFormat(ATiming : TDateTime) : String;
+
+Var
+  M : Int64;
+
+begin
+  Result:='ss.zzz';
+  M:=MinutesBetween(ATiming,0);
+  if M>60 then
+    Result:='hh:mm:'+Result
+  else if M>1 then
+   Result:='mm:'+Result;
+end;
+
 procedure TPlainResultsWriter.WriteSuiteFooter(ATestSuite: TTestSuite; ALevel: integer; 
   ATiming: TDateTime; ANumRuns: integer; ANumErrors: integer; ANumFailures: integer;
   ANumIgnores: integer);
@@ -149,7 +167,7 @@ begin
   inherited;
   idx := Integer(FSuiteHeaderIdx[FSuiteHeaderIdx.Count -1]);
   if Not SkipTiming then
-    S:= ' Time:'+ FormatDateTime('ss.zzz', ATiming);
+    S:= ' Time:'+ FormatDateTime(TimeFormat(ATiming), ATiming);
   S:=S+ ' N:'+ IntToStr(ANumRuns)+ ' E:'+ IntToStr(ANumErrors)+ ' F:'+ IntToStr(ANumFailures)+
     ' I:'+ IntToStr(ANumIgnores) ;
   FDoc[idx] := FDoc[idx]+S;

packages/fcl-fpcunit/src/xmltestreport.pp

@@ -21,7 +21,7 @@
     is valid XML, with reserved characters correctly escaped.
     This allows the XML document to be further processed with XSLT etc without
     any issues.
-		
+
   Notes:
     Specify 'null' as the filename if you don't want to output to file (e.g.
     used by the GUI test runner which instead reads the Document property).
@@ -194,7 +194,7 @@ begin
   inherited;
   FResults := FDoc.CreateElement('TestResults');
   FResults.AppendChild(FDoc.CreateComment(' Generated using FPCUnit on '
-    + FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) ));
+    + FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) ));
   FDoc.AppendChild(FResults);
   FListing := FDoc.CreateElement('TestListing');
   FResults.AppendChild(FListing);
@@ -283,7 +283,7 @@ begin
 
   { Summary of ISO 8601  http://www.cl.cam.ac.uk/~mgk25/iso-time.html }
   n := FDoc.CreateElement('DateTimeRan');
-  n.AppendChild(FDoc.CreateTextNode(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now)));
+  n.AppendChild(FDoc.CreateTextNode(FormatDateTime('yyyy-mm-dd hh:nn:ss', Now)));
   lResults.AppendChild(n);
 
   // This is so that the GUI Test Runner doesn't output text as well.

packages/fcl-image/src/fpreadtiff.pas

@@ -2256,6 +2256,8 @@ var
     p[s1.Count]:=s2.Data^;
     // increase TableCount
     inc(TableCount);
+    if ((SrcPos+3=Count) and (CurBitLength+SrcPosBit>16)) or
+       ((SrcPos+2=Count) and (CurBitLength+SrcPosBit<=16)) then exit;
     case TableCount+259 of
     512,1024,2048: inc(CurBitLength);
     end;

packages/fcl-image/src/freetype.pp

@@ -416,8 +416,8 @@ begin
   result := FList.count-1;
   while (result >= 0) and
         ( ({$ifdef CaseSense}CompareText{$else}CompareStr{$endif}
-              (TMgrFont(FList[anIndex]).Filename, afilename) <> 0) or
-          (anIndex <> TMgrFont(FList[anIndex]).font^.face_index)
+              (TMgrFont(FList[Result]).Filename, afilename) <> 0) or
+          (anIndex <> TMgrFont(FList[Result]).font^.face_index)
         ) do
     dec (result);
 end;

packages/fcl-process/src/os2/simpleipc.inc

@@ -171,6 +171,7 @@ begin
   Owner.FMsgType := Hdr.MsgType;
   if Hdr.MsgLen > 0 then
     begin
+      Owner.FMsgData.Size:=0;
       Owner.FMsgData.Seek (0, soFromBeginning);
       Owner.FMsgData.CopyFrom (FStream, Hdr.MsgLen);
     end

packages/fcl-process/src/simpleipc.pp

@@ -351,7 +351,6 @@ begin
   CheckActive;
   FBusy:=True;
   Try
-    FMsgData.Size:=0;
     FIPCComm.ReadMessage;
     If Assigned(FOnMessage) then
       FOnMessage(Self);

packages/fcl-process/src/unix/simpleipc.inc

@@ -261,6 +261,7 @@ begin
   M:=MsgData;
   if count > 0 then
     begin
+    M.Size:=0;
     M.Seek(0,soFrombeginning);
     M.CopyFrom(FStream,Count);
     end

packages/fcl-process/src/win/process.inc

@@ -116,7 +116,7 @@ begin
   TA.nLength := SizeOf(TA);
 end;
 
-Procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFO);
+Procedure InitStartupInfo(P : TProcess; Var SI : STARTUPINFOA);
 
 Const
   SWC : Array [TShowWindowOptions] of Cardinal =
@@ -179,7 +179,7 @@ begin
 end;
 
 
-Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfo; CE : Boolean; APipeBufferSize : Cardinal);
+Procedure CreatePipes(Var HI,HO,HE : Thandle; Var SI : TStartupInfoA; CE : Boolean; APipeBufferSize : Cardinal);
 
 begin
   CreatePipeHandles(SI.hStdInput,HI, APipeBufferSize);
@@ -224,7 +224,7 @@ Var
   FProcessAttributes : TSecurityAttributes;
   FThreadAttributes : TSecurityAttributes;
   FProcessInformation : TProcessInformation;
-  FStartupInfo : STARTUPINFO;
+  FStartupInfo : STARTUPINFOA;
   HI,HO,HE : THandle;
   Cmd : String;
   

packages/fcl-process/src/win/simpleipc.inc

@@ -169,6 +169,7 @@ Var
 begin
   CDS:=PCopyDataStruct(Msg.Lparam);
   Owner.FMsgType:=CDS^.dwData;
+  Owner.FMsgData.Size:=0;
   Owner.FMsgData.Seek(0,soFrombeginning);
   Owner.FMsgData.WriteBuffer(CDS^.lpData^,CDS^.cbData);
 end;
@@ -257,7 +258,7 @@ begin
     CDS.dwData:=MsgType;
     CDS.lpData:=Data.Memory;
     CDS.cbData:=Data.Size;
-    Windows.SendMessage(FHWnd,WM_COPYDATA,0,Integer(@CDS));
+    Windows.SendMessage(FHWnd,WM_COPYDATA,0,PtrInt(@CDS));
   Finally
     FreeAndNil(FMemStr);
   end;

packages/fcl-process/src/wince/simpleipc.inc

@@ -168,6 +168,7 @@ Var
 
 begin
   CDS:=PCopyDataStruct(Msg.Lparam);
+  Owner.FMsgData.Size:=0;
   Owner.FMsgData.Seek(0,soFrombeginning);
   Owner.FMsgData.WriteBuffer(CDS^.lpData^,CDS^.cbData);
 end;

packages/fcl-web/fpmake.pp

@@ -199,6 +199,11 @@ begin
     T:=P.Targets.AddUnit('fpjsonrpc.pp');
     T.ResourceStrings:=true;
     T:=P.Targets.AddUnit('webjsonrpc.pp');
+    With T.Dependencies do
+      begin
+      AddUnit('fpjsonrpc');
+      end;
+    T:=P.Targets.AddUnit('fpdispextdirect.pp');
     With T.Dependencies do
       begin
       AddUnit('fpjsonrpc');
@@ -207,8 +212,9 @@ begin
     T.ResourceStrings:=true;
     With T.Dependencies do
       begin
-      AddUnit('fpjsonrpc');
+      AddUnit('fpdispextdirect');
       AddUnit('webjsonrpc');
+      AddUnit('httpdefs');
       end;
 {$ifndef ALLPACKAGES}
     Run;

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

@@ -21,7 +21,7 @@ unit cgiapp;
 Interface
 
 uses
-  CustApp,Classes,SysUtils;
+  CustApp,Classes, SysUtils, httpdefs;
 
 Const
   CGIVarCount = 23 deprecated;
@@ -128,6 +128,8 @@ Type
     Property Response : TStream Read FResponse; deprecated;
   end;
 
+  ECGI = Class(Exception);
+
 ResourceString
   SWebMaster = 'webmaster' deprecated;
   SCGIError  = 'CGI Error' deprecated;
@@ -428,13 +430,13 @@ var
 begin
   R:=RequestMethod;
   if (R='') then
-    Raise Exception.Create(SErrNoRequestMethod);
+    Raise ECGI.Create(SErrNoRequestMethod);
   if CompareText(R,'POST')=0 then
     InitPostVars
   else if CompareText(R,'GET')=0 then
     InitGetVars
   else
-    Raise Exception.CreateFmt(SErrInvalidRequestMethod,[R]);
+    Raise ECGI.CreateFmt(SErrInvalidRequestMethod,[R]);
 end;
 
 Procedure TCgiApplication.ProcessURLEncoded(M : TMemoryStream);
@@ -622,7 +624,7 @@ begin
       FI:=TFormItem(L[i]);
       FI.Process;
       If (FI.Name='') then
-        Raise Exception.CreateFmt('Invalid multipart encoding: %s',[FI.Data]);
+        Raise ECGI.CreateFmt('Invalid multipart encoding: %s',[FI.Data]);
       Key:=FI.Name;
       If Not FI.IsFile Then
         begin
@@ -691,7 +693,7 @@ begin
     else if CompareText(ContentType,'APPLICATION/X-WWW-FORM-URLENCODED')=0 then
       ProcessUrlEncoded(M)
     else
-      Raise Exception.CreateFmt(SErrUnsupportedContentType,[ContentType]);
+      Raise ECGI.CreateFmt(SErrUnsupportedContentType,[ContentType]);
   finally
     M.Free;
   end;

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

@@ -118,6 +118,8 @@ Type
     Property RequestVariableCount : Integer Read GetRequestVariableCount;
   end;
 
+  ECGI = Class(EFPWebError);
+
 Var
   CGIRequestClass : TCGIRequestClass = TCGIRequest;
   CGIResponseClass : TCGIResponseClass = TCGIResponse;

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

@@ -293,7 +293,7 @@ begin
       FUR(Self,AFCGIRecord)
     else
       if poFailonUnknownRecord in FPO then
-        Raise EFPWebError.CreateFmt('Unknown FASTCGI record type: %s',[AFCGIRecord^.reqtype]);
+        TFCgiHandler.DoError('Unknown FASTCGI record type: %s',[AFCGIRecord^.reqtype]);
   end;
 end;
 
@@ -429,7 +429,7 @@ var ErrorCode,
     
 begin
   if Not (Request is TFCGIRequest) then
-    Raise Exception.Create(SErrNorequest);
+    TFCgiHandler.DoError(SErrNorequest);
   R:=TFCGIRequest(Request);
   BytesToWrite := BEtoN(ARecord^.contentLength) + ARecord^.paddingLength+sizeof(FCGI_Header);
   P:=PByte(Arecord);
@@ -439,7 +439,7 @@ begin
       begin
       // TODO : Better checking on ErrorCode
       R.FKeepConnectionAfterRequest:=False;
-      Raise HTTPError.CreateFmt(SErrWritingSocket,[ErrorCode]);
+      TFCgiHandler.DoError(SErrWritingSocket,[ErrorCode]);
       end;
     Inc(P,BytesWritten);
     Dec(BytesToWrite,BytesWritten);
@@ -697,7 +697,7 @@ function TFCgiHandler.Read_FCGIRecord : PFCGI_Header;
         Inc(Result,Count);
         end
       else if (Count<0) then
-        Raise HTTPError.CreateFmt(SErrReadingSocket,[Count]);
+        DoError(SErrReadingSocket,[Count]);
     until (ByteAmount=0) or (Count=0);
   end;
 
@@ -719,7 +719,7 @@ begin
     // TODO : if connection closed gracefully, the request should no longer be handled.
     // Need to discard request/response
   else If (BytesRead<>Sizeof(Header)) then
-    Raise HTTPError.CreateFmt(SErrReadingHeader,[BytesRead]);
+    DoError(SErrReadingHeader,[BytesRead]);
   ContentLength:=BetoN(Header.contentLength);
   PaddingLength:=Header.paddingLength;
   Getmem(ResRecord,BytesRead+ContentLength+PaddingLength);
@@ -758,7 +758,7 @@ begin
   AddressLength:=Sizeof(IAddress);
   Socket := fpsocket(AF_INET,SOCK_STREAM,0);
   if Socket=-1 then
-    raise EFPWebError.CreateFmt(SNoSocket,[socketerror]);
+    DoError(SNoSocket,[socketerror]);
   IAddress.sin_family:=AF_INET;
   IAddress.sin_port:=htons(Port);
   if FAddress<>'' then
@@ -775,7 +775,7 @@ begin
     CloseSocket(socket);
     Socket:=0;
     Terminate;
-    raise Exception.CreateFmt(SBindFailed,[port,socketerror]);
+    DoError(SBindFailed,[port,socketerror]);
     end;
   if (FLingerTimeout>0) then
     begin
@@ -798,7 +798,7 @@ begin
     CloseSocket(socket);
     Socket:=0;
     Terminate;
-    raise Exception.CreateFmt(SListenFailed,[port,socketerror]);
+    DoError(SListenFailed,[port,socketerror]);
     end;
 end;
 
@@ -994,7 +994,7 @@ begin
       if not terminated then
         begin
         Terminate;
-        raise Exception.CreateFmt(SNoInputHandle,[socketerror]);
+        DoError(SNoInputHandle,[socketerror]);
         end
       end;
     repeat

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

@@ -106,6 +106,8 @@ Type
     FOnLog : TLogEvent;
     FPreferModuleName : Boolean;
   protected
+    Class Procedure DoError(Msg : String; AStatusCode : Integer = 0; AStatusText : String = '');
+    Class Procedure DoError(Fmt : String; Const Args : Array of const;AStatusCode : Integer = 0; AStatusText : String = '');
     procedure Terminate; virtual;
     Function GetModuleName(Arequest : TRequest) : string;
     function WaitForRequest(out ARequest : TRequest; out AResponse : TResponse) : boolean; virtual; abstract;
@@ -205,7 +207,7 @@ Type
     Property PreferModuleName : Boolean Read GetPreferModuleName Write SetPreferModuleName;
   end;
 
-  EFPWebError = Class(Exception);
+  EFPWebError = Class(EFPHTTPError);
 
 procedure ExceptionToHTML(S: TStrings; const E: Exception; const Title, Email, Administrator: string);
 
@@ -254,7 +256,7 @@ begin
     end;
 end;
 
-procedure TWebHandler.Run;
+Procedure TWebHandler.Run;
 var ARequest : TRequest;
     AResponse : TResponse;
 begin
@@ -267,16 +269,29 @@ begin
     end;
 end;
 
-procedure TWebHandler.Log(EventType: TEventType; const Msg: String);
+Procedure TWebHandler.Log(EventType: TEventType; Const Msg: String);
 begin
   If Assigned(FOnLog) then
     FOnLog(EventType,Msg);
 end;
 
 procedure TWebHandler.ShowRequestException(R: TResponse; E: Exception);
+
+  Function GetStatusCode : integer;
+
+  begin
+    if (E is EHTTP) then
+      Result:=EHTTP(E).StatusCode
+    else
+      Result:=E.HelpContext;
+    if (Result=0) then
+      Result:=500;
+  end;
+
 Var
- S : TStrings;
- handled: boolean;
+  S : TStrings;
+  handled: boolean;
+  CT : String;
 
 begin
   if R.ContentSent then exit;
@@ -294,8 +309,14 @@ begin
     end;
   If (not R.HeadersSent) then
     begin
-    R.Code:=500;
-    R.CodeText:='Application error '+E.ClassName;
+    R.Code:=GetStatusCode;
+    if (E is EHTTP) Then
+      CT:=EHTTP(E).StatusText
+    else
+      CT:='';
+    if (CT='') then
+      CT:='Application error '+E.ClassName;;
+    R.CodeText:=CT;
     R.ContentType:='text/html';
     end;
   If (R.ContentType='text/html') then
@@ -311,27 +332,27 @@ begin
     end;
 end;
 
-procedure TWebHandler.InitRequest(ARequest: TRequest);
+Procedure TWebHandler.InitRequest(ARequest: TRequest);
 begin
   ARequest.OnUnknownEncoding:=Self.OnUnknownRequestEncoding;
 end;
 
-procedure TWebHandler.InitResponse(AResponse: TResponse);
+Procedure TWebHandler.InitResponse(AResponse: TResponse);
 begin
   // Do nothing
 end;
 
-function TWebHandler.GetEmail: String;
+Function TWebHandler.GetEmail: String;
 begin
   Result := FEmail;
 end;
 
-function TWebHandler.GetAdministrator: String;
+Function TWebHandler.GetAdministrator: String;
 begin
   Result := FAdministrator;
 end;
 
-procedure TWebHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
+Procedure TWebHandler.HandleRequest(ARequest: TRequest; AResponse: TResponse);
 Var
   MC : TCustomHTTPModuleClass;
   M  : TCustomHTTPModule;
@@ -350,7 +371,7 @@ begin
       MN:=GetModuleName(ARequest);
       MI:=ModuleFactory.FindModule(MN);
       if (MI=Nil) then
-        Raise EFPWebError.CreateFmt(SErrNoModuleForRequest,[MN]);
+        DoError(SErrNoModuleForRequest,[MN],400,'Not found');
       MC:=MI.ModuleClass;
       end;
     M:=FindModule(MC); // Check if a module exists already
@@ -386,6 +407,24 @@ begin
     Result:=ARequest.ScriptName;
 end;
 
+Class Procedure TWebHandler.DoError(Msg : String;AStatusCode : Integer = 0; AStatusText : String = '');
+
+Var
+  E : EFPWebError;
+
+begin
+  E:=EFPWebError.Create(Msg);
+  E.StatusCode:=AStatusCode;
+  E.StatusText:=AStatusText;
+  Raise E;
+end;
+
+Class Procedure TWebHandler.DoError(Fmt: String; Const Args: Array of const;
+  AStatusCode: Integer = 0; AStatusText: String = '');
+begin
+  DoError(Format(Fmt,Args),AStatusCode,AStatusText);
+end;
+
 procedure TWebHandler.Terminate;
 begin
   FTerminated := true;
@@ -393,7 +432,7 @@ begin
     FOnTerminate(Self);
 end;
 
-function TWebHandler.GetModuleName(Arequest: TRequest): string;
+Function TWebHandler.GetModuleName(Arequest: TRequest): string;
 
    Function GetDefaultModuleName : String;
 
@@ -426,7 +465,7 @@ begin
   If (Result='') then
     begin
     if Not AllowDefaultModule then
-      Raise EFPWebError.Create(SErrNoModuleNameForRequest);
+      DoError(SErrNoModuleNameForRequest,400,'Not found');
     Result:=GetDefaultModuleName
     end;
 end;
@@ -450,8 +489,8 @@ begin
     Result:=Nil;
 end;
 
-procedure TWebHandler.SetBaseURL(AModule: TCustomHTTPModule;
-  Const AModuleName : String; ARequest: TRequest);
+Procedure TWebHandler.SetBaseURL(AModule: TCustomHTTPModule;
+  Const AModuleName: String; ARequest: TRequest);
 
 Var
   S,P : String;
@@ -469,7 +508,7 @@ begin
   AModule.BaseURL:=S+P;
 end;
 
-procedure TWebHandler.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
+Procedure TWebHandler.DoHandleRequest(ARequest: TRequest; AResponse: TResponse);
 begin
   Try
     HandleRequest(ARequest,AResponse);

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

@@ -157,7 +157,7 @@ Type
   end;
   
 
-  EFPApacheError = Class(Exception);
+  EFPApacheError = Class(EHTTP);
   
 Var
   Application : TCustomApacheApplication = Nil;

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

@@ -157,7 +157,7 @@ Type
   end;
   
 
-  EFPApacheError = Class(Exception);
+  EFPApacheError = Class(EHTTP);
   
 Var
   Application : TCustomApacheApplication = Nil;

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

@@ -516,7 +516,7 @@ type
     Property OnCreateWriter;
   end;
   
-  EHTMLError = Class(Exception);
+  EHTMLError = Class(EHTTP);
 
 const SimpleOkButton: array[0..0] of TWebButton = ((buttontype: btok;caption: 'Ok';onclick: ''));
 
@@ -603,12 +603,12 @@ end;
 
 procedure TJavaScriptStack.RedrawContentProducer(AContentProducer: THTMLContentProducer);
 begin
-  raise exception.Create('RedrawContentProducer not supported by current WebController');
+  raise EHTMLError.Create('RedrawContentProducer not supported by current WebController');
 end;
 
 procedure TJavaScriptStack.CallServerEvent(AHTMLContentProducer: THTMLContentProducer; AEvent: Integer; APostVariable: string = '');
 begin
-  raise exception.Create('SendServerEvent not supported by current WebController');
+  raise EHTMLError.Create('SendServerEvent not supported by current WebController');
 end;
 
 procedure TJavaScriptStack.Clear;
@@ -786,7 +786,7 @@ begin
     else
       begin
       for i := 0 to high(Events) do if assigned(events[i].csCallback) or assigned(events[i].ServerEvent) then
-        raise exception.Create('There is no webcontroller available, which is necessary to use events.');
+        raise EHTMLError.Create('There is no webcontroller available, which is necessary to use events.');
       end;
     end;
 end;
@@ -832,7 +832,7 @@ begin
       end;
     end;
   if ExceptIfNotAvailable then
-    raise Exception.Create('No webcontroller available');
+    raise EHTMLError.Create('No webcontroller available');
 end;
 
 procedure THTMLContentProducer.BeforeGenerateContent;
@@ -1478,7 +1478,7 @@ var
 begin
   i := length(FIterationIDs);
   if i=0 then
-    raise Exception.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
+    raise EHTMLError.Create('DecrementIterationLevel can not be called more times then IncrementIterationLevel');
   SetLength(FIterationIDs,i-1);
 end;
 

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

@@ -110,7 +110,12 @@ Type
     FAfterInitModule : TInitModuleEvent;
     FBaseURL: String;
     FWebModuleKind: TWebModuleKind;
+  Protected
+    Class Function DefaultModuleName : String; virtual;
+    Class Function DefaultSkipStreaming : Boolean; virtual;
   public
+    Class Procedure RegisterModule(Const AModuleName : String = ''); overload;
+    Class Procedure RegisterModule(Const AModuleName : String; ASkipStreaming : Boolean); overload;
     Procedure HandleRequest(ARequest : TRequest; AResponse : TResponse); virtual; abstract;
     Procedure DoAfterInitModule(ARequest : TRequest); virtual;
     property Kind: TWebModuleKind read FWebModuleKind write FWebModuleKind default wkPooled;
@@ -207,7 +212,9 @@ Type
     Property Modules [Index : Integer]: TModuleItem Read GetModule Write SetModule;default;
   end;
 
-  EFPHTTPError = Class(Exception);
+  { EFPHTTPError }
+
+  EFPHTTPError = Class(EHTTP);
 
 Procedure RegisterHTTPModule(ModuleClass : TCustomHTTPModuleClass; SkipStreaming : Boolean = False);
 Procedure RegisterHTTPModule(Const ModuleName : String; ModuleClass : TCustomHTTPModuleClass; SkipStreaming : Boolean = False);
@@ -227,6 +234,7 @@ Resourcestring
   SErrRequestNotHandled = 'Web request was not handled by actions.';
   SErrNoSessionFactoryClass = 'No session manager class available. Include iniwebsession unit and recompile.';
   SErrNoSessionOutsideRequest = 'Default session not available outside handlerequest';
+
 Implementation
 
 {$ifdef cgidebug}
@@ -248,9 +256,37 @@ begin
   Result:=GSM;
 end;
 
+
 { TCustomHTTPModule }
 
-procedure TCustomHTTPModule.DoAfterInitModule(ARequest: TRequest);
+Class Function TCustomHTTPModule.DefaultModuleName: String;
+begin
+  Result:=ClassName;
+end;
+
+Class Function TCustomHTTPModule.DefaultSkipStreaming: Boolean;
+begin
+  Result:=False;
+end;
+
+Class Procedure TCustomHTTPModule.RegisterModule(Const AModuleName: String);
+begin
+  RegisterModule(AModuleName,DefaultSkipStreaming);
+end;
+
+Class Procedure TCustomHTTPModule.RegisterModule(Const AModuleName: String;
+  ASkipStreaming: Boolean);
+
+Var
+  MN : String;
+begin
+  MN:=AModuleName;
+  if MN='' then
+    MN:=DefaultModuleName;
+  RegisterHTTPModule(MN,Self,ASkipStreaming);
+end;
+
+Procedure TCustomHTTPModule.DoAfterInitModule(ARequest: TRequest);
 begin
   If Assigned(FAfterInitModule) then
     FAfterInitModule(Self, ARequest);

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

@@ -268,7 +268,8 @@ Type
     Property OnHeaders;
     Property OnGetSocketHandler;
   end;
-  EHTTPClient = Class(Exception);
+
+  EHTTPClient = Class(EHTTP);
 
 Function EncodeURLElement(S : String) : String;
 Function DecodeURLElement(Const S : String) : String;

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

@@ -195,7 +195,7 @@ Type
     Property OnRequestError;
   end;
 
-  EHTTPServer = Class(Exception);
+  EHTTPServer = Class(EHTTP);
 
   Function GetStatusCode (ACode: Integer) : String;
 
@@ -475,7 +475,7 @@ begin
   Request.PathInfo:=Request.URL;
   S:=GetNextWord(AStartLine);
   If (Pos('HTTP/',S)<>1) then
-    Raise Exception.Create(SErrMissingProtocol);
+    Raise EHTTPServer.CreateHelp(SErrMissingProtocol,400);
   Delete(S,1,5);
   Request.ProtocolVersion:=trim(S);
 end;

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

@@ -155,7 +155,7 @@ Type
     Property AfterInitModule;
   end;
 
-  EFPWebError = Class(HTTPError);
+  EFPWebError = Class(EHTTP);
 
 resourcestring
   SErrInvalidVar        = 'Invalid template variable name : "%s"';

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

@@ -494,8 +494,21 @@ type
 
   TRequestEvent = Procedure (Sender: TObject; ARequest : TRequest) of object;
   TResponseEvent = Procedure (Sender: TObject; AResponse : TResponse) of object;
-  
-  HTTPError = Class(Exception);
+
+  { EHTTP }
+
+  EHTTP = Class(Exception)
+  private
+    FStatusCode: Integer;
+    FStatusText: String;
+    function GetStatusCode: Integer;virtual;
+  Public
+    // These are transformed to the HTTP status code and text. Helpcontext is taken as the default for statuscode.
+    Property StatusCode : Integer Read GetStatusCode Write FStatusCode;
+    Property StatusText : String Read FStatusText Write FStatusText;
+  end;
+
+  HTTPError = EHTTP;
 
 Function HTTPDecode(const AStr: String): String;
 Function HTTPEncode(const AStr: String): String;
@@ -668,6 +681,15 @@ Type
     Procedure Process(Stream : TStream); override;
   end;
 
+{ EHTTP }
+
+function EHTTP.GetStatusCode: Integer;
+begin
+  Result:=FStatusCode;
+  if Result=0 then
+    Result:=HelpContext;
+end;
+
 
 procedure THTTPMimeItem.SetHeader(AIndex: Integer; const AValue: String);
 begin
@@ -1521,7 +1543,7 @@ begin
 {$endif}
   R:=Method;
   if (R='') then
-    Raise Exception.Create(SErrNoRequestMethod);
+    Raise EHTTP.CreateHelp(SErrNoRequestMethod,400);
   // Always process QUERYSTRING.
   InitGetVars;
   // POST and PUT, force post var treatment.

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

@@ -375,7 +375,7 @@ end;
 function TWebPage.GetWebController: TWebController;
 begin
   if not assigned(FWebController) then
-    raise exception.create('No webcontroller available');
+    raise EHTTP.create('No webcontroller available');
   result := FWebController;
 end;
 

packages/fcl-web/src/jsonrpc/fpdispextdirect.pp

@@ -0,0 +1,296 @@
+{
+    This file is part of the Free Component Library
+
+    Ext.Direct support - http independent part
+    Copyright (c) 2007 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+unit fpdispextdirect;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, fpjson, fpjsonrpc ;
+
+Const
+  DefaultExtDirectOptions = DefaultDispatchOptions + [jdoRequireClass];
+
+Type
+  { TCustomExtDirectDispatcher }
+
+  TCustomExtDirectDispatcher = Class(TCustomJSONRPCDispatcher)
+  private
+    FAPIType: String;
+    FNameSpace: String;
+    FURL: String;
+    function GetNameSpace: String;
+    function isNameSpaceStored: boolean;
+  Protected
+    // Use this to initialize the container when the handler was created.
+    Procedure InitContainer(H: TCustomJSONRPCHandler;  AContext: TJSONRPCCallContext; AContainer: TComponent); virtual;
+    // Format the result
+    function FormatResult(const AClassName, AMethodName: TJSONStringType; const Params, ID, Return: TJSONData): TJSONData; override;
+    // Called during API creation. Can be used to restrict list of reported handlers.
+    Function PublishHandler(H: TCustomJSONRPCHandler): Boolean; virtual;
+    // Called during API creation. Can be used to restrict list of reported handlers.
+    Function PublishHandlerDef(HD: TJSONRPCHandlerDef): Boolean; virtual;
+    // 'tid'
+    Class Function TransactionProperty : String; override;
+    // 'method'
+    Class Function MethodProperty : String; override;
+    // 'action'
+    Class Function ClassNameProperty : String; override;
+    // 'data'
+    Class Function ParamsProperty : String; override;
+    // Add session support
+    Function FindHandler(Const AClassName,AMethodName : TJSONStringType;AContext : TJSONRPCCallContext; Out FreeObject : TComponent) : TCustomJSONRPCHandler; override;
+    // Add type field
+    function CreateJSON2Error(Const AMessage : String; Const ACode : Integer; ID : TJSONData = Nil; idname : TJSONStringType = 'id' ) : TJSONObject; override;
+    // Create API method description
+    Function HandlerToAPIMethod (H: TCustomJSONRPCHandler): TJSONObject; virtual;
+    Function HandlerDefToAPIMethod (H: TJSONRPCHandlerDef): TJSONObject; virtual;
+    // Create API
+    Function DoAPI : TJSONData; virtual;
+    // Namespace for API description. Must be set. Default 'FPWeb'
+    Property NameSpace : String Read GetNameSpace Write FNameSpace Stored isNameSpaceStored;
+    // URL property for router. Must be set
+    Property URL : String Read FURL Write FURL;
+    // "type". By default: 'remoting'
+    Property APIType : String Read FAPIType Write FAPIType;
+  Public
+    // Override to set additional opions.
+    Constructor Create(AOwner : TComponent); override;
+    // Return API description object
+    Function API: TJSONData;
+    // Return API Description including namespace, as a string
+    Function APIAsString(Formatted : Boolean = False) : String; virtual;
+  end;
+
+  { TExtDirectDispatcher }
+
+  TExtDirectDispatcher = Class(TCustomExtDirectDispatcher)
+  Published
+    Property NameSpace;
+    Property URL;
+    Property APIType;
+    Property OnStartBatch;
+    Property OnDispatchRequest;
+    Property OnFindHandler;
+    Property OnEndBatch;
+    Property Options;
+  end;
+
+
+implementation
+{ TCustomExtDirectDispatcher }
+Const
+  DefaultNameSpace = 'FPWeb';
+
+function TCustomExtDirectDispatcher.GetNameSpace: String;
+begin
+  Result:=FNameSpace;
+  If (Result='') then
+    Result:=DefaultNameSpace
+end;
+
+function TCustomExtDirectDispatcher.isNameSpaceStored: boolean;
+begin
+  Result:=NameSpace<>DefaultNameSpace;
+end;
+
+function TCustomExtDirectDispatcher.FormatResult(const AClassName,
+  AMethodName: TJSONStringType; const Params, ID, Return: TJSONData): TJSONData;
+
+begin
+  Result:=Inherited FormatResult(AClassName,AMethodName,Params,ID,Return);
+  TJSONObject(Result).Add('type','rpc');
+  TJSONObject(Result).Add('action',AClassName);
+  TJSONObject(Result).Add('method',AMethodName);
+end;
+
+Class Function TCustomExtDirectDispatcher.TransactionProperty: String;
+begin
+  Result:='tid';
+end;
+
+Class Function TCustomExtDirectDispatcher.MethodProperty: String;
+begin
+  Result:='method';
+end;
+
+Class Function TCustomExtDirectDispatcher.ClassNameProperty: String;
+begin
+  Result:='action';
+end;
+
+Class Function TCustomExtDirectDispatcher.ParamsProperty: String;
+begin
+  Result:='data';
+end;
+
+Procedure TCustomExtDirectDispatcher.InitContainer(H : TCustomJSONRPCHandler; AContext : TJSONRPCCallContext; AContainer : TComponent);
+
+begin
+  // Do nothing, must be overridden in descendents
+end;
+
+Function TCustomExtDirectDispatcher.FindHandler(Const AClassName,
+  AMethodName: TJSONStringType; AContext: TJSONRPCCallContext; Out
+  FreeObject: TComponent): TCustomJSONRPCHandler;
+begin
+  {$ifdef extdebug}SendDebugFmt('Searching for %s %s',[AClassName,AMethodName]);{$endif}
+  Result:=inherited FindHandler(AClassName, AMethodName, AContext, FreeObject);
+  InitContainer(Result,AContext,FreeObject);
+  {$ifdef extdebug}SendDebugFmt('Done with searching for %s %s : %d',[AClassName,AMethodName,Ord(Assigned(Result))]);{$endif}
+end;
+
+function TCustomExtDirectDispatcher.CreateJSON2Error(Const AMessage: String;
+  Const ACode: Integer; ID: TJSONData; idname: TJSONStringType): TJSONObject;
+begin
+  Result:=inherited CreateJSON2Error(AMessage,ACode,ID,idname);
+  TJSONObject(Result).Add('type','rpc');
+end;
+
+Function TCustomExtDirectDispatcher.HandlerToAPIMethod(H: TCustomJSONRPCHandler
+  ): TJSONObject;
+begin
+  Result:=TJSONObject.Create(['name',H.Name,'len',H.ParamDefs.Count])
+end;
+
+Function TCustomExtDirectDispatcher.HandlerDefToAPIMethod(H: TJSONRPCHandlerDef
+  ): TJSONObject;
+begin
+  Result:=TJSONObject.Create(['name',H.HandlerMethodName,'len',H.ArgumentCount])
+end;
+
+Function TCustomExtDirectDispatcher.PublishHandler(H : TCustomJSONRPCHandler) : Boolean;
+
+begin
+  Result:=(H<>Nil); // Avoid warning
+end;
+
+Function TCustomExtDirectDispatcher.PublishHandlerDef(HD : TJSONRPCHandlerDef) : Boolean;
+
+begin
+  Result:=(HD<>Nil); // Avoid warning
+end;
+
+Function TCustomExtDirectDispatcher.DoAPI: TJSONData;
+
+Var
+  A,D : TJSONObject;
+  R : TJSONArray;
+  N : TJSONStringType;
+  H : TCustomJSONRPCHandler;
+  I,J : Integer;
+  M : TCustomJSONRPCHandlerManager;
+  HD : TJSONRPCHandlerDef;
+
+begin
+  {$ifdef extdebug}SendDebugFmt('Creating API entries',[]);{$endif}
+  D:=TJSONObject.Create;
+  try
+    D.Add('url',URL);
+    D.Add('type',APIType);
+    A:=TJSONObject.Create;
+    D.Add('actions',A);
+    R:=Nil;
+    N:='';
+    If (jdoSearchOwner in Options) and Assigned(Owner) then
+      begin
+      for I:=Owner.ComponentCount-1 downto 0 do
+        If Owner.Components[i] is TCustomJSONRPCHandler then
+          begin
+          H:=Owner.Components[i] as TCustomJSONRPCHandler;
+          if PublishHandler(H) then
+            begin
+            If (R=Nil) then
+              begin
+              N:=Owner.Name;
+              R:=TJSONArray.Create;
+              A.Add(N,R);
+              end;
+            R.Add(HandlerToAPIMethod(H));
+            end;
+          end;
+      end;
+    If (jdoSearchRegistry in Options) then
+      begin
+      M:=JSONRPCHandlerManager;
+      For I:=M.HandlerCount-1 downto 0 do
+        begin
+        HD:=M.HandlerDefs[i];
+        if PublishHandlerDef(HD) then
+          begin
+          If (R=Nil) or (CompareText(N,HD.HandlerClassName)<>0) then
+            begin
+            N:=HD.HandlerClassName;
+            J:=A.IndexOfName(N);
+            If (J=-1) then
+              begin
+              R:=TJSONArray.Create;
+              A.Add(N,R);
+              end
+            else
+              R:=A.Items[J] as TJSONArray;
+            end;
+          R.Add(HandlerDefToAPIMethod(HD));
+          end;
+        end;
+      end;
+    Result:=D;
+  except
+    FreeAndNil(D);
+    Raise;
+  end;
+end;
+
+Constructor TCustomExtDirectDispatcher.Create(AOwner: TComponent);
+
+Var
+  O : TJSONRPCDispatchOptions;
+
+begin
+  inherited Create(AOwner);
+  Options:=DefaultExtDirectOptions;
+  APIType:='remoting';
+end;
+
+Function TCustomExtDirectDispatcher.API: TJSONData;
+begin
+  Result:=DoAPI;
+end;
+
+Function TCustomExtDirectDispatcher.APIAsString(Formatted: Boolean = False): String;
+
+Var
+  A : TJSONData;
+
+begin
+  A:=API;
+  try
+    if Formatted then
+      Result:=NameSpace + ' = ' + A.FormatJSON + ';'
+    else
+      Result:=NameSpace + ' = ' + A.AsJSON + ';';
+  finally
+    A.Free;
+  end;
+end;
+
+
+{$ifdef extdebug}
+uses dbugintf;
+{$endif}
+
+end.
+

packages/fcl-web/src/jsonrpc/fpextdirect.pp

@@ -1,3 +1,17 @@
+{
+    This file is part of the Free Component Library
+
+    Ext.Direct support - http part
+    Copyright (c) 2007 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
 unit fpextdirect;
 
 {$mode objfpc}{$H+}
@@ -6,58 +20,22 @@ unit fpextdirect;
 interface
 
 uses
-  Classes, SysUtils, fpjson, fpjsonrpc, webjsonrpc, httpdefs;
+  Classes, SysUtils, fpjson, fpjsonrpc, fpdispextdirect, webjsonrpc, httpdefs;
 
 Const
-  DefaultExtDirectOptions = DefaultDispatchOptions + [jdoRequireClass];
+  // Redefinition for backwards compatibility
+  DefaultExtDirectOptions = fpdispextdirect.DefaultExtDirectOptions;
 
 Type
+  // Redefinition for backwards compatibility
+
   { TCustomExtDirectDispatcher }
 
-  TCustomExtDirectDispatcher = Class(TCustomJSONRPCDispatcher)
-  private
-    FAPIType: String;
-    FNameSpace: String;
-    FURL: String;
-    function GetNameSpace: String;
-    function isNameSpaceStored: boolean;
-  Protected
-    function FormatResult(const AClassName, AMethodName: TJSONStringType;
-      const Params, ID, Return: TJSONData): TJSONData; override;
-    // 'tid'
-    Class Function TransactionProperty : String; override;
-    // 'method'
-    Class Function MethodProperty : String; override;
-    // 'action'
-    Class Function ClassNameProperty : String; override;
-    // 'data'
-    Class Function ParamsProperty : String; override;
-    // Add session support
-    Function FindHandler(Const AClassName,AMethodName : TJSONStringType;AContext : TJSONRPCCallContext; Out FreeObject : TComponent) : TCustomJSONRPCHandler; override;
-    // Add type field
-    function CreateJSON2Error(Const AMessage : String; Const ACode : Integer; ID : TJSONData = Nil; idname : TJSONStringType = 'id' ) : TJSONObject; override;
-    // Create API method description
-    Function HandlerToAPIMethod (H: TCustomJSONRPCHandler): TJSONObject; virtual;
-    Function HandlerDefToAPIMethod (H: TJSONRPCHandlerDef): TJSONObject; virtual;
-    // Create API
-    Function DoAPI : TJSONData; virtual;
-    // Namespace for API description. Must be set. Default 'FPWeb'
-    Property NameSpace : String Read GetNameSpace Write FNameSpace Stored isNameSpaceStored;
-    // URL property for router. Must be set
-    Property URL : String Read FURL Write FURL;
-    // "type". By default: 'remoting'
-    Property APIType : String Read FAPIType Write FAPIType;
-  Public
-    // Override to set additional opions.
-    Constructor Create(AOwner : TComponent); override;
-    // Return API description object
-    Function API: TJSONData;
-    // Return API Description including namespace, as a string
-    Function APIAsString : String;
+  TCustomExtDirectDispatcher = Class(fpdispextdirect.TCustomExtDirectDispatcher)
+    Procedure InitContainer(H: TCustomJSONRPCHandler;  AContext: TJSONRPCCallContext; AContainer: TComponent); override;
   end;
 
   { TExtDirectDispatcher }
-
   TExtDirectDispatcher = Class(TCustomExtDirectDispatcher)
   Published
     Property NameSpace;
@@ -149,178 +127,15 @@ Resourcestring
   SErrInvalidPath = 'Invalid path';
 
 { TCustomExtDirectDispatcher }
-Const
-  DefaultNameSpace = 'FPWeb';
-
-function TCustomExtDirectDispatcher.GetNameSpace: String;
-begin
-  Result:=FNameSpace;
-  If (Result='') then
-    Result:=DefaultNameSpace
-end;
-
-function TCustomExtDirectDispatcher.isNameSpaceStored: boolean;
-begin
-  Result:=NameSpace<>DefaultNameSpace;
-end;
-
-function TCustomExtDirectDispatcher.FormatResult(Const AClassName, AMethodName: TJSONStringType;
-Const Params,ID, Return : TJSONData) : TJSONData;
-
-begin
-  Result:=Inherited FormatResult(AClassName,AMethodName,Params,ID,Return);
-  TJSONObject(Result).Add('type','rpc');
-  TJSONObject(Result).Add('action',AClassName);
-  TJSONObject(Result).Add('method',AMethodName);
-end;
-
-class function TCustomExtDirectDispatcher.TransactionProperty: String;
-begin
-  Result:='tid';
-end;
-
-class function TCustomExtDirectDispatcher.MethodProperty: String;
-begin
-  Result:='method';
-end;
-
-class function TCustomExtDirectDispatcher.ClassNameProperty: String;
-begin
-  Result:='action';
-end;
-
-class function TCustomExtDirectDispatcher.ParamsProperty: String;
-begin
-  Result:='data';
-end;
-
-function TCustomExtDirectDispatcher.FindHandler(const AClassName,
-  AMethodName: TJSONStringType; AContext: TJSONRPCCallContext; out
-  FreeObject: TComponent): TCustomJSONRPCHandler;
-begin
-  {$ifdef extdebug}SendDebugFmt('Searching for %s %s',[AClassName,AMethodName]);{$endif}
-  Result:=inherited FindHandler(AClassName, AMethodName, AContext, FreeObject);
-  If (AContext is TJSONRPCSessionContext) and (FreeObject is TCustomJSONRPCModule) then
-    TCustomJSONRPCModule(FreeObject).Session:=TJSONRPCSessionContext(AContext).Session;
-  {$ifdef extdebug}SendDebugFmt('Done with searching for %s %s : %d',[AClassName,AMethodName,Ord(Assigned(Result))]);{$endif}
-end;
-
-function TCustomExtDirectDispatcher.CreateJSON2Error(const AMessage: String;
-  const ACode: Integer; ID: TJSONData; idname: TJSONStringType): TJSONObject;
-begin
-  Result:=inherited CreateJSON2Error(AMessage,ACode,ID,idname);
-  TJSONObject(Result).Add('type','rpc');
-end;
-
-function TCustomExtDirectDispatcher.HandlerToAPIMethod(H: TCustomJSONRPCHandler): TJSONObject;
-begin
-  Result:=TJSONObject.Create(['name',H.Name,'len',H.ParamDefs.Count])
-end;
-
-function TCustomExtDirectDispatcher.HandlerDefToAPIMethod(H: TJSONRPCHandlerDef
-  ): TJSONObject;
-begin
-  Result:=TJSONObject.Create(['name',H.HandlerMethodName,'len',H.ArgumentCount])
-end;
-
-function TCustomExtDirectDispatcher.DoAPI: TJSONData;
-
-Var
-  A,D : TJSONObject;
-  R : TJSONArray;
-  N : TJSONStringType;
-  H : TCustomJSONRPCHandler;
-  I,J : Integer;
-  M : TCustomJSONRPCHandlerManager;
-  HD : TJSONRPCHandlerDef;
-
-begin
-  {$ifdef extdebug}SendDebugFmt('Creating API entries',[]);{$endif}
-  D:=TJSONObject.Create;
-  try
-    D.Add('url',URL);
-    D.Add('type',APIType);
-    A:=TJSONObject.Create;
-    D.Add('actions',A);
-    R:=Nil;
-    N:='';
-    If (jdoSearchOwner in Options) and Assigned(Owner) then
-      begin
-      for I:=Owner.ComponentCount-1 downto 0 do
-        If Owner.Components[i] is TCustomJSONRPCHandler then
-          begin
-          If (R=Nil) then
-            begin
-            N:=Owner.Name;
-            R:=TJSONArray.Create;
-            A.Add(N,R);
-            end;
-          H:=Owner.Components[i] as TCustomJSONRPCHandler;
-          R.Add(HandlerToAPIMethod(H));
-          end;
-      end;
-    If (jdoSearchRegistry in Options) then
-      begin
-      M:=JSONRPCHandlerManager;
-      For I:=M.HandlerCount-1 downto 0 do
-        begin
-        HD:=M.HandlerDefs[i];
-  {$ifdef extdebug}SendDebugFmt('Creating API entry for %s.%s',[HD.HandlerClassName,HD.HandlerMethodName]);{$endif}
-        If (R=Nil) or (CompareText(N,HD.HandlerClassName)<>0) then
-          begin
-  {$ifdef extdebug}SendDebugFmt('Seems like new action entry : %s<> %s',[HD.HandlerClassName,N]);{$endif}
-          N:=HD.HandlerClassName;
-          J:=A.IndexOfName(N);
-          If (J=-1) then
-            begin
-  {$ifdef extdebug}SendDebugFmt('Creating new action entry : %s ',[N]);{$endif}
-            R:=TJSONArray.Create;
-            A.Add(N,R);
-            end
-          else
-            R:=A.Items[J] as TJSONArray;
-          end;
-        R.Add(HandlerDefToAPIMethod(HD));
-        end;
-      end;
-    Result:=D;
-  except
-    FreeAndNil(D);
-    Raise;
-  end;
-end;
-
-constructor TCustomExtDirectDispatcher.Create(AOwner: TComponent);
-
-Var
-  O : TJSONRPCDispatchOptions;
-
-begin
-  inherited Create(AOwner);
-  Options:=DefaultExtDirectOptions;
-  APIType:='remoting';
-end;
 
-function TCustomExtDirectDispatcher.API: TJSONData;
+Procedure TCustomExtDirectDispatcher.InitContainer(H: TCustomJSONRPCHandler;
+  AContext: TJSONRPCCallContext; AContainer: TComponent);
 begin
-  Result:=DoAPI;
+  inherited InitContainer(H, AContext, AContainer);
+  If (AContext is TJSONRPCSessionContext) and (AContainer is TCustomJSONRPCModule) then
+    TCustomJSONRPCModule(AContainer).Session:=TJSONRPCSessionContext(AContext).Session;
 end;
 
-function TCustomExtDirectDispatcher.APIAsString: String;
-
-Var
-  A : TJSONData;
-
-begin
-  A:=API;
-  try
-    Result:=NameSpace + ' = ' + A.AsJSON + ';';
-  finally
-    A.Free;
-  end;
-end;
-
-
 { TCustomExtDirectContentProducer }
 
 function TCustomExtDirectContentProducer.GetIDProperty: String;

packages/fcl-web/src/jsonrpc/fpjsonrpc.pp

@@ -1,3 +1,17 @@
+{
+    This file is part of the Free Component Library
+
+    JSON-RPC functionality - http independant (backend) part
+    Copyright (c) 2007 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
 unit fpjsonrpc;
 
 {$mode objfpc}{$H+}
@@ -151,10 +165,11 @@ Type
     FOnStartBatch: TNotifyEvent;
     FOptions: TJSONRPCDispatchOptions;
   Protected
-
     // Find handler. If none found, nil is returned. Executes OnFindHandler if needed.
     // On return 'DoFree' must be set to indicate that the hand
     Function FindHandler(Const AClassName,AMethodName : TJSONStringType;AContext : TJSONRPCCallContext; Out FreeObject : TComponent) : TCustomJSONRPCHandler; virtual;
+    // Execute handler instance. This can be overridden to implement e.g. authentication globally before actually executing the handler.
+    Function ExecuteHandler(H: TCustomJSONRPCHandler; Params, ID: TJSONData; AContext: TJSONRPCCallContext): TJSONData; virtual;
     // Execute method. Finds handler, and returns response.
     Function ExecuteMethod(Const AClassName, AMethodName : TJSONStringType; Params,ID : TJSONData; AContext : TJSONRPCCallContext) : TJSONData; virtual;
     // Check and Execute a single request. Exceptions are caught and converted to request error object.
@@ -240,6 +255,7 @@ Type
     Property ArgumentCount : Integer Read FArgumentCount Write FArgumentCount;
     Property ParamDefs : TJSONParamDefs Read GetParamDefs Write SetParamDefs;
   end;
+  TJSONRPCHandlerDefClass = Class of TJSONRPCHandlerDef;
 
   { TJSONRPCHandlerDefs }
 
@@ -261,6 +277,7 @@ Type
     FRegistering: Boolean;
   Protected
     procedure Initialize; virtual;
+    procedure DoClear; virtual;
     // Handler support
     Procedure RemoveHandlerDef(Const Index : Integer); virtual; abstract;
     function AddHandlerDef(Const AClassName,AMethodName : TJSONStringType) : TJSONRPCHandlerDef; virtual; abstract;
@@ -279,6 +296,7 @@ Type
     Function GetHandler(Const AClassName,AMethodName : TJSONStringType; AOwner : TComponent; Out AContainer : TComponent): TCustomJSONRPCHandler;
     Procedure GetClassNames (List : TStrings); // Should be a stringlist of TJSONStringType
     Procedure GetMethodsOfClass(Const AClassName : TJSONStringType; List : TStrings); // Should be a stringlist of TJSONStringType
+    Procedure Clear;
     // properties
     Property Registering : Boolean Read FRegistering;
     Property HandlerCount : Integer Read GetHandlerDefCount;
@@ -292,6 +310,8 @@ Type
   Private
     FHandlerDefs : TJSONRPCHandlerDefs;
   Protected
+    procedure DoClear; override;
+    Function CreateDefs : TJSONRPCHandlerDefs; virtual;
     Procedure RemoveHandlerDef(Const Index : Integer); override;
     function AddHandlerDef(Const AClassName,AMethodName : TJSONStringType) : TJSONRPCHandlerDef; override;
     function IndexOfHandlerDef(Const AClassName,AMethodName : TJSONStringType) : Integer; override;
@@ -329,10 +349,11 @@ Function CreateErrorForRequest(Const Req,Error : TJSONData) : TJSONData;
 
 Function JSONRPCHandlerManager : TCustomJSONRPCHandlerManager;
 
-// Class that will be created. Must be set before first call to JSONRPCHandlerManager.
 Var
+  // Class that will be created. Must be set before first call to JSONRPCHandlerManager.
   JSONRPCHandlerManagerClass : TCustomJSONRPCHandlerManagerClass = TJSONRPCHandlerManager;
-
+  // Class of Defs that will be created by TJSONRPCHandlerManager. Must be set before first call to JSONRPCHandlerManager.
+  DefaultJSONRPCHandlerDefClass : TJSONRPCHandlerDefClass = TJSONRPCHandlerDef;
 
 Const
   // JSON RPC 2.0 error codes
@@ -714,6 +735,11 @@ begin
     end;
 end;
 
+Function TCustomJSONRPCDispatcher.ExecuteHandler(H : TCustomJSONRPCHandler; Params,ID: TJSONData;AContext : TJSONRPCCallContext): TJSONData;
+begin
+  Result:=H.Execute(Params,AContext);
+end;
+
 function TCustomJSONRPCDispatcher.ExecuteMethod(Const AClassName,AMethodName: TJSONStringType;
   Params,ID: TJSONData;AContext : TJSONRPCCallContext): TJSONData;
 
@@ -731,7 +757,7 @@ begin
   try
     If Assigned(FOndispatchRequest) then
       FOndispatchRequest(Self,AClassName,AMethodName,Params);
-    Result:=H.Execute(Params,AContext);
+    Result:=ExecuteHandler(H,Params,ID,AContext);
   finally
     If Assigned(FreeObject) then
       FreeAndNil(FreeObject);
@@ -1167,7 +1193,22 @@ begin
   // Do nothing
 end;
 
-procedure TCustomJSONRPCHandlerManager.UnregisterHandler(const AClassName,
+procedure TCustomJSONRPCHandlerManager.DoClear;
+Var
+  I : Integer;
+  D : TJSONRPCHandlerDef;
+  C,M : String;
+begin
+  For I:=HandlerCount-1 downto 0 do
+    begin
+    D:=HandlerDefs[i];
+    C:=D.HandlerClassName;
+    M:=D.HandlerMethodName;
+    UnregisterHandler(C,M);
+    end;
+end;
+
+Procedure TCustomJSONRPCHandlerManager.UnregisterHandler(Const AClassName,
   AMethodName: TJSONStringType);
 
 Var
@@ -1184,8 +1225,8 @@ begin
       JSONRPCError(SErrUnknownJSONRPCMethodHandler,[AMethodName]);
 end;
 
-procedure TCustomJSONRPCHandlerManager.RegisterDatamodule(
-  const AClass: TDatamoduleClass; const AHandlerClassName: TJSONStringType);
+Procedure TCustomJSONRPCHandlerManager.RegisterDatamodule(
+  Const AClass: TDatamoduleClass; Const AHandlerClassName: TJSONStringType);
 
 Var
   DM : TDatamodule;
@@ -1228,19 +1269,17 @@ begin
   end;
 end;
 
-function TCustomJSONRPCHandlerManager.RegisterHandler(
-  const AMethodName: TJSONStringType;
-  AClass: TCustomJSONRPCHandlerClass;
-  AArgumentCount : Integer = 0): TJSONRPCHandlerDef;
+Function TCustomJSONRPCHandlerManager.RegisterHandler(
+  Const AMethodName: TJSONStringType; AClass: TCustomJSONRPCHandlerClass;
+  AArgumentCount: Integer): TJSONRPCHandlerDef;
 
 begin
   Result:=RegisterHandler('',AMethodName,AClass,AArgumentCount);
 end;
 
-function TCustomJSONRPCHandlerManager.RegisterHandler(
-  const AClassName,AMethodName: String;
-  AClass: TCustomJSONRPCHandlerClass;
-  AArgumentCount : Integer = 0): TJSONRPCHandlerDef;
+Function TCustomJSONRPCHandlerManager.RegisterHandler(Const AClassName,
+  AMethodName: TJSONStringType; AClass: TCustomJSONRPCHandlerClass;
+  AArgumentCount: Integer): TJSONRPCHandlerDef;
 
 Var
   I : Integer;
@@ -1264,7 +1303,7 @@ begin
   end;
 end;
 
-function TCustomJSONRPCHandlerManager.FindHandlerDefByName(const AClassName,
+Function TCustomJSONRPCHandlerManager.FindHandlerDefByName(Const AClassName,
   AMethodName: TJSONStringType): TJSONRPCHandlerDef;
 
 Var
@@ -1278,7 +1317,7 @@ begin
     Result:=GetHandlerDef(I);
 end;
 
-function TCustomJSONRPCHandlerManager.GetHandlerDefByName(const AClassName,
+Function TCustomJSONRPCHandlerManager.GetHandlerDefByName(Const AClassName,
   AMethodName: TJSONStringType): TJSONRPCHandlerDef;
 begin
   Result:=FindHandlerDefByName(AClassName,AMethodName);
@@ -1289,8 +1328,8 @@ begin
       JSONRPCError(SErrUnknownJSONRPCMethodHandler,[AMethodName]);
 end;
 
-function TCustomJSONRPCHandlerManager.GetHandler(
-  const ADef: TJSONRPCHandlerDef; AOwner: TComponent; out AContainer: TComponent
+Function TCustomJSONRPCHandlerManager.GetHandler(
+  Const ADef: TJSONRPCHandlerDef; AOwner: TComponent; Out AContainer: TComponent
   ): TCustomJSONRPCHandler;
 
 Var
@@ -1304,8 +1343,8 @@ begin
   Result:=ADef.CreateInstance(O,AContainer);
 end;
 
-function TCustomJSONRPCHandlerManager.GetHandler(const AClassName,
-  AMethodName: TJSONStringType; AOwner: TComponent; out AContainer: TComponent
+Function TCustomJSONRPCHandlerManager.GetHandler(Const AClassName,
+  AMethodName: TJSONStringType; AOwner: TComponent; Out AContainer: TComponent
   ): TCustomJSONRPCHandler;
 
 Var
@@ -1316,31 +1355,65 @@ begin
   Result:=GetHandler(D,AOwner,AContainer);
 end;
 
-procedure TCustomJSONRPCHandlerManager.GetClassNames(List: TStrings);
-begin
+Procedure TCustomJSONRPCHandlerManager.GetClassNames(List: TStrings);
 
+Var
+  D : TJSONRPCHandlerDef;
+  I : Integer;
+
+begin
+  For I:=0 to HandlerCount-1 do
+    begin
+    D:=HandlerDefs[i];
+    If List.IndexOf(D.HandlerClassName)=-1 then
+      List.Add(D.HandlerClassName);
+    end;
 end;
 
-procedure TCustomJSONRPCHandlerManager.GetMethodsOfClass(
-  const AClassName: TJSONStringType; List: TStrings);
+Procedure TCustomJSONRPCHandlerManager.GetMethodsOfClass(
+  Const AClassName: TJSONStringType; List: TStrings);
+Var
+  D : TJSONRPCHandlerDef;
+  I : Integer;
+
 begin
+  For I:=0 to HandlerCount-1 do
+    begin
+    D:=HandlerDefs[i];
+    If AClassName=D.HandlerClassName then
+      List.Add(D.HandlerMethodName);
+    end;
+end;
 
+Procedure TCustomJSONRPCHandlerManager.Clear;
+begin
+  DoClear;
 end;
 
 { TJSONRPCHandlerManager }
 
-procedure TJSONRPCHandlerManager.RemoveHandlerDef(const Index: Integer);
+procedure TJSONRPCHandlerManager.DoClear;
+begin
+  FHandlerDefs.Clear;
+end;
+
+Function TJSONRPCHandlerManager.CreateDefs: TJSONRPCHandlerDefs;
+begin
+  Result:=TJSONRPCHandlerDefs.Create(DefaultJSONRPCHandlerDefClass);
+end;
+
+Procedure TJSONRPCHandlerManager.RemoveHandlerDef(Const Index: Integer);
 begin
   FHandlerDefs.Delete(Index);
 end;
 
-function TJSONRPCHandlerManager.AddHandlerDef(const AClassName,
+function TJSONRPCHandlerManager.AddHandlerDef(Const AClassName,
   AMethodName: TJSONStringType): TJSONRPCHandlerDef;
 begin
   Result:=FHandlerDefs.AddHandler(AClassName,AMethodName);
 end;
 
-function TJSONRPCHandlerManager.IndexOfHandlerDef(const AClassName,
+function TJSONRPCHandlerManager.IndexOfHandlerDef(Const AClassName,
   AMethodName: TJSONStringType): Integer;
 begin
   Result:=FHandlerDefs.IndexOfHandler(AClassName,AMethodName);
@@ -1357,13 +1430,13 @@ begin
   Result:=FHandlerDefs.Count;
 end;
 
-constructor TJSONRPCHandlerManager.Create(AOwner: TComponent);
+Constructor TJSONRPCHandlerManager.Create(AOwner: TComponent);
 begin
   inherited Create(AOwner);
-  FHandlerDefs:=TJSONRPCHandlerDefs.Create(TJSONRPCHandlerDef);
+  FHandlerDefs:=CreateDefs;
 end;
 
-destructor TJSONRPCHandlerManager.Destroy;
+Destructor TJSONRPCHandlerManager.Destroy;
 begin
   FreeAndNil(FHandlerDefs);
   inherited Destroy;

packages/fcl-web/src/jsonrpc/webjsonrpc.pp

@@ -1,3 +1,17 @@
+{
+    This file is part of the Free Component Library
+
+    JSON-RPC functionality - http dependant part
+    Copyright (c) 2007 by Michael Van Canneyt [email protected]
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
 unit webjsonrpc;
 
 {$mode objfpc}{$H+}

packages/hash/examples/Makefile.fpc

@@ -3,10 +3,10 @@
 #
 
 [target]
-programs=mdtest crctest sha1test
+programs=mdtest crctest sha1test md5performancetest  sha1performancetest
 
 [require]
-packages=hash
+packages=hash rtl-extra rtl-objpas
 
 [install]
 fpcpackage=y

packages/hash/examples/md5performancetest.pas

@@ -0,0 +1,29 @@
+program md5performancetest;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  SysUtils,Classes,md5,dateutils;
+
+var
+  StartTime: TDateTime;
+  EndTime: TDateTime;
+  i: integer;
+  s,ss: string;
+begin
+  writeln('MD5 of a million "a" symbols');
+  Writeln('x86 only: compile md5 unit with -dMD5SLOW to use unoptimized original version');
+  SetLength(s, 1000000);
+  for i := 1 to 1000000 do s[i] := 'a';
+
+  StartTime:=now;
+  for i := 0 to 1000 do
+    ss := LowerCase(MDPrint(MDString(s, MD_VERSION_5)));
+  EndTime:=now;
+  writeln('Performance test finished. Elapsed time:');
+  writeln(TimeToStr(EndTime-StartTime));
+end.
+

packages/hash/examples/mdtest.pas

@@ -1,8 +1,8 @@
 {
     This file is part of the Free Pascal packages.
-    Copyright (c) 1999-2000 by the Free Pascal development team
+    Copyright (c) 1999-2014 by the Free Pascal development team
 
-    Tests the MD5 program.
+    Tests MD2, MD4 and MD5 hashes.
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -15,10 +15,10 @@
 
 program mdtest;
 
-{$h+}
+{$mode objfpc}{$h+}
 
 uses
-  md5;
+  SysUtils, md5;
 
 const
   Suite: array[1..7] of string = (
@@ -60,31 +60,57 @@ const
      '57edf4a22be3c955ac49da2e2107b67a')
   );
 
-procedure performTest(const Ver: TMDVersion);
+function performTest(const Ver: TMDVersion; const Verbose: boolean): boolean;
+// Runs test and returns success or failure
 var
   I: Integer;
   S: String;
 begin
+  result := false;
   for I := Low(Suite) to High(Suite) do
   begin
     S := LowerCase(MDPrint(MDString(Suite[I], Ver)));
     if S = Results[Ver, I] then
-      Write('passed  ') else
-      Write('failed  ');
-    WriteLn('  "', Suite[I], '" = ', S);
+      result := true;
+    if Verbose then WriteLn('  "', Suite[I], '" = ', S);
   end;
 end;
 
+var
+  i: integer;
 begin
+  i:=0;
   Writeln('Executing RFC 1319 test suite ...');
-  performTest(MD_VERSION_2);
+  if performTest(MD_VERSION_2,true) then
+    Write('RFC 1319 test suite passed  ')
+  else
+  begin
+    Write('RFC 1319 test suite failed  ');
+    i:=i or 1;
+  end;
+  Writeln;
   Writeln;
 
   Writeln('Executing RFC 1320 test suite ...');
-  performTest(MD_VERSION_4);
+  if performTest(MD_VERSION_4,true) then
+    Write('RFC 1320 test suite passed  ')
+  else
+  begin
+    Write('RFC 1320 test suite failed  ');
+    i:=i or 2;
+  end;
+  Writeln;
   Writeln;
 
   Writeln('Executing RFC 1321 test suite ...');
-  performTest(MD_VERSION_5);
+  if performTest(MD_VERSION_5,true) then
+    Write('RFC 1321 test suite passed  ')
+  else
+  begin
+    Write('RFC 1321 test suite failed  ');
+    i:=i or 4;
+  end;
+  Writeln;
   Writeln;
+  halt(i); //halt with error code 0 if everything ok
 end.

packages/hash/examples/sha1performancetest.pas

@@ -0,0 +1,29 @@
+program sha1performancetest;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  SysUtils,Classes,sha1,dateutils;
+
+var
+  StartTime: TDateTime;
+  EndTime: TDateTime;
+  i: integer;
+  s,ss: string;
+begin
+  writeln('MD5 of a million "a" symbols');
+  Writeln('compile sha unit with -dSHA1SLOW to use unoptimized original version');
+  SetLength(s, 1000000);
+  for i := 1 to 1000000 do s[i] := 'a';
+
+  StartTime:=now;
+  for i := 0 to 1000 do
+    ss := LowerCase(SHA1Print(SHA1string(s)));
+  EndTime:=now;
+  writeln('Performance test finished. Elapsed time:');
+  writeln(TimeToStr(EndTime-StartTime));
+end.
+

packages/hash/examples/sha1test.pp

@@ -1,23 +1,24 @@
 program sha1test;
 {$mode objfpc}{$h+}
 
-uses sha1;
+uses SysUtils, sha1;
 
+function performTest: cardinal;
+// Runs test and returns result code (0=success)
 var
-  code: cardinal;
   s, sdig: string;
   i: integer;
   ctx: TSHA1Context;
   d: TSHA1Digest;
 begin
-  code := 0;
+  result := 0;
   sdig := SHA1Print(SHA1String('abc'));
   if sdig <> 'a9993e364706816aba3e25717850c26c9cd0d89d' then
-    code := code or 1;
-    
+    result := result or 1;
+
   sdig := SHA1Print(SHA1String('abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq'));
   if sdig <> '84983e441c3bd26ebaae4aa1f95129e5e54670f1' then
-    code := code or 2;
+    result := result or 2;
 
   // SHA-1 of a million 'a' symbols
   SetLength(s, 1000);
@@ -28,11 +29,21 @@ begin
   SHA1Final(ctx, d);
   sdig := SHA1Print(d);
   if sdig <> '34aa973cd4c4daa4f61eeb2bdbad27316534016f' then
-    code := code or 4;
+    result := result or 4;
+end;
+
+var
+  StartTime, EndTime: TDateTime;
+  code: cardinal;
+begin
+  writeln('Performing basic SHA-1 test...');
+  code:=performTest;
 
   if code = 0 then
     writeln('Basic SHA-1 tests passed')
   else
+  begin
     writeln('SHA-1 tests failed: ', code);
-  Halt(code);
-end.
+  end;
+  Halt(code);	
+end.

packages/hash/fpmake.pp

@@ -40,6 +40,8 @@ begin
     T:=P.Targets.AddExampleunit('examples/sha1test.pp');
     T:=P.Targets.AddExampleunit('examples/hmd5.pas');
     T:=P.Targets.AddExampleunit('examples/hsha1.pas');
+    T:=P.Targets.AddExampleunit('examples/md5performancetest.pas');
+    T:=P.Targets.AddExampleunit('examples/sha1performancetest.pas');
     // md5.ref
 {$ifndef ALLPACKAGES}
     Run;

packages/hash/src/md5.pp

@@ -1,6 +1,6 @@
 {
     This file is part of the Free Pascal packages.
-    Copyright (c) 1999-2006 by the Free Pascal development team
+    Copyright (c) 1999-2014 by the Free Pascal development team
 
     Implements a MD2 digest algorithm (RFC 1319)
     Implements a MD4 digest algorithm (RFC 1320)
@@ -15,6 +15,10 @@
 
  **********************************************************************}
 
+// Define to use original MD5 code on i386 processors.
+// Undefine to use original implementation.
+{not $DEFINE MD5SLOW}
+
 unit md5;
 
 {$mode objfpc}
@@ -298,6 +302,110 @@ begin
 end;
 
 
+{$IF (NOT(DEFINED(MD5SLOW))) and (DEFINED(CPUI386)) }
+{$i md5i386.inc}
+{$ENDIF}
+{$IF (NOT(DEFINED(MD5SLOW))) and (DEFINED(CPUX86_64)) }
+{$OPTIMIZATION USERBP} //PEEPHOLE
+procedure MD5Transform(var Context: TMDContext; Buffer: Pointer);
+type
+  TBlock = array[0..15] of Cardinal;
+  PBlock = ^TBlock;
+var
+  a, b, c, d: Cardinal;
+  //Block: array[0..15] of Cardinal absolute Buffer;
+  Block: PBlock absolute Buffer;
+begin
+  //Invert(Buffer, @Block, 64);
+  a := Context.State[0];
+  b := Context.State[1];
+  c := Context.State[2];
+  d := Context.State[3];
+
+{$push}
+{$r-,q-}
+
+  // Round 1
+  a := b + roldword(dword(a + ((b and c) or ((not b) and d)) + Block^[0]  + $d76aa478),  7);
+  d := a + roldword(dword(d + ((a and b) or ((not a) and c)) + Block^[1]  + $e8c7b756), 12);
+  c := d + roldword(dword(c + ((d and a) or ((not d) and b)) + Block^[2]  + $242070db), 17);
+  b := c + roldword(dword(b + ((c and d) or ((not c) and a)) + Block^[3]  + $c1bdceee), 22);
+  a := b + roldword(dword(a + ((b and c) or ((not b) and d)) + Block^[4]  + $f57c0faf),  7);
+  d := a + roldword(dword(d + ((a and b) or ((not a) and c)) + Block^[5]  + $4787c62a), 12);
+  c := d + roldword(dword(c + ((d and a) or ((not d) and b)) + Block^[6]  + $a8304613), 17);
+  b := c + roldword(dword(b + ((c and d) or ((not c) and a)) + Block^[7]  + $fd469501), 22);
+  a := b + roldword(dword(a + ((b and c) or ((not b) and d)) + Block^[8]  + $698098d8),  7);
+  d := a + roldword(dword(d + ((a and b) or ((not a) and c)) + Block^[9]  + $8b44f7af), 12);
+  c := d + roldword(dword(c + ((d and a) or ((not d) and b)) + Block^[10] + $ffff5bb1), 17);
+  b := c + roldword(dword(b + ((c and d) or ((not c) and a)) + Block^[11] + $895cd7be), 22);
+  a := b + roldword(dword(a + ((b and c) or ((not b) and d)) + Block^[12] + $6b901122),  7);
+  d := a + roldword(dword(d + ((a and b) or ((not a) and c)) + Block^[13] + $fd987193), 12);
+  c := d + roldword(dword(c + ((d and a) or ((not d) and b)) + Block^[14] + $a679438e), 17);
+  b := c + roldword(dword(b + ((c and d) or ((not c) and a)) + Block^[15] + $49b40821), 22);
+  // Round 2
+  a := b + roldword(dword(a + ((b and d) or (c and (not d))) + Block^[1]  + $f61e2562),  5);
+  d := a + roldword(dword(d + ((a and c) or (b and (not c))) + Block^[6]  + $c040b340),  9);
+  c := d + roldword(dword(c + ((d and b) or (a and (not b))) + Block^[11] + $265e5a51), 14);
+  b := c + roldword(dword(b + ((c and a) or (d and (not a))) + Block^[0]  + $e9b6c7aa), 20);
+  a := b + roldword(dword(a + ((b and d) or (c and (not d))) + Block^[5]  + $d62f105d),  5);
+  d := a + roldword(dword(d + ((a and c) or (b and (not c))) + Block^[10] + $02441453),  9);
+  c := d + roldword(dword(c + ((d and b) or (a and (not b))) + Block^[15] + $d8a1e681), 14);
+  b := c + roldword(dword(b + ((c and a) or (d and (not a))) + Block^[4]  + $e7d3fbc8), 20);
+  a := b + roldword(dword(a + ((b and d) or (c and (not d))) + Block^[9]  + $21e1cde6),  5);
+  d := a + roldword(dword(d + ((a and c) or (b and (not c))) + Block^[14] + $c33707d6),  9);
+  c := d + roldword(dword(c + ((d and b) or (a and (not b))) + Block^[3]  + $f4d50d87), 14);
+  b := c + roldword(dword(b + ((c and a) or (d and (not a))) + Block^[8]  + $455a14ed), 20);
+  a := b + roldword(dword(a + ((b and d) or (c and (not d))) + Block^[13] + $a9e3e905),  5);
+  d := a + roldword(dword(d + ((a and c) or (b and (not c))) + Block^[2]  + $fcefa3f8),  9);
+  c := d + roldword(dword(c + ((d and b) or (a and (not b))) + Block^[7]  + $676f02d9), 14);
+  b := c + roldword(dword(b + ((c and a) or (d and (not a))) + Block^[12] + $8d2a4c8a), 20);
+  // Round 3
+  a := b + roldword(dword(a + (b xor c xor d) + Block^[5]  + $fffa3942),  4);
+  d := a + roldword(dword(d + (a xor b xor c) + Block^[8]  + $8771f681), 11);
+  c := d + roldword(dword(c + (d xor a xor b) + Block^[11] + $6d9d6122), 16);
+  b := c + roldword(dword(b + (c xor d xor a) + Block^[14] + $fde5380c), 23);
+  a := b + roldword(dword(a + (b xor c xor d) + Block^[1]  + $a4beea44),  4);
+  d := a + roldword(dword(d + (a xor b xor c) + Block^[4]  + $4bdecfa9), 11);
+  c := d + roldword(dword(c + (d xor a xor b) + Block^[7]  + $f6bb4b60), 16);
+  b := c + roldword(dword(b + (c xor d xor a) + Block^[10] + $bebfbc70), 23);
+  a := b + roldword(dword(a + (b xor c xor d) + Block^[13] + $289b7ec6),  4);
+  d := a + roldword(dword(d + (a xor b xor c) + Block^[0]  + $eaa127fa), 11);
+  c := d + roldword(dword(c + (d xor a xor b) + Block^[3]  + $d4ef3085), 16);
+  b := c + roldword(dword(b + (c xor d xor a) + Block^[6]  + $04881d05), 23);
+  a := b + roldword(dword(a + (b xor c xor d) + Block^[9]  + $d9d4d039),  4);
+  d := a + roldword(dword(d + (a xor b xor c) + Block^[12] + $e6db99e5), 11);
+  c := d + roldword(dword(c + (d xor a xor b) + Block^[15] + $1fa27cf8), 16);
+  b := c + roldword(dword(b + (c xor d xor a) + Block^[2]  + $c4ac5665), 23);
+  // Round 4
+  a := b + roldword(dword(a + (c xor (b or (not d))) + Block^[0]  + $f4292244),  6);
+  d := a + roldword(dword(d + (b xor (a or (not c))) + Block^[7]  + $432aff97), 10);
+  c := d + roldword(dword(c + (a xor (d or (not b))) + Block^[14] + $ab9423a7), 15);
+  b := c + roldword(dword(b + (d xor (c or (not a))) + Block^[5]  + $fc93a039), 21);
+  a := b + roldword(dword(a + (c xor (b or (not d))) + Block^[12] + $655b59c3),  6);
+  d := a + roldword(dword(d + (b xor (a or (not c))) + Block^[3]  + $8f0ccc92), 10);
+  c := d + roldword(dword(c + (a xor (d or (not b))) + Block^[10] + $ffeff47d), 15);
+  b := c + roldword(dword(b + (d xor (c or (not a))) + Block^[1]  + $85845dd1), 21);
+  a := b + roldword(dword(a + (c xor (b or (not d))) + Block^[8]  + $6fa87e4f),  6);
+  d := a + roldword(dword(d + (b xor (a or (not c))) + Block^[15] + $fe2ce6e0), 10);
+  c := d + roldword(dword(c + (a xor (d or (not b))) + Block^[6]  + $a3014314), 15);
+  b := c + roldword(dword(b + (d xor (c or (not a))) + Block^[13] + $4e0811a1), 21);
+  a := b + roldword(dword(a + (c xor (b or (not d))) + Block^[4]  + $f7537e82),  6);
+  d := a + roldword(dword(d + (b xor (a or (not c))) + Block^[11] + $bd3af235), 10);
+  c := d + roldword(dword(c + (a xor (d or (not b))) + Block^[2]  + $2ad7d2bb), 15);
+  b := c + roldword(dword(b + (d xor (c or (not a))) + Block^[9]  + $eb86d391), 21);
+
+
+  inc(Context.State[0],a);
+  inc(Context.State[1],b);
+  inc(Context.State[2],c);
+  inc(Context.State[3],d);
+{$pop}
+  inc(Context.Length,64);
+end;
+{$OPTIMIZATION DEFAULT}
+{$ENDIF}
+{$IF DEFINED(MD5SLOW) or (NOT ((DEFINED(CPUX86_64)) or (DEFINED(CPUI386))))}
+// Original version
 procedure MD5Transform(var Context: TMDContext; Buffer: Pointer);
 
 {$push}
@@ -372,6 +480,7 @@ begin
 {$pop}
   inc(Context.Length,64);
 end;
+{$ENDIF}
 
 
 procedure MDInit(out Context: TMDContext; const Version: TMDVersion);