* Sync with trunk r23500.

git-svn-id: branches/targetandroid@23501 -

.gitattributes

@@ -2613,6 +2613,7 @@ packages/fcl-stl/src/gpriorityqueue.pp svneol=native#text/plain
 packages/fcl-stl/src/gqueue.pp svneol=native#text/plain
 packages/fcl-stl/src/gset.pp svneol=native#text/plain
 packages/fcl-stl/src/gstack.pp svneol=native#text/plain
+packages/fcl-stl/src/gtree.pp svneol=native#text/plain
 packages/fcl-stl/src/gutil.pp svneol=native#text/plain
 packages/fcl-stl/src/gvector.pp svneol=native#text/plain
 packages/fcl-stl/tests/clean svneol=native#text/plain
@@ -2628,6 +2629,7 @@ packages/fcl-stl/tests/gqueuetest.pp svneol=native#text/plain
 packages/fcl-stl/tests/gsetrefcounttest.pp svneol=native#text/plain
 packages/fcl-stl/tests/gsettest.pp svneol=native#text/plain
 packages/fcl-stl/tests/gstacktest.pp svneol=native#text/plain
+packages/fcl-stl/tests/gtreetest.pp svneol=native#text/plain
 packages/fcl-stl/tests/gvectortest.pp svneol=native#text/plain
 packages/fcl-stl/tests/run-all-tests svneol=native#text/plain
 packages/fcl-stl/tests/suiteconfig.pp svneol=native#text/plain
@@ -9970,6 +9972,20 @@ tests/test/cg/obj/linux/i386/tcext4.o -text
 tests/test/cg/obj/linux/i386/tcext5.o -text
 tests/test/cg/obj/linux/i386/tcext6.o -text
 tests/test/cg/obj/linux/m68k/ctest.o -text
+tests/test/cg/obj/linux/mips/cpptcl1.o -text
+tests/test/cg/obj/linux/mips/cpptcl2.o -text
+tests/test/cg/obj/linux/mips/ctest.o -text
+tests/test/cg/obj/linux/mips/tcext3.o -text
+tests/test/cg/obj/linux/mips/tcext4.o -text
+tests/test/cg/obj/linux/mips/tcext5.o -text
+tests/test/cg/obj/linux/mips/tcext6.o -text
+tests/test/cg/obj/linux/mipsel/cpptcl1.o -text
+tests/test/cg/obj/linux/mipsel/cpptcl2.o -text
+tests/test/cg/obj/linux/mipsel/ctest.o -text
+tests/test/cg/obj/linux/mipsel/tcext3.o -text
+tests/test/cg/obj/linux/mipsel/tcext4.o -text
+tests/test/cg/obj/linux/mipsel/tcext5.o -text
+tests/test/cg/obj/linux/mipsel/tcext6.o -text
 tests/test/cg/obj/linux/powerpc/cpptcl1.o -text
 tests/test/cg/obj/linux/powerpc/cpptcl2.o -text
 tests/test/cg/obj/linux/powerpc/ctest.o -text
@@ -10807,10 +10823,22 @@ tests/test/terecs1.pp svneol=native#text/pascal
 tests/test/terecs10.pp svneol=native#text/pascal
 tests/test/terecs11.pp svneol=native#text/pascal
 tests/test/terecs12.pp svneol=native#text/pascal
+tests/test/terecs12a.pp svneol=native#text/pascal
+tests/test/terecs12b.pp svneol=native#text/pascal
+tests/test/terecs12c.pp svneol=native#text/pascal
+tests/test/terecs12d.pp svneol=native#text/pascal
 tests/test/terecs13.pp svneol=native#text/pascal
+tests/test/terecs13a.pp svneol=native#text/pascal
+tests/test/terecs13b.pp svneol=native#text/pascal
+tests/test/terecs13c.pp svneol=native#text/pascal
+tests/test/terecs13d.pp svneol=native#text/pascal
 tests/test/terecs14.pp svneol=native#text/pascal
 tests/test/terecs15.pp svneol=native#text/pascal
 tests/test/terecs16.pp svneol=native#text/pascal
+tests/test/terecs17.pp svneol=native#text/pascal
+tests/test/terecs17a.pp svneol=native#text/pascal
+tests/test/terecs18.pp svneol=native#text/pascal
+tests/test/terecs18a.pp svneol=native#text/pascal
 tests/test/terecs2.pp svneol=native#text/pascal
 tests/test/terecs3.pp svneol=native#text/pascal
 tests/test/terecs4.pp svneol=native#text/pascal
@@ -11459,6 +11487,7 @@ tests/test/trhlp41.pp svneol=native#text/pascal
 tests/test/trhlp42.pp svneol=native#text/pascal
 tests/test/trhlp43.pp svneol=native#text/pascal
 tests/test/trhlp44.pp svneol=native#text/pascal
+tests/test/trhlp45.pp svneol=native#text/pascal
 tests/test/trhlp5.pp svneol=native#text/pascal
 tests/test/trhlp6.pp svneol=native#text/pascal
 tests/test/trhlp7.pp svneol=native#text/pascal
@@ -12918,6 +12947,7 @@ tests/webtbs/tw1931.pp svneol=native#text/plain
 tests/webtbs/tw1932.pp svneol=native#text/plain
 tests/webtbs/tw19325.pp svneol=native#text/pascal
 tests/webtbs/tw1935.pp svneol=native#text/plain
+tests/webtbs/tw19357.pp svneol=native#text/pascal
 tests/webtbs/tw1936.pp svneol=native#text/plain
 tests/webtbs/tw19368.pp svneol=native#text/pascal
 tests/webtbs/tw1938.pp svneol=native#text/plain
@@ -13127,6 +13157,7 @@ tests/webtbs/tw2305.pp svneol=native#text/plain
 tests/webtbs/tw2306.pp svneol=native#text/plain
 tests/webtbs/tw2307.pp svneol=native#text/plain
 tests/webtbs/tw2311.pp svneol=native#text/plain
+tests/webtbs/tw23130.pp svneol=native#text/pascal
 tests/webtbs/tw23136.pp svneol=native#text/pascal
 tests/webtbs/tw2317.pp svneol=native#text/plain
 tests/webtbs/tw2318.pp svneol=native#text/plain

compiler/arm/aoptcpu.pas

@@ -41,6 +41,9 @@ Type
     procedure RemoveSuperfluousMove(const p: tai; movp: tai; const optimizer: string);
     function RegUsedAfterInstruction(reg: Tregister; p: tai;
                                      var AllUsedRegs: TAllUsedRegs): Boolean;
+    { returns true if reg reaches it's end of life at p, this means it is either
+      reloaded with a new value or it is deallocated afterwards }
+    function RegEndOfLife(reg: TRegister;p: taicpu): boolean;
     { gets the next tai object after current that contains info relevant
       to the optimizer in p1 which used the given register or does a 
       change in program flow.
@@ -73,7 +76,7 @@ Type
 Implementation
 
   uses
-    cutils,verbose,globals,
+    cutils,verbose,globtype,globals,
     systems,
     cpuinfo,
     cgobj,cgutils,procinfo,
@@ -302,13 +305,20 @@ Implementation
     end;
 
 
+  function TCpuAsmOptimizer.RegEndOfLife(reg : TRegister;p : taicpu) : boolean;
+    begin
+       Result:=assigned(FindRegDealloc(reg,tai(p.Next))) or
+         RegLoadedWithNewValue(reg,p);
+    end;
+
+
   function TCpuAsmOptimizer.GetNextInstructionUsingReg(Current: tai;
     var Next: tai; reg: TRegister): Boolean;
     begin
       Next:=Current;
       repeat
         Result:=GetNextInstruction(Next,Next);
-      until not(Result) or (Next.typ<>ait_instruction) or (RegInInstruction(reg,Next)) or
+      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));
     end;
 
@@ -763,38 +773,60 @@ Implementation
                           mov reg1,reg0, shift imm1
                           mov reg1,reg1, shift imm2
                           mov reg1,reg1, shift imm3 ...
+                          mov reg2,reg1, shift imm3 ...
                         }
-                        else if getnextinstruction(hp1,hp2) and
+                        else if GetNextInstructionUsingReg(hp1,hp2, taicpu(hp1).oper[0]^.reg) and
                           MatchInstruction(hp2, A_MOV, [taicpu(p).condition], [PF_None]) and
                           (taicpu(hp2).ops=3) and
-                          MatchOperand(taicpu(hp2).oper[0]^, taicpu(hp1).oper[0]^.reg) and
                           MatchOperand(taicpu(hp2).oper[1]^, taicpu(hp1).oper[0]^.reg) and
+                          RegEndofLife(taicpu(p).oper[0]^.reg,taicpu(hp2)) and
                           (taicpu(hp2).oper[2]^.typ = top_shifterop) and
                           (taicpu(hp2).oper[2]^.shifterop^.rs = NR_NO) then
                           begin
                             { mov reg1,reg0, lsl imm1
                               mov reg1,reg1, lsr/asr imm2
-                              mov reg1,reg1, lsl imm3 ...
-
-                              if imm3<=imm1 and imm2>=imm3
+                              mov reg2,reg1, lsl imm3 ...
                               to
                               mov reg1,reg0, lsl imm1
-                              mov reg1,reg1, lsr/asr imm2-imm3
+                              mov reg2,reg1, lsr/asr imm2-imm3
+                              if
+                              imm1>=imm2
                             }
                             if (taicpu(p).oper[2]^.shifterop^.shiftmode=SM_LSL) and (taicpu(hp2).oper[2]^.shifterop^.shiftmode=SM_LSL) and
                               (taicpu(hp1).oper[2]^.shifterop^.shiftmode in [SM_ASR,SM_LSR]) and
-                              (taicpu(hp2).oper[2]^.shifterop^.shiftimm<=taicpu(p).oper[2]^.shifterop^.shiftimm) and
-                              (taicpu(hp1).oper[2]^.shifterop^.shiftimm>=taicpu(hp2).oper[2]^.shifterop^.shiftimm) then
+                              (taicpu(p).oper[2]^.shifterop^.shiftimm>=taicpu(hp1).oper[2]^.shifterop^.shiftimm) then
                               begin
-                                dec(taicpu(hp1).oper[2]^.shifterop^.shiftimm,taicpu(hp2).oper[2]^.shifterop^.shiftimm);
-                                DebugMsg('Peephole ShiftShiftShift2ShiftShift 1 done', p);
-                                asml.remove(hp2);
-                                hp2.free;
-                                result := true;
-                                if taicpu(hp1).oper[2]^.shifterop^.shiftimm=0 then
+                                if (taicpu(hp2).oper[2]^.shifterop^.shiftimm>=taicpu(hp1).oper[2]^.shifterop^.shiftimm) then
                                   begin
-                                    asml.remove(hp1);
-                                    hp1.free;
+                                    if not(RegUsedBetween(taicpu(hp2).oper[0]^.reg,p,hp1)) and
+                                      not(RegUsedBetween(taicpu(hp2).oper[0]^.reg,hp1,hp2)) then
+                                      begin
+                                        DebugMsg('Peephole ShiftShiftShift2ShiftShift 1a done', p);
+                                        inc(taicpu(p).oper[2]^.shifterop^.shiftimm,taicpu(hp2).oper[2]^.shifterop^.shiftimm-taicpu(hp1).oper[2]^.shifterop^.shiftimm);
+                                        taicpu(p).oper[0]^.reg:=taicpu(hp2).oper[0]^.reg;
+                                        asml.remove(hp1);
+                                        asml.remove(hp2);
+                                        hp1.free;
+                                        hp2.free;
+
+                                        if taicpu(hp1).oper[2]^.shifterop^.shiftimm>=32 then
+                                          begin
+                                            taicpu(p).freeop(1);
+                                            taicpu(p).freeop(2);
+                                            taicpu(p).loadconst(1,0);
+                                          end;
+                                        result := true;
+                                      end;
+                                  end
+                                else if not(RegUsedBetween(taicpu(hp2).oper[0]^.reg,hp1,hp2)) then
+                                  begin
+                                    DebugMsg('Peephole ShiftShiftShift2ShiftShift 1b done', p);
+
+                                    dec(taicpu(hp1).oper[2]^.shifterop^.shiftimm,taicpu(hp2).oper[2]^.shifterop^.shiftimm);
+                                    taicpu(hp1).oper[0]^.reg:=taicpu(hp2).oper[0]^.reg;
+                                    asml.remove(hp2);
+                                    hp2.free;
+                                    result := true;
                                   end;
                               end
                             { mov reg1,reg0, lsr/asr imm1
@@ -829,10 +861,10 @@ Implementation
                           end;
                       end;
                     { Change the common
-                      mov r0, r0, lsr #24
-                      and r0, r0, #255
+                      mov r0, r0, lsr #xxx
+                      and r0, r0, #yyy/bic r0, r0, #xxx
 
-                      and remove the superfluous and
+                      and remove the superfluous and/bic if possible
 
                       This could be extended to handle more cases.
                     }
@@ -840,29 +872,46 @@ Implementation
                        (taicpu(p).oper[2]^.typ = top_shifterop) and
                        (taicpu(p).oper[2]^.shifterop^.rs = NR_NO) and
                        (taicpu(p).oper[2]^.shifterop^.shiftmode = SM_LSR) and
-                       (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and
                        GetNextInstructionUsingReg(p,hp1, taicpu(p).oper[0]^.reg) and
                        (assigned(FindRegDealloc(taicpu(p).oper[0]^.reg,tai(hp1.Next))) or
-                         regLoadedWithNewValue(taicpu(p).oper[0]^.reg, hp1)) and
-                       MatchInstruction(hp1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and
-                       (taicpu(hp1).ops=3) and
-                       MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[0]^) and
-                       MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and
-                       (taicpu(hp1).oper[2]^.typ = top_const) and
-                       { Check if the AND actually would only mask out bits beeing already zero because of the shift
-                         For LSR #25 and an AndConst of 255 that whould go like this:
-                         255 and ((2 shl (32-25))-1)
-                         which results in 127, which is one less a power-of-2, meaning all lower bits are set.
-
-                         LSR #25 and AndConst of 254:
-                         254 and ((2 shl (32-25))-1) = 126 -> lowest bit is clear, so we can't remove it.
-                       }
-                       ispowerof2((taicpu(hp1).oper[2]^.val and ((2 shl (32-taicpu(p).oper[2]^.shifterop^.shiftimm))-1))+1) then
-                      begin
-                        DebugMsg('Peephole LsrAnd2Lsr done', hp1);
-                        asml.remove(hp1);
-                        hp1.free;
-                      end;
+                         regLoadedWithNewValue(taicpu(p).oper[0]^.reg, hp1)) then
+                       begin
+                         if (taicpu(p).oper[2]^.shifterop^.shiftimm >= 24 ) and
+                           MatchInstruction(hp1, A_AND, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                           (taicpu(hp1).ops=3) and
+                           MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and
+                           (taicpu(hp1).oper[2]^.typ = top_const) and
+                           { Check if the AND actually would only mask out bits beeing already zero because of the shift
+                             For LSR #25 and an AndConst of 255 that whould go like this:
+                             255 and ((2 shl (32-25))-1)
+                             which results in 127, which is one less a power-of-2, meaning all lower bits are set.
+
+                             LSR #25 and AndConst of 254:
+                             254 and ((2 shl (32-25))-1) = 126 -> lowest bit is clear, so we can't remove it.
+                           }
+                           ispowerof2((taicpu(hp1).oper[2]^.val and ((2 shl (32-taicpu(p).oper[2]^.shifterop^.shiftimm))-1))+1) then
+                           begin
+                             DebugMsg('Peephole LsrAnd2Lsr done', hp1);
+                             taicpu(p).oper[0]^.reg:=taicpu(hp1).oper[0]^.reg;
+                             asml.remove(hp1);
+                             hp1.free;
+                             result:=true;
+                           end
+                         else if MatchInstruction(hp1, A_BIC, [taicpu(p).condition], [taicpu(p).oppostfix]) and
+                           (taicpu(hp1).ops=3) and
+                           MatchOperand(taicpu(p).oper[0]^, taicpu(hp1).oper[1]^) and
+                           (taicpu(hp1).oper[2]^.typ = top_const) and
+                           { Check if the BIC actually would only mask out bits beeing already zero because of the shift }
+                           (taicpu(hp1).oper[2]^.val<>0) and
+                           (BsfDWord(taicpu(hp1).oper[2]^.val)>=32-taicpu(p).oper[2]^.shifterop^.shiftimm) then
+                           begin
+                             DebugMsg('Peephole LsrBic2Lsr done', hp1);
+                             taicpu(p).oper[0]^.reg:=taicpu(hp1).oper[0]^.reg;
+                             asml.remove(hp1);
+                             hp1.free;
+                             result:=true;
+                           end;
+                       end;
 
                     {
                       optimize
@@ -1064,7 +1113,51 @@ Implementation
                               break;
                             end;
                       end;
-
+                    {
+                      Fold
+                        mov r1, r1, lsl #2
+                        ldr/ldrb r0, [r0, r1]
+                      to
+                        ldr/ldrb r0, [r0, r1, lsl #2]
+
+                      XXX: This still needs some work, as we quite often encounter something like
+                             mov r1, r2, lsl #2
+                             add r2, r3, #imm
+                             ldr r0, [r2, r1]
+                           which can't be folded because r2 is overwritten between the shift and the ldr.
+                           We could try to shuffle the registers around and fold it into.
+                             add r1, r3, #imm
+                             ldr r0, [r1, r2, lsl #2]
+                    }
+                    if (taicpu(p).opcode = A_MOV) and
+                       (taicpu(p).ops = 3) and
+                       (taicpu(p).oper[1]^.typ = top_reg) and
+                       (taicpu(p).oper[2]^.typ = top_shifterop) and
+                       { RRX is tough to handle, because it requires tracking the C-Flag,
+                         it is also extremly unlikely to be emitted this way}
+                       (taicpu(p).oper[2]^.shifterop^.shiftmode <> SM_RRX) and
+                       (taicpu(p).oper[2]^.shifterop^.shiftimm <> 0) and
+                       (taicpu(p).oppostfix = PF_NONE) and
+                       GetNextInstructionUsingReg(p, hp1, taicpu(p).oper[0]^.reg) and
+                       {Only LDR, LDRB, STR, STRB can handle scaled register indexing}
+                       MatchInstruction(hp1, [A_LDR, A_STR], [taicpu(p).condition],
+                                             [PF_None, PF_B]) and
+                       (taicpu(hp1).oper[1]^.ref^.index = taicpu(p).oper[0]^.reg) and
+                       (taicpu(hp1).oper[1]^.ref^.base <> taicpu(p).oper[0]^.reg) and
+                       { Only fold if there isn't another shifterop already. }
+                       (taicpu(hp1).oper[1]^.ref^.shiftmode = SM_None) and
+                       not(RegModifiedBetween(taicpu(p).oper[1]^.reg,p,hp1)) and
+                       (assigned(FindRegDealloc(taicpu(p).oper[0]^.reg,tai(hp1.Next))) or
+                         regLoadedWithNewValue(taicpu(p).oper[0]^.reg, hp1)) then
+                       begin
+                         DebugMsg('Peephole FoldShiftLdrStr done', hp1);
+                         taicpu(hp1).oper[1]^.ref^.index := taicpu(p).oper[1]^.reg;
+                         taicpu(hp1).oper[1]^.ref^.shiftmode := taicpu(p).oper[2]^.shifterop^.shiftmode;
+                         taicpu(hp1).oper[1]^.ref^.shiftimm := taicpu(p).oper[2]^.shifterop^.shiftimm;
+                         asml.remove(p);
+                         p.free;
+                         p:=hp1;
+                       end;
                     {
                       Often we see shifts and then a superfluous mov to another register
                       In the future this might be handled in RedundantMovProcess when it uses RegisterTracking
@@ -1099,24 +1192,38 @@ Implementation
                         {
                           change
                           and reg2,reg1,const1
+                          ...
                           and reg3,reg2,const2
                           to
                           and reg3,reg1,(const1 and const2)
                         }
-                        if GetNextInstruction(p, hp1) and
+                        if GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
                         MatchInstruction(hp1, A_AND, [taicpu(p).condition], [PF_None]) and
-                        { either reg3 and reg2 are equal or reg2 is deallocated after the and }
-                        (MatchOperand(taicpu(hp1).oper[0]^, taicpu(p).oper[0]^.reg) or
-                         assigned(FindRegDealloc(taicpu(p).oper[0]^.reg,tai(hp1.Next)))) and
+                        RegEndOfLife(taicpu(p).oper[0]^.reg,taicpu(hp1)) and
                         MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[0]^.reg) and
                         (taicpu(hp1).oper[2]^.typ = top_const) then
                           begin
-                            DebugMsg('Peephole AndAnd2And done', p);
-                            taicpu(p).loadConst(2,taicpu(p).oper[2]^.val and taicpu(hp1).oper[2]^.val);
-                            taicpu(p).oppostfix:=taicpu(hp1).oppostfix;
-                            taicpu(p).loadReg(0,taicpu(hp1).oper[0]^.reg);
-                            asml.remove(hp1);
-                            hp1.free;
+                            if not(RegUsedBetween(taicpu(hp1).oper[0]^.reg,p,hp1)) then
+                              begin
+                                DebugMsg('Peephole AndAnd2And done', p);
+                                taicpu(p).loadConst(2,taicpu(p).oper[2]^.val and taicpu(hp1).oper[2]^.val);
+                                taicpu(p).oppostfix:=taicpu(hp1).oppostfix;
+                                taicpu(p).loadReg(0,taicpu(hp1).oper[0]^.reg);
+                                asml.remove(hp1);
+                                hp1.free;
+                                Result:=true;
+                              end
+                            else if not(RegUsedBetween(taicpu(p).oper[1]^.reg,p,hp1)) then
+                              begin
+                                DebugMsg('Peephole AndAnd2And done', hp1);
+                                taicpu(hp1).loadConst(2,taicpu(hp1).oper[2]^.val and taicpu(hp1).oper[2]^.val);
+                                taicpu(hp1).oppostfix:=taicpu(p).oppostfix;
+                                taicpu(hp1).loadReg(1,taicpu(p).oper[1]^.reg);
+                                asml.remove(p);
+                                p.free;
+                                p:=hp1;
+                                Result:=true;
+                              end;
                           end
                         {
                           change
@@ -1141,6 +1248,70 @@ Implementation
                             asml.remove(p);
                             p.free;
                             p:=hp1;
+                          end
+                        {
+                          from
+                          and reg1,reg0,2^n-1
+                          mov reg2,reg1, lsl imm1
+                          (mov reg3,reg2, lsr/asr imm1)
+                          remove either the and or the lsl/xsr sequence if possible
+                        }
+
+                        else if cutils.ispowerof2(taicpu(p).oper[2]^.val+1,i) and
+                          GetNextInstructionUsingReg(p,hp1,taicpu(p).oper[0]^.reg) and
+                          MatchInstruction(hp1, A_MOV, [taicpu(p).condition], [PF_None]) and
+                          (taicpu(hp1).ops=3) and
+                          MatchOperand(taicpu(hp1).oper[1]^, taicpu(p).oper[0]^.reg) and
+                          (taicpu(hp1).oper[2]^.typ = top_shifterop) and
+                          (taicpu(hp1).oper[2]^.shifterop^.rs = NR_NO) and
+                          (taicpu(hp1).oper[2]^.shifterop^.shiftmode=SM_LSL) and
+                          RegEndOfLife(taicpu(p).oper[0]^.reg,taicpu(hp1)) then
+                          begin
+                            {
+                              and reg1,reg0,2^n-1
+                              mov reg2,reg1, lsl imm1
+                              mov reg3,reg2, lsr/asr imm1
+                              =>
+                              and reg1,reg0,2^n-1
+                              if lsr and 2^n-1>=imm1 or asr and 2^n-1>imm1
+                            }
+                            if GetNextInstructionUsingReg(hp1,hp2,taicpu(p).oper[0]^.reg) and
+                              MatchInstruction(hp2, A_MOV, [taicpu(p).condition], [PF_None]) and
+                              (taicpu(hp2).ops=3) and
+                              MatchOperand(taicpu(hp2).oper[1]^, taicpu(hp1).oper[0]^.reg) and
+                              (taicpu(hp2).oper[2]^.typ = top_shifterop) and
+                              (taicpu(hp2).oper[2]^.shifterop^.rs = NR_NO) and
+                              (taicpu(hp2).oper[2]^.shifterop^.shiftmode in [SM_ASR,SM_LSR]) and
+                              (taicpu(hp1).oper[2]^.shifterop^.shiftimm=taicpu(hp2).oper[2]^.shifterop^.shiftimm) and
+                              RegEndOfLife(taicpu(hp1).oper[0]^.reg,taicpu(hp2)) and
+                              ((i<32-taicpu(hp1).oper[2]^.shifterop^.shiftimm) or
+                              ((i=32-taicpu(hp1).oper[2]^.shifterop^.shiftimm) and
+                               (taicpu(hp2).oper[2]^.shifterop^.shiftmode=SM_LSR))) then
+                              begin
+                                DebugMsg('Peephole AndLslXsr2And done', p);
+                                taicpu(p).oper[0]^.reg:=taicpu(hp2).oper[0]^.reg;
+                                asml.Remove(hp1);
+                                asml.Remove(hp2);
+                                hp1.free;
+                                hp2.free;
+                                result:=true;
+                              end
+                            {
+                              and reg1,reg0,2^n-1
+                              mov reg2,reg1, lsl imm1
+                              =>
+                              mov reg2,reg1, lsl imm1
+                              if imm1>i
+                            }
+                            else if i>32-taicpu(hp1).oper[2]^.shifterop^.shiftimm then
+                              begin
+                                DebugMsg('Peephole AndLsl2Lsl done', p);
+                                taicpu(hp1).oper[1]^.reg:=taicpu(p).oper[0]^.reg;
+                                asml.Remove(p);
+                                p.free;
+                                p:=hp1;
+                                result:=true;
+                              end
                           end;
                       end;
                     {
@@ -1410,7 +1581,8 @@ Implementation
                       into
                       b         abc
                     }
-                    if MatchInstruction(p, A_STM, [C_None], [PF_FD]) and
+                    if not(ts_thumb_interworking in current_settings.targetswitches) and
+                       MatchInstruction(p, A_STM, [C_None], [PF_FD]) and
                       GetNextInstruction(p, hp1) and
                       GetNextInstruction(hp1, hp2) and
                       SkipEntryExitMarker(hp2, hp2) and
@@ -1428,27 +1600,19 @@ Implementation
                       MatchInstruction(hp1, A_SUB, [C_None], [PF_NONE]) and
                       (taicpu(hp1).oper[0]^.typ = top_reg) and
                       (taicpu(hp1).oper[0]^.reg = NR_STACK_POINTER_REG) and
-                      (taicpu(hp1).oper[1]^.typ = top_reg) and
-                      (taicpu(hp1).oper[1]^.reg = NR_STACK_POINTER_REG) and
+                      MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp1).oper[1]^) and
                       (taicpu(hp1).oper[2]^.typ = top_const) and
 
                       MatchInstruction(hp3, A_ADD, [C_None], [PF_NONE]) and
-                      (taicpu(hp3).oper[0]^.typ = top_reg) and
-                      (taicpu(hp3).oper[0]^.reg = NR_STACK_POINTER_REG) and
-                      (taicpu(hp3).oper[1]^.typ = top_reg) and
-                      (taicpu(hp3).oper[1]^.reg = NR_STACK_POINTER_REG) and
-                      (taicpu(hp3).oper[2]^.typ = top_const) and
-                      (taicpu(hp1).oper[2]^.val = taicpu(hp3).oper[2]^.val) and
+                      MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp3).oper[0]^) and
+                      MatchOperand(taicpu(hp1).oper[0]^,taicpu(hp3).oper[1]^) and
+                      MatchOperand(taicpu(hp1).oper[2]^,taicpu(hp3).oper[2]^) and
 
                       MatchInstruction(hp2, [A_BL,A_BLX], [C_None], [PF_NONE]) and
                       (taicpu(hp2).oper[0]^.typ = top_ref) and
 
                       MatchInstruction(hp4, A_LDM, [C_None], [PF_FD]) and
-                      (taicpu(hp4).oper[0]^.typ = top_ref) and
-                      (taicpu(hp4).oper[0]^.ref^.index=NR_STACK_POINTER_REG) and
-                      (taicpu(hp4).oper[0]^.ref^.base=NR_NO) and
-                      (taicpu(hp4).oper[0]^.ref^.offset=0) and
-                      (taicpu(hp4).oper[0]^.ref^.addressmode=AM_PREINDEXED) and
+                      MatchOperand(taicpu(p).oper[0]^,taicpu(hp4).oper[0]^) and
                       (taicpu(hp4).oper[1]^.typ = top_regset) and
                       (taicpu(hp4).oper[1]^.regset^ = [RS_R15]) then
                       begin

compiler/cgobj.pas

@@ -1848,8 +1848,6 @@ implementation
 
 
     procedure tcg.a_loadmm_loc_reg(list: TAsmList; size: tcgsize; const loc: tlocation; const reg: tregister;shuffle : pmmshuffle);
-      var
-        tmpreg: tregister;
       begin
         case loc.loc of
           LOC_MMREGISTER,LOC_CMMREGISTER:

compiler/fppu.pas

@@ -947,7 +947,6 @@ var
       var
         b : byte;
         newmodulename : string;
-        ns: string;
       begin
        { read interface part }
          repeat

compiler/globtype.pas

@@ -225,7 +225,8 @@ interface
          { when automatically generating getters/setters for properties, use
            these strings as prefixes for the generated getters/setter names }
          ts_auto_getter_prefix,
-         ts_auto_setter_predix
+         ts_auto_setter_predix,
+         ts_thumb_interworking
        );
        ttargetswitches = set of ttargetswitch;
 
@@ -300,7 +301,8 @@ interface
          (name: 'COMPACTINTARRAYINIT'; hasvalue: false),
          (name:  'ENUMFIELDINIT';      hasvalue: false),
          (name: 'AUTOGETTERPREFIX';    hasvalue: true ),
-         (name: 'AUTOSETTERPREFIX';    hasvalue: true )
+         (name: 'AUTOSETTERPREFIX';    hasvalue: true ),
+         (name: 'THUMBINTERWORKING';   hasvalue: true )
        );
 
        { switches being applied to all CPUs at the given level }

compiler/m68k/cpupara.pas

@@ -87,6 +87,7 @@ unit cpupara;
               loc:=LOC_REFERENCE;
               reference.index:=NR_STACK_POINTER_REG;
               reference.offset:=target_info.first_parm_offset+nr*4;
+              size:=OS_INT;
            end;
       end;
 

compiler/m68k/n68kadd.pas

@@ -267,10 +267,10 @@ implementation
              begin
                 if nf_swapped in flags then
                   case nodetype of
-                     ltn : getresflags:=F_GE;
-                     lten : getresflags:=F_G;
-                     gtn : getresflags:=F_LE;
-                     gten : getresflags:=F_L;
+                     ltn : getresflags:=F_G;
+                     lten : getresflags:=F_GE;
+                     gtn : getresflags:=F_L;
+                     gten : getresflags:=F_LE;
                   end
                 else
                   case nodetype of
@@ -284,10 +284,10 @@ implementation
              begin
                 if nf_swapped in flags then
                   case nodetype of
-                     ltn : getresflags:=F_AE;
-                     lten : getresflags:=F_A;
-                     gtn : getresflags:=F_BE;
-                     gten : getresflags:=F_B;
+                     ltn : getresflags:=F_A;
+                     lten : getresflags:=F_AE;
+                     gtn : getresflags:=F_B;
+                     gten : getresflags:=F_BE;
                   end
                 else
                   case nodetype of

compiler/mips/cpugas.pas

@@ -100,7 +100,7 @@ unit cpugas;
          { ABI selection }
          Replace(result,'$ABI','-mabi='+abitypestr[mips_abi]);
          { ARCH selection }
-         Replace(result,'$ARCH','-march='+cputypestr[mips_cpu]);
+         Replace(result,'$ARCH','-march='+lower(cputypestr[mips_cpu]));
       end;
 
 {****************************************************************************}

compiler/mips/cpuinfo.pas

@@ -77,16 +77,17 @@ Const
    ];
 
    { cpu strings as accepted by 
-     GNU assembler in -arch=XXX option }
+     GNU assembler in -arch=XXX option 
+     this ilist needs to be uppercased }
    cputypestr : array[tcputype] of string[8] = ('',
-     { cpu_mips_default } 'mips2',
-     { cpu_mips1        } 'mips1',
-     { cpu_mips2        } 'mips2',
-     { cpu_mips3        } 'mips3',
-     { cpu_mips4        } 'mips4',
-     { cpu_mips5        } 'mips5',
-     { cpu_mips32       } 'mips32',
-     { cpu_mips32r2     } 'mips32r2'
+     { cpu_mips_default } 'MIPS2',
+     { cpu_mips1        } 'MIPS1',
+     { cpu_mips2        } 'MIPS2',
+     { cpu_mips3        } 'MIPS3',
+     { cpu_mips4        } 'MIPS4',
+     { cpu_mips5        } 'MIPS5',
+     { cpu_mips32       } 'MIPS32',
+     { cpu_mips32r2     } 'MIPS32R2'
    );
 
    mips_cpu : tcputype = cpu_mips_default;

compiler/msg/errore.msg

@@ -392,7 +392,7 @@ scan_w_setpeoptflags_not_support=02092_W_SETPEOPTFLAGS is not supported by the t
 #
 # Parser
 #
-# 03327 is the last used one
+# 03331 is the last used one
 #
 % \section{Parser messages}
 % This section lists all parser messages. The parser takes care of the
@@ -1385,8 +1385,8 @@ parser_e_no_destructor_in_records=03300_E_Destructors aren't allowed in records
 parser_e_class_methods_only_static_in_records=03301_E_Class methods must be static in records
 % Class methods declarations aren't allowed in records without static modifier.
 % Records have no inheritance and therefore non static class methods have no sence for them.
-parser_e_no_constructor_in_records=03302_E_Constructors aren't allowed in records or record helpers
-% Constructor declarations aren't allowed in records or record helpers.
+parser_e_no_parameterless_constructor_in_records=03302_E_Parameterless constructors aren't allowed in records or record helpers
+% Constructor declarations with no arguments aren't allowed in records or record helpers.
 parser_e_at_least_one_argument_must_be_of_type=03303_E_Either the result or at least one parameter must be of type "$1"
 % It is required that either the result of the routine or at least one of its parameters be of the specified type.
 % For example class operators either take an instance of the structured type in which they are defined, or they return one.
@@ -1471,6 +1471,18 @@ parser_w_case_difference_auto_property_getter_setter_prefix=03327_W_Case mismatc
 % not can it add one using the correct case (it could conflict with the original declaration).
 % Manually correct the case of the getter/setter to conform to the desired coding rules.
 % \var{TChild} overrides
+parser_e_no_consts_in_local_anonymous_records=03328_E_Constants declarations are not allowed in local or anonymous records
+% Records with constants must be defined globally. Constants cannot be defined inside records which are defined in a
+% procedure or function or in anonymous records.
+parser_e_no_methods_in_local_anonymous_records=03329_E_Method declarations are not allowed in local or anonymous records
+% Records with methods must be defined globally. Methods cannot be defined inside records which are defined in a
+% procedure or function or in anonymous records.
+parser_e_no_properties_in_local_anonymous_records=03330_E_Property declarations are not allowed in local or anonymous records
+% Records with properties must be defined globally. Properties cannot be defined inside records which are defined in a
+% procedure or function or in anonymous records.
+parser_e_no_class_in_local_anonymous_records=03331_E_Class memeber declarations are not allowed in local or anonymous records
+% Records with class members must be defined globally. Class members cannot be defined inside records which are defined in a
+% procedure or function or in anonymous records.
 %
 % \end{description}
 %
@@ -3614,6 +3626,7 @@ A*2WP<x>_Minimum iOS deployment version: 3.0, 5.0.1, ... (Darwin)
 A*2WR_Generate relocation code (Windows)
 P*2WT_Specify MPW tool type application (Classic Mac OS)
 **2WX_Enable executable stack (Linux)
+A*2Wx_Generate thumb interworking safe code if possible
 **1X_Executable options:
 **2Xc_Pass --shared/-dynamic to the linker (BeOS, Darwin, FreeBSD, Linux)
 **2Xd_Do not search default library path (sometimes required for cross-compiling when not using -XR)

compiler/msgidx.inc

@@ -397,7 +397,7 @@ const
   parser_e_no_record_published=03299;
   parser_e_no_destructor_in_records=03300;
   parser_e_class_methods_only_static_in_records=03301;
-  parser_e_no_constructor_in_records=03302;
+  parser_e_no_parameterless_constructor_in_records=03302;
   parser_e_at_least_one_argument_must_be_of_type=03303;
   parser_e_cant_use_type_parameters_here=03304;
   parser_e_externals_no_section=03305;
@@ -423,6 +423,10 @@ const
   parser_e_cannot_generate_property_getter_setter=03325;
   parser_w_overriding_property_getter_setter=03326;
   parser_w_case_difference_auto_property_getter_setter_prefix=03327;
+  parser_e_no_consts_in_local_anonymous_records=03328;
+  parser_e_no_methods_in_local_anonymous_records=03329;
+  parser_e_no_properties_in_local_anonymous_records=03330;
+  parser_e_no_class_in_local_anonymous_records=03331;
   type_e_mismatch=04000;
   type_e_incompatible_types=04001;
   type_e_not_equal_types=04002;
@@ -963,9 +967,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 68093;
+  MsgTxtSize = 68471;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,93,328,120,87,56,126,26,202,63,
+    26,93,332,120,87,56,126,26,202,63,
     54,20,1,1,1,1,1,1,1,1
   );

compiler/ncal.pas

@@ -23,6 +23,8 @@ unit ncal;
 
 {$i fpcdefs.inc}
 
+{ $define DEBUGINLINE}
+
 interface
 
     uses
@@ -2300,7 +2302,11 @@ implementation
           function call }
         if not paramanager.ret_in_param(resultdef,procdefinition) then
           begin
-            result:=true;
+            { don't replace the function result if we are inlining and if the destination is complex, this
+              could lead to lengthy code in case the function result is used often and it is assigned e.g.
+              to a threadvar }
+            result:=not(cnf_do_inline in callnodeflags) or
+              (node_complexity(aktassignmentnode.left)<=1);
             exit;
           end;
 

compiler/ncgcal.pas

@@ -493,8 +493,6 @@ implementation
 
     procedure tcgcallnode.copy_back_paras;
       var
-        hp,
-        hp2 : tnode;
         ppn : tcallparanode;
       begin
         ppn:=tcallparanode(left);

compiler/ncgcnv.pas

@@ -513,9 +513,9 @@ interface
       end;
 
     procedure Tcgtypeconvnode.second_nil_to_methodprocvar;
-
+    {$ifdef jvm}
     var r:Treference;
-
+    {$endif}
     begin
 {$ifdef jvm}
 {$ifndef nounsupported}

compiler/ncnv.pas

@@ -1996,7 +1996,6 @@ implementation
     function ttypeconvnode.typecheck_proc_to_procvar : tnode;
       var
         pd : tabstractprocdef;
-        nestinglevel : byte;
       begin
         result:=nil;
         pd:=tabstractprocdef(left.resultdef);

compiler/ngenutil.pas

@@ -264,7 +264,6 @@ implementation
       stat: tstatementnode;
       block: tnode;
       psym: tsym;
-      tcinitproc: tprocdef;
     begin
       result:=maybe_insert_trashing(pd,n);
       if target_info.system in systems_typed_constants_node_init then
@@ -291,7 +290,6 @@ implementation
                     if (psym.typ<>procsym) or
                        (tprocsym(psym).procdeflist.count<>1) then
                       internalerror(2011040301);
-                    tcinitproc:=tprocdef(tprocsym(psym).procdeflist[0]);
                     addstatement(stat,ccallnode.create(nil,tprocsym(psym),
                       pd.struct.symtable,nil,[]));
                   end;

compiler/nmem.pas

@@ -168,30 +168,39 @@ implementation
         case left.resultdef.typ of
           classrefdef :
             resultdef:=left.resultdef;
-          objectdef,
-          recorddef:
-            { access to the classtype while specializing? }
-            if (df_generic in left.resultdef.defoptions) then
-              begin
-                defaultresultdef:=true;
-                if assigned(current_structdef) then
-                  begin
-                    if assigned(current_structdef.genericdef) then
-                      if current_structdef.genericdef=left.resultdef then
+          recorddef,
+          objectdef:
+            begin
+              if (left.resultdef.typ=objectdef) or
+                 ((target_info.system in systems_jvm) and
+                  (left.resultdef.typ=recorddef)) then
+                begin
+                  { access to the classtype while specializing? }
+                  if (df_generic in left.resultdef.defoptions) then
+                    begin
+                      defaultresultdef:=true;
+                      if assigned(current_structdef) then
                         begin
-                          resultdef:=tclassrefdef.create(current_structdef);
-                          defaultresultdef:=false;
+                          if assigned(current_structdef.genericdef) then
+                            if current_structdef.genericdef=left.resultdef then
+                              begin
+                                resultdef:=tclassrefdef.create(current_structdef);
+                                defaultresultdef:=false;
+                              end
+                            else
+                              CGMessage(parser_e_cant_create_generics_of_this_type);
                         end
                       else
-                        CGMessage(parser_e_cant_create_generics_of_this_type);
-                  end
-                else
-                  message(parser_e_cant_create_generics_of_this_type);
-                if defaultresultdef then
-                  resultdef:=tclassrefdef.create(left.resultdef);
-              end
-            else
-              resultdef:=tclassrefdef.create(left.resultdef);
+                        message(parser_e_cant_create_generics_of_this_type);
+                      if defaultresultdef then
+                        resultdef:=tclassrefdef.create(left.resultdef);
+                    end
+                  else
+                    resultdef:=tclassrefdef.create(left.resultdef);
+                end
+              else
+                CGMessage(parser_e_pointer_to_class_expected);
+            end
           else
             CGMessage(parser_e_pointer_to_class_expected);
         end;
@@ -467,6 +476,7 @@ implementation
          hp  : tnode;
          hsym : tfieldvarsym;
          isprocvar : boolean;
+         offset: asizeint;
       begin
         result:=nil;
         typecheckpass(left);
@@ -575,10 +585,26 @@ implementation
 {$endif i386}
                (tabsolutevarsym(tloadnode(hp).symtableentry).abstyp=toaddr) then
                begin
+                 offset:=tabsolutevarsym(tloadnode(hp).symtableentry).addroffset;
+                 hp:=left;
+                 while assigned(hp)and(hp.nodetype=subscriptn) do
+                   begin
+                     hsym:=tsubscriptnode(hp).vs;
+                     if tabstractrecordsymtable(hsym.owner).is_packed then
+                       begin
+                         { can't calculate the address of a non-byte aligned field }
+                         if (hsym.fieldoffset mod 8)<>0 then
+                           exit;
+                         inc(offset,hsym.fieldoffset div 8)
+                       end
+                     else
+                       inc(offset,hsym.fieldoffset);
+                     hp:=tunarynode(hp).left;
+                   end;
                  if nf_typedaddr in flags then
-                   result:=cpointerconstnode.create(tabsolutevarsym(tloadnode(hp).symtableentry).addroffset,getpointerdef(left.resultdef))
+                   result:=cpointerconstnode.create(offset,getpointerdef(left.resultdef))
                  else
-                   result:=cpointerconstnode.create(tabsolutevarsym(tloadnode(hp).symtableentry).addroffset,voidpointertype);
+                   result:=cpointerconstnode.create(offset,voidpointertype);
                  exit;
                end
               else if (nf_internal in flags) or

compiler/nset.pas

@@ -98,6 +98,7 @@ interface
           procedure buildderefimpl;override;
           procedure derefimpl;override;
           function dogetcopy : tnode;override;
+          procedure printnodetree(var t:text);override;
           procedure insertintolist(l : tnodelist);override;
           function pass_typecheck:tnode;override;
           function pass_1 : tnode;override;
@@ -829,7 +830,6 @@ implementation
 
 
     function tcasenode.dogetcopy : tnode;
-
       var
          n : tcasenode;
          i : longint;
@@ -858,11 +858,42 @@ implementation
          dogetcopy:=n;
       end;
 
-    procedure tcasenode.insertintolist(l : tnodelist);
 
+    procedure tcasenode.printnodetree(var t: text);
+      var
+        i : longint;
+      begin
+        write(t,printnodeindention,'(');
+        printnodeindent;
+        printnodeinfo(t);
+        writeln(t);
+        printnode(t,left);
+        for i:=0 to blocks.count-1 do
+          begin
+            writeln(t,printnodeindention,'(caseblock blockid: ',i);
+            printnodeindent;
+            printnode(t,pcaseblock(blocks[i])^.statement);
+            printnodeunindent;
+            writeln(t,printnodeindention,')');
+          end;
+        if assigned(elseblock) then
+          begin
+            writeln(t,printnodeindention,'(else: ',i);
+            printnodeindent;
+            printnode(t,elseblock);
+            printnodeunindent;
+            writeln(t,printnodeindention,')');
+          end;
+        printnodeunindent;
+        writeln(t,printnodeindention,')');
+      end;
+
+
+    procedure tcasenode.insertintolist(l : tnodelist);
       begin
       end;
 
+
     function caselabelsequal(n1,n2: pcaselabel): boolean;
       begin
         result :=

compiler/optcse.pas

@@ -133,7 +133,7 @@ unit optcse;
         end;
 
       var
-        i,j : longint;
+        i : longint;
       begin
         result:=fen_false;
         { don't add the tree below an untyped const parameter: there is

compiler/options.pas

@@ -1917,7 +1917,19 @@ begin
                           end
                         else
                           IllegalPara(opt);
-                      end
+                      end;
+                    'x':
+                      begin
+                        if target_info.cpu=systems.cpu_arm then
+                          begin
+                            if UnsetBool(More, j, opt, false) then
+                              exclude(init_settings.targetswitches,ts_thumb_interworking)
+                            else
+                              include(init_settings.targetswitches,ts_thumb_interworking);
+                          end
+                        else
+                          IllegalPara(opt);
+                      end;
                     else
                       IllegalPara(opt);
                   end;
@@ -2726,8 +2738,8 @@ var
   abi : tabi;
 {$if defined(arm) or defined(avr)}
   cpuflag : tcpuflags;
-{$endif defined(arm) or defined(avr)}
   hs : string;
+{$endif defined(arm) or defined(avr)}
 begin
   option:=coption.create;
   disable_configfile:=false;

compiler/pdecl.pas

@@ -839,7 +839,13 @@ implementation
         consume(_THREADVAR);
         if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
           message(parser_e_threadvars_only_sg);
-        read_var_decls([vd_threadvar]);
+        if f_threading in features then
+          read_var_decls([vd_threadvar])
+        else
+          begin
+            Message(parser_f_unsupported_feature);
+            read_var_decls([]);
+          end;
       end;
 
 

compiler/pdecobj.pas

@@ -901,11 +901,7 @@ implementation
               if is_objectpascal_helper(astruct) then
                 if is_classdef then
                   { class constructors are not allowed in class helpers }
-                  Message(parser_e_no_class_constructor_in_helpers)
-                else if is_record(tobjectdef(astruct).extendeddef) then
-                  { as long as constructors aren't allowed in records they
-                    aren't allowed in helpers either }
-                  Message(parser_e_no_constructor_in_records);
+                  Message(parser_e_no_class_constructor_in_helpers);
 
               { only 1 class constructor is allowed }
               if is_classdef and (oo_has_class_constructor in astruct.objectoptions) then
@@ -916,7 +912,15 @@ implementation
               if is_classdef then
                 result:=class_constructor_head(current_structdef)
               else
-                result:=constructor_head;
+                begin
+                  result:=constructor_head;
+                  if is_objectpascal_helper(astruct) and
+                     is_record(tobjectdef(astruct).extendeddef) and
+                     (result.minparacount=0) then
+                      { as long as parameterless constructors aren't allowed in records they
+                       aren't allowed in helpers either }
+                    MessagePos(result.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records);
+                end;
 
               chkcpp(result);
 

compiler/pexpr.pas

@@ -226,7 +226,6 @@ implementation
          hdef  : tdef;
          temp  : ttempcreatenode;
          newstatement : tstatementnode;
-         procinfo : tprocinfo;
        begin
          { Properties are not allowed, because the write can
            be different from the read }
@@ -923,7 +922,10 @@ implementation
                begin
                  { We are calling from the static class method which has no self node }
                  if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
-                   p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
+                   if st.symtabletype=recordsymtable then
+                     p1:=ctypenode.create(current_procinfo.procdef.struct)
+                   else
+                     p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))
                  else
                    p1:=load_self_node;
                  { We are calling a member }
@@ -2445,7 +2447,10 @@ implementation
                           if assigned(current_structdef) and
                               (((current_structdef<>hdef) and is_owned_by(current_structdef,hdef)) or
                                (sp_static in srsym.symoptions)) then
-                            p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
+                            if srsymtable.symtabletype=recordsymtable then
+                              p1:=ctypenode.create(hdef)
+                            else
+                              p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
                           else
                           if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
                             p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef.struct))

compiler/pmodules.pas

@@ -1011,7 +1011,7 @@ type
         force_init_final : boolean;
         init_procinfo,
         finalize_procinfo : tcgprocinfo;
-        i,idx : longint;
+        i : longint;
         ag : boolean;
         finishstate : tfinishstate;
         globalstate : tglobalstate;

compiler/psub.pas

@@ -493,7 +493,11 @@ implementation
                        end;
                     end
                 else
-                  if not is_record(current_structdef) then
+                  if not is_record(current_structdef) and
+                     not (
+                            is_objectpascal_helper(current_structdef) and
+                            is_record(tobjectdef(current_structdef).extendeddef)
+                          ) then
                     internalerror(200305103);
                 { if self=nil then exit
                   calling fail instead of exit is useless because

compiler/ptype.pas

@@ -520,6 +520,13 @@ implementation
 
 
     procedure parse_record_members;
+
+      function IsAnonOrLocal: Boolean;
+        begin
+          result:=(current_structdef.objname^='') or
+                  not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]);
+        end;
+
       var
         pd : tprocdef;
         oldparse_only: boolean;
@@ -544,8 +551,7 @@ implementation
                 member_blocktype:=bt_type;
 
                 { local and anonymous records can not have inner types. skip top record symtable }
-                if (current_structdef.objname^='') or
-                   not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]) then
+                if IsAnonOrLocal then
                   Message(parser_e_no_types_in_local_anonymous_records);
               end;
             _VAR :
@@ -560,6 +566,10 @@ implementation
               begin
                 consume(_CONST);
                 member_blocktype:=bt_const;
+
+                { local and anonymous records can not have constants. skip top record symtable }
+                if IsAnonOrLocal then
+                  Message(parser_e_no_consts_in_local_anonymous_records);
               end;
             _ID, _CASE, _OPERATOR :
               begin
@@ -661,6 +671,8 @@ implementation
               end;
             _PROPERTY :
               begin
+                if IsAnonOrLocal then
+                  Message(parser_e_no_properties_in_local_anonymous_records);
                 struct_property_dec(is_classdef);
                 fields_allowed:=false;
                 is_classdef:=false;
@@ -676,17 +688,24 @@ implementation
                    not((token=_ID) and (idtoken=_OPERATOR)) then
                   Message(parser_e_procedure_or_function_expected);
 
+                if IsAnonOrLocal then
+                  Message(parser_e_no_class_in_local_anonymous_records);
+
                 is_classdef:=true;
               end;
             _PROCEDURE,
             _FUNCTION:
               begin
+                if IsAnonOrLocal then
+                  Message(parser_e_no_methods_in_local_anonymous_records);
                 pd:=parse_record_method_dec(current_structdef,is_classdef);
                 fields_allowed:=false;
                 is_classdef:=false;
               end;
             _CONSTRUCTOR :
               begin
+                if IsAnonOrLocal then
+                  Message(parser_e_no_methods_in_local_anonymous_records);
                 if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
                   Message(parser_w_constructor_should_be_public);
 
@@ -699,7 +718,11 @@ implementation
                 if is_classdef then
                   pd:=class_constructor_head(current_structdef)
                 else
-                  pd:=constructor_head;
+                  begin
+                    pd:=constructor_head;
+                    if pd.minparacount = 0 then
+                      MessagePos(pd.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records);
+                  end;
 
                 parse_only:=oldparse_only;
                 fields_allowed:=false;
@@ -707,6 +730,8 @@ implementation
               end;
             _DESTRUCTOR :
               begin
+                if IsAnonOrLocal then
+                  Message(parser_e_no_methods_in_local_anonymous_records);
                 if not is_classdef then
                   Message(parser_e_no_destructor_in_records);
 

compiler/scanner.pas

@@ -933,6 +933,7 @@ In case not, the value returned can be arbitrary.
            setElemType : TCTETypeSet;
 
         begin
+           read_factor:='';
            if current_scanner.preproc_token=_ID then
              begin
                 if current_scanner.preproc_pattern='DEFINED' then

compiler/symtable.pas

@@ -1023,7 +1023,7 @@ implementation
 
     procedure tabstractrecordsymtable.addfieldlist(list: tfpobjectlist; maybereorder: boolean);
       var
-        fieldvs, insertfieldvs, bestfieldvs: tfieldvarsym;
+        fieldvs, insertfieldvs: tfieldvarsym;
         base, fieldoffset, space, insertfieldsize, insertfieldoffset, bestinsertfieldoffset, bestspaceleft: asizeint;
         i, j, bestfieldindex: longint;
         globalfieldalignment,
@@ -1955,9 +1955,14 @@ implementation
         while assigned(symtable) and (symtable.symtabletype in [ObjectSymtable,recordsymtable]) do
           begin
             if (result='') then
-              result:=symtable.name^
+              if symtable.name<>nil then
+                result:=symtable.name^
+              else
             else
-              result:=symtable.name^+delimiter+result;
+              if symtable.name<>nil then
+                result:=symtable.name^+delimiter+result
+              else
+                result:=delimiter+result;
             symtable:=symtable.defowner.owner;
           end;
       end;
@@ -2986,7 +2991,6 @@ implementation
     function  search_system_proc(const s: TIDString): tprocdef;
       var
         srsym: tsym;
-        pd: tprocdef;
       begin
         srsym:=tsym(systemunit.find(s));
         if not assigned(srsym) and
@@ -3233,7 +3237,6 @@ implementation
     function search_struct_member(pd : tabstractrecorddef;const s : string):tsym;
     { searches n in symtable of pd and all anchestors }
       var
-        srsym      : tsym;
         srsymtable : tsymtable;
       begin
         { in case this is a formal class, first find the real definition }

compiler/x86/itx86int.pas

@@ -60,22 +60,17 @@ implementation
 
     function findreg_by_intname(const s:string):integer;
       var
-        i,p : integer;
-        s1: string;
-
         l,r,m: integer;
       begin
         {Binary search.}
-        p:=0;
-        i := (high(tregisterindex) + 1) shr 1;
-           l := 0;
-           r := high(tregisterindex) + 1;
-           while l < r do
-           begin
-              m := (l + r) div 2;
-              if int_regname_table[int_regname_index[m]] < s then l := m + 1
-              else r := m;
-           end;
+        l := 0;
+        r := high(tregisterindex) + 1;
+        while l < r do
+          begin
+            m := (l + r) div 2;
+            if int_regname_table[int_regname_index[m]] < s then l := m + 1
+            else r := m;
+          end;
 
         if int_regname_table[int_regname_index[r]]=s then
           findreg_by_intname:=int_regname_index[r]

compiler/x86/rax86.pas

@@ -345,7 +345,6 @@ var
   memrefsize: integer;
   memopsize: integer;
   memoffset: asizeint;
-  s1: string;
 begin
   ExistsMemRefNoSize := false;
   ExistsMemRef       := false;

compiler/x86_64/cpuelf.pas

@@ -212,8 +212,11 @@ implementation
         R_X86_64_PLTOFF64,
         R_X86_64_GOTPLT64:
           begin
-            objsym:=ObjReloc.symbol.exesymbol.ObjSymbol;
-            objsym.refs:=objsym.refs or symref_plt;
+            if assigned(ObjReloc.symbol) and assigned(ObjReloc.symbol.exesymbol) then
+              begin
+                objsym:=ObjReloc.symbol.exesymbol.ObjSymbol;
+                objsym.refs:=objsym.refs or symref_plt;
+              end;
           end;
       end;
 

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

@@ -30,7 +30,13 @@ TYpe
   TVisitorOption = (voRead,voReadList,voCreate,voDelete,voUpdate,
                     voCommonSetupParams,voSingleSaveVisitor,voRegisterVisitors);
   TVisitorOptions = set of TVisitorOption;
-  
+
+  { TTiOPFFieldPropDef }
+
+  TTiOPFFieldPropDef = Class(TFieldPropDef)
+  Public
+    Constructor Create(ACollection : TCollection); override;
+  end;
   { TTiOPFCodeOptions }
 
   TTiOPFCodeOptions = Class (TClassCodeGeneratorOptions)
@@ -100,6 +106,7 @@ TYpe
     // Not to be overridden.
     procedure WriteListAddObject(Strings: TStrings; const ListClassName, ObjectClassName: String);
     // Overrides of parent objects
+    Function CreateFieldPropDefs : TFieldPropDefs; override;
     function AllowPropertyDeclaration(F: TFieldPropDef; AVisibility: TVisibilities): Boolean; override;
     Function GetInterfaceUsesClause : string; override;
     procedure WriteVisibilityStart(V: TVisibility; Strings: TStrings); override;
@@ -134,6 +141,14 @@ begin
     Delete(Result,1,1);
 end;
 
+{ TTiOPFFieldPropDef }
+
+constructor TTiOPFFieldPropDef.Create(ACollection: TCollection);
+begin
+  inherited Create(ACollection);
+  PropSetters:=[psWrite];
+end;
+
 { TTiOPFCodeOptions }
 
 function TTiOPFCodeOptions.GetListClassName: String;
@@ -872,7 +887,7 @@ begin
       ptSingle, ptDouble, ptExtended, ptComp :
         S:='AsFloat';
       ptCurrency :
-        S:='AsCurrency';
+        S:='AsFloat';
       ptDateTime :
         S:='AsDateTime';
       ptEnumerated :
@@ -1139,7 +1154,7 @@ begin
       AddLn(Strings,'Public');
     IncIndent;
     Try
-      AddLn(Strings,'Property Items[Index : Integer] : %s Read GetObj Write SetObj; Default;',[ObjectClassname]);
+      AddLn(Strings,'Property Items[AIndex : Integer] : %s Read GetObj Write SetObj; Default;',[ObjectClassname]);
     Finally
       DecIndent;
     end;
@@ -1178,6 +1193,11 @@ begin
    Addln(Strings);
 end;
 
+function TTiOPFCodeGenerator.CreateFieldPropDefs: TFieldPropDefs;
+begin
+  Result:=TFieldPropDefs.Create(TTiOPFFieldPropDef);
+end;
+
 function TTiOPFCodeGenerator.AllowPropertyDeclaration(F: TFieldPropDef;
   AVisibility: TVisibilities): Boolean;
 begin

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

@@ -38,6 +38,8 @@ Type
   TVisibility = (vPrivate,vProtected,vPublic,vPublished);
   TVisibilities = Set of TVisibility;
   TPropAccess = (paReadWrite,paReadonly,paWriteonly);
+  TPropSetter = (psRead,psWrite);
+  TPropSetters = set of TPropSetter;
 
 
   TFieldPropDefs = Class;
@@ -51,6 +53,7 @@ Type
     FFieldType: TFieldType;
     FPropAccess: TPropAccess;
     FPropDef: String;
+    FPropSetters: TPropSetters;
     FPropType : TPropType;
     FPRopSize: Integer;
     FPropName : String;
@@ -66,8 +69,8 @@ Type
     Constructor Create(ACollection : TCollection) ; override;
     Procedure Assign(ASource : TPersistent); override;
     Function FieldPropDefs : TFieldPropDefs;
-    Function HasGetter : Boolean; Virtual; // Always false.
-    Function HasSetter : Boolean; Virtual; // True for streams/strings
+    Function HasGetter : Boolean; Virtual; // Checks Propsetters for psRead
+    Function HasSetter : Boolean; Virtual; // True for streams/strings or if Propsetters has pswrite
     Function ObjPasTypeDef : String; virtual; // Object pascal definition of type
     Function ObjPasReadDef : String; virtual; // Object pascal definition of getter
     Function ObjPasWriteDef : String; virtual; // Object pascal definition of setter
@@ -81,6 +84,7 @@ Type
     Property PropertyDef : String Read FPropDef Write FPropDef;
     Property PropertyVisibility : TVisibility Read FPropVis Write FPropVis;
     Property PropertyAccess : TPropAccess Read FPropAccess Write FPropAccess;
+    Property PropSetters : TPropSetters Read FPropSetters Write FPropSetters;
   end;
   
   { TFieldPropDefs }
@@ -113,6 +117,7 @@ Type
     FInterfaceUnits: String;
     FOptions: TCodeOptions;
     FUnitName: String;
+    FExtraSetterLine : string;
     procedure SetImplementationUnits(const AValue: String);
     procedure SetInterfaceUnits(const AValue: String);
     procedure SetUnitname(const AValue: String);
@@ -122,9 +127,15 @@ Type
     Constructor create; virtual;
     Procedure Assign(ASource : TPersistent); override;
   Published
+    // Line of code that will be added to each property setter. Use %PROPNAME% to include property name in the line.
+    Property ExtraSetterLine : String Read FExtraSetterLine Write FExtraSetterLine;
+    // options
     Property Options : TCodeOptions Read FOptions Write SetOPtions;
+    // Name of unit if a unit is generated.
     Property UnitName : String Read FUnitName Write SetUnitname;
+    // Comma-separated list of  units that will be put in the interface units clause
     Property InterfaceUnits : String Read FInterfaceUnits Write SetInterfaceUnits;
+    //  Comma-separated list of  units that will be put in the implementation units clause
     Property ImplementationUnits : String Read FImplementationUnits Write SetImplementationUnits;
   end;
   TCodeGeneratorOptionsClass = Class of TCodeGeneratorOptions;
@@ -539,13 +550,13 @@ end;
 
 function TFieldPropDef.HasGetter: Boolean;
 begin
-  Result:=False;
+  Result:=psRead in PropSetters;
 end;
 
 function TFieldPropDef.HasSetter: Boolean;
 begin
   Result:=(PropertyAccess in [paReadWrite,paWriteOnly])
-          and (PropertyType in [ptStream,ptTStrings]);
+          and ((PropertyType in [ptStream,ptTStrings]) or (psWrite in Propsetters));
 end;
 
 function TFieldPropDef.ObjPasTypeDef: String;
@@ -832,7 +843,7 @@ begin
   For I:=0 to Fields.Count-1 do
     begin
     F:=Fields[i];
-    if AllowPropertyDeclaration(F,[]) and F.HasGetter then
+    if AllowPropertyDeclaration(F,[]) and F.HasSetter then
       begin
       If not B then
         begin
@@ -867,22 +878,33 @@ Procedure TDDClassCodeGenerator.WritePropertySetterImpl(Strings : TStrings; F :
 
 Var
   S : String;
+  L : Integer;
 
 begin
-  S:=PropertyGetterDeclaration(F,True);
+  S:=PropertySetterDeclaration(F,True);
   BeginMethod(Strings,S);
   AddLn(Strings,'begin');
   IncIndent;
   Try
+    AddLn(Strings,Format('if (F%s=AValue) then exit;',[F.PropertyName]));
     Case F.PropertyType of
       ptTStrings :
         S:=Format('F%s.Assign(AValue);',[F.PropertyName]);
       ptStream :
         S:=Format('F%s.CopyFrom(AValue,0);',[F.PropertyName]);
     else
-       S:=Format('F%s:=AValue',[F.PropertyName]);
+       S:=Format('F%s:=AValue;',[F.PropertyName]);
     end;
     AddLn(Strings,S);
+    S:=CodeOptions.ExtraSetterLine;
+    L:=Length(S);
+    if (L>0) then
+      begin
+      S:=StringReplace(S,'%PROPNAME%',F.PropertyName,[rfReplaceAll,rfIgnoreCase]);
+      if (S[L]<>';') then
+        S:=S+';';
+      AddLn(Strings,S);  
+      end;
   Finally
     DecIndent;
   end;
@@ -1093,7 +1115,7 @@ begin
   Result:='Procedure ';
   If Impl then
     Result:=Result+ClassOptions.ObjectClassName+'.';
-  Result:=Result+Def.ObjPasReadDef+' (AValue  : '+Def.ObjPasTypeDef+');';
+  Result:=Result+Def.ObjPasWriteDef+' (AValue  : '+Def.ObjPasTypeDef+');';
 end;
 
 function TDDClassCodeGenerator.NeedsConstructor: Boolean;
@@ -1478,8 +1500,11 @@ begin
   If ASource is TCodeGeneratorOptions then
     begin
     CG:=ASource as TCodeGeneratorOptions;
+    FInterfaceUnits:=CG.InterfaceUnits;
+    FImplementationUnits:=CG.ImplementationUnits;
     FOptions:=CG.FOptions;
     FUnitName:=CG.UnitName;
+    FExtraSetterLine:=CG.ExtraSetterLine;
     end
   else
     inherited Assign(ASource);

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

@@ -1077,6 +1077,9 @@ function TPQConnection.GetSchemaInfoSQL(SchemaType: TSchemaType;
 var s : string;
 
 begin
+  // select * from information_schema.tables with 
+  // where table_schema [not] in ('pg_catalog','information_schema') may be better.
+  // But the following should work:
   case SchemaType of
     stTables     : s := 'select '+
                           'relfilenode        as recno, '+
@@ -1086,7 +1089,7 @@ begin
                           '0                  as table_type '+
                         'from pg_class c '+
                           'left join pg_namespace n on c.relnamespace=n.oid '+
-                        'where relkind=''r''' +
+                        'where (relkind=''r'') and not (nspname in (''pg_catalog'',''information_schema''))' +
                         'order by relname';
 
     stSysTables  : s := 'select '+
@@ -1097,7 +1100,7 @@ begin
                           '0                  as table_type '+
                         'from pg_class c '+
                           'left join pg_namespace n on c.relnamespace=n.oid '+
-                        'where relkind=''r'' and nspname=''pg_catalog'' ' + // only system tables
+                        'where (relkind=''r'') and nspname in ((''pg_catalog'',''information_schema'')) ' + // only system tables
                         'order by relname';
     stColumns    : s := 'select '+
                           'a.attnum           as recno, '+

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

@@ -278,6 +278,7 @@ type
     procedure SetReadOnly(AValue : Boolean); override;
     Function LogEvent(EventType : TDBEventType) : Boolean;
     Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
   public
     procedure Prepare; virtual;
     procedure UnPrepare; virtual;
@@ -286,7 +287,6 @@ type
     destructor Destroy; override;
     procedure SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string); virtual;
     property Prepared : boolean read IsPrepared;
-    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
     function RowsAffected: TRowsCount; virtual;
     function ParamByName(Const AParamName : String) : TParam;
   protected
@@ -342,6 +342,7 @@ type
   TSQLQuery = Class(TCustomSQLQuery)
   public
     property SchemaType;
+    Property StatementType;
   Published
     property MaxIndexesCount;
    // TDataset stuff

packages/fcl-extra/src/daemonapp.pp

@@ -929,6 +929,7 @@ destructor TCustomDaemonApplication.Destroy;
 begin
   if assigned(FEventLog) then
     FEventLog.Free;
+  inherited Destroy;
 end;
 
 procedure TCustomDaemonApplication.DoRun;

packages/fcl-image/src/fpcanvas.pp

@@ -102,7 +102,7 @@ type
     property Bold : boolean index 5 read GetFlags write SetFlags;
     property Italic : boolean index 6 read GetFlags write SetFlags;
     property Underline : boolean index 7 read GetFlags write SetFlags;
-    property StrikeTrough : boolean index 8 read GetFlags write SetFlags;
+    property StrikeThrough : boolean index 8 read GetFlags write SetFlags;
     property Orientation: Integer read GetOrientation write SetOrientation default 0;
         
   end;

packages/fcl-passrc/src/pastree.pp

@@ -524,6 +524,8 @@ type
     Modifiers: TStringList;
     Interfaces : TFPList;
     GenericTemplateTypes : TFPList;
+    Function FindMember(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
+    Function FindMemberInAncestors(MemberClass : TPTreeElement; Const MemberName : String) : TPasElement;
     Function IsPacked : Boolean;
     Function InterfaceGUID : string;
   end;
@@ -660,6 +662,8 @@ type
   { TPasProperty }
 
   TPasProperty = class(TPasVariable)
+  Public
+    FResolvedType : TPasType;
   public
     constructor Create(const AName: string; AParent: TPasElement); override;
     destructor Destroy; override;
@@ -672,6 +676,7 @@ type
     ReadAccessorName, WriteAccessorName,ImplementsName,
       StoredAccessorName: string;
     IsDefault, IsNodefault: Boolean;
+    Function ResolvedType : TPasType;
     Function IndexValue : String;
     Function DefaultValue : string;
   end;
@@ -1363,6 +1368,49 @@ begin
   end;
 end;
 
+function TPasClassType.FindMember(MemberClass: TPTreeElement; const MemberName: String): TPasElement;
+
+Var
+  I : Integer;
+
+begin
+//  Writeln('Looking for ',MemberName,'(',MemberClass.ClassName,') in ',Name);
+  Result:=Nil;
+  I:=0;
+  While (Result=Nil) and (I<Members.Count) do
+    begin
+    Result:=TPasElement(Members[i]);
+    if (Result.ClassType<>MemberClass) or (CompareText(Result.Name,MemberName)<>0) then
+      Result:=Nil;
+    Inc(I);
+    end;
+end;
+
+function TPasClassType.FindMemberInAncestors(MemberClass: TPTreeElement;
+  const MemberName: String): TPasElement;
+
+  Function A (C : TPasClassType) : TPasClassType;
+
+  begin
+    if C.AncestorType is TPasClassType then
+      C:=TPasClassType(C.AncestorType)
+    else
+      C:=Nil;
+  end;
+
+Var
+  C : TPasClassType;
+
+begin
+  Result:=Nil;
+  C:=A(Self);
+  While (Result=Nil) and (C<>Nil) do
+    begin
+    Result:=C.FindMember(MemberClass,MemberName);
+    C:=A(C);
+    end;
+end;
+
 function TPasClassType.InterfaceGUID: string;
 begin
   If Assigned(GUIDExpr) then
@@ -2512,6 +2560,7 @@ begin
 end;
 
 
+
 function TPasVariable.Value: String;
 begin
   If Assigned(Expr) then
@@ -2559,6 +2608,40 @@ begin
   ProcessHints(True, Result);
 end;
 
+function TPasProperty.ResolvedType: TPasType;
+
+  Function GC(P : TPasProperty) : TPasClassType;
+
+  begin
+    if Assigned(P) and Assigned(P.Parent) and (P.Parent is TPasClassType) then
+      Result:=P.Parent as TPasClassType
+    else
+      Result:=Nil;
+  end;
+
+
+Var
+  P : TPasProperty;
+  C : TPasClassType;
+
+begin
+  Result:=FResolvedType;
+  if Result=Nil then
+    Result:=VarType;
+  P:=Self;
+  While (Result=Nil) and (P<>Nil) do
+    begin
+    C:=GC(P);
+//    Writeln('Looking for ',Name,' in ancestor ',C.Name);
+    P:=TPasProperty(C.FindMemberInAncestors(TPasProperty,Name));
+    if Assigned(P) then
+      begin
+//      Writeln('Found ',Name,' in ancestor : ',P.Name);
+      Result:=P.ResolvedType;
+      end
+    end;
+end;
+
 function TPasProperty.IndexValue: String;
 begin
   If Assigned(IndexExpr) then

packages/fcl-passrc/src/pscanner.pp

@@ -190,6 +190,7 @@ type
   private
     FTextFile: Text;
     FileOpened: Boolean;
+    FBuffer : Array[0..4096-1] of byte;
   public
     constructor Create(const AFilename: string); override;
     destructor Destroy; override;
@@ -797,10 +798,12 @@ end;
   ---------------------------------------------------------------------}
 
 constructor TFileLineReader.Create(const AFilename: string);
+
 begin
   inherited Create(AFileName);
   Assign(FTextFile, AFilename);
   Reset(FTextFile);
+  SetTextBuf(FTextFile,FBuffer,SizeOf(FBuffer));
   FileOpened := true;
 end;
 

packages/fcl-stl/fpmake.pp

@@ -47,6 +47,7 @@ begin
           AddUnit('gdeque');
         end;
     T:=P.Targets.AddUnit('gset.pp');
+    T:=P.Targets.AddUnit('gtree.pp');
     T:=P.Targets.AddUnit('gstack.pp');
       with T.Dependencies do
         begin

packages/fcl-stl/src/gtree.pp

@@ -0,0 +1,139 @@
+{
+   This file is part of the Free Pascal FCL library.
+   Copyright 2013 Mario Ray Mahardhika
+ 
+   Implements a generic Tree.
+ 
+   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 gtree;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  gvector,gstack,gqueue;
+
+type
+
+  { TTreeNode }
+
+  generic TTreeNode<T> = class
+  public type
+    TTreeNodeList = specialize TVector<TTreeNode>;
+  protected
+    FData: T;
+    FChildren: TTreeNodeList;
+  public
+    constructor Create;
+    constructor Create(const AData: T);
+    destructor Destroy; override;
+    property Data: T read FData write FData;
+    property Children: TTreeNodeList read FChildren;
+  end;
+
+  generic TDepthFirstCallback<T> = procedure (const AData: T);
+  generic TBreadthFirstCallback<T> = procedure (const AData: T);
+
+  generic TTree<T> = class
+  public type
+    TTreeNodeType = specialize TTreeNode<T>;
+    TDepthFirstCallbackType = specialize TDepthFirstCallback<T>;
+    TBreadthFirstCallbackType = specialize TBreadthFirstCallback<T>;
+  private type
+  type
+    TStackType = specialize TStack<TTreeNodeType>;
+    TQueueType = specialize TQueue<TTreeNodeType>;
+  private
+    FRoot: TTreeNodeType;
+  public
+    constructor Create;
+    destructor Destroy; override;
+    procedure DepthFirstTraverse(Callback: TDepthFirstCallbackType);
+    procedure BreadthFirstTraverse(Callback: TBreadthFirstCallbackType);
+    property Root: TTreeNodeType read FRoot write FRoot;
+  end;
+
+implementation
+
+
+{ TTreeNode }
+
+constructor TTreeNode.Create;
+begin
+  FChildren := TTreeNodeList.Create;
+end;
+
+constructor TTreeNode.Create(const AData: T);
+begin
+  FData := AData;
+  FChildren := TTreeNodeList.Create;
+end;
+
+destructor TTreeNode.Destroy;
+var
+  Child: TTreeNode;
+begin
+  for Child in FChildren do begin
+    Child.Free;
+  end;
+  FChildren.Free;
+end;
+
+{ TTree }
+
+constructor TTree.Create;
+begin
+  FRoot := nil;
+end;
+
+destructor TTree.Destroy;
+begin
+  FRoot.Free;
+end;
+
+procedure TTree.DepthFirstTraverse(Callback: TDepthFirstCallbackType);
+var
+  Stack: TStackType;
+  Node,Child: TTreeNodeType;
+begin
+  if Assigned(FRoot) then begin
+    Stack := TStackType.Create;
+    Stack.Push(FRoot);
+    while Stack.Size > 0 do begin
+      Node := Stack.Top;
+      Stack.Pop;
+      Callback(Node.Data);
+      for Child in Node.Children do Stack.Push(Child);
+    end;
+    Stack.Free;
+  end;
+end;
+
+procedure TTree.BreadthFirstTraverse(Callback: TBreadthFirstCallbackType);
+var
+  Queue: TQueueType;
+  Node,Child: TTreeNodeType;
+begin
+  if Assigned(FRoot) then begin
+    Queue := TQueueType.Create;
+    Queue.Push(FRoot);
+    while Queue.Size > 0 do begin
+      Node := Queue.Front;
+      Queue.Pop;
+      Callback(Node.Data);
+      for Child in Node.Children do Queue.Push(Child);
+    end;
+    Queue.Free;
+  end;
+end;
+
+end.
+

packages/fcl-stl/tests/gtreetest.pp

@@ -0,0 +1,50 @@
+program gtreetest;
+
+{$mode objfpc}{$H+}
+
+uses
+  gtree;
+
+procedure WriteIntegerCallback(const i: Integer);
+begin
+  Write(i,' ');
+end;
+
+type
+  TIntegerTreeNode = specialize TTreeNode<Integer>;
+  TIntegerTree = specialize TTree<Integer>;
+var
+  Tree: TIntegerTree;
+  Node,Tmp: TIntegerTreeNode;
+  i: Integer;
+begin
+  Node := TIntegerTreeNode.Create(0);
+  for i := 1 to 3 do begin
+    Tmp := TIntegerTreeNode.Create(i);
+    Node.Children.PushBack(Tmp);
+  end;
+  Tmp := Node;
+  Node := TIntegerTreeNode.Create(4);
+  Node.Children.PushBack(Tmp);
+  for i := 5 to 7 do begin
+    Tmp := TIntegerTreeNode.Create(i);
+    Node.Children.PushBack(Tmp);
+  end;
+  Tmp := Node;
+  Node := TIntegerTreeNode.Create(8);
+  Node.Children.PushBack(Tmp);
+  for i := 9 to 10 do begin
+    Tmp := TIntegerTreeNode.Create(i);
+    Node.Children.PushBack(Tmp);
+  end;
+
+  Tree := TIntegerTree.Create;
+  Tree.Root := Node;
+
+  WriteLn('Depth first:');
+  Tree.DepthFirstTraverse(@WriteIntegerCallback);WriteLn;
+  WriteLn('Breadth first:');
+  Tree.BreadthFirstTraverse(@WriteIntegerCallback);WriteLn;
+
+  Tree.Free;
+end.

packages/fcl-xml/src/htmwrite.pp

@@ -72,7 +72,7 @@ type
     procedure VisitDocumentType(Node: TDOMNode);
     procedure VisitPI(Node: TDOMNode);
   public
-    constructor Create(AStream: TStream);
+    constructor Create(AStream: TStream; ACapacity : Cardinal = 4096);
     destructor Destroy; override;
   end;
 
@@ -111,14 +111,14 @@ end;
     THTMLWriter
   ---------------------------------------------------------------------}
 
-constructor THTMLWriter.Create(AStream: TStream);
+constructor THTMLWriter.Create(AStream: TStream; ACapacity : Cardinal = 4096);
 begin
   inherited Create;
   FStream := AStream;
   // some overhead - always be able to write at least one extra UCS4
-  FBuffer := AllocMem(512+32);
+  FCapacity := ACapacity;
+  FBuffer := AllocMem(FCapacity+32);
   FBufPos := FBuffer;
-  FCapacity := 512;
   // Later on, this may be put under user control
   // for now, take OS setting
   FLineBreak := sLineBreak;

packages/winunits-base/src/shlobj.pp

@@ -876,6 +876,8 @@ Const
   FOS_FORCESHOWHIDDEN     = $10000000;
   FOS_DEFAULTNOMINIMODE	  = $20000000;
   FOS_FORCEPREVIEWPANEON  = $40000000;
+  SHGFP_TYPE_CURRENT      =  0;   // shgetfolderpath, current value for user, verify it exists
+  SHGFP_TYPE_DEFAULT  	  =  1;   // shgetfolderpath, default value, may not exist
    
 Type
       SFGAOF  = ULONG;

rtl/inc/compproc.inc

@@ -554,11 +554,10 @@ procedure fpc_raise_nested; compilerproc;
 function fpc_help_constructor(_self:pointer;var _vmt:pointer;_vmt_pos:cardinal):pointer;compilerproc;
 procedure fpc_help_destructor(_self,_vmt:pointer;vmt_pos:cardinal);compilerproc;
 procedure fpc_help_fail(_self:pointer;var _vmt:pointer;vmt_pos:cardinal);compilerproc;
-{$endif FPC_HAS_FEATURE_OBJECTS}
-
 
 procedure fpc_check_object(_vmt:pointer); compilerproc;
 procedure fpc_check_object_ext(vmt,expvmt:pointer);compilerproc;
+{$endif FPC_HAS_FEATURE_OBJECTS}
 
 
 {$ifdef FPC_HAS_FEATURE_RTTI}

rtl/inc/fexpand.inc

@@ -161,7 +161,7 @@ begin
             S := GetEnv ('HOME');
   {$ENDIF FPC_FEXPAND_GETENV_PCHAR}
  {$ENDIF FPC_FEXPAND_SYSUTILS}
-            if (S = '') or (Length (S) = 1)
+            if (S = '') or (Length (S) = 1) and (Length (Pa) > 1)
                                           and (S [1] = DirectorySeparator) then
                 Delete (Pa, 1, 1)
             else

rtl/inc/text.inc

@@ -1698,7 +1698,11 @@ const
   { how many bytes of the string have been processed already (used for readstr) }
   BytesReadIndex = 17;
 
-threadvar
+{$ifdef FPC_HAS_FEATURE_THREADING}
+ThreadVar
+{$else FPC_HAS_FEATURE_THREADING}
+Var
+{$endif FPC_HAS_FEATURE_THREADING}
   ReadWriteStrText: textrec;
 
 procedure WriteStrShort(var t: textrec);

rtl/inc/threadvr.inc

@@ -50,7 +50,7 @@ end;
 
 procedure init_all_unit_threadvars;
 var
-  i : integer;
+  i : longint;
 begin
 {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
   with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do
@@ -84,7 +84,7 @@ end;
 
 procedure copy_all_unit_threadvars;
 var
-  i : integer;
+  i: longint;
 begin
 {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
   with PltvInitTablesTable(EntryInformation.ThreadvarTablesTable)^ do

rtl/linux/Makefile

@@ -210,14 +210,6 @@ endif
 ifeq ($(OS_TARGET),linux)
 linuxHier=1
 endif
-ifndef CROSSCOMPILE
-BUILDFULLNATIVE=1
-export BUILDFULLNATIVE
-endif
-ifdef BUILDFULLNATIVE
-BUILDNATIVE=1
-export BUILDNATIVE
-endif
 export OS_TARGET OS_SOURCE ARCH CPU_TARGET CPU_SOURCE FULL_TARGET FULL_SOURCE TARGETSUFFIX SOURCESUFFIX CROSSCOMPILE
 ifdef FPCDIR
 override FPCDIR:=$(subst \,/,$(FPCDIR))
@@ -3248,9 +3240,11 @@ ifeq ($(ARCH),powerpc64)
 endif
 ifeq ($(ARCH),mips)
   ASTARGET=-32 -mips32 -EB
+  ASSHAREDOPT=-KPIC
 endif
 ifeq ($(ARCH),mipsel)
   ASTARGET=-32 -mips32 -EL
+  ASSHAREDOPT=-KPIC
 endif
 ifeq ($(ARCH),sparc)
   ifneq ($(findstring -Cg ,$(COMPILER)),)
@@ -3263,7 +3257,7 @@ endif
 prt0$(OEXT) : $(ARCH)/prt0.as
 	$(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)prt0$(OEXT) $(ARCH)/prt0.as
 dllprt0$(OEXT) : $(ARCH)/dllprt0.as
-	$(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)dllprt0$(OEXT) $(ARCH)/dllprt0.as
+	$(AS) $(ASTARGET) $(ASSHAREDOPT) -o $(UNITTARGETDIRPREFIX)dllprt0$(OEXT) $(ARCH)/dllprt0.as
 gprt0$(OEXT) : $(ARCH)/gprt0.as
 	$(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)gprt0$(OEXT) $(ARCH)/gprt0.as
 cprt0$(OEXT) : $(ARCH)/cprt0.as

rtl/linux/Makefile.fpc

@@ -129,9 +129,11 @@ endif
 # Select 32/64 mode
 ifeq ($(ARCH),mips)
   ASTARGET=-32 -mips32 -EB
+  ASSHAREDOPT=-KPIC
 endif
 ifeq ($(ARCH),mipsel)
   ASTARGET=-32 -mips32 -EL
+  ASSHAREDOPT=-KPIC
 endif
 
 ifeq ($(ARCH),sparc)
@@ -150,8 +152,9 @@ endif
 prt0$(OEXT) : $(ARCH)/prt0.as
         $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)prt0$(OEXT) $(ARCH)/prt0.as
 
+# ASSHAREDOPT adds -KPIC mandatoy for mips/mipsel objects in shared libs
 dllprt0$(OEXT) : $(ARCH)/dllprt0.as
-        $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)dllprt0$(OEXT) $(ARCH)/dllprt0.as
+        $(AS) $(ASTARGET) $(ASSHAREDOPT) -o $(UNITTARGETDIRPREFIX)dllprt0$(OEXT) $(ARCH)/dllprt0.as
 
 gprt0$(OEXT) : $(ARCH)/gprt0.as
         $(AS) $(ASTARGET) -o $(UNITTARGETDIRPREFIX)gprt0$(OEXT) $(ARCH)/gprt0.as

rtl/linux/mips/dllprt0.as

@@ -1 +1,125 @@
-.include "mips/prt0.as"
+/*
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2009 by Michael Van Canneyt and David Zhang
+
+    Startup code for elf32-mipsel/elf32-mips
+
+    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.
+*/
+        .set noat
+
+	.section ".text"
+
+	.align 4
+	.global _dynamic_start
+	.ent	_dynamic_start
+	.type _dynamic_start,@function
+_dynamic_start:
+        .set noreorder
+	.cpload $25
+        /* TODO: check whether this code is correct */
+        la      $v0,__dl_fini
+        lw      $v0,($v0)
+	lw      $v1,%call16(_start)($gp)
+	move    $t9,$v1
+        jalr	$t9
+	nop
+
+	.end	_dynamic_start
+	.size 	_dynamic_start, .-_dynamic_start
+
+	.align 4
+	.global _start
+        .set    nomips16
+        .ent    _start
+ 	.type	_start,@function
+/*  This is the canonical entry point, usually the first thing in the text
+    segment.  The SVR4/Mips ABI (pages 3-31, 3-32) says that when the entry
+    point runs, most registers' values are unspecified, except for:
+
+    v0 ($2)	Function pointer of a function to be executed at exit
+
+    sp ($29)	The stack contains the arguments and environment:
+ 		0(%sp)			argc
+ 		4(%sp)			argv[0]
+
+ 		...
+ 		(4*argc)(%sp)		NULL
+ 		(4*(argc+1))(%sp)	envp[0]
+ 		...
+ 					NULL
+    ra ($31)	Return address set to zero.
+*/
+_start:
+        /* load fp */
+        .set noreorder
+	.cpload $25
+	addiu   $sp,$sp,-32
+        move    $s8,$sp
+	.cprestore 16
+        la      $t1,__stkptr
+        sw      $s8,($t1)
+
+        /* align stack */
+        li      $at,-8
+        and     $sp,$sp,$at
+
+        addiu   $sp,$sp,-32
+
+        lui     $s7,0x3d
+        addiu   $s7,$s7,2304
+        li      $at,-8
+        and     $s7,$s7,$at
+        addiu   $s7,$s7,-32
+
+        /* store argc */
+        lw      $a0,0($s8)
+        la      $a1,operatingsystem_parameter_argc
+        sw      $a0,($a1)
+
+        /* store argv */
+        addiu   $a1,$s8,4
+        la      $a2,operatingsystem_parameter_argv
+        sw      $a1,($a2)
+
+        /* store envp */
+        addiu   $a2,$a0,1
+        sll     $a2,$a2,0x2
+        addu    $a2,$a2,$a1
+        la      $a3,operatingsystem_parameter_envp
+        sw      $a2,($a3)
+        la      $t9,PASCALMAIN
+        jalr    $t9
+        nop
+	b       _haltproc
+        nop
+
+	.end	_start
+	.size 	_start, .-_start
+
+	.globl  _haltproc
+	.ent	_haltproc
+	.type   _haltproc,@function
+_haltproc:
+        /* TODO: need to check whether __dl_fini is non-zero and call the function pointer in case */
+
+        li      $v0,4001
+        syscall
+        b       _haltproc
+        nop
+
+	.end _haltproc
+	.size _haltproc, .-_haltproc
+
+        .comm __stkptr,4
+        .comm __dl_fini,4
+
+        .comm operatingsystem_parameter_envp,4
+        .comm operatingsystem_parameter_argc,4
+        .comm operatingsystem_parameter_argv,4
+

rtl/m68k/m68k.inc

@@ -92,6 +92,8 @@ procedure FillChar(var x;count:longint;value:byte); assembler;
      move.l x, a0          { destination                   }
      move.l count, d1      { number of bytes to fill       }
      move.b value, d0      { fill data                     }
+     tst.l d1              { anything to fill at all?      }
+     beq    @LMEMSET5
      cmpi.l #65535, d1     { check, if this is a word move }
      ble    @LMEMSET3      { use fast dbra mode            }
      bra @LMEMSET2
@@ -318,9 +320,11 @@ end;
 procedure fillword(var x;count : longint;value : word);
   begin
     asm
-     move.l x, a0         { destination             }
-     move.l count, d1     { number of bytes to fill }
-     move.w value, d0     { fill data               }
+     move.l x, a0         { destination              }
+     move.l count, d1     { number of bytes to fill  }
+     move.w value, d0     { fill data                }
+     tst.l d1             { anything to fill at all? }
+     beq @LMEMSET3
      bra @LMEMSET21
    @LMEMSET11:
      move.w d0,(a0)+
@@ -328,6 +332,7 @@ procedure fillword(var x;count : longint;value : word);
      subq.l #1,d1
      cmp.b #-1,d1
      bne  @LMEMSET11
+   @LMEMSET3:
     end ['d0','d1','a0'];
   end;
 
@@ -349,16 +354,16 @@ function abs(l : longint) : longint;
 function InterLockedDecrement (var Target: longint) : longint;
   begin
   {$warning FIX ME}
-    Result := Target;
     Dec(Target);
+    Result := Target;
   end;
 
 
 function InterLockedIncrement (var Target: longint) : longint;
   begin
   {$warning FIX ME}
-    Result := Target;
     Inc(Target);
+    Result := Target;
   end;
 
 

rtl/win/systhrd.inc

@@ -225,7 +225,12 @@ var
 {$ifdef DEBUG_MT}
         writeln('Jumping to thread function of thread ',Win32GetCurrentThreadId);
 {$endif DEBUG_MT}
+{$ifdef FPC_USE_WIN64_SEH}
+        { use special 'top-level' exception handler around the thread function }
+        ThreadMain:=main_wrapper(ti.p,pointer(ti.f));
+{$else FPC_USE_WIN64_SEH}
         ThreadMain:=ti.f(ti.p);
+{$endif FPC_USE_WIN64_SEH}
       end;
 
 

rtl/win64/system.pp

@@ -125,6 +125,19 @@ implementation
 var
   SysInstance : qword;public;
 
+{$ifdef FPC_USE_WIN64_SEH}
+function main_wrapper(arg: Pointer; proc: Pointer): ptrint; assembler; nostackframe;
+asm
+    subq   $40, %rsp
+.seh_stackalloc 40
+.seh_endprologue
+    call   %rdx             { "arg" is passed in %rcx }
+    nop                     { this nop is critical for exception handling }
+    addq   $40, %rsp
+.seh_handler __FPC_default_handler,@except,@unwind
+end;
+{$endif FPC_USE_WIN64_SEH}
+
 { include system independent routines }
 {$I system.inc}
 
@@ -179,18 +192,6 @@ var
     to check if the call stack can be written on exceptions }
   _SS : Cardinal;
 
-{$ifdef FPC_USE_WIN64_SEH}
-procedure main_wrapper(p: TProcedure); assembler; nostackframe;
-asm
-    subq   $40, %rsp
-.seh_stackalloc 40
-.seh_endprologue
-    call   %rcx
-    nop                     { this nop is critical for exception handling }
-    addq   $40, %rsp
-.seh_handler __FPC_default_handler,@except,@unwind
-end;
-{$endif FPC_USE_WIN64_SEH}
 
 
 procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
@@ -209,7 +210,8 @@ procedure Exe_entry;[public,alias:'_FPC_EXE_Entry'];
         movq %rbp,%rsi
         xorq %rbp,%rbp
 {$ifdef FPC_USE_WIN64_SEH}
-        lea  PASCALMAIN(%rip),%rcx
+        xor  %rcx,%rcx
+        lea  PASCALMAIN(%rip),%rdx
         call main_wrapper
 {$else FPC_USE_WIN64_SEH}
         call PASCALMAIN

tests/test/cg/obj/readme.txt

@@ -33,6 +33,9 @@ FreeBSD-i386 : gcc (GCC) 4.2.1 20070719  [FreeBSD] 8.2-RELEASE
 Linux-sparc : gcc (Debian 4.3.2-1.1) 4.3.2
 OpenBSD-x86_64 : gcc (GCC) 4.2.1 20070719 
 Linux-arm-gnueabihf : gcc version 4.6.3 (Debian 4.6.3-8+rpi1)
+Linux-mipsel : gcc (Debian 4.4.5-8) 4.4.5
+Linux-mips : gcc (Debian 4.4.5-8) 4.4.5
+
 
 Android-arm  : GCC 4.7
 Android-i386 : GCC 4.7

tests/test/terecs12a.pp

@@ -0,0 +1,19 @@
+{ %FAIL }
+{ %NORUN }
+program terecs12a;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+procedure Test;
+type
+  TRecord = record
+  private const
+    TestConst = 0;
+  end;
+begin
+end;
+
+begin
+end.

tests/test/terecs12b.pp

@@ -0,0 +1,20 @@
+{ %FAIL }
+{ %NORUN }
+program terecs12b;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+procedure Test;
+type
+  TRecord = record
+  var
+    TestField: Integer;
+    property TestProperty: Integer read TestField;
+  end;
+begin
+end;
+
+begin
+end.

tests/test/terecs12c.pp

@@ -0,0 +1,19 @@
+{ %FAIL }
+{ %NORUN }
+program terecs12c;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+procedure Test;
+type
+  TRecord = record
+  class var
+    TestField: Integer;
+  end;
+begin
+end;
+
+begin
+end.

tests/test/terecs12d.pp

@@ -0,0 +1,18 @@
+{ %FAIL }
+{ %NORUN }
+program terecs12d;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+procedure Test;
+type
+  TRecord = record
+    procedure Test;
+  end;
+begin
+end;
+
+begin
+end.

tests/test/terecs13a.pp

@@ -0,0 +1,16 @@
+{ %FAIL }
+{ %NORUN }
+program terecs13a;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+var
+  R: record
+    private const
+      TestConst = 0;
+  end;
+
+begin
+end.

tests/test/terecs13b.pp

@@ -0,0 +1,17 @@
+{ %FAIL }
+{ %NORUN }
+program terecs13b;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+var
+  R: record
+    var
+      TestField: Integer;
+      property TestProperty: Integer read TestField;
+  end;
+
+begin
+end.

tests/test/terecs13c.pp

@@ -0,0 +1,16 @@
+{ %FAIL }
+{ %NORUN }
+program terecs13c;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+var
+  R: record
+    class var
+      TestField: Integer;
+  end;
+
+begin
+end.

tests/test/terecs13d.pp

@@ -0,0 +1,15 @@
+{ %FAIL }
+{ %NORUN }
+program terecs13d;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+var
+  R: record
+    procedure Test;
+  end;
+
+begin
+end.

tests/test/terecs15.pp

@@ -12,15 +12,15 @@ type
     Y: Integer;
   public
     // delphi does not allow constructors without arguments
-    constructor CreateAndTest;
-    constructor Create; overload;
+    constructor CreateAndTest(dummy: byte);
+    constructor Create(dummy: boolean); overload;
     constructor Create(AX, AY: Integer); overload;
     constructor Create(AY: Integer); overload;
   end;
 
 { TRec }
 
-constructor TRec.CreateAndTest;
+constructor TRec.CreateAndTest(dummy: byte);
 begin
   X := 1;
   if X <> 1 then
@@ -30,7 +30,7 @@ begin
     halt(2);
 end;
 
-constructor TRec.Create;
+constructor TRec.Create(dummy: boolean);
 begin
   X := 10;
   Y := 20;
@@ -44,7 +44,7 @@ end;
 
 constructor TRec.Create(AY: Integer);
 begin
-  Create;
+  Create(false);
   Y := AY;
 end;
 
@@ -59,8 +59,8 @@ end;
 var
   R: TRec;
 begin
-  R.CreateAndTest;
-  R := TRec.Create;
+  R.CreateAndTest(0);
+  R := TRec.Create(false);
   if R.X <> 10 then
     halt(3);
   if R.Y <> 20 then
@@ -68,6 +68,6 @@ begin
   TestRec(TRec.Create(1, 2), 1, 2, 5, 6);
   TestRec(TRec.Create(2), 10, 2, 7, 8);
   // delphi has an internal error here
-  TestRec(R.Create, 10, 20, 9, 10);
+  TestRec(R.Create(false), 10, 20, 9, 10);
 end.
 

tests/test/terecs16.pp

@@ -4,18 +4,18 @@ program terecs16;
 type
   TRec = record
     l: longint;
-    constructor Create;
+    constructor Create(a: longint);
   end;
 
 
 var
   r: TRec;
 
-  constructor TRec.Create;
+  constructor TRec.Create(a: longint);
   begin
-    l := 0;
+    l := a;
     r.l := 4;
-    if l <> 0 then
+    if l <> a then
       halt(1);
     l := 5;
     if r.l <> 4 then
@@ -24,7 +24,7 @@ var
   end;
 
 begin
-  r := TRec.Create;
+  r := TRec.Create(10);
   if r.l <> 5 then
     halt(3);
 end.

tests/test/terecs17.pp

@@ -0,0 +1,27 @@
+{ %FAIL }
+{ %NORUN }
+program terecs17;
+
+{$mode delphi}
+
+type
+
+  { TRec }
+
+  TRec = record
+    X: Integer;
+    constructor Create;
+  end;
+
+{ TRec }
+
+constructor TRec.Create;
+begin
+
+end;
+
+var
+  R: TRec;
+begin
+  R := TRec.Create;
+end.

tests/test/terecs17a.pp

@@ -0,0 +1,27 @@
+{ %FAIL }
+{ %NORUN }
+program terecs17a;
+
+{$mode delphi}
+
+type
+
+  { TRec }
+
+  TRec = record
+    X: Integer;
+    constructor Create(I: integer = 0);
+  end;
+
+{ TRec }
+
+constructor TRec.Create(I: integer = 0);
+begin
+
+end;
+
+var
+  R: TRec;
+begin
+  R := TRec.Create;
+end.

tests/test/terecs18.pp

@@ -0,0 +1,32 @@
+{ %FAIL }
+{ %NORUN }
+program terecs18;
+
+{$mode delphi}
+
+type
+
+  { TRec }
+
+  TRec = record
+    X: Integer;
+  end;
+
+  { TRecHelper }
+
+  TRecHelper = record helper for TRec
+    constructor Create;
+  end;
+
+{ TRecHelper }
+
+constructor TRecHelper.Create;
+begin
+
+end;
+
+var
+  R: TRec;
+begin
+  R := TRec.Create;
+end.

tests/test/terecs18a.pp

@@ -0,0 +1,32 @@
+{ %FAIL }
+{ %NORUN }
+program terecs18a;
+
+{$mode delphi}
+
+type
+
+  { TRec }
+
+  TRec = record
+    X: Integer;
+  end;
+
+  { TRecHelper }
+
+  TRecHelper = record helper for TRec
+    constructor Create(I: Integer = 0);
+  end;
+
+{ TRecHelper }
+
+constructor TRecHelper.Create;
+begin
+
+end;
+
+var
+  R: TRec;
+begin
+  R := TRec.Create;
+end.

tests/test/trhlp12.pp

@@ -1,6 +1,4 @@
-{ %FAIL }
-
-{ for now constructors are forbidden in record helpers }
+{ constructors in record helpers }
 program trhlp12;
 
 {$ifdef fpc}

tests/test/trhlp45.pp

@@ -0,0 +1,28 @@
+program trhlp45;
+
+{$mode delphi}
+
+type
+  TRec = record
+    X: Integer;
+  end;
+
+  THelpRec = record helper for TRec
+    constructor Create(AX: Integer);
+  end;
+
+
+{ THelpRec }
+
+constructor THelpRec.Create(AX: Integer);
+begin
+  X := AX;
+end;
+
+var
+  R: TRec;
+begin
+  R := TRec.Create(1);
+  if R.X <> 1 then
+    halt(1);
+end.

tests/test/units/dos/tfexpand.pp

@@ -398,18 +398,37 @@ if CDir [Length (CDir)] = DirSep then Check ('c:anything', CDir + 'anything')
  S := GetEnv ('HOME');
  { On m68k netbsd at least, HOME contains a final slash
    remove it PM }
- if S[length(S)]=DirSep then
+ if (Length (S) > 1) and (S [Length (S)] = DirSep) then
    S:=Copy(S,1,Length(S)-1);
- Check ('~', S);
- Check ('~' + DirSep + '.', S);
- if (Length (S) > 0) and (S [Length (S)] <> DirSep) then S := S + DirSep;
+ if Length (S) = 0 then
+  begin
+   Check ('~', CurDir);
+   Check ('~' + DirSep + '.', DirSep);
+  end
+ else
+  begin
+   Check ('~', S);
+   Check ('~' + DirSep + '.', S);
+  end;
+ if (Length (S) > 0) and (S [Length (S)] <> DirSep) then
+  S := S + DirSep;
  Check ('~NobodyWithThisNameShouldEverExist.test/nothing', CurDir + DirSep +
                             '~NobodyWithThisNameShouldEverExist.test/nothing');
  Check ('/tmp/~NoSuchUserAgain', '/tmp/~NoSuchUserAgain');
- Check ('~' + DirSep, S);
- Check ('~' + DirSep + '.' + DirSep, S);
- Check ('~' + DirSep + 'directory' + DirSep + 'another',
+ if Length (S) = 0 then
+  begin
+   Check ('~' + DirSep, DirSep);
+   Check ('~' + DirSep + '.' + DirSep, DirSep);
+   Check ('~' + DirSep + 'directory' + DirSep + 'another',
+                                    DirSep + 'directory' + DirSep + 'another');
+  end
+ else
+  begin
+   Check ('~' + DirSep, S);
+   Check ('~' + DirSep + '.' + DirSep, S);
+   Check ('~' + DirSep + 'directory' + DirSep + 'another',
                                          S + 'directory' + DirSep + 'another');
+  end;
 {$ELSE UNIX}
  {$IFNDEF NODRIVEC}
  Check (TestDrive + '..', TestDir + TestDir1Name);

tests/webtbs/tw19357.pp

@@ -0,0 +1,25 @@
+program tw19357;
+type
+  TLvl0 = bitpacked record
+    a,b: longword;
+  end;
+
+  TTest = packed record
+    a,b: longword;
+    c: TLvl0;
+  end;
+
+var
+  h: TTest absolute 100;
+const
+  x: pointer = @h.c.b;
+begin
+  if ptruint(@h.a) <> 100 then
+    halt(1);
+  if ptruint(@h.b) <> 104 then
+    halt(2);
+  if ptruint(@h.c.b) <> 112 then
+    halt(3);
+  if ptruint(x) <> 112 then
+    halt(4);
+end.

tests/webtbs/tw23130.pp

@@ -0,0 +1,34 @@
+program tw23130;
+{$MODE DELPHI}
+
+type
+  TFunction<TArgument, TResult> = function (const arg: TArgument): TResult;
+
+  TWrapper = record
+    class function Z(const arg: Integer): Boolean; static;
+    class procedure W; static;
+  end;
+
+  TWrapper2 = class
+    procedure ZZ(f: TFunction<Integer, Boolean>);
+  end;
+
+class function TWrapper.Z(const arg: Integer): Boolean;
+begin
+  Result := arg < 0;
+end;
+
+class procedure TWrapper.W;
+begin
+  with TWrapper2.Create do begin
+    ZZ(@Z);  { Replace with @TWrapper.Z to get rid of the error }
+    Free;
+  end;
+end;
+
+procedure TWrapper2.ZZ(f: TFunction<Integer, Boolean>);
+begin
+end;
+
+begin
+end.

utils/fpdoc/dglobals.pp

@@ -25,6 +25,10 @@ interface
 
 uses Classes, DOM, PasTree, PParser, StrUtils,uriparser;
 
+Const
+  CacheSize = 20;
+  ContentBufSize = 4096 * 8;
+
 Var
   LEOL : Integer;
   modir : string;
@@ -297,6 +301,8 @@ type
   private
     FDocLogLevels: TFPDocLogLevels;
     FOnParseUnit: TOnParseUnitEvent;
+    function ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
+    function ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict: Boolean=False): String;
   protected
     DescrDocs: TObjectList;             // List of XML documents
     DescrDocNames: TStringList;         // Names of the XML documents
@@ -332,7 +338,7 @@ type
     // Link tree support
     procedure AddLink(const APathName, ALinkTo: String);
     function FindAbsoluteLink(const AName: String): String;
-    function ResolveLink(AModule: TPasModule; const ALinkDest: String): String;
+    function ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
     function FindLinkedNode(ANode: TDocNode): TDocNode;
 
     // Documentation file support
@@ -615,7 +621,6 @@ var
 begin
   for i := 0 to FPackages.Count - 1 do
     TPasPackage(FPackages[i]).Release;
-  FPackages.Free;
   FRootDocNode.Free;
   FRootLinkNode.Free;
   DescrDocNames.Free;
@@ -977,11 +982,14 @@ end;
 
 var
   s: String;
+  buf : Array[1..ContentBufSize-1] of byte;
+
 begin
   if not FileExists(AFileName) then
     raise EInOutError.Create('File not found: ' + AFileName);
   Assign(f, AFilename);
   Reset(f);
+  SetTextBuf(F,Buf,SizeOf(Buf));
   while not EOF(f) do
   begin
     ReadLn(f, s);
@@ -1031,9 +1039,11 @@ var
   ClassDecl: TPasClassType;
   Member: TPasElement;
   s: String;
+  Buf : Array[0..ContentBufSize-1] of byte;
 begin
   Assign(ContentFile, AFilename);
   Rewrite(ContentFile);
+  SetTextBuf(ContentFile,Buf,SizeOf(Buf));
   try
     WriteLn(ContentFile, '# FPDoc Content File');
     WriteLn(ContentFile, ':link tree');
@@ -1243,84 +1253,77 @@ begin
     SetLength(Result, 0);
 end;
 
-function TFPDocEngine.ResolveLink(AModule: TPasModule;
-  const ALinkDest: String): String;
-var
-  i: Integer;
-  ThisPackage: TLinkNode;
-  UnitList: TFPList;
+function TFPDocEngine.ResolveLinkInPackages(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
 
-  function CanWeExit(AResult: string): boolean;
-  var
-    s: string;
-  begin
-    s := StringReplace(Lowercase(ALinkDest), '.', '_', [rfReplaceAll]);
-    Result := pos(s, AResult) > 0;
-  end;
+Var
+  ThisPackage: TLinkNode;
 
 begin
-  // system.WriteLn('ResolveLink(', AModule.Name, ' - ', ALinkDest, ')... ');
-  if Length(ALinkDest) = 0 then
-  begin
-    SetLength(Result, 0);
-    exit;
-  end;
-
-  if (ALinkDest[1] = '#') or (not assigned(AModule)) then
-    Result := FindAbsoluteLink(ALinkDest)
-  else
-  begin
-    if Pos(AModule.Name, ALinkDest) = 1 then
-    begin
-      Result := ResolveLink(AModule, amodule.packagename + '.' + ALinkDest);
-      if CanWeExit(Result) then
-        Exit;
-    end
-    else
+  { Try all packages }
+  Result:='';
+  ThisPackage:=RootLinkNode.FirstChild;
+  while Assigned(ThisPackage) and (Result='') do
     begin
-      Result := ResolveLink(AModule, AModule.PathName + '.' + ALinkDest);
-      if CanWeExit(Result) then
-        Exit;
+    Result:=ResolveLink(AModule, ThisPackage.Name + '.' + ALinkDest, Strict);
+    ThisPackage := ThisPackage.NextSibling;
     end;
+end;
 
-    { Try all packages }
-    SetLength(Result, 0);
-    ThisPackage := RootLinkNode.FirstChild;
-    while Assigned(ThisPackage) do
+function TFPDocEngine.ResolveLinkInUsedUnits(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
+
+var
+  i: Integer;
+  UL: TFPList;
+
+begin
+  Result:='';
+  UL:=AModule.InterfaceSection.UsesList;
+  I:=UL.Count-1;
+  While (Result='') and (I>=0) do
     begin
-      Result := ResolveLink(AModule, ThisPackage.Name + '.' + ALinkDest);
-      if CanWeExit(Result) then
-        Exit;
-      ThisPackage := ThisPackage.NextSibling;
+    Result:=ResolveLinkInPackages(AModule,TPasType(UL[i]).Name+'.'+ALinkDest, strict);
+    Dec(I);
     end;
+end;
 
-    if not CanWeExit(Result) then
+function TFPDocEngine.ResolveLink(AModule: TPasModule; const ALinkDest: String; Strict : Boolean = False): String;
+var
+  i: Integer;
+
+begin
+{
+  if Assigned(AModule) then
+      system.WriteLn('ResolveLink(', AModule.Name, ' - ', ALinkDest, ')... ')
+    else
+      system.WriteLn('ResolveLink(Nil - ', ALinkDest, ')... ');
+}
+  if (ALinkDest='') then
+    Exit('');
+  if (ALinkDest[1] = '#') then
+    Result := FindAbsoluteLink(ALinkDest)
+  else if (AModule=Nil) then
+    Result:= FindAbsoluteLink(RootLinkNode.FirstChild.Name+'.'+ALinkDest)
+  else
     begin
-      { Okay, then we have to try all imported units of the current module }
-      UnitList := AModule.InterfaceSection.UsesList;
-      for i := UnitList.Count - 1 downto 0 do
+    if Pos(AModule.Name,ALinkDest) = 1 then
+      Result := ResolveLink(AModule, AModule.packagename + '.' + ALinkDest, Strict)
+    else
+      Result := ResolveLink(AModule, AModule.PathName + '.' + ALinkDest, Strict);
+    if (Result='') then
       begin
-        { Try all packages }
-        ThisPackage := RootLinkNode.FirstChild;
-        while Assigned(ThisPackage) do
-        begin
-          Result := ResolveLink(AModule, ThisPackage.Name + '.' +
-            TPasType(UnitList[i]).Name + '.' + ALinkDest);
-            if CanWeExit(Result) then
-              Exit;
-          ThisPackage := ThisPackage.NextSibling;
-        end;
+      Result:=ResolveLinkInPackages(AModule,ALinkDest,Strict);
+      if (Result='') then
+        Result:=ResolveLinkInUsedUnits(Amodule,AlinkDest,Strict);
       end;
     end;
-  end;
-
-  if Length(Result) = 0 then
+  // Match on parent : class/enumerated/record/module
+  if (Result='') and not strict then
     for i := Length(ALinkDest) downto 1 do
       if ALinkDest[i] = '.' then
-      begin
-        Result := ResolveLink(AModule, Copy(ALinkDest, 1, i - 1));
+        begin
+        Result := ResolveLink(AModule, Copy(ALinkDest, 1, i - 1), Strict);
         exit;
-      end;
+        end;
 end;
 
 procedure ReadXMLFileALT(OUT ADoc:TXMLDocument;const AFileName:ansistring);

utils/fpdoc/dw_html.pp

@@ -123,7 +123,7 @@ type
 
     Procedure CreateAllocator; virtual;
     procedure CreateCSSFile; virtual;
-    function ResolveLinkID(const Name: String): DOMString;
+    function ResolveLinkID(const Name: String; Level : Integer = 0): DOMString;
     function ResolveLinkIDInUnit(const Name,AUnitName: String): DOMString;
     function ResolveLinkWithinPackage(AElement: TPasElement;
       ASubpageIndex: Integer): String;
@@ -917,46 +917,13 @@ begin
     Result:=ResolveLinkID(AUnitName+'.'+Name);
 end;
 
-function THTMLWriter.ResolveLinkID(const Name: String): DOMString;
+function THTMLWriter.ResolveLinkID(const Name: String; Level : Integer = 0): DOMString;
+
 var
   i: Integer;
   ThisPackage: TLinkNode;
 begin
-  if Length(Name) = 0 then
-  begin
-    SetLength(Result, 0);
-    exit;
-  end;
-
-  if Name[1] = '#' then
-    Result := Engine.FindAbsoluteLink(Name)
-  else
-  begin
-    SetLength(Result, 0);
-    { Try all packages }
-    ThisPackage := Engine.RootLinkNode.FirstChild;
-    while Assigned(ThisPackage) do
-    begin
-      Result := Engine.FindAbsoluteLink(ThisPackage.Name + '.' + Name);
-      if Length(Result) = 0 then
-      begin
-        if Assigned(Module) then
-          begin
-          Result := Engine.FindAbsoluteLink(Module.PathName + '.' + Name);
-//          WriteLn('Searching for ', Module.PathName + '.' + Name, ' => ', Result);
-          end;
-        if Length(Result) = 0 then
-          for i := Length(Name) downto 1 do
-            if Name[i] = '.' then
-            begin
-              Result := ResolveLinkID(Copy(Name, 1, i - 1));
-              exit;
-            end;
-      end;
-      ThisPackage := ThisPackage.NextSibling;
-    end;
-  end;
-
+  Result:=Engine.ResolveLink(Module,Name, False);
   if Length(Result) > 0 then
     if Copy(Result, 1, Length(CurDirectory) + 1) = CurDirectory + '/' then
       Result := Copy(Result, Length(CurDirectory) + 2, Length(Result))
@@ -1192,7 +1159,7 @@ end;
 
 procedure THTMLWriter.DescrBeginLink(const AId: DOMString);
 var
-  a,s: String;
+  a,s,n : String;
 begin
   a:=AId;
   s := ResolveLinkID(a);
@@ -1203,7 +1170,11 @@ begin
     else
       s:='?';
     if a='' then a:='<empty>';
-    DoLog(SErrUnknownLinkID, [s,a]);
+    if Assigned(CurrentContext) then
+      N:=CurrentContext.Name
+    else
+      N:='?';
+    DoLog(SErrUnknownLinkID, [s,n,a]);
     PushOutputNode(CreateEl(CurOutputNode, 'b'));
   end else
     PushOutputNode(CreateLink(CurOutputNode, s));
@@ -2146,7 +2117,7 @@ Procedure THTMLWriter.AppendSeeAlsoSection(AElement : TPasElement;DocNode : TDoc
 var
   Node: TDOMNode;
   TableEl, El, TREl, TDEl, ParaEl, NewEl, DescrEl: TDOMElement;
-  l,s: String;
+  l,s,n: String;
   f: Text;
   IsFirstSeeAlso : Boolean;
 
@@ -2177,7 +2148,11 @@ begin
          else
            s:='?';
          if l='' then l:='<empty>';
-         DoLog(SErrUnknownLinkID, [s,l]);
+         if Assigned(AElement) then
+           N:=AElement.Name
+         else
+           N:='?';
+         DoLog(SErrUnknownLinkID, [s,N,l]);
          NewEl := CreateEl(ParaEl,'b')
          end
        else
@@ -3167,6 +3142,7 @@ var
     CurVisibility: TPasMemberVisibility;
     i: Integer;
     s: String;
+    t : TPasType;
     ah,ol,wt,ct,wc,cc  : boolean;
     ThisInterface,
     ThisClass: TPasClassType;
@@ -3285,13 +3261,6 @@ var
           AppendSym(CodeEl, ' = ');
           AppendText(CodeEl,TPasConst(Member).Expr.GetDeclaration(True));
           end
-        else if (Member is TPasVariable) then
-          begin
-          AppendHyperlink(CodeEl, Member);
-          AppendSym(CodeEl, ': ');
-          AppendHyperlink(CodeEl, TPasVariable(Member).VarType);
-          AppendSym(CodeEl, ';');
-          end
         else if (Member is TPasType) then
           begin
           AppendHyperlink(CodeEl, Member);
@@ -3302,10 +3271,11 @@ var
           begin
           AppendKw(CodeEl, 'property ');
           AppendHyperlink(CodeEl, Member);
-          if Assigned(TPasProperty(Member).VarType) then
+          t:=TPasProperty(Member).ResolvedType;
+          if Assigned(T) then
           begin
             AppendSym(CodeEl, ': ');
-            AppendHyperlink(CodeEl, TPasProperty(Member).VarType);
+            AppendHyperlink(CodeEl, T);
           end;
           AppendSym(CodeEl, ';');
           if TPasProperty(Member).IsDefault then
@@ -3329,6 +3299,13 @@ var
           if Length(s) > 0 then
             AppendText(CodeEl, '  [' + s + ']');
           end
+        else if (Member is TPasVariable) then
+          begin
+          AppendHyperlink(CodeEl, Member);
+          AppendSym(CodeEl, ': ');
+          AppendHyperlink(CodeEl, TPasVariable(Member).VarType);
+          AppendSym(CodeEl, ';');
+          end
         else
           AppendText(CreateWarning(CodeEl), '<' + Member.ClassName + '>');
       end;
@@ -3602,15 +3579,18 @@ var
   procedure CreatePropertyPage(Element: TPasProperty);
   var
     NeedBreak: Boolean;
+    T : TPasType;
+
   begin
     AppendKw(CodeEl, 'property ');
     AppendHyperlink(CodeEl, Element.Parent);
     AppendSym(CodeEl, '.');
     AppendText(CodeEl, Element.Name);
-    if Assigned(Element.VarType) then
+    T:=Element.ResolvedType;
+    if Assigned(T) then
     begin
       AppendSym(CodeEl, ' : ');
-      AppendType(CodeEl, TableEl, Element.VarType, False);
+      AppendType(CodeEl, TableEl, T, False);
     end;
 
     NeedBreak := False;

utils/fpdoc/dwriter.pp

@@ -47,7 +47,7 @@ resourcestring
 
   SErrDescrTagUnknown = 'Warning: Unknown tag "%s" in description';
   SErrUnknownEntityReference = 'Warning: Unknown entity reference "&%s;" found';
-  SErrUnknownLinkID = 'Warning: Target ID of <link> in unit "%s" is unknown: "%s"';
+  SErrUnknownLinkID = 'Warning: Target ID of <link> in unit "%s", element "%s", is unknown: "%s"';
   SErrUnknownPrintShortID = 'Warning: Target ID of <printshort> is unknown: "%s"';
   SErrUnknownLink = 'Could not resolve link to "%s"';
   SErralreadyRegistered = 'Class for output format "%s" already registered';
@@ -75,6 +75,7 @@ type
     FEmitNotes: Boolean;
     FEngine  : TFPDocEngine;
     FPackage : TPasPackage;
+    FContext : TPasElement;
     FTopics  : TList;
     FImgExt : String;
     FBeforeEmitNote : TWriterNoteEvent;
@@ -159,6 +160,7 @@ type
     procedure DescrEndTableRow; virtual; abstract;
     procedure DescrBeginTableCell; virtual; abstract;
     procedure DescrEndTableCell; virtual; abstract;
+    Property CurrentContext : TPasElement Read FContext ;
   public
     Constructor Create(APackage: TPasPackage; AEngine: TFPDocEngine); virtual;
     destructor Destroy;  override;
@@ -491,20 +493,24 @@ begin
   Result := False;
   if not Assigned(El) then
     exit;
-
-  Node := El.FirstChild;
-  while Assigned(Node) do
-  begin
-    if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'link') then
-      ConvertLink(AContext, TDOMElement(Node))
-    else if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'url') then
-      ConvertURL(AContext, TDOMElement(Node))
-    else
-      if not ConvertBaseShort(AContext, Node) then
-        exit;
-    Node := Node.NextSibling;
+  FContext:=AContext;
+  try
+    Node := El.FirstChild;
+    while Assigned(Node) do
+    begin
+      if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'link') then
+        ConvertLink(AContext, TDOMElement(Node))
+      else if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'url') then
+        ConvertURL(AContext, TDOMElement(Node))
+      else
+        if not ConvertBaseShort(AContext, Node) then
+          exit;
+      Node := Node.NextSibling;
+    end;
+    Result := True;
+  finally
+    FContext:=Nil;
   end;
-  Result := True;
 end;
 
 function TFPDocWriter.ConvertNotes(AContext: TPasElement; El: TDOMElement
@@ -732,53 +738,58 @@ var
   Node, Child: TDOMNode;
   ParaCreated: Boolean;
 begin
-  if AutoInsertBlock then
-    if IsExtShort(El.FirstChild) then
-      DescrBeginParagraph
-    else
-      AutoInsertBlock := False;
+  FContext:=AContext;
+  try
+    if AutoInsertBlock then
+      if IsExtShort(El.FirstChild) then
+        DescrBeginParagraph
+      else
+        AutoInsertBlock := False;
 
-  Node := El.FirstChild;
-  if not ConvertExtShort(AContext, Node) then
-  begin
-    while Assigned(Node) do
+    Node := El.FirstChild;
+    if not ConvertExtShort(AContext, Node) then
     begin
-      if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'section') then
+      while Assigned(Node) do
       begin
-        DescrBeginSectionTitle;
-        Child := Node.FirstChild;
-        while Assigned(Child) and (Child.NodeType <> ELEMENT_NODE) do
+        if (Node.NodeType = ELEMENT_NODE) and (Node.NodeName = 'section') then
         begin
-          if not IsDescrNodeEmpty(Child) then
-            Warning(AContext, SErrInvalidContentBeforeSectionTitle);
-          Child := Child.NextSibling;
-        end;
-        if not Assigned(Child) or (Child.NodeName <> 'title') then
-          Warning(AContext, SErrSectionTitleExpected)
-        else
-          ConvertShort(AContext, TDOMElement(Child));
-
-        DescrBeginSectionBody;
-
-        if IsExtShort(Child) then
-        begin
-          DescrBeginParagraph;
-          ParaCreated := True;
-        end else
-          ParaCreated := False;
+          DescrBeginSectionTitle;
+          Child := Node.FirstChild;
+          while Assigned(Child) and (Child.NodeType <> ELEMENT_NODE) do
+          begin
+            if not IsDescrNodeEmpty(Child) then
+              Warning(AContext, SErrInvalidContentBeforeSectionTitle);
+            Child := Child.NextSibling;
+          end;
+          if not Assigned(Child) or (Child.NodeName <> 'title') then
+            Warning(AContext, SErrSectionTitleExpected)
+          else
+            ConvertShort(AContext, TDOMElement(Child));
 
-        ConvertExtShortOrNonSectionBlocks(AContext, Child.NextSibling);
+          DescrBeginSectionBody;
 
-        if ParaCreated then
-          DescrEndParagraph;
-        DescrEndSection;
-      end else if not ConvertNonSectionBlock(AContext, Node) then
-        Warning(AContext, SErrInvalidDescr, [Node.NodeName]);
-      Node := Node.NextSibling;
-    end;
-  end else
-    if AutoInsertBlock then
-      DescrEndParagraph;
+          if IsExtShort(Child) then
+          begin
+            DescrBeginParagraph;
+            ParaCreated := True;
+          end else
+            ParaCreated := False;
+
+          ConvertExtShortOrNonSectionBlocks(AContext, Child.NextSibling);
+
+          if ParaCreated then
+            DescrEndParagraph;
+          DescrEndSection;
+        end else if not ConvertNonSectionBlock(AContext, Node) then
+          Warning(AContext, SErrInvalidDescr, [Node.NodeName]);
+        Node := Node.NextSibling;
+      end;
+    end else
+      if AutoInsertBlock then
+        DescrEndParagraph;
+  finally
+    FContext:=Nil;
+  end;
 end;
 
 procedure TFPDocWriter.ConvertExtShortOrNonSectionBlocks(AContext: TPasElement;