* synchronised with trunk till r30345

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

.gitattributes

@@ -517,6 +517,8 @@ compiler/oglx.pas svneol=native#text/plain
 compiler/ogmacho.pas svneol=native#text/plain
 compiler/ogmap.pas svneol=native#text/plain
 compiler/ognlm.pas svneol=native#text/plain
+compiler/ogomf.pas svneol=native#text/plain
+compiler/omfbase.pas svneol=native#text/plain
 compiler/optbase.pas svneol=native#text/plain
 compiler/optconstprop.pas svneol=native#text/pascal
 compiler/optcse.pas svneol=native#text/plain
@@ -3231,6 +3233,8 @@ packages/fcl-xml/tests/readertest.pp svneol=native#text/plain
 packages/fcl-xml/tests/readerunit.pp svneol=native#text/plain
 packages/fcl-xml/tests/template.xml svneol=native#text/plain
 packages/fcl-xml/tests/testgen.pp svneol=native#text/plain
+packages/fcl-xml/tests/testxmlconf.lpi svneol=native#text/plain
+packages/fcl-xml/tests/testxmlconf.lpr svneol=native#text/plain
 packages/fcl-xml/tests/xmlts.pp svneol=native#text/plain
 packages/fcl-xml/tests/xpathts.pp svneol=native#text/plain
 packages/fftw/Makefile svneol=native#text/plain
@@ -8204,7 +8208,9 @@ rtl/embedded/avr/start.inc svneol=native#text/plain
 rtl/embedded/buildrtl.lpi svneol=native#text/plain
 rtl/embedded/buildrtl.pp svneol=native#text/plain
 rtl/embedded/check.inc svneol=native#text/plain
+rtl/embedded/classes.pp svneol=native#text/plain
 rtl/embedded/consoleio.pp svneol=native#text/pascal
+rtl/embedded/dos.pp svneol=native#text/plain
 rtl/embedded/empty.cfg svneol=native#text/plain
 rtl/embedded/heapmgr.pp svneol=native#text/pascal
 rtl/embedded/i386/multiboot.pp svneol=native#text/plain
@@ -8216,7 +8222,9 @@ rtl/embedded/sysheap.inc svneol=native#text/plain
 rtl/embedded/sysos.inc svneol=native#text/plain
 rtl/embedded/sysosh.inc svneol=native#text/plain
 rtl/embedded/system.pp svneol=native#text/plain
+rtl/embedded/systhrd.inc svneol=native#text/plain
 rtl/embedded/sysutils.pp svneol=native#text/pascal
+rtl/embedded/tthread.inc svneol=native#text/plain
 rtl/emx/Makefile svneol=native#text/plain
 rtl/emx/Makefile.fpc svneol=native#text/plain
 rtl/emx/dos.pas svneol=native#text/plain
@@ -14356,6 +14364,8 @@ tests/webtbs/tw2738.pp svneol=native#text/plain
 tests/webtbs/tw2739.pp svneol=native#text/plain
 tests/webtbs/tw27424.pp svneol=native#text/pascal
 tests/webtbs/tw27515.pp svneol=native#text/pascal
+tests/webtbs/tw27517.pp svneol=native#text/plain
+tests/webtbs/tw27529.pp svneol=native#text/plain
 tests/webtbs/tw2758.pp svneol=native#text/plain
 tests/webtbs/tw2763.pp svneol=native#text/plain
 tests/webtbs/tw27634.pp svneol=native#text/plain
@@ -14363,6 +14373,7 @@ tests/webtbs/tw2765.pp svneol=native#text/plain
 tests/webtbs/tw27658.pp svneol=native#text/plain
 tests/webtbs/tw27665.pp svneol=native#text/plain
 tests/webtbs/tw2767.pp svneol=native#text/plain
+tests/webtbs/tw27691.pp svneol=native#text/plain
 tests/webtbs/tw2771.pp svneol=native#text/plain
 tests/webtbs/tw2772.pp svneol=native#text/plain
 tests/webtbs/tw2776.pp svneol=native#text/plain

compiler/arm/aasmcpu.pas

@@ -216,6 +216,7 @@ uses
          constructor op_reg_reg_reg(op : tasmop;_op1,_op2,_op3 : tregister);
          constructor op_reg_reg_const(op : tasmop;_op1,_op2 : tregister; _op3: aint);
          constructor op_reg_const_const(op : tasmop;_op1 : tregister; _op2,_op3: aint);
+         constructor op_reg_reg_const_const(op : tasmop;_op1,_op2 : tregister; _op3,_op4: aint);
          constructor op_reg_reg_sym_ofs(op : tasmop;_op1,_op2 : tregister; _op3: tasmsymbol;_op3ofs: longint);
          constructor op_reg_reg_ref(op : tasmop;_op1,_op2 : tregister; const _op3: treference);
          constructor op_reg_reg_shifterop(op : tasmop;_op1,_op2 : tregister;_op3 : tshifterop);
@@ -309,7 +310,8 @@ uses
 implementation
 
   uses
-    itcpugas,aoptcpu;
+    itcpugas,aoptcpu,
+    systems;
 
 
     procedure taicpu.loadshifterop(opidx:longint;const so:tshifterop);
@@ -522,6 +524,17 @@ implementation
        end;
 
 
+    constructor taicpu.op_reg_reg_const_const(op: tasmop; _op1, _op2: tregister; _op3, _op4: aint);
+      begin
+        inherited create(op);
+        ops:=4;
+        loadreg(0,_op1);
+        loadreg(1,_op2);
+        loadconst(2,aint(_op3));
+        loadconst(3,aint(_op4));
+      end;
+
+
     constructor taicpu.op_reg_const_ref(op : tasmop;_op1 : tregister;_op2 : aint;_op3 : treference);
       begin
          inherited create(op);
@@ -765,7 +778,8 @@ implementation
               { check for pre/post indexed }
               result := operand_read;
           //Thumb2
-          A_LSL, A_LSR, A_ROR, A_ASR, A_SDIV, A_UDIV, A_MOVW, A_MOVT, A_MLS, A_BFI:
+          A_LSL, A_LSR, A_ROR, A_ASR, A_SDIV, A_UDIV, A_MOVW, A_MOVT, A_MLS, A_BFI,
+          A_SMMLA,A_SMMLS:
             if opnr in [0] then
               result:=operand_write
             else
@@ -1558,6 +1572,7 @@ implementation
                     A_NEG:
                       begin
                         taicpu(curtai).opcode:=A_RSB;
+                        taicpu(curtai).oppostfix:=PF_S; // NEG should always set flags (according to documentation NEG<c> = RSBS<c>)
 
                         if taicpu(curtai).ops=2 then
                           begin
@@ -1585,7 +1600,9 @@ implementation
 
     procedure finalizearmcode(list, listtoinsert: TAsmList);
       begin
-        expand_instructions(list);
+        { Don't expand pseudo instructions when using GAS, it breaks on some thumb instructions }
+        if target_asm.id<>as_gas then
+          expand_instructions(list);
 
         { Do Thumb-2 16bit -> 32bit transformations }
         if GenerateThumb2Code then

compiler/arm/cpubase.pas

@@ -608,7 +608,7 @@ unit cpubase;
         else
           begin
             result:=false;
-            for i:=1 to 31 do
+            for i:=8 to 31 do
               begin
                 t:=RolDWord(d,i);
                 if ((t and $FF)=t) and

compiler/arm/cpuinfo.pas

@@ -767,8 +767,8 @@ Const
        { cpu_armv7    } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_BLX_LABEL,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2,CPUARM_HAS_UMULL],
        { cpu_armv7a   } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_BLX_LABEL,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2,CPUARM_HAS_UMULL],
        { cpu_armv7r   } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_BLX_LABEL,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_THUMB_IDIV,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2,CPUARM_HAS_UMULL],
-       { cpu_armv7m   } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_THUMB_IDIV,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2],
-       { cpu_armv7em  } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_THUMB_IDIV,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2]
+       { cpu_armv7m   } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_THUMB_IDIV,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2,CPUARM_HAS_UMULL],
+       { cpu_armv7em  } [CPUARM_HAS_BX,CPUARM_HAS_BLX,CPUARM_HAS_CLZ,CPUARM_HAS_EDSP,CPUARM_HAS_REV,CPUARM_HAS_RBIT,CPUARM_HAS_LDREX,CPUARM_HAS_THUMB_IDIV,CPUARM_HAS_DMB,CPUARM_HAS_THUMB2,CPUARM_HAS_UMULL]
      );
 
    { contains all CPU supporting any kind of thumb instruction set }

compiler/arm/rgcpu.pas

@@ -579,9 +579,9 @@ unit rgcpu;
               A_SMULL,
               A_SMLAL:
                 begin
+                  add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
                   if current_settings.cputype<cpu_armv6 then
                     begin
-                      add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[1]^.reg));
                       add_edge(getsupreg(taicpu(p).oper[1]^.reg),getsupreg(taicpu(p).oper[2]^.reg));
                       add_edge(getsupreg(taicpu(p).oper[0]^.reg),getsupreg(taicpu(p).oper[2]^.reg));
                     end;

compiler/fmodule.pas

@@ -996,6 +996,7 @@ implementation
                 { Give a note when the unit is not referenced, skip
                   this is for units with an initialization/finalization }
                 if (unitmap[pu.u.moduleid].refs=0) and
+                   pu.in_uses and
                    ((pu.u.flags and (uf_init or uf_finalize))=0) then
                   CGMessagePos2(pu.unitsym.fileinfo,sym_n_unit_not_used,pu.u.realmodulename^,realmodulename^);
               end;

compiler/i8086/cputarg.pas

@@ -53,10 +53,7 @@ implementation
 //      ,agx86int
     {$endif}
 
-//      ,ogcoff
-//      ,ogelf
-//      ,ogmacho
-//      ,cpuelf
+        ,ogomf
 
 {**************************************
         Assembler Readers

compiler/link.pas

@@ -761,22 +761,24 @@ Implementation
 
     Function TExternalLinker.MakeStaticLibrary:boolean;
 
-        function GetNextFiles(const maxCmdLength : Longint; var item : TCmdStrListItem) : TCmdStr;
+        function GetNextFiles(const maxCmdLength : Longint; var item : TCmdStrListItem; const addfilecmd : string) : TCmdStr;
           begin
             result := '';
             while (assigned(item) and ((length(result) + length(item.str) + 1) < maxCmdLength)) do begin
-              result := result + ' ' + item.str;
+              result := result + ' ' + addfilecmd + item.str;
               item := TCmdStrListItem(item.next);
             end;
           end;
 
       var
-        binstr, scriptfile : TCmdStr;
-        cmdstr, nextcmd, smartpath : TCmdStr;
+        binstr, firstbinstr, scriptfile : TCmdStr;
+        cmdstr, firstcmd, nextcmd, smartpath : TCmdStr;
         current : TCmdStrListItem;
         script: Text;
         scripted_ar : boolean;
+        ar_creates_different_output_file : boolean;
         success : boolean;
+        first : boolean;
       begin
         MakeStaticLibrary:=false;
       { remove the library, to be sure that it is rewritten }
@@ -785,6 +787,16 @@ Implementation
         smartpath:=FixPath(ChangeFileExt(current_module.asmfilename,target_info.smartext),false);
         SplitBinCmd(target_ar.arcmd,binstr,cmdstr);
         binstr := FindUtil(utilsprefix + binstr);
+        if target_ar.arfirstcmd<>'' then
+          begin
+            SplitBinCmd(target_ar.arfirstcmd,firstbinstr,firstcmd);
+            firstbinstr := FindUtil(utilsprefix + firstbinstr);
+          end
+        else
+          begin
+            firstbinstr:=binstr;
+            firstcmd:=cmdstr;
+          end;
 
 
         scripted_ar:=(target_ar.id=ar_gnu_ar_scripted) or
@@ -823,14 +835,33 @@ Implementation
           end
         else
           begin
+            ar_creates_different_output_file:=(Pos('$OUTPUTLIB',cmdstr)>0) or (Pos('$OUTPUTLIB',firstcmd)>0);
             Replace(cmdstr,'$LIB',maybequoted(current_module.staticlibfilename));
+            Replace(firstcmd,'$LIB',maybequoted(current_module.staticlibfilename));
+            Replace(cmdstr,'$OUTPUTLIB',maybequoted(current_module.staticlibfilename+'.tmp'));
+            Replace(firstcmd,'$OUTPUTLIB',maybequoted(current_module.staticlibfilename+'.tmp'));
             { create AR commands }
             success := true;
             current := TCmdStrListItem(SmartLinkOFiles.First);
+            first := true;
             repeat
-              nextcmd := cmdstr;
-              Replace(nextcmd,'$FILES',GetNextFiles(2047, current));
-              success:=DoExec(binstr,nextcmd,false,true);
+              if first then
+                nextcmd := firstcmd
+              else
+                nextcmd := cmdstr;
+              Replace(nextcmd,'$FILES',GetNextFiles(2047, current, target_ar.addfilecmd));
+              if first then
+                success:=DoExec(firstbinstr,nextcmd,false,true)
+              else
+                success:=DoExec(binstr,nextcmd,false,true);
+              if ar_creates_different_output_file then
+                begin
+                  if FileExists(current_module.staticlibfilename,false) then
+                    DeleteFile(current_module.staticlibfilename);
+                  if FileExists(current_module.staticlibfilename+'.tmp',false) then
+                    RenameFile(current_module.staticlibfilename+'.tmp',current_module.staticlibfilename);
+                end;
+              first := false;
             until (not assigned(current)) or (not success);
           end;
 
@@ -1573,6 +1604,8 @@ Implementation
       ar_gnu_ar_info : tarinfo =
           (
             id          : ar_gnu_ar;
+            addfilecmd  : '';
+            arfirstcmd  : '';
             arcmd       : 'ar qS $LIB $FILES';
             arfinishcmd : 'ar s $LIB'
           );
@@ -1580,25 +1613,33 @@ Implementation
       ar_gnu_ar_scripted_info : tarinfo =
           (
             id    : ar_gnu_ar_scripted;
+            addfilecmd  : '';
+            arfirstcmd  : '';
             arcmd : 'ar -M < $SCRIPT';
             arfinishcmd : ''
           );
 
       ar_gnu_gar_info : tarinfo =
           ( id          : ar_gnu_gar;
+            addfilecmd  : '';
+            arfirstcmd  : '';
             arcmd       : 'gar qS $LIB $FILES';
             arfinishcmd : 'gar s $LIB'
           );
 
       ar_watcom_wlib_omf_info : tarinfo =
           ( id          : ar_watcom_wlib_omf;
-            arcmd       : 'wlib -q -fo -c -b $LIB $FILES';
+            addfilecmd  : '+';
+            arfirstcmd  : 'wlib -q -fo -c -b -n -o=$OUTPUTLIB $LIB $FILES';
+            arcmd       : 'wlib -q -fo -c -b -o=$OUTPUTLIB $LIB $FILES';
             arfinishcmd : ''
           );
 
       ar_watcom_wlib_omf_scripted_info : tarinfo =
           (
             id    : ar_watcom_wlib_omf_scripted;
+            addfilecmd  : '+';
+            arfirstcmd  : '';
             arcmd : 'wlib @$SCRIPT';
             arfinishcmd : ''
           );

compiler/m68k/aasmcpu.pas

@@ -473,7 +473,8 @@ type
 
         case opcode of
           // CPU opcodes
-          A_MOVE, A_MOVEQ, A_MOVEA, A_MVZ, A_MVS, A_MOV3Q, A_LEA:
+          A_MOVE, A_MOVEQ, A_MOVEA, A_MVZ, A_MVS, A_MOV3Q, A_LEA,
+          A_BSET, A_BCLR:
             if opnr=1 then
               result:=operand_write;
           A_ADD, A_ADDQ, A_ADDX, A_SUB, A_SUBQ, A_SUBX,
@@ -490,13 +491,13 @@ type
             result:=operand_write;
           A_NEG, A_NEGX, A_EXT, A_EXTB, A_NOT, A_SWAP:
             result:=operand_readwrite;
-          A_TST,A_CMP,A_CMPI:
+          A_TST,A_CMP,A_CMPI,A_BTST:
             begin end; { Do nothing, default operand_read is fine here. }
 
           // FPU opcodes
           A_FSXX, A_FSEQ, A_FSNE, A_FSLT, A_FSLE, A_FSGT, A_FSGE:
              result:=operand_write;
-          A_FABS,A_FSQRT,A_FNEG:
+          A_FABS,A_FSQRT,A_FNEG,A_FSIN,A_FCOS:
              if ops = 1 then
                begin
                  if opnr = 0 then

compiler/m68k/aoptcpu.pas

@@ -112,6 +112,17 @@ unit aoptcpu;
                           result:=true;
                         end;
                   end;
+              { MOVEA #0,Ax to SUBA Ax,Ax, because it's shorter }
+              A_MOVEA:
+                if (taicpu(p).oper[0]^.typ = top_const) and
+                   (taicpu(p).oper[0]^.val = 0) then
+                  begin
+                    DebugMsg('Optimizer: MOVEA #0,Ax to SUBA Ax,Ax',p);
+                    taicpu(p).opcode:=A_SUBA;
+                    taicpu(p).opsize:=S_L; { otherwise it will be .W -> BOOM }
+                    taicpu(p).loadoper(0,taicpu(p).oper[1]^);
+                    result:=true;
+                  end;
               { CMP #0,<ea> equals to TST <ea>, just shorter and TST is more flexible anyway }
               A_CMP:
                 if (taicpu(p).oper[0]^.typ = top_const) and

compiler/m68k/cgcpu.pas

@@ -741,9 +741,13 @@ unit cgcpu;
         if isaddressregister(register) then
           begin
             { an m68k manual I have recommends SUB Ax,Ax to be used instead of CLR for address regs }
-            if a = 0 then
+            { Premature optimization is the root of all evil - this code breaks spilling if the
+              register contains a spilled regvar, eg. a Pointer which is set to nil, then random
+              havoc happens... This is kept here for reference now, to allow fixing of the spilling
+              later. Most of the optimizations below here could be moved to the optimizer. (KB) }
+            {if a = 0 then
               list.concat(taicpu.op_reg_reg(A_SUB,S_L,register,register))
-            else
+            else}
               { ISA B/C Coldfire has MOV3Q which can move -1 or 1..7 to any reg }
               if (current_settings.cputype in [cpu_isa_b,cpu_isa_c]) and 
                  ((longint(a) = -1) or ((longint(a) > 0) and (longint(a) < 8))) then

compiler/m68k/cpubase.pas

@@ -68,7 +68,7 @@ unit cpubase;
          a_move16,
          { coldfire v4 instructions }
          a_mov3q,a_mvz,a_mvs,a_sats,a_byterev,a_ff1,
-         { fpu processor instructions - directly supported only. }
+         { fpu processor instructions - directly supported }
          { ieee aware and misc. condition codes not supported   }
          a_fabs,a_fadd,
          a_fbeq,a_fbne,a_fbngt,a_fbgt,a_fbge,a_fbnge,
@@ -82,6 +82,8 @@ unit cpubase;
          a_fsflmul,a_ftst,
          a_ftrapeq,a_ftrapne,a_ftrapgt,a_ftrapngt,a_ftrapge,a_ftrapnge,
          a_ftraplt,a_ftrapnlt,a_ftraple,a_ftrapgl,a_ftrapngl,a_ftrapgle,a_ftrapngle,
+         { fpu instructions - indirectly supported }
+         a_fsin,a_fcos,
          { protected instructions }
          a_cprestore,a_cpsave,
          { fpu unit protected instructions                    }

compiler/m68k/hlcgcpu.pas

@@ -28,13 +28,20 @@ unit hlcgcpu;
 
 interface
 
+
   uses
-    aasmdata,
-    symdef,
+    globtype,
+    aasmbase, aasmdata,
+    cgbase, cgutils,
+    symconst,symtype,symdef,
     hlcg2ll;
 
   type
     thlcgcpu = class(thlcg2ll)
+      procedure a_bit_set_reg_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister); override;
+      procedure a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: tcgint; destreg: tregister); override;
+      procedure a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference); override;
+      procedure a_bit_set_const_ref(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: tcgint; const ref: treference); override;
       procedure g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);override;
     end;
 
@@ -43,33 +50,87 @@ interface
 implementation
 
   uses
-    globtype,verbose,
+    globals, verbose, systems, cutils,
     fmodule,
-    aasmbase,aasmtai,aasmcpu,
-    symconst,
+    aasmtai, aasmcpu,
+    defutil,
     hlcgobj,
-    cgbase, cgutils, cgobj, cpubase, cgcpu;
+    cpuinfo, cgobj, cpubase, cgcpu;
+
+
+
+  const
+    bit_set_clr_instr: array[boolean] of tasmop = (A_BCLR,A_BSET);
+
+  procedure thlcgcpu.a_bit_set_reg_reg(list: TAsmList; doset: boolean; bitnumbersize, destsize: tdef; bitnumber, dest: tregister);
+    var
+      tmpvalue: tregister;
+    begin
+      tmpvalue:=getintregister(list,ptruinttype);
+      //list.concat(tai_comment.create(strpnew('a_bit_set_reg_reg: called!')));
+      a_load_const_reg(list,ptruinttype,destsize.size*8-1,tmpvalue);
+      a_op_reg_reg(list,OP_SUB,bitnumbersize,bitnumber,tmpvalue);
+      list.concat(taicpu.op_reg_reg(bit_set_clr_instr[doset],S_NO,tmpvalue,dest));
+    end;
+
+
+  procedure thlcgcpu.a_bit_set_const_reg(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: tcgint; destreg: tregister);
+    begin
+      //list.concat(tai_comment.create(strpnew('a_bit_set_const_reg: called!')));
+      list.concat(taicpu.op_const_reg(bit_set_clr_instr[doset],S_NO,(destsize.size*8)-bitnumber-1,destreg));
+    end;
+
+
+  procedure thlcgcpu.a_bit_set_reg_ref(list: TAsmList; doset: boolean; fromsize, tosize: tdef; bitnumber: tregister; const ref: treference);
+    var
+      tmpvalue: tregister;
+      sref: tsubsetreference;
+    begin
+      //list.concat(tai_comment.create(strpnew('a_bit_set_reg_ref: called!')));
+      sref:=get_bit_reg_ref_sref(list,fromsize,tosize,bitnumber,ref);
+      tcg68k(cg).fixref(list,sref.ref);
+
+      tmpvalue:=getintregister(list,ptruinttype);
+      a_load_const_reg(list,ptruinttype,7,tmpvalue);
+      a_op_reg_reg(list,OP_SUB,fromsize,sref.bitindexreg,tmpvalue);
+
+      { memory accesses of bset/bclr are always byte, so no alignment problem }
+      list.concat(taicpu.op_reg_ref(bit_set_clr_instr[doset],S_NO,tmpvalue,sref.ref));
+    end;
+
+
+  procedure thlcgcpu.a_bit_set_const_ref(list: TAsmList; doset: boolean; destsize: tdef; bitnumber: tcgint; const ref: treference);
+    var
+      sref: tsubsetreference;
+    begin
+      //list.concat(tai_comment.create(strpnew('a_bit_set_const_ref: called!')));
+      sref:=get_bit_const_ref_sref(bitnumber,destsize,ref);
+      tcg68k(cg).fixref(list,sref.ref);
+
+      { memory accesses of bset/bclr are always byte, so no alignment problem }
+      list.concat(taicpu.op_const_ref(bit_set_clr_instr[doset],S_NO,8-sref.startbit-1,sref.ref));
+    end;
 
 
   procedure thlcgcpu.g_intf_wrapper(list: TAsmList; procdef: tprocdef; const labelname: string; ioffset: longint);
 
-      procedure getselftoa0(offs:longint);
-        var
-          href : treference;
-          selfoffsetfromsp : longint;
-        begin
-          { move.l offset(%sp),%a0 }
-
-          { framepointer is pushed for nested procs }
-          if procdef.parast.symtablelevel>normal_function_level then
-            selfoffsetfromsp:=sizeof(aint)
-          else
-            selfoffsetfromsp:=0;
-          reference_reset_base(href, voidstackpointertype, NR_SP,selfoffsetfromsp+offs,4);
-          cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_A0);
-        end;
-
-      procedure loadvmttoa0;
+    procedure getselftoa0(offs:longint);
+      var
+        href : treference;
+        selfoffsetfromsp : longint;
+      begin
+        { move.l offset(%sp),%a0 }
+
+        { framepointer is pushed for nested procs }
+        if procdef.parast.symtablelevel>normal_function_level then
+          selfoffsetfromsp:=sizeof(aint)
+        else
+          selfoffsetfromsp:=0;
+        reference_reset_base(href, voidstackpointertype, NR_SP,selfoffsetfromsp+offs,4);
+        cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_A0);
+      end;
+
+    procedure loadvmttoa0;
       var
         href : treference;
       begin
@@ -78,7 +139,7 @@ implementation
         cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,NR_A0);
       end;
 
-      procedure op_ona0methodaddr;
+    procedure op_ona0methodaddr;
       var
         href : treference;
       begin

compiler/m68k/itcpugas.pas

@@ -62,7 +62,7 @@ interface
          'move16',
          { coldfire v4 instructions }
          'mov3q','mvz','mvs','sats','byterev','ff1',
-         { fpu processor instructions - directly supported only. }
+         { fpu processor instructions - directly supported }
          { ieee aware and misc. condition codes not supported   }
          'fabs','fadd',
          'fbeq','fbne','fbngt','fbgt','fbge','fbnge',
@@ -76,6 +76,8 @@ interface
          'fsflmul','ftst',
          'ftrapeq','ftrapne','ftrapgt','ftrapngt','ftrapge','ftrapnge',
          'ftraplt','ftrapnlt','ftraple','ftrapgl','ftrapngl','ftrapgle','ftrapngle',
+         { fpu instructions - indirectly supported }
+         'fsin','fcos',
          { protected instructions }
          'cprestore','cpsave',
          { fpu unit protected instructions                    }

compiler/m68k/n68kinl.pas

@@ -34,18 +34,18 @@ interface
         function first_sqr_real: tnode; override;
         function first_sqrt_real: tnode; override;
         {function first_arctan_real: tnode; override;
-        function first_ln_real: tnode; override;
+        function first_ln_real: tnode; override;}
         function first_cos_real: tnode; override;
-        function first_sin_real: tnode; override;}
+        function first_sin_real: tnode; override;
 
         procedure second_abs_real; override;
         procedure second_sqr_real; override;
         procedure second_sqrt_real; override;
         {procedure second_arctan_real; override;
-        procedure second_ln_real; override;
+        procedure second_ln_real; override;}
         procedure second_cos_real; override;
         procedure second_sin_real; override;
-        procedure second_prefetch; override;
+        {procedure second_prefetch; override;
         procedure second_abs_long; override;}
       private
         procedure second_do_operation(op: TAsmOp);
@@ -112,6 +112,38 @@ implementation
           end;
       end;
 
+    function t68kinlinenode.first_sin_real : tnode;
+      begin
+        if (cs_fp_emulation in current_settings.moduleswitches) then
+          result:=inherited first_sin_real
+        else
+          begin
+            case current_settings.fputype of
+              fpu_68881:
+                expectloc:=LOC_FPUREGISTER;
+              else
+                internalerror(2015022203);
+            end;
+            first_sin_real:=nil;
+          end;
+      end;
+
+    function t68kinlinenode.first_cos_real : tnode;
+      begin
+        if (cs_fp_emulation in current_settings.moduleswitches) then
+          result:=inherited first_cos_real
+        else
+          begin
+            case current_settings.fputype of
+              fpu_68881:
+                expectloc:=LOC_FPUREGISTER;
+              else
+                internalerror(2015022203);
+            end;
+            first_cos_real:=nil;
+          end;
+      end;
+
     procedure t68kinlinenode.second_abs_real;
       begin
         //current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('second_abs_real called!')));
@@ -147,6 +179,18 @@ implementation
         second_do_operation(A_FSQRT);
       end;
 
+    procedure t68kinlinenode.second_sin_real;
+      begin
+        //current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('second_sqrt_real called!')));
+        second_do_operation(A_FSIN);
+      end;
+
+    procedure t68kinlinenode.second_cos_real;
+      begin
+        //current_asmdata.CurrAsmList.concat(tai_comment.create(strpnew('second_sqrt_real called!')));
+        second_do_operation(A_FCOS);
+      end;
+
     procedure t68kinlinenode.second_do_operation(op: TAsmOp);
       var
         href: TReference;

compiler/m68k/n68kmem.pas

@@ -33,7 +33,8 @@ interface
 
     type
        t68kvecnode = class(tcgvecnode)
-          procedure update_reference_reg_mul(maybe_const_reg: tregister; regsize: tdef; l: aint);override;
+          procedure update_reference_reg_mul(maybe_const_reg: tregister; regsize: tdef; l: aint); override;
+          procedure update_reference_reg_packed(maybe_const_reg: tregister; regsize: tdef; l:aint); override;
           //procedure pass_generate_code;override;
        end;
 
@@ -45,7 +46,8 @@ implementation
       symdef,paramgr,
       aasmtai,aasmdata,
       nld,ncon,nadd,
-      cgutils,cgobj;
+      cgutils,cgobj,
+      defutil;
 
 
 {*****************************************************************************
@@ -123,6 +125,62 @@ implementation
           location.reference.alignment:=newalignment(location.reference.alignment,l);
       end;
 
+     { see remarks for tcgvecnode.update_reference_reg_mul above }
+     procedure t68kvecnode.update_reference_reg_packed(maybe_const_reg: tregister; regsize: tdef; l:aint);
+       var
+         sref: tsubsetreference;
+         offsetreg, hreg: tregister;
+         alignpower: aint;
+         temp : longint;
+       begin
+         { only orddefs are bitpacked. Even then we only need special code in }
+         { case the bitpacked *byte size* is not a power of two, otherwise    }
+         { everything can be handled using the the regular array code.        }
+         if ((l mod 8) = 0) and
+            (ispowerof2(l div 8,temp) or
+             not is_ordinal(resultdef)
+{$ifndef cpu64bitalu}
+             or is_64bitint(resultdef)
+{$endif not cpu64bitalu}
+             ) then
+           begin
+             update_reference_reg_mul(maybe_const_reg,regsize,l div 8);
+             exit;
+           end;
+         if (l > 8*sizeof(aint)) then
+           internalerror(200608051);
+         sref.ref := location.reference;
+         hreg := cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
+         cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,OS_INT,tarraydef(left.resultdef).lowrange,maybe_const_reg,hreg);
+         cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_IMUL,OS_INT,l,hreg);
+         { keep alignment for index }
+         sref.ref.alignment := left.resultdef.alignment;
+         if not ispowerof2(packedbitsloadsize(l),temp) then
+           internalerror(2006081201);
+         alignpower:=temp;
+         offsetreg := cg.getintregister(current_asmdata.CurrAsmList,OS_ADDR);
+         cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SHR,OS_ADDR,3+alignpower,hreg,offsetreg);
+         cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SHL,OS_ADDR,alignpower,offsetreg);
+         if (sref.ref.base = NR_NO) then
+           sref.ref.base := offsetreg
+         else if (sref.ref.index = NR_NO) then
+           sref.ref.index := offsetreg
+         else
+           begin
+             cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_ADD,OS_ADDR,sref.ref.base,offsetreg);
+             sref.ref.base := offsetreg;
+           end;
+         cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_AND,OS_INT,(1 shl (3+alignpower))-1,hreg);
+         sref.bitindexreg := hreg;
+         sref.startbit := 0;
+         sref.bitlen := resultdef.packedbitsize;
+         if (left.location.loc = LOC_REFERENCE) then
+           location.loc := LOC_SUBSETREF
+         else
+           location.loc := LOC_CSUBSETREF;
+         location.sref := sref;
+       end;
+
     {procedure t68kvecnode.pass_generate_code;
       begin
         inherited pass_generate_code;

compiler/nadd.pas

@@ -2152,7 +2152,7 @@ implementation
             inserttypeconv(right,sinttype);
           end;
 
-         if cmp_of_disjunct_ranges(res) then
+         if cmp_of_disjunct_ranges(res) and not(nf_internal in flags) then
            begin
              if res then
                CGMessage(type_w_comparison_always_true)

compiler/nflw.pas

@@ -84,6 +84,7 @@ interface
 
        tifnode = class(tloopnode)
           constructor create(l,r,_t1 : tnode);virtual;reintroduce;
+          constructor create_internal(l,r,_t1 : tnode);virtual;reintroduce;
           function pass_typecheck:tnode;override;
           function pass_1 : tnode;override;
           function simplify(forinline : boolean) : tnode;override;
@@ -1337,6 +1338,13 @@ implementation
       end;
 
 
+    constructor tifnode.create_internal(l,r,_t1 : tnode);
+      begin
+        create(l,r,_t1);
+        include(flags,nf_internal);
+      end;
+
+
     function tifnode.internalsimplify(warn: boolean) : tnode;
       begin
         result:=nil;

compiler/nmat.pas

@@ -361,7 +361,7 @@ implementation
              result_data:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,true);
 
              { right <=0? }
-             addstatement(statements,cifnode.create(caddnode.create(lten,right.getcopy,cordconstnode.create(0,resultdef,false)),
+             addstatement(statements,cifnode.create_internal(caddnode.create_internal(lten,right.getcopy,cordconstnode.create(0,resultdef,false)),
                { then: result:=left mod right }
                ccallnode.createintern('fpc_divbyzero',nil),
                nil
@@ -371,17 +371,17 @@ implementation
              { result:=(-left) mod right }
              addstatement(else_statements,cassignmentnode.create(ctemprefnode.create(result_data),cmoddivnode.create(modn,cunaryminusnode.create(left.getcopy),right.getcopy)));
              { result<>0? }
-             addstatement(else_statements,cifnode.create(caddnode.create(unequaln,ctemprefnode.create(result_data),cordconstnode.create(0,resultdef,false)),
+             addstatement(else_statements,cifnode.create_internal(caddnode.create_internal(unequaln,ctemprefnode.create(result_data),cordconstnode.create(0,resultdef,false)),
                { then: result:=right-result }
-               cassignmentnode.create(ctemprefnode.create(result_data),caddnode.create(subn,right.getcopy,ctemprefnode.create(result_data))),
+               cassignmentnode.create_internal(ctemprefnode.create(result_data),caddnode.create_internal(subn,right.getcopy,ctemprefnode.create(result_data))),
                nil
                ));
 
              addstatement(statements,result_data);
              { if left>=0 }
-             addstatement(statements,cifnode.create(caddnode.create(gten,left.getcopy,cordconstnode.create(0,resultdef,false)),
+             addstatement(statements,cifnode.create_internal(caddnode.create_internal(gten,left.getcopy,cordconstnode.create(0,resultdef,false)),
                { then: result:=left mod right }
-               cassignmentnode.create(ctemprefnode.create(result_data),cmoddivnode.create(modn,left.getcopy,right.getcopy)),
+               cassignmentnode.create_internal(ctemprefnode.create(result_data),cmoddivnode.create(modn,left.getcopy,right.getcopy)),
                { else block }
                else_block
                ));

compiler/ogomf.pas

@@ -0,0 +1,131 @@
+{
+    Copyright (c) 2015 by Nikolay Nikolov
+
+    Contains the binary Relocatable Object Module Format (OMF) reader and writer
+    This is the object format used on the i8086-msdos platform.
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit ogomf;
+
+{$i fpcdefs.inc}
+
+interface
+
+    uses
+       { common }
+       cclasses,globtype,
+       { target }
+       systems,
+       { assembler }
+       cpuinfo,cpubase,aasmbase,assemble,link,
+       { OMF definitions }
+       omfbase,
+       { output }
+       ogbase,
+       owbase;
+
+    type
+      TOmfObjData = class(TObjData)
+      public
+        function sectionname(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder):string;override;
+        procedure writeReloc(Data:aint;len:aword;p:TObjSymbol;Reloctype:TObjRelocationType);override;
+      end;
+
+      TOmfObjOutput = class(tObjOutput)
+      protected
+        function writeData(Data:TObjData):boolean;override;
+      public
+        constructor create(AWriter:TObjectWriter);override;
+      end;
+
+      TOmfAssembler = class(tinternalassembler)
+        constructor create(smart:boolean);override;
+      end;
+
+implementation
+
+    uses
+       SysUtils,
+       cutils,verbose,globals,
+       fmodule,aasmtai,aasmdata,
+       ogmap,
+       version
+       ;
+
+{****************************************************************************
+                                TOmfObjData
+****************************************************************************}
+
+    function TOmfObjData.sectionname(atype:TAsmSectiontype;const aname:string;aorder:TAsmSectionOrder):string;
+      begin
+        result:=aname;
+      end;
+
+    procedure TOmfObjData.writeReloc(Data:aint;len:aword;p:TObjSymbol;Reloctype:TObjRelocationType);
+      begin
+      end;
+
+{****************************************************************************
+                                TOmfObjOutput
+****************************************************************************}
+
+    function TOmfObjOutput.writeData(Data:TObjData):boolean;
+      begin
+        result:=true;
+      end;
+
+    constructor TOmfObjOutput.create(AWriter:TObjectWriter);
+      begin
+        inherited create(AWriter);
+        cobjdata:=TOmfObjData;
+      end;
+
+{****************************************************************************
+                               TOmfAssembler
+****************************************************************************}
+
+    constructor TOmfAssembler.Create(smart:boolean);
+      begin
+        inherited Create(smart);
+        CObjOutput:=TOmfObjOutput;
+      end;
+
+{*****************************************************************************
+                                  Initialize
+*****************************************************************************}
+{$ifdef i8086}
+    const
+       as_i8086_omf_info : tasminfo =
+          (
+            id     : as_i8086_omf;
+            idtxt  : 'OMF';
+            asmbin : '';
+            asmcmd : '';
+            supported_targets : [system_i8086_msdos];
+            flags : [af_outputbinary,af_needar,af_no_debug];
+            labelprefix : '..@';
+            comment : '; ';
+            dollarsign: '$';
+          );
+{$endif i8086}
+
+initialization
+{$ifdef i8086}
+  RegisterAssembler(as_i8086_omf_info,TOmfAssembler);
+{$endif i8086}
+end.

compiler/omfbase.pas

@@ -0,0 +1,175 @@
+{
+    Copyright (c) 2015 by Nikolay Nikolov
+
+    Contains Relocatable Object Module Format (OMF) definitions
+    This is the object format used on the i8086-msdos platform.
+
+    This program is free software; you can redistribute it and/or modify
+    it under the terms of the GNU General Public License as published by
+    the Free Software Foundation; either version 2 of the License, or
+    (at your option) any later version.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+    GNU General Public License for more details.
+
+    You should have received a copy of the GNU General Public License
+    along with this program; if not, write to the Free Software
+    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+ ****************************************************************************
+}
+unit omfbase;
+
+{$i fpcdefs.inc}
+
+interface
+
+  uses
+    owbase;
+
+  const
+    { OMF record types }
+    RT_THEADR    = $80;  { Translator Header Record }
+    RT_LHEADR    = $82;  { Library Module Header Record }
+    RT_COMENT    = $88;  { Comment Record }
+    RT_MODEND    = $8A;  { Module End Record }
+    RT_MODEND32  = $8B;
+    RT_EXTDEF    = $8C;  { External Names Definition Record }
+    RT_PUBDEF    = $90;  { Public Names Definition Record }
+    RT_PUBDEF32  = $91;
+    RT_LINNUM    = $94;  { Line Numbers Record }
+    RT_LINNUM32  = $95;
+    RT_LNAMES    = $96;  { List of Names Record }
+    RT_SEGDEF    = $98;  { Segment Definition Record }
+    RT_SEGDEF32  = $99;
+    RT_GRPDEF    = $9A;  { Group Definition Record }
+    RT_FIXUPP    = $9C;  { Fixup Record }
+    RT_FIXUPP32  = $9D;
+    RT_LEDATA    = $A0;  { Logical Enumerated Data Record }
+    RT_LEDATA32  = $A1;
+    RT_LIDATA    = $A2;  { Logical Iterated Data Record }
+    RT_LIDATA32  = $A3;
+    RT_COMDEF    = $B0;  { Communal Names Definition Record }
+    RT_BAKPAT    = $B2;  { Backpatch Record }
+    RT_BAKPAT32  = $B3;
+    RT_LEXTDEF   = $B4;  { Local External Names Definition Record }
+    RT_LEXTDEF32 = $B5;
+    RT_LPUBDEF   = $B6;  { Local Public Names Definition Record }
+    RT_LPUBDEF32 = $B7;
+    RT_LCOMDEF   = $B8;  { Local Communal Names Definition Record }
+    RT_CEXTDEF   = $BC;  { COMDAT External Names Definition Record }
+    RT_COMDAT    = $C2;  { Initialized Communal Data Record }
+    RT_COMDAT32  = $C3;
+    RT_LINSYM    = $C4;  { Symbol Line Numbers Record }
+    RT_LINSYM32  = $C5;
+    RT_ALIAS     = $C6;  { Alias Definition Record }
+    RT_NBKPAT    = $C8;  { Named Backpatch Record }
+    RT_NBKPAT32  = $C9;
+    RT_LLNAMES   = $CA;  { Local Logical Names Definition Record }
+    RT_VERNUM    = $CC;  { OMF Version Number Record }
+    RT_VENDEXT   = $CE;  { Vendor-specific OMF Extension Record }
+
+  type
+
+    { TOmfRawRecord }
+
+    TOmfRawRecord = class
+    private
+      function GetChecksumByte: Byte;
+      function GetRecordLength: Word;
+      function GetRecordType: Byte;
+      procedure SetChecksumByte(AValue: Byte);
+      procedure SetRecordLength(AValue: Word);
+      procedure SetRecordType(AValue: Byte);
+    public
+      RawData: array [-3..65535] of Byte;
+      property RecordType: Byte read GetRecordType write SetRecordType;
+      property RecordLength: Word read GetRecordLength write SetRecordLength;
+
+      procedure CalculateChecksumByte;
+      function VerifyChecksumByte: boolean;
+      property ChecksumByte: Byte read GetChecksumByte write SetChecksumByte;
+
+      procedure ReadFrom(aReader: TObjectReader);
+      procedure WriteTo(aWriter: TObjectWriter);
+    end;
+
+implementation
+
+  { TOmfRawRecord }
+
+  function TOmfRawRecord.GetRecordType: Byte;
+    begin
+      Result:=RawData[-3];
+    end;
+
+  procedure TOmfRawRecord.SetRecordType(AValue: Byte);
+    begin
+      RawData[-3]:=AValue;
+    end;
+
+  function TOmfRawRecord.GetRecordLength: Word;
+    begin
+      Result:=RawData[-2] or (RawData[-1] shl 8);
+    end;
+
+  procedure TOmfRawRecord.SetRecordLength(AValue: Word);
+    begin
+      RawData[-2]:=Byte(AValue);
+      RawData[-1]:=Byte(AValue shr 8);
+    end;
+
+  function TOmfRawRecord.GetChecksumByte: Byte;
+    begin
+      if RecordLength>0 then
+        Result:=RawData[RecordLength-1]
+      else
+        Result:=0;
+    end;
+
+  procedure TOmfRawRecord.SetChecksumByte(AValue: Byte);
+    begin
+      if RecordLength>0 then
+        RawData[RecordLength-1]:=AValue;
+    end;
+
+  procedure TOmfRawRecord.CalculateChecksumByte;
+    var
+      I: Integer;
+      b: Byte;
+    begin
+      b:=0;
+      for I:=-3 to RecordLength-2 do
+        b:=byte(b+RawData[I]);
+      SetChecksumByte($100-b);
+    end;
+
+  function TOmfRawRecord.VerifyChecksumByte: boolean;
+    var
+      I: Integer;
+      b: Byte;
+    begin
+      { according to the OMF spec, some tools always write a 0 rather than
+        computing the checksum, so it should also be accepted as correct }
+      if ChecksumByte=0 then
+        exit(true);
+      b:=0;
+      for I:=-3 to RecordLength-1 do
+        b:=byte(b+RawData[I]);
+      Result:=(b=0);
+    end;
+
+  procedure TOmfRawRecord.ReadFrom(aReader: TObjectReader);
+    begin
+      aReader.read(RawData, 3);
+      aReader.read(RawData[0], RecordLength);
+    end;
+
+  procedure TOmfRawRecord.WriteTo(aWriter: TObjectWriter);
+    begin
+      aWriter.write(RawData, RecordLength+3);
+    end;
+
+end.

compiler/options.pas

@@ -1353,7 +1353,12 @@ begin
                    StopOptions(1);
                  end;
                if l>0 then
-                 set_system_compvar(hs,Copy(more,l+2,255))
+                 begin
+                   if cs_support_macro in init_settings.moduleswitches then
+                     set_system_macro(hs,Copy(more,l+2,255))
+                   else
+                     set_system_compvar(hs,Copy(more,l+2,255));
+                 end
                else
                  def_system_macro(hs);
              end;

compiler/pexpr.pas

@@ -3440,12 +3440,9 @@ implementation
                  if try_to_consume(_LKLAMMER) then
                   begin
                     p1:=factor(true,false);
-                    if token in postfixoperator_tokens then
-                     begin
-                       again:=true;
-                       postfixoperators(p1,again,getaddr);
-                     end
-                    else
+                    { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
+                    if token<>_RKLAMMER then
+                      p1:=sub_expr(opcompare,true,false,p1);
                     consume(_RKLAMMER);
                   end
                  else

compiler/ppc8086.lpi

@@ -1,4 +1,4 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
     <Version Value="9"/>
@@ -28,11 +28,10 @@
         <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
-    <Units Count="230">
+    <Units Count="232">
       <Unit0>
         <Filename Value="pp.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pp"/>
       </Unit0>
       <Unit1>
         <Filename Value="i8086\cgcpu.pas"/>
@@ -51,17 +50,14 @@
       <Unit4>
         <Filename Value="i8086\cpunode.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cpunode"/>
       </Unit4>
       <Unit5>
         <Filename Value="i8086\cpupara.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cpupara"/>
       </Unit5>
       <Unit6>
         <Filename Value="i8086\cpupi.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cpupi"/>
       </Unit6>
       <Unit7>
         <Filename Value="i8086\cputarg.pas"/>
@@ -76,17 +72,14 @@
       <Unit9>
         <Filename Value="i8086\ra8086att.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ra8086att"/>
       </Unit9>
       <Unit10>
         <Filename Value="i8086\ra8086int.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ra8086int"/>
       </Unit10>
       <Unit11>
         <Filename Value="i8086\rgcpu.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="rgcpu"/>
       </Unit11>
       <Unit12>
         <Filename Value="i8086\n8086add.pas"/>
@@ -96,7 +89,6 @@
       <Unit13>
         <Filename Value="i8086\n8086mat.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086mat"/>
       </Unit13>
       <Unit14>
         <Filename Value="i8086\n8086inl.pas"/>
@@ -106,7 +98,6 @@
       <Unit15>
         <Filename Value="i8086\n8086cal.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086cal"/>
       </Unit15>
       <Unit16>
         <Filename Value="x86\cgx86.pas"/>
@@ -121,27 +112,22 @@
       <Unit18>
         <Filename Value="x86\nx86set.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86set"/>
       </Unit18>
       <Unit19>
         <Filename Value="x86\nx86add.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86add"/>
       </Unit19>
       <Unit20>
         <Filename Value="x86\nx86cnv.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86cnv"/>
       </Unit20>
       <Unit21>
         <Filename Value="x86\cpubase.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cpubase"/>
       </Unit21>
       <Unit22>
         <Filename Value="x86\nx86mem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86mem"/>
       </Unit22>
       <Unit23>
         <Filename Value="x86\nx86inl.pas"/>
@@ -151,31 +137,27 @@
       <Unit24>
         <Filename Value="x86\nx86cal.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86cal"/>
       </Unit24>
       <Unit25>
         <Filename Value="x86\rgx86.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="rgx86"/>
       </Unit25>
       <Unit26>
         <Filename Value="x86\agx86att.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="agx86att"/>
       </Unit26>
       <Unit27>
         <Filename Value="i8086\n8086con.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086con"/>
       </Unit27>
       <Unit28>
         <Filename Value="x86\nx86con.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nx86con"/>
       </Unit28>
       <Unit29>
         <Filename Value="x86\aasmcpu.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="aasmcpu"/>
       </Unit29>
       <Unit30>
         <Filename Value="x86\agx86int.pas"/>
@@ -185,6 +167,7 @@
       <Unit31>
         <Filename Value="x86\cga.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="cga"/>
       </Unit31>
       <Unit32>
         <Filename Value="x86\hlcgx86.pas"/>
@@ -218,7 +201,6 @@
       <Unit39>
         <Filename Value="i8086\n8086cnv.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086cnv"/>
       </Unit39>
       <Unit40>
         <Filename Value="systems\i_msdos.pas"/>
@@ -233,7 +215,6 @@
       <Unit42>
         <Filename Value="i8086\n8086mem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086mem"/>
       </Unit42>
       <Unit43>
         <Filename Value="cgobj.pas"/>
@@ -248,7 +229,6 @@
       <Unit45>
         <Filename Value="scandir.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="scandir"/>
       </Unit45>
       <Unit46>
         <Filename Value="ncginl.pas"/>
@@ -263,7 +243,6 @@
       <Unit48>
         <Filename Value="pdecsub.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pdecsub"/>
       </Unit48>
       <Unit49>
         <Filename Value="ncgcal.pas"/>
@@ -278,22 +257,18 @@
       <Unit51>
         <Filename Value="ncgadd.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgadd"/>
       </Unit51>
       <Unit52>
         <Filename Value="nadd.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nadd"/>
       </Unit52>
       <Unit53>
         <Filename Value="defutil.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="defutil"/>
       </Unit53>
       <Unit54>
         <Filename Value="constexp.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="constexp"/>
       </Unit54>
       <Unit55>
         <Filename Value="hlcgobj.pas"/>
@@ -303,12 +278,10 @@
       <Unit56>
         <Filename Value="ncgmem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgmem"/>
       </Unit56>
       <Unit57>
         <Filename Value="cgutils.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cgutils"/>
       </Unit57>
       <Unit58>
         <Filename Value="cutils.pas"/>
@@ -328,42 +301,34 @@
       <Unit61>
         <Filename Value="ncnv.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncnv"/>
       </Unit61>
       <Unit62>
         <Filename Value="psub.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="psub"/>
       </Unit62>
       <Unit63>
         <Filename Value="ngenutil.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ngenutil"/>
       </Unit63>
       <Unit64>
         <Filename Value="pinline.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pinline"/>
       </Unit64>
       <Unit65>
         <Filename Value="pmodules.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pmodules"/>
       </Unit65>
       <Unit66>
         <Filename Value="aasmtai.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="aasmtai"/>
       </Unit66>
       <Unit67>
         <Filename Value="dbgdwarf.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="dbgdwarf"/>
       </Unit67>
       <Unit68>
         <Filename Value="symdef.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symdef"/>
       </Unit68>
       <Unit69>
         <Filename Value="ogcoff.pas"/>
@@ -373,77 +338,62 @@
       <Unit70>
         <Filename Value="psystem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="psystem"/>
       </Unit70>
       <Unit71>
         <Filename Value="symconst.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symconst"/>
       </Unit71>
       <Unit72>
         <Filename Value="paramgr.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="paramgr"/>
       </Unit72>
       <Unit73>
         <Filename Value="ncgld.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgld"/>
       </Unit73>
       <Unit74>
         <Filename Value="pparautl.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pparautl"/>
       </Unit74>
       <Unit75>
         <Filename Value="ncgutil.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgutil"/>
       </Unit75>
       <Unit76>
         <Filename Value="ncgnstmm.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgnstmm"/>
       </Unit76>
       <Unit77>
         <Filename Value="nld.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nld"/>
       </Unit77>
       <Unit78>
         <Filename Value="nmem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nmem"/>
       </Unit78>
       <Unit79>
         <Filename Value="ncal.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncal"/>
       </Unit79>
       <Unit80>
         <Filename Value="symtype.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symtype"/>
       </Unit80>
       <Unit81>
         <Filename Value="symsym.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symsym"/>
       </Unit81>
       <Unit82>
         <Filename Value="symbase.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symbase"/>
       </Unit82>
       <Unit83>
         <Filename Value="nflw.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nflw"/>
       </Unit83>
       <Unit84>
         <Filename Value="scanner.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="scanner"/>
       </Unit84>
       <Unit85>
         <Filename Value="ncon.pas"/>
@@ -458,7 +408,6 @@
       <Unit87>
         <Filename Value="defcmp.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="defcmp"/>
       </Unit87>
       <Unit88>
         <Filename Value="fpcdefs.inc"/>
@@ -467,52 +416,42 @@
       <Unit89>
         <Filename Value="nmat.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nmat"/>
       </Unit89>
       <Unit90>
         <Filename Value="optdfa.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="optdfa"/>
       </Unit90>
       <Unit91>
         <Filename Value="parabase.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="parabase"/>
       </Unit91>
       <Unit92>
         <Filename Value="cgbase.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cgbase"/>
       </Unit92>
       <Unit93>
         <Filename Value="ncgcnv.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgcnv"/>
       </Unit93>
       <Unit94>
         <Filename Value="ncgcon.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgcon"/>
       </Unit94>
       <Unit95>
         <Filename Value="nset.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nset"/>
       </Unit95>
       <Unit96>
         <Filename Value="optloop.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="optloop"/>
       </Unit96>
       <Unit97>
         <Filename Value="aasmbase.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="aasmbase"/>
       </Unit97>
       <Unit98>
         <Filename Value="aasmdata.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="aasmdata"/>
       </Unit98>
       <Unit99>
         <Filename Value="aasmsym.pas"/>
@@ -521,11 +460,11 @@
       <Unit100>
         <Filename Value="aggas.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="aggas"/>
       </Unit100>
       <Unit101>
         <Filename Value="agjasmin.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="agjasmin"/>
       </Unit101>
       <Unit102>
         <Filename Value="aopt.pas"/>
@@ -554,10 +493,12 @@
       <Unit108>
         <Filename Value="assemble.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="assemble"/>
       </Unit108>
       <Unit109>
         <Filename Value="browcol.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="browcol"/>
       </Unit109>
       <Unit110>
         <Filename Value="catch.pas"/>
@@ -578,11 +519,11 @@
       <Unit114>
         <Filename Value="cfileutl.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="cfileutl"/>
       </Unit114>
       <Unit115>
         <Filename Value="cg64f32.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cg64f32"/>
       </Unit115>
       <Unit116>
         <Filename Value="cghlcpu.pas"/>
@@ -607,6 +548,7 @@
       <Unit121>
         <Filename Value="comprsrc.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="comprsrc"/>
       </Unit121>
       <Unit122>
         <Filename Value="cpid.pas"/>
@@ -619,7 +561,6 @@
       <Unit124>
         <Filename Value="cresstr.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="cresstr"/>
       </Unit124>
       <Unit125>
         <Filename Value="cstreams.pas"/>
@@ -644,10 +585,12 @@
       <Unit130>
         <Filename Value="dirparse.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="dirparse"/>
       </Unit130>
       <Unit131>
         <Filename Value="elfbase.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="elfbase"/>
       </Unit131>
       <Unit132>
         <Filename Value="export.pas"/>
@@ -660,10 +603,12 @@
       <Unit134>
         <Filename Value="finput.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="finput"/>
       </Unit134>
       <Unit135>
         <Filename Value="fmodule.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="fmodule"/>
       </Unit135>
       <Unit136>
         <Filename Value="fpccrc.pas"/>
@@ -677,7 +622,6 @@
       <Unit138>
         <Filename Value="gendef.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="gendef"/>
       </Unit138>
       <Unit139>
         <Filename Value="globstat.pas"/>
@@ -686,7 +630,6 @@
       <Unit140>
         <Filename Value="htypechk.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="htypechk"/>
       </Unit140>
       <Unit141>
         <Filename Value="impdef.pas"/>
@@ -703,6 +646,7 @@
       <Unit144>
         <Filename Value="link.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="link"/>
       </Unit144>
       <Unit145>
         <Filename Value="macho.pas"/>
@@ -715,7 +659,6 @@
       <Unit147>
         <Filename Value="nbas.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="nbas"/>
       </Unit147>
       <Unit148>
         <Filename Value="ncgbas.pas"/>
@@ -724,7 +667,6 @@
       <Unit149>
         <Filename Value="ncgflw.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ncgflw"/>
       </Unit149>
       <Unit150>
         <Filename Value="ncgmat.pas"/>
@@ -757,7 +699,6 @@
       <Unit157>
         <Filename Value="ngtcon.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ngtcon"/>
       </Unit157>
       <Unit158>
         <Filename Value="nobj.pas"/>
@@ -770,7 +711,6 @@
       <Unit160>
         <Filename Value="node.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="node"/>
       </Unit160>
       <Unit161>
         <Filename Value="nopt.pas"/>
@@ -809,18 +749,22 @@
       <Unit169>
         <Filename Value="oglx.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="oglx"/>
       </Unit169>
       <Unit170>
         <Filename Value="ogmacho.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="ogmacho"/>
       </Unit170>
       <Unit171>
         <Filename Value="ogmap.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="ogmap"/>
       </Unit171>
       <Unit172>
         <Filename Value="ognlm.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="ognlm"/>
       </Unit172>
       <Unit173>
         <Filename Value="optbase.pas"/>
@@ -857,18 +801,22 @@
       <Unit181>
         <Filename Value="owar.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="owar"/>
       </Unit181>
       <Unit182>
         <Filename Value="owbase.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="owbase"/>
       </Unit182>
       <Unit183>
         <Filename Value="parser.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="parser"/>
       </Unit183>
       <Unit184>
         <Filename Value="pass_1.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="pass_1"/>
       </Unit184>
       <Unit185>
         <Filename Value="pass_2.pas"/>
@@ -885,7 +833,6 @@
       <Unit188>
         <Filename Value="pdecobj.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pdecobj"/>
       </Unit188>
       <Unit189>
         <Filename Value="pdecvar.pas"/>
@@ -910,17 +857,14 @@
       <Unit194>
         <Filename Value="ppu.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ppu"/>
       </Unit194>
       <Unit195>
         <Filename Value="procinfo.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="procinfo"/>
       </Unit195>
       <Unit196>
         <Filename Value="pstatmnt.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="pstatmnt"/>
       </Unit196>
       <Unit197>
         <Filename Value="ptconst.pas"/>
@@ -961,6 +905,7 @@
       <Unit206>
         <Filename Value="script.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="script"/>
       </Unit206>
       <Unit207>
         <Filename Value="switches.pas"/>
@@ -989,11 +934,11 @@
       <Unit213>
         <Filename Value="systems.pas"/>
         <IsPartOfProject Value="True"/>
+        <UnitName Value="systems"/>
       </Unit213>
       <Unit214>
         <Filename Value="tgobj.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="tgobj"/>
       </Unit214>
       <Unit215>
         <Filename Value="tokens.pas"/>
@@ -1026,43 +971,45 @@
       <Unit222>
         <Filename Value="i8086\n8086ld.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086ld"/>
       </Unit222>
       <Unit223>
         <Filename Value="i8086\symcpu.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symcpu"/>
       </Unit223>
       <Unit224>
         <Filename Value="x86\ni86mem.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="ni86mem"/>
       </Unit224>
       <Unit225>
         <Filename Value="x86\symi86.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symi86"/>
       </Unit225>
       <Unit226>
         <Filename Value="x86\symx86.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="symx86"/>
       </Unit226>
       <Unit227>
         <Filename Value="i8086\n8086tcon.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086tcon"/>
       </Unit227>
       <Unit228>
         <Filename Value="i8086\tgcpu.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="tgcpu"/>
       </Unit228>
       <Unit229>
         <Filename Value="i8086\n8086util.pas"/>
         <IsPartOfProject Value="True"/>
-        <UnitName Value="n8086util"/>
       </Unit229>
+      <Unit230>
+        <Filename Value="ogomf.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="ogomf"/>
+      </Unit230>
+      <Unit231>
+        <Filename Value="omfbase.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="omfbase"/>
+      </Unit231>
     </Units>
   </ProjectOptions>
   <CompilerOptions>
@@ -1099,7 +1046,6 @@
         <StopAfterErrCount Value="50"/>
       </ConfigFile>
       <CustomOptions Value="-di8086 -dEXTDEBUG -gl"/>
-      <CompilerPath Value="$(CompPath)"/>
     </Other>
   </CompilerOptions>
 </CONFIG>

compiler/systems.inc

@@ -216,6 +216,7 @@
              ,as_i8086_nasmobj
              ,as_gas_powerpc_xcoff
              ,as_arm_elf32
+             ,as_i8086_omf
              ,as_llvm
        );
 

compiler/systems.pas

@@ -83,6 +83,8 @@ interface
        parinfo = ^tarinfo;
        tarinfo = record
           id          : tar;
+          addfilecmd  : string[10];
+          arfirstcmd  : string[50];
           arcmd       : string[50];
           arfinishcmd : string[10];
        end;

compiler/verbose.pas

@@ -438,7 +438,7 @@ implementation
 
     Procedure UpdateStatus;
       var
-        module : tmodulebase;
+        module : tmodule;
       begin
       { fix status }
         status.currentline:=current_filepos.line;
@@ -454,8 +454,12 @@ implementation
               status.currentmodulestate:=ModuleStateStr[module.state];
               status.currentsource:=module.sourcefiles.get_file_name(current_filepos.fileindex);
               status.currentsourcepath:=module.sourcefiles.get_file_path(current_filepos.fileindex);
+              { if sources are not available, construct a prefix from the
+                ppu file name }
+              if not(module.sources_avail) then
+                status.currentsourcepath:=module.ppufilename+':'
               { if currentsourcepath is relative, make it absolute }
-              if not path_absolute(status.currentsourcepath) then
+              else if not path_absolute(status.currentsourcepath) then
                 status.currentsourcepath:=GetCurrentDir+status.currentsourcepath;
 
               { update lastfileidx only if name known PM }

ide/fpdebug.pas

@@ -57,7 +57,6 @@ type
      NoSwitch : boolean;
      HasExe   : boolean;
      RunCount : longint;
-     WindowWidth : longint;
      FPCBreakErrorNumber : longint;
 {$ifdef SUPPORT_REMOTE}
      isRemoteDebugging,
@@ -67,7 +66,6 @@ type
 {$endif SUPPORT_REMOTE}
     constructor Init;
     procedure SetExe(const exefn:string);
-    procedure SetWidth(AWidth : longint);
     procedure SetSourceDirs;
     destructor  Done;
     function DoSelectSourceline(const fn:string;line,BreakIndex:longint): Boolean;virtual;
@@ -665,7 +663,6 @@ begin
   NoSwitch:=False;
   HasExe:=false;
   Debugger:=@self;
-  WindowWidth:=-1;
   switch_to_user:=true;
   GetDir(0,OrigPwd);
   SetCommand('print object off');
@@ -725,12 +722,6 @@ begin
 end;
 
 
-procedure TDebugController.SetWidth(AWidth : longint);
-begin
-  WindowWidth:=AWidth;
-  SetCommand('width '+inttostr(WindowWidth));
-end;
-
 procedure TDebugController.SetSourceDirs;
   const
 {$ifdef GDBMI}
@@ -3501,8 +3492,6 @@ end;
       DeskTop^.Lock;
       Clear;
 
-      if Debugger^.WindowWidth<>-1 then
-        Debugger^.SetCommand('width 0xffffffff');
       Debugger^.Backtrace;
       { generate list }
       { all is in tframeentry }
@@ -3543,8 +3532,6 @@ end;
         end;
       if Assigned(list) and (List^.Count > 0) then
         FocusItem(0);
-      if Debugger^.WindowWidth<>-1 then
-        Debugger^.SetCommand('width '+IntToStr(Debugger^.WindowWidth));
       DeskTop^.Unlock;
 {$endif NODEBUG}
     end;

ide/fpviews.pas

@@ -2495,8 +2495,10 @@ begin
     Editor^.AddLine('');
   Insert(Editor);
 {$ifndef NODEBUG}
+ {$ifndef GDBMI}
   if assigned(Debugger) then
-    Debugger^.SetWidth(Size.X-1);
+    Debugger^.SetCommand('width ' + IntToStr(Size.X-1));
+ {$endif GDBMI}
 {$endif NODEBUG}
   Editor^.silent:=false;
   Editor^.AutoRepeat:=true;

packages/chm/src/fasthtmlparser.pas

@@ -1,22 +1,5 @@
-{ Copyright (C) <2005> <Andrew Haines> fasthtmlparser.pas
-
-  This library is free software; you can redistribute it and/or modify it
-  under the terms of the GNU Library General Public License as published by
-  the Free Software Foundation; either version 2 of the License, or (at your
-  option) any later version.
-
-  This program is distributed in the hope that it will be useful, but WITHOUT
-  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
-  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
-  for more details.
-
-  You should have received a copy of the GNU Library General Public License
-  along with this library; if not, write to the Free Software Foundation,
-  Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02111-1301, USA.
-}
 {
-  See the file COPYING.FPC, included in this distribution,
-  for details about the copyright.
+  See the section LICENSE/TERMS below for details about the copyright.
 }
 // TODO:
 {

packages/fcl-db/src/base/bufdataset.pas

@@ -1252,7 +1252,7 @@ begin
   InitDefaultIndexes;
   CalcRecordSize;
 
-  FBRecordcount := 0;
+  FBRecordCount := 0;
 
   for IndexNr:=0 to FIndexesCount-1 do with FIndexes[IndexNr] do
     InitialiseSpareRecord(IntAllocRecordBuffer);
@@ -1283,6 +1283,7 @@ var r  : integer;
 begin
   FOpen:=False;
   FReadFromFile:=False;
+  FBRecordCount:=0;
 
   if FIndexesCount>0 then with FIndexes[0] do if IsInitialized then
     begin
@@ -2676,7 +2677,10 @@ end;
 
 function TCustomBufDataset.GetRecordCount: Longint;
 begin
-  Result := FBRecordCount;
+  if Active then
+    Result := FBRecordCount
+  else
+    Result:=0;  
 end;
 
 function TCustomBufDataset.UpdateStatus: TUpdateStatus;

packages/fcl-db/src/base/sqlscript.pp

@@ -260,7 +260,7 @@ begin
     if (Result='') then
       begin
       if FEmitLine then
-        AddToStatement(S,(FCol=1));
+        AddToStatement(S,(FCol<=1));
       FCol:=1;
       FLine:=FLine+1;
       end
@@ -442,11 +442,12 @@ function TCustomSQLScript.NextStatement: AnsiString;
 
 var
   pnt: AnsiString;
-  terminator_found: Boolean;
+  addnewline,terminator_found: Boolean;
 
 begin
   terminator_found:=False;
   ClearStatement;
+  addnewline:=false;
   while FLine <= FSQL.Count do
     begin
     pnt:=FindNextSeparator([FTerminator, '/*', '"', '''', '--']);
@@ -476,7 +477,10 @@ begin
       begin
       FComment:=True;
       if FCommentsInSQL then
-        AddToStatement(Copy(FSQL[FLine-1],FCol,Length(FSQL[FLine-1])-FCol+1),True);
+        begin
+        AddToStatement(Copy(FSQL[FLine-1],FCol,Length(FSQL[FLine-1])-FCol+1),False);
+        AddNewLine:=true;
+        end;
       Inc(Fline);
       FCol:=0;
       FComment:=False;
@@ -494,7 +498,8 @@ begin
       AddToStatement(pnt,False);
       FCol:=FCol + length(pnt);
       pnt:=FindNextSeparator(['''']);
-      AddToStatement(pnt,false);
+      AddToStatement(pnt,addnewline);
+      addnewline:=False;
       FCol:=FCol + length(pnt);
       end;
     end;

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

@@ -103,13 +103,14 @@ type
     function GetTransactionHandle(trans : TSQLHandle): pointer; override;
     function Commit(trans : TSQLHandle) : boolean; override;
     function RollBack(trans : TSQLHandle) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
-    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
     procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction : TSQLTransaction); override;
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
+    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
+    function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override;
   public
     constructor Create(AOwner : TComponent); override;
     function GetConnectionInfo(InfoType:TConnInfoType): string; override;
@@ -208,7 +209,8 @@ begin
   else result := true;
 end;
 
-function TIBConnection.StartDBTransaction(trans : TSQLHandle;AParams : String) : boolean;
+function TIBConnection.StartDBTransaction(trans: TSQLHandle; AParams: string
+  ): boolean;
 var
   DBHandle : pointer;
   tr       : TIBTrans;
@@ -641,7 +643,7 @@ begin
   end;
 end;
 
-Function TIBConnection.AllocateCursorHandle : TSQLCursor;
+function TIBConnection.AllocateCursorHandle: TSQLCursor;
 
 var curs : TIBCursor;
 
@@ -665,7 +667,7 @@ begin
   FreeAndNil(cursor);
 end;
 
-Function TIBConnection.AllocateTransactionHandle : TSQLHandle;
+function TIBConnection.AllocateTransactionHandle: TSQLHandle;
 
 begin
   result := TIBTrans.create;
@@ -1388,12 +1390,27 @@ begin
                           '(r.rdb$system_flag = 0 or r.rdb$system_flag is null) and (rdb$relation_name = ''' + Uppercase(SchemaObjectName) + ''') ' +
                         'ORDER BY '+
                           'r.rdb$field_name';
+    stSequences  : s := 'SELECT ' +
+                          'rdb$generator_id         as recno,' +
+                          '''' + DatabaseName + ''' as sequence_catalog,' +
+                          '''''                     as sequence_schema,' +
+                          'rdb$generator_name       as sequence_name ' +
+                        'FROM ' +
+                          'rdb$generators ' +
+                        'WHERE ' +
+                          'rdb$system_flag = 0 or rdb$system_flag is null ' +
+                        'ORDER BY ' +
+                          'rdb$generator_name';
   else
     DatabaseError(SMetadataUnavailable)
   end; {case}
   result := s;
 end;
 
+function TIBConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
+begin
+  Result := Format('SELECT gen_id(%s, %d) FROM RDB$DATABASE', [SequenceName, IncrementBy]);
+end;
 
 procedure TIBConnection.UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string);
 
@@ -1480,7 +1497,7 @@ begin
   end;
 end;
 
-procedure TIBConnection.GetFloat(CurrBuff, Buffer : pointer; Size : byte);
+procedure TIBConnection.GetFloat(CurrBuff, Buffer: pointer; Size: Byte);
 var
   Ext : extended;
   Dbl : double;

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

@@ -121,12 +121,13 @@ type
     function Commit(trans : TSQLHandle) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     function StartImplicitTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; AParams : string) : boolean; override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs;TableName : string); override;
-    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
     procedure LoadBlobIntoBuffer(FieldDef: TFieldDef;ABlobBuf: PBufBlobField; cursor: TSQLCursor;ATransaction : TSQLTransaction); override;
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
+    function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; override;
+    function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; override;
   public
     constructor Create(AOwner : TComponent); override;
     destructor Destroy; override;
@@ -332,7 +333,7 @@ begin
 {$EndIf}
 end;
 
-Procedure TPQConnection.GetExtendedFieldInfo(cursor: TPQCursor;
+procedure TPQConnection.GetExtendedFieldInfo(cursor: TPQCursor;
   Bindings: TFieldBindings);
 
 Var
@@ -387,7 +388,7 @@ begin
     P.SQLDBData:=TPQCursor(C).GetFieldBinding(F.FieldDef);
 end;
 
-Function TPQConnection.ErrorOnUnknownType: Boolean;
+function TPQConnection.ErrorOnUnknownType: Boolean;
 begin
   Result:=False;
 end;
@@ -555,8 +556,8 @@ begin
   Result := true;
 end;
 
-function TPQConnection.StartDBTransaction(trans: TSQLHandle;
-  AParams: string): boolean;
+function TPQConnection.StartDBTransaction(trans: TSQLHandle; AParams: string
+  ): boolean;
 
 Var
   res : PPGresult;
@@ -724,7 +725,7 @@ begin
 end;
 
 function TPQConnection.TranslateFldType(res: PPGresult; Tuple: integer; out
-  Size: integer; Out ATypeOID: oid): TFieldType;
+  Size: integer; out ATypeOID: oid): TFieldType;
 
 const
   VARHDRSZ=sizeof(longint);
@@ -805,18 +806,18 @@ begin
   end;
 end;
 
-Function TPQConnection.AllocateCursorHandle: TSQLCursor;
+function TPQConnection.AllocateCursorHandle: TSQLCursor;
 
 begin
   result := TPQCursor.create;
 end;
 
-Procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
+procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
 begin
   FreeAndNil(cursor);
 end;
 
-Function TPQConnection.AllocateTransactionHandle: TSQLHandle;
+function TPQConnection.AllocateTransactionHandle: TSQLHandle;
 
 begin
   result := TPQTrans.create;
@@ -1495,6 +1496,11 @@ begin
   result := s;
 end;
 
+function TPQConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
+begin
+  Result := Format('SELECT nextval(''%s'')', [SequenceName]);
+end;
+
 procedure TPQConnection.LoadBlobIntoBuffer(FieldDef: TFieldDef;
   ABlobBuf: PBufBlobField; cursor: TSQLCursor; ATransaction: TSQLTransaction);
 var

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

@@ -23,7 +23,7 @@ interface
 uses SysUtils, Classes, DB, bufdataset, sqlscript;
 
 type
-  TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages, stSchemata);
+  TSchemaType = (stNoSchema, stTables, stSysTables, stProcedures, stColumns, stProcedureParams, stIndexes, stPackages, stSchemata, stSequences);
 
   TStatementType = (stUnknown, stSelect, stInsert, stUpdate, stDelete,
     stDDL, stGetSegment, stPutSegment, stExecProcedure,
@@ -210,12 +210,13 @@ type
     function Commit(trans : TSQLHandle) : boolean; virtual; abstract;
     function RollBack(trans : TSQLHandle) : boolean; virtual; abstract;
     function StartImplicitTransaction(trans : TSQLHandle; aParams : string) : boolean; virtual;
-    function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; virtual; abstract;
+    function StartDBTransaction(trans : TSQLHandle; aParams : string) : boolean; virtual; abstract;
     procedure CommitRetaining(trans : TSQLHandle); virtual; abstract;
     procedure RollBackRetaining(trans : TSQLHandle); virtual; abstract;
 
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs; TableName : string); virtual;
     function GetSchemaInfoSQL(SchemaType : TSchemaType; SchemaObjectName, SchemaPattern : string) : string; virtual;
+    function GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string; virtual;
 
     Procedure MaybeConnect;
 
@@ -234,10 +235,12 @@ type
     procedure GetProcedureNames(List : TStrings); virtual;
     procedure GetFieldNames(const TableName : string; List : TStrings); virtual;
     procedure GetSchemaNames(List: TStrings); virtual;
+    procedure GetSequenceNames(List: TStrings); virtual;
     function GetConnectionInfo(InfoType:TConnInfoType): string; virtual;
     function GetStatementInfo(const ASQL: string): TSQLStatementInfo; virtual;
     procedure CreateDB; virtual;
     procedure DropDB; virtual;
+    function GetNextValue(const SequenceName: string; IncrementBy: integer=1): Int64; virtual;
     property ConnOptions: TConnOptions read FConnOptions;
   published
     property Password : string read FPassword write FPassword;
@@ -372,6 +375,31 @@ type
     Property Transaction;
   end;
 
+
+  { TSQLSequence }
+
+  TSQLSequenceApplyEvent = (saeOnNewRecord, saeOnPost);
+
+  TSQLSequence = class(TPersistent)
+  private
+    FQuery: TCustomSQLQuery;
+    FFieldName: String;
+    FSequenceName: String;
+    FIncrementBy: Integer;
+    FApplyEvent: TSQLSequenceApplyEvent;
+  public
+    constructor Create(AQuery: TCustomSQLQuery);
+    procedure Assign(Source: TPersistent); override;
+    procedure Apply;
+    function GetNextValue: Int64;
+  published
+    property FieldName: String read FFieldName write FFieldName;
+    property SequenceName: String read FSequenceName write FSequenceName;
+    property IncrementBy: Integer read FIncrementBy write FIncrementBy default 1;
+    property ApplyEvent: TSQLSequenceApplyEvent read FApplyEvent write FApplyEvent default saeOnNewRecord;
+  end;
+
+
   { TCustomSQLQuery }
 
   TSQLQueryOption = (sqoKeepOpenOnCommit, sqoAutoApplyUpdates, sqoAutoCommit);
@@ -406,6 +434,7 @@ type
     FInsertQry,
     FUpdateQry,
     FDeleteQry           : TCustomSQLStatement;
+    FSequence            : TSQLSequence;
     procedure FreeFldBuffers;
     function GetParamCheck: Boolean;
     function GetParams: TParams;
@@ -464,6 +493,8 @@ type
     procedure BeforeRefreshOpenCursor; override;
     procedure SetReadOnly(AValue : Boolean); override;
     procedure Notification(AComponent: TComponent; Operation: TOperation); override;
+    procedure DoOnNewRecord; override;
+    procedure DoBeforePost; override;
     class function FieldDefsClass : TFieldDefsClass; override;
     // IProviderSupport methods
     function PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError; override;
@@ -531,6 +562,7 @@ type
     property UsePrimaryKeyAsKey : boolean read FUsePrimaryKeyAsKey write SetUsePrimaryKeyAsKey default true;
     property StatementType : TStatementType read GetStatementType;
     Property DataSource : TDataSource Read GetDataSource Write SetDataSource;
+    property Sequence: TSQLSequence read FSequence write FSequence;
     property ServerFilter: string read FServerFilterText write SetServerFilterText;
     property ServerFiltered: Boolean read FServerFiltered write SetServerFiltered default False;
     property ServerIndexDefs : TServerIndexDefs read GetServerIndexDefs;
@@ -589,6 +621,7 @@ type
     property UpdateMode;
     property UsePrimaryKeyAsKey;
     Property DataSource;
+    property Sequence;
     property ServerFilter;
     property ServerFiltered;
     property ServerIndexDefs;
@@ -665,7 +698,7 @@ type
     function GetTransactionHandle(trans : TSQLHandle): pointer; override;
     function Commit(trans : TSQLHandle) : boolean; override;
     function RollBack(trans : TSQLHandle) : boolean; override;
-    function StartdbTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
+    function StartDBTransaction(trans : TSQLHandle; aParams : string) : boolean; override;
     procedure CommitRetaining(trans : TSQLHandle); override;
     procedure RollBackRetaining(trans : TSQLHandle); override;
     procedure UpdateIndexDefs(IndexDefs : TIndexDefs; TableName : string); override;
@@ -745,6 +778,7 @@ begin
   Result := Format('%.2d:%.2d:%.2d.%.3d',[hour,minute,second,millisecond]);
 end;
 
+
 { TSQLDBFieldDefs }
 
 class function TSQLDBFieldDefs.FieldDefClass: TFieldDefClass;
@@ -752,6 +786,7 @@ begin
   Result:=TSQLDBFieldDef;
 end;
 
+
 { TSQLDBParams }
 
 class function TSQLDBParams.ParamClass: TParamClass;
@@ -759,6 +794,7 @@ begin
   Result:=TSQLDBParam;
 end;
 
+
 { ESQLDatabaseError }
 
 constructor ESQLDatabaseError.CreateFmt(const Fmt: string; const Args: array of const;
@@ -782,8 +818,6 @@ begin
   SQLState  := ASQLState;
 end;
 
-Type
-  TInternalTransaction = Class(TSQLTransaction);
 
 { TCustomSQLStatement }
 
@@ -976,8 +1010,6 @@ begin
   Result:=False;
 end;
 
-
-
 procedure TCustomSQLStatement.GetStatementInfo(var ASQL: String; out Info: TSQLStatementInfo);
 
 begin
@@ -1090,6 +1122,7 @@ begin
   Result:=FRowsAffected;
 end;
 
+
 { TSQLConnection }
 
 constructor TSQLConnection.Create(AOwner: TComponent);
@@ -1287,6 +1320,11 @@ begin
   GetDBInfo(stSchemata,'','SCHEMA_NAME',List);
 end;
 
+procedure TSQLConnection.GetSequenceNames(List: TStrings);
+begin
+  GetDBInfo(stSequences,'','SEQUENCE_NAME',List);
+end;
+
 function TSQLConnection.GetConnectionInfo(InfoType: TConnInfoType): string;
 var i: TConnInfoType;
 begin
@@ -1509,12 +1547,12 @@ begin
   Result := nil;
 end;
 
-Function TSQLConnection.LogEvent(EventType: TDBEventType): Boolean;
+function TSQLConnection.LogEvent(EventType: TDBEventType): Boolean;
 begin
   Result:=(Assigned(FOnLog) or Assigned(GlobalDBLogHook)) and (EventType in LogEvents);
 end;
 
-Procedure TSQLConnection.Log(EventType: TDBEventType; Const Msg: String);
+procedure TSQLConnection.Log(EventType: TDBEventType; const Msg: String);
 
 Var
   M : String;
@@ -1535,13 +1573,13 @@ begin
     end;
 end;
 
-Procedure TSQLConnection.RegisterStatement(S: TCustomSQLStatement);
+procedure TSQLConnection.RegisterStatement(S: TCustomSQLStatement);
 begin
   if FStatements.IndexOf(S)=-1 then
     FStatements.Add(S);
 end;
 
-Procedure TSQLConnection.UnRegisterStatement(S: TCustomSQLStatement);
+procedure TSQLConnection.UnRegisterStatement(S: TCustomSQLStatement);
 begin
   if Assigned(FStatements) then // Can be nil, when we are destroying and datasets are uncoupled.
     FStatements.Remove(S);
@@ -1764,11 +1802,36 @@ begin
   case SchemaType of
     stProcedures: Result := 'SELECT *, ROUTINE_NAME AS PROCEDURE_NAME FROM INFORMATION_SCHEMA.ROUTINES';
     stSchemata  : Result := 'SELECT * FROM INFORMATION_SCHEMA.SCHEMATA';
+    stSequences : Result := 'SELECT * FROM INFORMATION_SCHEMA.SEQUENCES';
     else DatabaseError(SMetadataUnavailable);
   end;
 end;
 
-Procedure TSQLConnection.MaybeConnect;
+function TSQLConnection.GetNextValueSQL(const SequenceName: string; IncrementBy: Integer): string;
+begin
+  Result := 'SELECT NEXT VALUE FOR ' + SequenceName;
+end;
+
+function TSQLConnection.GetNextValue(const SequenceName: string; IncrementBy: integer): Int64;
+var
+  Q: TCustomSQLQuery;
+begin
+  Result := 0;
+  Q := TCustomSQLQuery.Create(nil);
+  try
+    Q.DataBase := Self;
+    Q.Transaction := Transaction;
+    Q.SQL.Text := GetNextValueSQL(SequenceName, IncrementBy);
+    Q.Open;
+    if not Q.Eof then
+      Result := Q.Fields[0].AsLargeInt;
+    Q.Close;
+  finally
+    FreeAndNil(Q);
+  end;
+end;
+
+procedure TSQLConnection.MaybeConnect;
 begin
   If Not Connected then
     begin
@@ -1790,6 +1853,7 @@ begin
   DatabaseError(SNotSupported);
 end;
 
+
 { TSQLTransaction }
 
 procedure TSQLTransaction.EndTransaction;
@@ -1931,7 +1995,7 @@ begin
     end
   else
     begin
-    if Db.StartdbTransaction(FTrans,FParams.CommaText) then
+    if Db.StartDBTransaction(FTrans,FParams.CommaText) then
       OpenTrans
     end;
 end;
@@ -1995,6 +2059,50 @@ begin
 end;
 
 
+{ TSQLSequence }
+
+constructor TSQLSequence.Create(AQuery: TCustomSQLQuery);
+begin
+  inherited Create;
+  FQuery := AQuery;
+  FApplyEvent := saeOnNewRecord;
+  FIncrementBy := 1;
+end;
+
+procedure TSQLSequence.Assign(Source: TPersistent);
+var SourceSequence: TSQLSequence;
+begin
+  if Source is TSQLSequence then
+  begin
+    SourceSequence := TSQLSequence(Source);
+    FFieldName    := SourceSequence.FieldName;
+    FSequenceName := SourceSequence.SequenceName;
+    FIncrementBy  := SourceSequence.IncrementBy;
+    FApplyEvent   := SourceSequence.ApplyEvent;
+  end
+  else
+    inherited;
+end;
+
+procedure TSQLSequence.Apply;
+var Field: TField;
+begin
+  if Assigned(FQuery) and (FSequenceName<>'') and (FFieldName<>'') then
+  begin
+    Field := FQuery.FindField(FFieldName);
+    if Assigned(Field) and Field.IsNull then
+      Field.AsLargeInt := GetNextValue;
+  end;
+end;
+
+function TSQLSequence.GetNextValue: Int64;
+begin
+  if (FQuery=Nil) or (FQuery.SQLConnection=Nil) then
+    DatabaseError(SErrDatabasenAssigned);
+  Result := FQuery.SQLConnection.GetNextValue(FSequenceName, FIncrementBy);
+end;
+
+
 Type
 
   { TQuerySQLStatement }
@@ -2096,6 +2204,7 @@ begin
   FRefreshSQL := TStringList.Create;
   FRefreshSQL.OnChange := @OnChangeModifySQL;
 
+  FSequence := TSQLSequence.Create(Self);
   FServerIndexDefs := TServerIndexDefs.Create(Self);
 
   FServerFiltered := False;
@@ -2120,7 +2229,8 @@ begin
   FreeAndNil(FUpdateSQL);
   FreeAndNil(FDeleteSQL);
   FreeAndNil(FRefreshSQL);
-  FServerIndexDefs.Free;
+  FreeAndNil(FSequence);
+  FreeAndNil(FServerIndexDefs);
   inherited Destroy;
 end;
 
@@ -2823,6 +2933,20 @@ begin
     DataSource:=Nil;
 end;
 
+procedure TCustomSQLQuery.DoOnNewRecord;
+begin
+  inherited;
+  if FSequence.ApplyEvent = saeOnNewRecord then
+    FSequence.Apply;
+end;
+
+procedure TCustomSQLQuery.DoBeforePost;
+begin
+  if (State = dsInsert) and (FSequence.ApplyEvent = saeOnPost) then
+    FSequence.Apply;
+  inherited;
+end;
+
 function TCustomSQLQuery.PSGetUpdateException(E: Exception; Prev: EUpdateError): EUpdateError;
 var
   PrevErrorCode, ErrorCode: Integer;
@@ -3205,11 +3329,10 @@ begin
   Result:=FProxy.RollBack(trans);
 end;
 
-function TSQLConnector.StartdbTransaction(trans: TSQLHandle; aParams: string
-  ): boolean;
+function TSQLConnector.StartDBTransaction(trans: TSQLHandle; aParams: string): boolean;
 begin
   CheckProxy;
-  Result:=FProxy.StartdbTransaction(trans, aParams);
+  Result:=FProxy.StartDBTransaction(trans, aParams);
 end;
 
 procedure TSQLConnector.CommitRetaining(trans: TSQLHandle);

packages/fcl-db/tests/testdbbasics.pas

@@ -454,17 +454,17 @@ var
 begin
   query1:= DBConnector.GetNDataset(11);
   datalink1:= TDataLink.create;
-  datasource1:= tdatasource.create(nil);
+  datasource1:= TDataSource.create(nil);
   try
-    datalink1.datasource:= datasource1;
-    datasource1.dataset:= query1;
+    datalink1.DataSource:= datasource1;
+    datasource1.DataSet:= query1;
 
-    query1.active := true;
+    query1.active := True;
     query1.active := False;
     CheckEquals(0, THackDataLink(datalink1).RecordCount);
-    query1.active := true;
+    query1.active := True;
     CheckTrue(THackDataLink(datalink1).RecordCount>0);
-    query1.active := false;
+    query1.active := False;
   finally
     datalink1.free;
     datasource1.free;
@@ -488,13 +488,11 @@ begin
     CheckEquals(count,RecordCount);
 
     Close;
-
     end;
 end;
 
 procedure TTestCursorDBBasics.TestRecNo;
-var i       : longint;
-    passed  : boolean;
+var passed  : boolean;
 begin
   with DBConnector.GetNDataset(0) do
     begin
@@ -502,27 +500,23 @@ begin
     // return 0
     passed := false;
     try
-      i := recno;
+      passed := RecNo = 0;
     except on E: Exception do
-      begin
       passed := E.classname = EDatabaseError.className
-      end;
     end;
     if not passed then
       CheckEquals(0,RecNo,'Failed to get the RecNo from a closed dataset');
 
-    // Accessing Recordcount on a closed dataset should raise an EDatabaseError or should
+    // Accessing RecordCount on a closed dataset should raise an EDatabaseError or should
     // return 0
     passed := false;
     try
-      i := recordcount;
+      passed := RecordCount = 0;
     except on E: Exception do
-      begin
       passed := E.classname = EDatabaseError.className
-      end;
     end;
     if not passed then
-      CheckEquals(0,RecNo,'Failed to get the Recordcount from a closed dataset');
+      CheckEquals(0,RecordCount,'Failed to get the RecordCount from a closed dataset');
 
     Open;
 
@@ -564,6 +558,16 @@ begin
     CheckEquals(1,RecordCount);
 
     Close;
+
+    // Tests if RecordCount resets to 0 after dataset is closed
+    passed := false;
+    try
+      passed := RecordCount = 0;
+    except on E: Exception do
+      passed := E.classname = EDatabaseError.className
+    end;
+    if not passed then
+      CheckEquals(0,RecordCount,'RecordCount after Close');
     end;
 end;
 

packages/fcl-db/tests/testspecifictbufdataset.pas

@@ -39,6 +39,7 @@ type
     procedure TestAutoIncField;
     procedure TestAutoIncFieldStreaming;
     procedure TestAutoIncFieldStreamingXML;
+    Procedure TestRecordCount;
   end;
 
 implementation
@@ -248,6 +249,22 @@ begin
   IntTestAutoIncFieldStreaming(true);
 end;
 
+procedure TTestSpecificTBufDataset.TestRecordCount;
+var
+  BDS:TBufDataSet;
+  
+begin
+  BDS:=TBufDataSet.Create(nil);
+  BDS.FieldDefs.Add('ID',ftLargeint);
+  BDS.CreateDataSet;
+  BDS.AppendRecord([1]);
+  BDS.AppendRecord([2]);
+  BDS.AppendRecord([3]);
+  BDS.Close;
+  AssertEquals('IsEmpty: ',True,BDS.IsEmpty);
+  AssertEquals('RecordCount: ',0,BDS.RecordCount);
+end;
+  
 initialization
 {$ifdef fpc}
 

packages/fcl-db/tests/testsqldb.pas

@@ -53,6 +53,7 @@ type
     Procedure TestRefreshSQLMultipleRecords;
     Procedure TestRefreshSQLNoRecords;
     Procedure TestFetchAutoInc;
+    procedure TestSequence;
   end;
 
   { TTestTSQLConnection }
@@ -86,7 +87,7 @@ implementation
 
 { TTestTSQLQuery }
 
-Procedure TTestTSQLQuery.Setup;
+procedure TTestTSQLQuery.Setup;
 begin
   inherited Setup;
   SQLDBConnector.Connection.Options:=[];
@@ -181,7 +182,7 @@ begin
   end;
 end;
 
-Procedure TTestTSQLQuery.TestKeepOpenOnCommit;
+procedure TTestTSQLQuery.TestKeepOpenOnCommit;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -219,12 +220,12 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TrySetPacketRecords;
+procedure TTestTSQLQuery.TrySetPacketRecords;
 begin
   FMyQ.PacketRecords:=10;
 end;
 
-Procedure TTestTSQLQuery.TestKeepOpenOnCommitPacketRecords;
+procedure TTestTSQLQuery.TestKeepOpenOnCommitPacketRecords;
 begin
   with SQLDBConnector do
     begin
@@ -234,12 +235,12 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TrySetQueryOptions;
+procedure TTestTSQLQuery.TrySetQueryOptions;
 begin
   FMyQ.Options:=[sqoKeepOpenOnCommit];
 end;
 
-Procedure TTestTSQLQuery.TestCheckSettingsOnlyWhenInactive;
+procedure TTestTSQLQuery.TestCheckSettingsOnlyWhenInactive;
 begin
   // Check that we can only set QueryOptions when the query is inactive.
   with SQLDBConnector do
@@ -261,7 +262,7 @@ begin
   AssertTrue('Have modifications in after post',FMyq.UpdateStatus=usModified)
 end;
 
-Procedure TTestTSQLQuery.TestAutoApplyUpdatesPost;
+procedure TTestTSQLQuery.TestAutoApplyUpdatesPost;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -296,7 +297,7 @@ begin
 
 end;
 
-Procedure TTestTSQLQuery.TestAutoApplyUpdatesDelete;
+procedure TTestTSQLQuery.TestAutoApplyUpdatesDelete;
 
 var Q: TSQLQuery;
     I: Integer;
@@ -328,13 +329,13 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.DoApplyUpdates;
+procedure TTestTSQLQuery.DoApplyUpdates;
 
 begin
   FMyQ.ApplyUpdates();
 end;
 
-Procedure TTestTSQLQuery.TestCheckRowsAffected;
+procedure TTestTSQLQuery.TestCheckRowsAffected;
 var Q: TSQLQuery;
     I: Integer;
 begin
@@ -359,7 +360,7 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TestAutoCommit;
+procedure TTestTSQLQuery.TestAutoCommit;
 var
   I : Integer;
 begin
@@ -389,7 +390,7 @@ begin
     end;
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQL;
+procedure TTestTSQLQuery.TestRefreshSQL;
 var
   Q: TSQLQuery;
 
@@ -424,7 +425,7 @@ begin
   AssertEquals('Field value has been fetched from the database', 1, Q.FieldByName('b').AsInteger);
 end;
 
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQL;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQL;
 
 var
   Q: TSQLQuery;
@@ -456,7 +457,7 @@ begin
   AssertEquals('Field value has been fetched from the database ','fgh',Q.FieldByName('b').AsString);
 end;
 
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQL1Field;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQL1Field;
 var
   Q: TSQLQuery;
 
@@ -485,7 +486,7 @@ begin
   AssertEquals('Field value b has NOT been fetched from the database ','',Q.FieldByName('b').AsString);
 end;
 
-Procedure TTestTSQLQuery.TestGeneratedRefreshSQLNoKey;
+procedure TTestTSQLQuery.TestGeneratedRefreshSQLNoKey;
 begin
   with SQLDBConnector do
     begin
@@ -507,7 +508,7 @@ begin
   AssertException('Cannot refresh without primary key',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQLMultipleRecords;
+procedure TTestTSQLQuery.TestRefreshSQLMultipleRecords;
 
 begin
   with SQLDBConnector do
@@ -534,7 +535,7 @@ begin
   AssertException('Multiple records returned by RefreshSQL gives an error',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestRefreshSQLNoRecords;
+procedure TTestTSQLQuery.TestRefreshSQLNoRecords;
 begin
   with SQLDBConnector do
     begin
@@ -560,7 +561,7 @@ begin
   AssertException('No records returned by RefreshSQL gives an error',EUpdateError,@DoApplyUpdates);
 end;
 
-Procedure TTestTSQLQuery.TestFetchAutoInc;
+procedure TTestTSQLQuery.TestFetchAutoInc;
 var datatype: string;
     id: largeint;
 begin
@@ -602,6 +603,50 @@ begin
     end;
 end;
 
+procedure TTestTSQLQuery.TestSequence;
+var SequenceNames : TStringList;
+begin
+  case SQLServerType of
+    ssFirebird:
+      SQLDBConnector.ExecuteDirect('create sequence FPDEV_SEQ1');
+    ssMSSQL, ssOracle, ssPostgreSQL:
+      SQLDBConnector.ExecuteDirect('create sequence FPDEV_SEQ1 MINVALUE 1');
+    else
+      Ignore(STestNotApplicable);
+  end;
+  SQLDBConnector.ExecuteDirect('create table FPDEV2 (id integer)');
+  SQLDBConnector.CommitDDL;
+
+  with SQLDBConnector.Query do
+    begin
+    SQL.Text := 'select * from FPDEV2';
+    Sequence.FieldName:='id';
+    Sequence.SequenceName:='FPDEV_SEQ1';
+    Open;
+    // default is get next value on new record
+    Append;
+    AssertEquals(1, FieldByName('id').AsInteger);
+
+    Sequence.ApplyEvent:=saeOnPost;
+    Append;
+    AssertTrue('Field ID must be null after Append', FieldByName('id').IsNull);
+    Post;
+    AssertEquals(2, FieldByName('id').AsInteger);
+    end;
+
+  // test GetSequenceNames
+  SequenceNames := TStringList.Create;
+  try
+    SQLDBConnector.Connection.GetSequenceNames(SequenceNames);
+    AssertTrue(SequenceNames.IndexOf('FPDEV_SEQ1') >= 0);
+  finally
+    SequenceNames.Free;
+  end;
+
+  SQLDBConnector.ExecuteDirect('drop sequence FPDEV_SEQ1');
+  SQLDBConnector.CommitDDL;
+end;
+
 
 { TTestTSQLConnection }
 

packages/fcl-fpcunit/src/DUnitCompatibleInterface.inc

@@ -21,7 +21,6 @@
     class procedure CheckNotNull(obj: IUnknown; msg: string = ''); overload; virtual;
     class procedure CheckIs(obj :TObject; pClass: TClass; msg: string = ''); overload;
     class procedure CheckSame(expected, actual: TObject; msg: string = ''); overload;
-    class procedure FailNotEquals(expected, actual: string; msg: string = ''; errorAddr: Pointer = nil); virtual;
     class procedure CheckTrue(condition: Boolean; msg: string = '');
     class procedure CheckFalse(condition: Boolean; msg: string = '');
     class procedure CheckException(AMethod: TRunMethod; AExceptionClass: ExceptClass; msg: string = '');
@@ -153,12 +152,6 @@ begin
    AssertSame(msg, expected, actual);
 end;
 
-class procedure TAssert.FailNotEquals(expected, actual: string; msg: string;
-  errorAddr: Pointer);
-begin
-  Fail(msg + ComparisonMsg(Expected, Actual));
-end;
-
 class procedure TAssert.CheckTrue(condition: Boolean; msg: string);
 begin
   if (not condition) then
@@ -181,9 +174,9 @@ class function TAssert.EqualsErrorMessage(const expected, actual: string;
     const ErrorMsg: string): string;
 begin
   if (ErrorMsg <> '') then
-    Result := Format(sMsgActualEqualsExpFmt, [ErrorMsg + ', ', expected, actual])
+    Result := Format(sExpectedButWasAndMessageFmt, [ErrorMsg + ', ', expected, actual])
   else
-    Result := Format(sActualEqualsExpFmt, [expected, actual])
+    Result := Format(sExpectedButWasFmt, [expected, actual])
 end;
 
 class function TAssert.NotEqualsErrorMessage(const expected, actual: string;

packages/fcl-fpcunit/src/consoletestrunner.pas

@@ -280,6 +280,7 @@ Type
   { TDecoratorTestSuite }
 
   TDecoratorTestSuite = Class(TTestSuite)
+  public
     Procedure  FreeDecorators(T : TTest);
     Destructor Destroy; override;
   end;

packages/fcl-fpcunit/src/fpcunit.pp

@@ -79,16 +79,21 @@ type
 
   TAssert = class(TTest)
   public
-    class procedure Fail(const AMessage: string);
-    class procedure Fail(const AFmt: string; Args : Array of const);
+    class procedure Fail(const AMessage: string; AErrorAddrs: Pointer = nil);
+    class procedure Fail(const AFmt: string; Args : Array of const;  AErrorAddrs: Pointer = nil);
+    class procedure FailEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+    class procedure FailNotEquals(const expected, actual: string; const ErrorMsg: string = ''; AErrorAddrs: Pointer = nil);
+
     class procedure AssertTrue(const AMessage: string; ACondition: boolean); overload;
     class procedure AssertTrue(ACondition: boolean); overload;
     class procedure AssertFalse(const AMessage: string; ACondition: boolean); overload;
     class procedure AssertFalse(ACondition: boolean); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: string); overload;
     class procedure AssertEquals(Expected, Actual: string); overload;
+    {$IFDEF UNICODE}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: UnicodeString); overload;
     class procedure AssertEquals(Expected, Actual: UnicodeString); overload;
+    {$ENDIF}
     class procedure AssertEquals(const AMessage: string; Expected, Actual: integer); overload;
     class procedure AssertEquals(Expected, Actual: integer); overload;
     class procedure AssertEquals(const AMessage: string; Expected, Actual: int64); overload;
@@ -142,15 +147,17 @@ type
     FRaisedExceptionClass: TClass;
     FRaisedExceptionMessage: string;
     FSourceUnitName: string;
+    FThrownExceptionAddress: Pointer;
     FTestLastStep: TTestStep;
     function GetAsString: string;
     function GetExceptionMessage: string;
     function GetIsFailure: boolean;
     function GetIsIgnoredTest: boolean;
     function GetExceptionClassName: string;
+    function GetLocationInfo: string;
     procedure SetTestLastStep(const Value: TTestStep);
   public
-    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+    constructor CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer = nil);
     property ExceptionClass: TClass read FRaisedExceptionClass;
   published
     property AsString: string read GetAsString;
@@ -160,6 +167,7 @@ type
     property ExceptionClassName: string read GetExceptionClassName;
     property SourceUnitName: string read FSourceUnitName write FSourceUnitName;
     property LineNumber: longint read FLineNumber write FLineNumber;
+    property LocationInfo: string read GetLocationInfo;
     property FailedMethodName: string read FFailedMethodName write FFailedMethodName;
     property TestLastStep: TTestStep read FTestLastStep write SetTestLastStep;
   end;
@@ -174,11 +182,17 @@ type
     procedure EndTestSuite(ATestSuite: TTestSuite);
   end;
 
+  { TTestCase }
+
   TTestCase = class(TAssert)
   private
     FName: string;
     FTestSuiteName: string;
     FEnableIgnores: boolean;
+    FExpectedExceptionFailMessage : String;
+    FExpectedException : TClass;
+    FExpectedExceptionMessage: String;
+    FExpectedExceptionContext: Integer;
   protected
     function CreateResult: TTestResult; virtual;
     procedure SetUp; virtual;
@@ -195,11 +209,17 @@ type
     constructor Create; virtual;
     constructor CreateWith(const ATestName: string; const ATestSuiteName: string); virtual;
     constructor CreateWithName(const AName: string); virtual;
+    procedure ExpectException(AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
+    procedure ExpectException(const Msg: String; AExceptionClass: TClass; AExceptionMessage: string=''; AExceptionHelpContext: Integer=0);
     function CountTestCases: integer; override;
     function CreateResultAndRun: TTestResult; virtual;
     procedure Run(AResult: TTestResult); override;
     function AsString: string;
     property TestSuiteName: string read GetTestSuiteName write SetTestSuiteName;
+    Property ExpectedExceptionFailMessage  : String Read FExpectedExceptionFailMessage;
+    Property ExpectedException : TClass Read FExpectedException;
+    Property ExpectedExceptionMessage : String Read FExpectedExceptionMessage;
+    Property ExpectedExceptionContext: Integer Read FExpectedExceptionContext;
   published
     property TestName: string read GetTestName write SetTestName;
   end;
@@ -261,9 +281,8 @@ type
     destructor Destroy; override;
     procedure ClearErrorLists;
     procedure StartTest(ATest: TTest);
-    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
-    procedure AddError(ATest: TTest; E: Exception; AUnitName: string;
-      AFailedMethodName: string; ALineNumber: longint);
+    procedure AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
+    procedure AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
     procedure EndTest(ATest: TTest);
     procedure AddListener(AListener: ITestListener);
     procedure RemoveListener(AListener: ITestListener);
@@ -288,8 +307,14 @@ type
     property StartingTime: TDateTime read FStartingTime;
   end;
 
-  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string;
-  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
+  function ComparisonMsg(const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+  {$IFDEF UNICODE}
+  function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string; overload;
+  {$ENDIF}
+  function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean=true): string; overload;
+
+  // Made public for 3rd party developers extending TTestCase with new AssertXXX methods
+  function CallerAddr: Pointer;
 
   
 Resourcestring
@@ -298,6 +323,8 @@ Resourcestring
   SCompareNotEqual = ' expected: not equal to <%s> but was: <%s>';
   SExpectedNotSame = 'expected not same';
   SExceptionCompare = 'Exception %s expected but %s was raised';
+  SExceptionMessageCompare = 'Exception raised but exception property Message differs: ';
+  SExceptionHelpContextCompare = 'Exception raised but exception property HelpContext differs: ';
   SMethodNotFound = 'Method <%s> not found';
   SNoValidInheritance = ' does not inherit from TTestCase';
   SNoValidTests = 'No valid tests found in ';
@@ -311,8 +338,6 @@ uses
 Const
   sExpectedButWasFmt = 'Expected:' + LineEnding + '"%s"' + LineEnding + 'But was:' + LineEnding + '"%s"';
   sExpectedButWasAndMessageFmt = '%s' + LineEnding + sExpectedButWasFmt;
-  sMsgActualEqualsExpFmt = '%s' + LineEnding + 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
-  sActualEqualsExpFmt = 'Expected ' + LineEnding + '< %s > ' + LineEnding + 'equals actual ' + LineEnding + '< %s >';
 
 
 { This lets us use a single include file for both the Interface and
@@ -321,6 +346,35 @@ Const
 {$define read_implementation}
 
 
+function CallerAddr: Pointer;
+var
+  bp: Pointer;
+begin
+  bp := get_caller_frame(get_frame);
+  if bp <> nil then
+    Result := get_caller_addr(bp)
+  else
+    Result := nil;
+end;
+
+function AddrsToStr(Addrs: Pointer): string;
+begin
+  if PtrUInt(Addrs) > 0 then
+    Result := '$'+Format('%p', [Addrs])
+  else
+    Result := 'n/a';
+end;
+
+
+function PointerToLocationInfo(Addrs: Pointer): string;
+
+begin
+  Result := BackTraceStrFunc(Addrs);
+  if Trim(Result) = '' then
+    Result := AddrsToStr(Addrs) + '  <no map file>';
+end;
+
+
 type
 
   TTestWarning = class(TTestCase)
@@ -346,7 +400,7 @@ begin
     Result := format(SCompareNotEqual, [aExpected, aActual]);
 end;
 
-
+{$IFDEF UNICODE}
 function ComparisonMsg(const aExpected: UnicodeString; const aActual: UnicodeString; const aCheckEqual: boolean=true): string;
 // aCheckEqual=false gives the error message if the test does *not* expect the results to be the same.
 begin
@@ -355,6 +409,12 @@ begin
   else {check unequal requires opposite error message}
     Result := format(UnicodeString(SCompareNotEqual), [aExpected, aActual]);
 end;
+{$ENDIF}
+
+function ComparisonMsg(const aMsg: string; const aExpected: string; const aActual: string; const aCheckEqual: boolean): string;
+begin
+  Result := '"' + aMsg + '"' + ComparisonMsg(aExpected, aActual, aCheckEqual);
+end;
 
 
 constructor EAssertionFailedError.Create;
@@ -369,13 +429,14 @@ begin
 end;
 
 
-constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep);
+constructor TTestFailure.CreateFailure(ATest: TTest; E: Exception; LastStep: TTestStep; ThrownExceptionAddrs: pointer);
 begin
   inherited Create;
   FTestName := ATest.GetTestName;
   FTestSuiteName := ATest.GetTestSuiteName;
   FRaisedExceptionClass := E.ClassType;
   FRaisedExceptionMessage := E.Message;
+  FThrownExceptionAddress := ThrownExceptionAddrs;
   FTestLastStep := LastStep;
 end;
 
@@ -400,6 +461,11 @@ begin
     Result := '<NIL>'
 end;
 
+function TTestFailure.GetLocationInfo: string;
+begin
+  Result := PointerToLocationInfo(FThrownExceptionAddress);
+end;
+
 
 function TTestFailure.GetExceptionMessage: string;
 begin
@@ -463,16 +529,31 @@ end;
 
 { TAssert }
 
-class procedure TAssert.Fail(const AMessage: string);
+class procedure TAssert.Fail(const AMessage: string; AErrorAddrs: Pointer);
 begin
-  raise EAssertionFailedError.Create(AMessage);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.Create(AMessage) at CallerAddr
+  else
+    raise EAssertionFailedError.Create(AMessage) at AErrorAddrs;
 end;
 
-class procedure TAssert.Fail(const AFmt: string; Args: array of const);
+class procedure TAssert.Fail(const AFmt: string; Args: array of const; AErrorAddrs: Pointer = nil);
 begin
-  raise EAssertionFailedError.CreateFmt(AFmt,Args);
+  if AErrorAddrs = nil then
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at CallerAddr
+  else    
+    raise EAssertionFailedError.CreateFmt(AFmt,Args) at AErrorAddrs;
 end;
 
+class procedure TAssert.FailEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(EqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
+
+class procedure TAssert.FailNotEquals(const expected, actual: string; const ErrorMsg: string; AErrorAddrs: Pointer);
+begin
+  Fail(NotEqualsErrorMessage(expected, actual, ErrorMsg), AErrorAddrs);
+end;
 
 class procedure TAssert.AssertTrue(const AMessage: string; ACondition: boolean);
 begin
@@ -502,7 +583,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: string);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), AnsiCompareStr(Expected, Actual) = 0);
+  AssertTrue(ComparisonMsg(AMessage ,Expected, Actual), AnsiCompareStr(Expected, Actual) = 0);
 end;
 
 
@@ -511,9 +592,10 @@ begin
   AssertEquals('', Expected, Actual);
 end;
 
-class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: Unicodestring);
+{$IFDEF UNICODE}
+class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: UnicodeString);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), (Expected=Actual));
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), (Expected=Actual));
 end;
 
 
@@ -521,7 +603,7 @@ class procedure TAssert.AssertEquals(Expected, Actual: UnicodeString);
 begin
   AssertEquals('', Expected, Actual);
 end;
-
+{$ENDIF}
 
 class procedure TAssert.AssertNotNull(const AString: string);
 begin
@@ -531,7 +613,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: integer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
 end;
 
 
@@ -543,7 +625,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: int64);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(Expected), IntToStr(Actual)), Expected = Actual);
 end;
 
 
@@ -555,7 +637,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: currency);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected), FloatToStr(Actual)), Expected = Actual);
 end;
 
 
@@ -567,7 +649,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual, Delta: double);
 begin
-  AssertTrue(AMessage + ComparisonMsg(FloatToStr(Expected),FloatToStr(Actual)),
+  AssertTrue(ComparisonMsg(AMessage,FloatToStr(Expected),FloatToStr(Actual)),
     (Abs(Expected - Actual) <= Delta));
 end;
 
@@ -586,7 +668,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: boolean);
 begin
-  AssertTrue(AMessage + ComparisonMsg(BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,BoolToStr(Expected, true), BoolToStr(Actual, true)), Expected = Actual);
 end;
 
 
@@ -598,7 +680,7 @@ end;
 
 class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: char);
 begin
-  AssertTrue(AMessage + ComparisonMsg(Expected, Actual), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,Expected, Actual), Expected = Actual);
 end;
 
 
@@ -619,7 +701,7 @@ class procedure TAssert.AssertEquals(const AMessage: string; Expected, Actual: T
   end;
 
 begin
-  AssertTrue(AMessage + ComparisonMsg(GetN(Expected), GetN(Actual)), Expected = Actual);
+  AssertTrue(ComparisonMsg(AMessage,GetN(Expected), GetN(Actual)), Expected = Actual);
 end;
 
 
@@ -631,7 +713,7 @@ end;
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: TObject);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
     Expected = Actual);
 end;
 
@@ -644,7 +726,7 @@ end;
 
 class procedure TAssert.AssertSame(const AMessage: string; Expected, Actual: Pointer);
 begin
-  AssertTrue(AMessage + ComparisonMsg(IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
+  AssertTrue(ComparisonMsg(AMessage,IntToStr(PtrInt(Expected)), IntToStr(PtrInt(Actual))),
     Expected = Actual);
 end;
 
@@ -898,6 +980,8 @@ var
   m: TMethod;
   RunMethod: TRunMethod;
   pMethod : Pointer;
+  FailMessage : String;
+
 begin
   AssertNotNull('name of the test not assigned', FName);
   pMethod := Self.MethodAddress(FName);
@@ -906,7 +990,33 @@ begin
     m.Code := pMethod;
     m.Data := self;
     RunMethod := TRunMethod(m);
-    RunMethod;
+    ExpectException('',Nil,'',0);
+    try
+      FailMessage:='';
+      RunMethod;
+      if (FExpectedException<>Nil) then
+        FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, SNoException])
+    except
+      On E : Exception do
+        begin
+        if FExpectedException=Nil then
+          Raise;
+        If not (E is FExpectedException) then
+          FailMessage:=Format(SExceptionCompare, [FExpectedException.ClassName, E.ClassName]);
+        if (FExpectedExceptionMessage<>'') then
+          if (FExpectedExceptionMessage<>E.Message) then
+            FailMessage:=Format(SExceptionmessageCompare+SCompare, [FExpectedExceptionMessage,E.Message]);
+        if (FExpectedExceptionContext<>0) then
+          if (FExpectedExceptionContext<>E.HelpContext) then
+            FailMessage:=Format(SExceptionHelpContextCompare+SCompare, [IntToStr(FExpectedExceptionContext),IntToStr(E.HelpContext)])
+        end;
+    end;
+    if (FailMessage<>'') then
+      begin
+      if (FExpectedExceptionFailMessage<>'') then
+        FailMessage:=' : '+FailMessage;
+      Fail(FExpectedExceptionFailMessage+FailMessage);
+      end;
   end
   else
     begin
@@ -1057,6 +1167,21 @@ begin
   end;
 end;
 
+procedure TTestCase.ExpectException(const Msg: String;
+  AExceptionClass: TClass; AExceptionMessage: string = '';
+  AExceptionHelpContext: Integer =0 );
+begin
+  FExpectedExceptionFailMessage:=Msg;
+  FExpectedException:=AExceptionClass;
+  FExpectedExceptionMessage:=AExceptionMessage;
+  FExpectedExceptionContext:=AExceptionHelpContext;
+end;
+
+procedure TTestCase.ExpectException(AExceptionClass: TClass;
+  AExceptionMessage: string = ''; AExceptionHelpContext: Integer = 0);
+begin
+  ExpectException('',AExceptionClass,AExceptionMessage,AExceptionHelpContext);
+end;
 
 procedure TTestSuite.Run(AResult: TTestResult);
 var
@@ -1174,13 +1299,13 @@ begin
 end;
 
 
-procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList);
+procedure TTestResult.AddFailure(ATest: TTest; E: EAssertionFailedError; aFailureList: TFPList; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   aFailureList.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddFailure(ATest, f);
@@ -1188,17 +1313,13 @@ begin
 end;
 
 
-procedure TTestResult.AddError(ATest: TTest; E: Exception;
-  AUnitName: string; AFailedMethodName: string; ALineNumber: longint);
+procedure TTestResult.AddError(ATest: TTest; E: Exception; AThrownExceptionAdrs: Pointer);
 var
   i: integer;
   f: TTestFailure;
 begin
   //lock mutex
-  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep);
-  f.SourceUnitName := AUnitName;
-  f.FailedMethodName := AFailedMethodName;
-  f.LineNumber := ALineNumber;
+  f := TTestFailure.CreateFailure(ATest, E, ATest.LastStep, AThrownExceptionAdrs);
   FErrors.Add(f);
   for i := 0 to FListeners.Count - 1 do
     ITestListener(FListeners[i]).AddError(ATest, f);
@@ -1233,26 +1354,17 @@ end;
 
 
 procedure TTestResult.RunProtected(ATestCase: TTest; protect: TProtect);
-var
-  func, source: shortstring;
-  line: longint;
 begin
-  func := '';
-  source := '';
-  line := 0;
   try
     protect(ATestCase, Self);
   except
     on E: EIgnoredTest do
-      AddFailure(ATestCase, E, FIgnoredTests);
+      AddFailure(ATestCase, E, FIgnoredTests, ExceptAddr);
     on E: EAssertionFailedError do
-      AddFailure(ATestCase, E, FFailures);
+      AddFailure(ATestCase, E, FFailures, ExceptAddr);
     on E: Exception do
       begin
-      {$ifdef SHOWLINEINFO}
-        GetLineInfo(LongWord(ExceptAddr), func, source, line);
-      {$endif}
-        AddError(ATestCase, E, source, func, line);
+        AddError(ATestCase, E, ExceptAddr);
       end;
   end;
 end;
@@ -1279,7 +1391,7 @@ begin
 //unlock mutex
 end;
 
-function TTestResult.SkipTest(ATestCase: TTestCase): Boolean;
+function TTestResult.SkipTest(ATestCase: TTestCase): boolean;
 var
   i: integer;
 begin
@@ -1292,7 +1404,7 @@ begin
   else
     for i := 0 to FSkippedTests.Count - 1 do
     begin
-      if PtrInt(FSkippedTests[i]) = PtrInt(ATestCase) then
+      if PtrUInt(FSkippedTests[i]) = PtrUInt(ATestCase) then
       begin
         Result := true;
         Exit;

packages/fcl-fpcunit/src/plaintestreport.pp

@@ -124,10 +124,8 @@ begin
     begin
       FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Error: ' + FTempFailure.ExceptionClassName;
       FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Source unit: ' + FTempFailure.SourceUnitName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Method name: ' + FTempFailure.FailedMethodName);
-      FDoc.Add(StringOfChar(' ',ALevel*2) + '    Line number: ' 
-        + IntToStr(FTempFailure.LineNumber));
+      FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      // TODO: Add stack dump output info
     end
     else
       if FTempFailure.IsIgnoredTest then
@@ -136,9 +134,13 @@ begin
            + FTempFailure.ExceptionMessage;
       end
       else
+      begin
         //is a failure
         FDoc[FDoc.Count -1] := FDoc[FDoc.Count -1] + '  Failed: ' 
           + FTempFailure.ExceptionMessage;
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    Exception:   ' + FTempFailure.ExceptionMessage);
+        FDoc.Add(StringOfChar(' ',ALevel*2) + '    at ' + FTempFailure.LocationInfo);
+      end;
   end;
   FTempFailure := nil;
 end;
@@ -225,9 +227,7 @@ begin
         Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
         Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
         Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
-        Result := Result + '    Source unitname:   ' + f.SourceUnitName + System.sLineBreak;
-        Result := Result + '    Line number:       ' + IntToStr(f.LineNumber) + System.sLineBreak;
-        Result := Result + '    Failed methodname: ' + f.FailedMethodName + System.sLineBreak;
+        Result := Result + '        at ' + f.LocationInfo + System.sLineBreak;
       end;
     end;
     if NumberOfFailures <> 0 then
@@ -242,6 +242,7 @@ begin
         Result := Result + '    Message:           ' + f.AsString + System.sLineBreak;
         Result := Result + '    Exception class:   ' + f.ExceptionClassName + System.sLineBreak;
         Result := Result + '    Exception message: ' + f.ExceptionMessage + System.sLineBreak;
+        Result := Result + '        at ' + f.LocationInfo + System.sLineBreak;
       end;
     end;
    if NumberOfIgnoredTests <> 0 then

packages/fcl-fpcunit/src/tests/asserttest.pp

@@ -23,6 +23,8 @@ uses
 
 type
 
+  { TAssertTest }
+
   TAssertTest = class(TTestCase)
   published
     procedure TestFail;
@@ -37,11 +39,25 @@ type
     procedure TestAssertTrue;
     procedure TestAssertFalse;
     procedure TestAssertNotSame;
+    procedure TestExpectExceptionOK;
+    procedure TestExpectExceptionNoException;
+    procedure TestExpectExceptionWrongExceptionClass;
+    procedure TestExpectExceptionWrongExceptionMessage;
+    procedure TestExpectExceptionWrongExceptionContext;
   end;
 
+  EMyException = Class(Exception);
+
+  { TMyTest }
+
   TMyTest = class(TTestCase)
   published
     procedure RaiseIgnoreTest;
+    procedure TestExpectException;
+    procedure TestExpectExceptionNone;
+    procedure TestExpectExceptionWrongClass;
+    procedure TestExpectExceptionWrongMessage;
+    procedure TestExpectExceptionWrongHelpContext;
   end;
 
   TTestIgnore = class(TTestCase)
@@ -233,10 +249,115 @@ begin
   Fail('Error: Objects are the same!');
 end;
 
+procedure TAssertTest.TestExpectExceptionOK;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectException');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 0, res.NumberOfFailures);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionNoException;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionNone');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but no exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionClass;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongClass');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception EMyException expected but Exception was raised',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionMessage;
+
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongMessage');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property Message differs:  expected: <A message> but was: <A wrong message>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
+procedure TAssertTest.TestExpectExceptionWrongExceptionContext;
+var
+  t: TMyTest;
+  res: TTestResult;
+begin
+  t := TMyTest.CreateWithName('TestExpectExceptionWrongHelpContext');
+  res := t.CreateResultAndRun;
+  assertEquals('no test was run', 1, res.RunTests);
+  assertEquals('no Ignored Test present', 0, res.NumberOfIgnoredTests);
+  assertEquals('no failed Test present', 1, res.NumberOfFailures);
+  assertEquals('Correct error message','Error message : Exception raised but exception property HelpContext differs:  expected: <123> but was: <124>',TTestFailure(res.Failures[0]).ExceptionMessage);
+  t.Free;
+  res.Free;
+end;
+
 procedure TMyTest.RaiseIgnoreTest;
 begin
   Ignore('This is an ignored test');
-  AssertEquals('the compiler can count', 3, 1+1); 
+  AssertEquals('the compiler can count', 3, 2);
+end;
+
+procedure TMyTest.TestExpectException;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionNone;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongClass;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise Exception.CreateHelp('A message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongMessage;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A wrong message',123);
+end;
+
+procedure TMyTest.TestExpectExceptionWrongHelpContext;
+begin
+  ExpectException('Error message',EMyException,'A message',123);
+  Raise EMyException.CreateHelp('A message',124);
 end;
 
 procedure TTestIgnore.TestIgnoreResult;
@@ -262,14 +383,14 @@ var
 begin
   t := TMyTest.CreateWithName('RaiseIgnoreTest');
   t.EnableIgnores := false;
-  res := t.CreateResultandRun;
+  res := t.CreateResultAndRun;
   assertEquals('no test was run', 1, res.RunTests);
   assertEquals('Ignored Test reported even if the switch is not active', 0, res.NumberOfIgnoredTests);
   assertEquals('no failure caught', 1, res.NumberOfFailures);
   assertFalse('failure is signalled as Ignored Test and the switch is not active', 
     TTestFailure(res.Failures[0]).IsIgnoredTest);
   assertEquals('wrong failure name', 'EAssertionFailedError', TTestFailure(res.Failures[0]).ExceptionClassName);
-  assertEquals('wrong message', 'the compiler can count expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
+  assertEquals('wrong message', '"the compiler can count" expected: <3> but was: <2>', TTestFailure(res.Failures[0]).ExceptionMessage);
   t.Free;
   res.Free;
 end;

packages/fcl-fpcunit/src/tests/frameworktest.pp

@@ -17,7 +17,8 @@
 program frameworktest;
 
 uses
-  custapp, classes, SysUtils, fpcunit, testreport, asserttest, suitetest;
+  consoletestrunner, classes, SysUtils, fpcunit, testreport, asserttest,
+  suitetest;
 
 Const
   ShortOpts = 'alh';
@@ -26,113 +27,24 @@ Const
   Version = 'Version 0.1';
 
 Type
-  TTestRunner = Class(TCustomApplication)
-  private
-    FSuite: TTestSuite;
-    FXMLResultsWriter: TXMLResultsWriter;
-  protected
-    procedure DoRun ; Override;
-    procedure doTestRun(aTest: TTest); virtual;
-  public
-    constructor Create(AOwner: TComponent); override;
-    destructor Destroy; override;
+  TFPCUnitRunner = Class(TTestRunner)
+
   end;
 
 
-constructor TTestRunner.Create(AOwner: TComponent);
-begin
-  inherited Create(AOwner);
-  FXMLResultsWriter := TXMLResultsWriter.Create;
-  FSuite := TTestSuite.Create;
-  FSuite.TestName := 'Framework test';
-  FSuite.AddTestSuiteFromClass(TAssertTest);
-  FSuite.AddTestSuiteFromClass(TTestIgnore);
-  FSuite.AddTest(TSuiteTest.Suite());
-end;
 
-destructor TTestRunner.Destroy;
-begin
-  FXMLResultsWriter.Free;
-  FSuite.Free;
-end;
 
-procedure TTestRunner.doTestRun(aTest: TTest);
-var
-  testResult: TTestResult;
-begin
-  testResult := TTestResult.Create;
-  try
-    testResult.AddListener(FXMLResultsWriter);
-    FXMLResultsWriter.WriteHeader;
-    aTest.Run(testResult);
-    FXMLResultsWriter.WriteResult(testResult);
-  finally
-    testResult.Free;
-  end;
-end;
 
-procedure TTestRunner.DoRun;
-var
-  I : Integer;
-  S : String;
-begin
-  S:=CheckOptions(ShortOpts,LongOpts);
-  If (S<>'') then
-    Writeln(S);
-  if HasOption('h', 'help') or (ParamCount = 0) then
-  begin
-    writeln(Title);
-    writeln(Version);
-    writeln('Usage: ');
-    writeln('-l or --list to show a list of registered tests');
-    writeln('default format is xml, add --format=latex to output the list as latex source');
-    writeln('-a or --all to run all the tests and show the results in xml format');
-    writeln('The results can be redirected to an xml file,');
-    writeln('for example: ./testrunner --all > results.xml');
-    writeln('use --suite=MyTestSuiteName to run only the tests in a single test suite class');
-  end
-  else;
-    if HasOption('l', 'list') then
-    begin
-      if HasOption('format') then
-      begin
-        if GetOptionValue('format') = 'latex' then
-          writeln(GetSuiteAsLatex(FSuite))
-        else
-          writeln(GetSuiteAsXML(FSuite));
-      end
-      else
-        writeln(GetSuiteAsXML(FSuite));
-    end;
-  if HasOption('a', 'all') then
-  begin
-    doTestRun(FSuite)
-  end
-  else
-    if HasOption('suite') then
-    begin
-      S := '';
-      S:=GetOptionValue('suite');
-      if S = '' then
-        for I := 0 to FSuite.Tests.count - 1 do
-          writeln(FSuite[i].TestName)
-      else
-      for I := 0 to FSuite.Tests.count - 1 do
-        if FSuite[i].TestName = S then
-        begin
-          doTestRun(FSuite.Test[i]);
-        end;
-    end;
-  Terminate;
-end;
 
 Var
-  App : TTestRunner;
+  App : TFPCUnitRunner;
 
 begin
-  App:=TTestRunner.Create(Nil);
+  DefaultFormat:=fPlain;
+  DefaultRunAllTests:=True;
+  App:=TFPCUnitRunner.Create(Nil);
   App.Initialize;
-  App.Title := 'FPCUnit Console Test Case runner.';
+  App.Title := 'FPCUnit Test Suite';
   App.Run;
   App.Free;
 end.

packages/fcl-image/src/fpreadpng.pp

@@ -403,20 +403,24 @@ end;
 function TFPReaderPNG.CalcColor: TColorData;
 var cd : longword;
     r : word;
-    b : byte;
-    tmp : pbytearray;
+    b : pbyte;
 begin
   if UsingBitGroup = 0 then
     begin
     Databytes := 0;
     if Header.BitDepth = 16 then
       begin
-       getmem(tmp, bytewidth);
-       fillchar(tmp^, bytewidth, 0);
-       for r:=0 to bytewidth-2 do
-        tmp^[r+1]:=FCurrentLine^[Dataindex+r];
-       move (tmp^[0], Databytes, bytewidth);
-       freemem(tmp);
+        b := @Databytes;
+        b^ := 0;
+        r := 0;
+        while (r < ByteWidth-1) do
+        begin
+          b^ := FCurrentLine^[DataIndex+r+1];
+          inc (b);
+          b^ := FCurrentLine^[DataIndex+r];
+          inc (b);
+          inc (r,2);
+        end;
       end
     else move (FCurrentLine^[DataIndex], Databytes, bytewidth);
     {$IFDEF ENDIAN_BIG}

packages/fcl-image/src/fpwritepng.pp

@@ -660,7 +660,7 @@ procedure TFPWriterPNG.WritetRNS;
   procedure PaletteAlpha;
   var r : integer;
   begin
-    with TheImage.palette do
+    with FPalette do
       begin
       // search last palette entry with transparency
       r := count;

packages/fcl-json/src/jsonconf.pp

@@ -73,6 +73,7 @@ type
   public
     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;
+    Procedure Reload;
     procedure Clear;
     procedure Flush;    // Writes the JSON file
     procedure OpenKey(const aPath: WideString; AllowCreate : Boolean);
@@ -528,12 +529,17 @@ begin
   DeletePath(APath);
 end;
 
-procedure TJSONConfig.Loaded;
+Procedure TJSONConfig.Reload;
+
 begin
-  inherited Loaded;
   if Length(Filename) > 0 then
     DoSetFilename(Filename,True);
 end;
+procedure TJSONConfig.Loaded;
+begin
+  inherited Loaded;
+  Reload;
+end;
 
 function TJSONConfig.FindPath(const APath: WideString; AllowCreate: Boolean
   ): TJSONObject;

packages/fcl-passrc/src/pparser.pp

@@ -988,7 +988,7 @@ function TPasParser.ParseType(Parent: TPasElement; Const TypeName : String = '';
 
 Const
   // These types are allowed only when full type declarations
-  FullTypeTokens = [tkGeneric,tkSpecialize,tkClass,tkInterface,tkType];
+  FullTypeTokens = [tkGeneric,{tkSpecialize,}tkClass,tkInterface,tkType];
   // Parsing of these types already takes care of hints
   NoHintTokens = [tkProcedure,tkFunction];
 var
@@ -1639,6 +1639,7 @@ begin
         Result.Overloads.Add(OldMember);
         Result.SourceFilename:=OldMember.SourceFilename;
         Result.SourceLinenumber:=OldMember.SourceLinenumber;
+        Result.DocComment:=Oldmember.DocComment;
         AList[i] := Result;
         end;
       end;

packages/fcl-passrc/tests/tcclasstype.pas

@@ -19,6 +19,7 @@ type
     FParent : String;
     FEnded,
     FStarted: Boolean;
+    procedure AssertSpecializedClass(C: TPasClassType);
     function GetC(AIndex: Integer): TPasConst;
     function GetF1: TPasVariable;
     function GetM(AIndex : Integer): TPasElement;
@@ -36,6 +37,7 @@ type
     Procedure EndClass(AEnd : String = 'end');
     Procedure AddMember(S : String);
     Procedure ParseClass;
+    Procedure DoParseClass(FromSpecial : Boolean = False);
     procedure SetUp; override;
     procedure TearDown; override;
     procedure DefaultMethod;
@@ -66,6 +68,8 @@ type
     procedure TestEmptyEndNoParent;
     Procedure TestOneInterface;
     Procedure TestTwoInterfaces;
+    procedure TestOneSpecializedClass;
+    procedure TestOneSpecializedClassInterface;
     Procedure TestOneField;
     Procedure TestOneFieldComment;
     Procedure TestOneVarField;
@@ -219,7 +223,7 @@ begin
   Result:=TPasConst(Members[AIndex]);
 end;
 
-Procedure TTestClassType.StartClass(AParent: String; InterfaceList: String);
+procedure TTestClassType.StartClass(AParent: String; InterfaceList: String);
 
 Var
   S : String;
@@ -237,7 +241,7 @@ begin
   FParent:=AParent;
 end;
 
-Procedure TTestClassType.StartClassHelper(ForType: String; AParent: String);
+procedure TTestClassType.StartClassHelper(ForType: String; AParent: String);
 Var
   S : String;
 begin
@@ -253,7 +257,7 @@ begin
   FParent:=AParent;
 end;
 
-Procedure TTestClassType.StartInterface(AParent: String; UUID: String);
+procedure TTestClassType.StartInterface(AParent: String; UUID: String);
 Var
   S : String;
 begin
@@ -267,7 +271,7 @@ begin
   FParent:=AParent;
 end;
 
-Procedure TTestClassType.StartRecordHelper(ForType: String; AParent: String);
+procedure TTestClassType.StartRecordHelper(ForType: String; AParent: String);
 Var
   S : String;
 begin
@@ -283,14 +287,14 @@ begin
   FParent:=AParent;
 end;
 
-Procedure TTestClassType.StartVisibility(A: TPasMemberVisibility);
+procedure TTestClassType.StartVisibility(A: TPasMemberVisibility);
 begin
   if not FStarted then
     StartClass;
   FDecl.Add('  '+VisibilityNames[A]);
 end;
 
-Procedure TTestClassType.EndClass(AEnd: String);
+procedure TTestClassType.EndClass(AEnd: String);
 begin
   if FEnded then exit;
   if not FStarted then
@@ -300,14 +304,20 @@ begin
     FDecl.Add('  '+AEnd);
 end;
 
-Procedure TTestClassType.AddMember(S: String);
+procedure TTestClassType.AddMember(S: String);
 begin
   if Not FStarted then
     StartClass;
   FDecl.Add('    '+S+';');
 end;
 
-Procedure TTestClassType.ParseClass;
+procedure TTestClassType.ParseClass;
+
+begin
+  DoParseClass(False);
+end;
+
+procedure TTestClassType.DoParseClass(FromSpecial: Boolean);
 begin
   EndClass;
   Add('Type');
@@ -325,8 +335,15 @@ begin
   if (FParent<>'') then
      begin
      AssertNotNull('Have parent class',TheClass.AncestorType);
-     AssertEquals('Parent class',TPasUnresolvedTypeRef,TheClass.AncestorType.ClassType);
-     AssertEquals('Parent class name',FParent,TPasUnresolvedTypeRef(TheClass.AncestorType).Name);
+     if FromSpecial then
+       begin
+       AssertEquals('Parent class',TPasClassType,TheClass.AncestorType.ClassType);
+       end
+     else
+       begin
+       AssertEquals('Parent class',TPasUnresolvedTypeRef,TheClass.AncestorType.ClassType);
+       AssertEquals('Parent class name',FParent,TPasUnresolvedTypeRef(TheClass.AncestorType).Name);
+       end;
      end;
   if (TheClass.ObjKind<>okInterface) then
     AssertNull('No interface, No GUID',TheClass.GUIDExpr);
@@ -353,7 +370,7 @@ begin
   inherited TearDown;
 end;
 
-Procedure TTestClassType.AssertVisibility(V: TPasMemberVisibility;
+procedure TTestClassType.AssertVisibility(V: TPasMemberVisibility;
   Member: TPasElement);
 begin
   If Member=Nil then
@@ -376,7 +393,7 @@ begin
   AssertEquals('Member name ',AName,Member.Name)
 end;
 
-Procedure TTestClassType.AssertProperty(P: TPasProperty;
+procedure TTestClassType.AssertProperty(P: TPasProperty;
   AVisibility: TPasMemberVisibility; AName, ARead, AWrite, AStored,
   AImplements: String; AArgCount: Integer; ADefault, ANodefault: Boolean);
 begin
@@ -425,7 +442,7 @@ begin
   AssertEquals('No members',0,TheClass.Members.Count);
 end;
 
-Procedure TTestClassType.TestOneInterface;
+procedure TTestClassType.TestOneInterface;
 begin
   StartClass('TObject','ISomething');
   ParseClass;
@@ -435,7 +452,7 @@ begin
   AssertEquals('Interface name','ISomething',TPasUnresolvedTypeRef(TheClass.Interfaces[0]).Name);
 end;
 
-Procedure TTestClassType.TestTwoInterfaces;
+procedure TTestClassType.TestTwoInterfaces;
 begin
   StartClass('TObject','ISomething, ISomethingElse');
   ParseClass;
@@ -448,7 +465,46 @@ begin
   AssertEquals('Interface name','ISomethingElse',TPasUnresolvedTypeRef(TheClass.Interfaces[1]).Name);
 end;
 
-Procedure TTestClassType.TestOneField;
+procedure TTestClassType.AssertSpecializedClass(C : TPasClassType);
+
+begin
+  AssertEquals('Parent class name is empty','',C.Name);
+  AssertNotNull('Have ancestor type',C.AncestorType);
+  AssertEquals('Have ancestor type name','TMyList',C.AncestorType.Name);
+  AssertNotNull('Have generic template types',C.GenericTemplateTypes);
+  AssertEquals('Have generic template types',1,C.GenericTemplateTypes.Count);
+  AssertEquals('Class name ',TPasGenericTemplateType,TObject(C.GenericTemplateTypes[0]).ClassType);
+  AssertEquals('Have generic template types','Integer',TPasElement(C.GenericTemplateTypes[0]).Name);
+end;
+
+procedure TTestClassType.TestOneSpecializedClass;
+
+Var
+  C : TPasClassType;
+
+begin
+  StartClass('Specialize TMyList<Integer>','');
+  DoParseClass(True);
+  C:=TPasClassType(TheClass.AncestorType);
+  AssertSpecializedClass(C);
+end;
+
+procedure TTestClassType.TestOneSpecializedClassInterface;
+Var
+  C : TPasClassType;
+
+begin
+  StartClass('Specialize TMyList<Integer>','ISomething');
+  DoParseClass(True);
+  C:=TPasClassType(TheClass.AncestorType);
+  AssertSpecializedClass(C);
+  AssertEquals('Have 1 interface',1,TheClass.Interfaces.Count);
+  AssertNotNull('Correct class',TheClass.Interfaces[0]);
+  AssertEquals('Correct class',TPasUnresolvedTypeRef,TObject(TheClass.Interfaces[0]).ClassType);
+  AssertEquals('Interface name','ISomething',TPasUnresolvedTypeRef(TheClass.Interfaces[0]).Name);
+end;
+
+procedure TTestClassType.TestOneField;
 begin
   AddMember('a : integer');
   ParseClass;
@@ -457,7 +513,7 @@ begin
   AssertVisibility;
 end;
 
-Procedure TTestClassType.TestOneFieldComment;
+procedure TTestClassType.TestOneFieldComment;
 begin
   AddComment:=true;
   AddMember('{c}a : integer');
@@ -467,7 +523,7 @@ begin
   AssertVisibility;
 end;
 
-Procedure TTestClassType.TestOneVarField;
+procedure TTestClassType.TestOneVarField;
 begin
   StartVisibility(visPublished);
   FDecl.Add('var');
@@ -478,7 +534,7 @@ begin
   AssertVisibility(visPublished);
 end;
 
-Procedure TTestClassType.TestOneClassField;
+procedure TTestClassType.TestOneClassField;
 begin
   StartVisibility(visPublished);
   FDecl.Add('class var');
@@ -491,7 +547,7 @@ begin
      Fail('Field is not a class field');
 end;
 
-Procedure TTestClassType.TestOneFieldVisibility;
+procedure TTestClassType.TestOneFieldVisibility;
 begin
   StartVisibility(visPublished);
   AddMember('a : integer');
@@ -501,7 +557,7 @@ begin
   AssertVisibility(visPublished);
 end;
 
-Procedure TTestClassType.TestOneFieldDeprecated;
+procedure TTestClassType.TestOneFieldDeprecated;
 begin
   AddMember('a : integer deprecated');
   ParseClass;
@@ -511,7 +567,7 @@ begin
   AssertVisibility;
 end;
 
-Procedure TTestClassType.TestTwoFields;
+procedure TTestClassType.TestTwoFields;
 begin
   AddMember('a : integer');
   AddMember('b : integer');
@@ -526,7 +582,7 @@ begin
   AssertVisibility(visDefault,Members[1]);
 end;
 
-Procedure TTestClassType.TestTwoFieldsB;
+procedure TTestClassType.TestTwoFieldsB;
 begin
   AddMember('a,b : integer');
   ParseClass;
@@ -540,7 +596,7 @@ begin
   AssertVisibility(visDefault,Members[1]);
 end;
 
-Procedure TTestClassType.TestTwoVarFieldsB;
+procedure TTestClassType.TestTwoVarFieldsB;
 begin
   StartVisibility(visPublic);
   FDecl.Add('var');
@@ -556,7 +612,7 @@ begin
   AssertVisibility(visPublic,Members[1]);
 end;
 
-Procedure TTestClassType.TestTwoFieldsVisibility;
+procedure TTestClassType.TestTwoFieldsVisibility;
 begin
   StartVisibility(visPublic);
   AddMember('a,b : integer');
@@ -571,7 +627,7 @@ begin
   AssertVisibility(visPublic,Members[1]);
 end;
 
-Procedure TTestClassType.TestConstProtectedEnd;
+procedure TTestClassType.TestConstProtectedEnd;
 begin
   // After bug report 25720
    StartVisibility(visPrivate);
@@ -585,7 +641,7 @@ begin
    ParseClass;
 end;
 
-Procedure TTestClassType.TestTypeProtectedEnd;
+procedure TTestClassType.TestTypeProtectedEnd;
 begin
   // After bug report 25720
    StartVisibility(visPrivate);
@@ -599,7 +655,7 @@ begin
    ParseClass;
 end;
 
-Procedure TTestClassType.TestVarProtectedEnd;
+procedure TTestClassType.TestVarProtectedEnd;
 begin
   // After bug report 25720
    StartVisibility(visPrivate);
@@ -655,7 +711,7 @@ begin
   AssertMemberName('unimplemented');
 end;
 
-Procedure TTestClassType.TestMethodSimple;
+procedure TTestClassType.TestMethodSimple;
 begin
   AddMember('Procedure DoSomething');
   ParseClass;
@@ -669,7 +725,7 @@ begin
   AssertEquals('No arguments',0,Method1.ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestMethodSimpleComment;
+procedure TTestClassType.TestMethodSimpleComment;
 begin
   AddComment:=True;
   AddMember('{c} Procedure DoSomething');
@@ -681,7 +737,7 @@ begin
   AssertEquals('Comment','c'+sLineBreak,Method1.DocComment);
 end;
 
-Procedure TTestClassType.TestClassMethodSimple;
+procedure TTestClassType.TestClassMethodSimple;
 begin
   AddMember('Class Procedure DoSomething');
   ParseClass;
@@ -695,7 +751,7 @@ begin
   AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestClassMethodSimpleComment;
+procedure TTestClassType.TestClassMethodSimpleComment;
 begin
   AddComment:=True;
   AddMember('{c} Class Procedure DoSomething');
@@ -703,7 +759,7 @@ begin
   AssertEquals('Comment','c'+sLineBreak,Members[0].DocComment);
 end;
 
-Procedure TTestClassType.TestConstructor;
+procedure TTestClassType.TestConstructor;
 begin
   AddMember('Constructor Create');
   ParseClass;
@@ -717,7 +773,7 @@ begin
   AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestClassConstructor;
+procedure TTestClassType.TestClassConstructor;
 begin
   AddMember('Class Constructor Create');
   ParseClass;
@@ -731,7 +787,7 @@ begin
   AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestDestructor;
+procedure TTestClassType.TestDestructor;
 begin
   AddMember('Destructor Destroy');
   ParseClass;
@@ -745,7 +801,7 @@ begin
   AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestClassDestructor;
+procedure TTestClassType.TestClassDestructor;
 begin
   AddMember('Class Destructor Destroy');
   ParseClass;
@@ -759,7 +815,7 @@ begin
   AssertEquals('No arguments',0,TPasClassProcedure(Members[0]).ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestFunctionMethodSimple;
+procedure TTestClassType.TestFunctionMethodSimple;
 begin
   AddMember('Function DoSomething : integer');
   ParseClass;
@@ -773,7 +829,7 @@ begin
   AssertEquals('No arguments',0,functionMethod1.ProcType.Args.Count)
 end;
 
-Procedure TTestClassType.TestClassFunctionMethodSimple;
+procedure TTestClassType.TestClassFunctionMethodSimple;
 begin
   AddMember('Class Function DoSomething : integer');
   ParseClass;
@@ -799,12 +855,12 @@ begin
   AssertEquals('Argument name','A',TPasVariable(Method1.ProcType.Args[0]).Name);
 end;
 
-Procedure TTestClassType.AssertParserError(Const Msg: String);
+procedure TTestClassType.AssertParserError(const Msg: String);
 begin
   AssertException(Msg,EParserError,@ParseClass)
 end;
 
-Procedure TTestClassType.TestMethodOneArg;
+procedure TTestClassType.TestMethodOneArg;
 begin
   AddMember('Procedure DoSomething(A : Integer)');
   ParseClass;
@@ -814,7 +870,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodVirtual;
+procedure TTestClassType.TestMethodVirtual;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual');
   ParseClass;
@@ -824,7 +880,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodVirtualSemicolon;
+procedure TTestClassType.TestMethodVirtualSemicolon;
 begin
   AddMember('Procedure DoSomething(A : Integer); virtual');
   ParseClass;
@@ -834,7 +890,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodVirtualAbstract;
+procedure TTestClassType.TestMethodVirtualAbstract;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual abstract');
   ParseClass;
@@ -845,7 +901,7 @@ begin
 end;
 
 
-Procedure TTestClassType.TestMethodOverride;
+procedure TTestClassType.TestMethodOverride;
 begin
   AddMember('Procedure DoSomething(A : Integer) override');
   ParseClass;
@@ -885,7 +941,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodVisibility;
+procedure TTestClassType.TestMethodVisibility;
 begin
   StartVisibility(visPublic);
   AddMember('Procedure DoSomething(A : Integer)');
@@ -896,7 +952,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodSVisibility;
+procedure TTestClassType.TestMethodSVisibility;
 begin
   AddMember('Procedure DoSomething(A : Integer)');
   StartVisibility(visPublic);
@@ -914,7 +970,7 @@ begin
   AssertEquals('Argument name','A',TPasVariable(Method2.ProcType.Args[0]).Name);
 end;
 
-Procedure TTestClassType.TestMethodOverloadVisibility;
+procedure TTestClassType.TestMethodOverloadVisibility;
 begin
   AddMember('Procedure DoSomething(A : Integer)');
   StartVisibility(visPublic);
@@ -925,7 +981,7 @@ begin
   AssertEquals('Default visibility',visDefault,Member1.Visibility);
 end;
 
-Procedure TTestClassType.TestMethodHint;
+procedure TTestClassType.TestMethodHint;
 begin
   AddMember('Procedure DoSomething(A : Integer) deprecated');
   ParseClass;
@@ -937,7 +993,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestMethodVirtualHint;
+procedure TTestClassType.TestMethodVirtualHint;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual; deprecated');
   ParseClass;
@@ -949,7 +1005,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, Method1.ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.TestIntegerMessageMethod;
+procedure TTestClassType.TestIntegerMessageMethod;
 begin
   AddMember('Procedure DoSomething(A : Integer) message 123');
   ParseClass;
@@ -960,7 +1016,7 @@ begin
   AssertEquals('Message name','123',Method1.MessageName);
 end;
 
-Procedure TTestClassType.TestStringMessageMethod;
+procedure TTestClassType.TestStringMessageMethod;
 begin
   AddMember('Procedure DoSomething(A : Integer) message ''aha''');
   ParseClass;
@@ -971,7 +1027,7 @@ begin
   AssertEquals('Message name','''aha''',Method1.MessageName);
 end;
 
-Procedure TTestClassType.Test2Methods;
+procedure TTestClassType.Test2Methods;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual');
   AddMember('Procedure DoSomethingElse');
@@ -986,7 +1042,7 @@ begin
   AssertEquals('Default calling convention',ccDefault, TPasProcedure(Members[1]).ProcType.CallingConvention);
 end;
 
-Procedure TTestClassType.Test2MethodsDifferentVisibility;
+procedure TTestClassType.Test2MethodsDifferentVisibility;
 begin
   AddMember('Procedure DoSomething(A : Integer) virtual');
   StartVisibility(visPublic);
@@ -1003,7 +1059,7 @@ begin
 
 end;
 
-Procedure TTestClassType.TestPropertyRedeclare;
+procedure TTestClassType.TestPropertyRedeclare;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something');
@@ -1016,7 +1072,7 @@ begin
   Assertequals('No default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyRedeclareComment;
+procedure TTestClassType.TestPropertyRedeclareComment;
 begin
   StartVisibility(visPublished);
   AddComment:=True;
@@ -1026,7 +1082,7 @@ begin
   AssertEquals('comment','p'+sLineBreak,Property1.DocComment);
 end;
 
-Procedure TTestClassType.TestPropertyRedeclareDefault;
+procedure TTestClassType.TestPropertyRedeclareDefault;
 begin
   StartVisibility(visPublic);
   AddMember('Property Something; default;');
@@ -1041,7 +1097,7 @@ begin
   AssertEquals('Is default property',True, Property1.IsDefault);
 end;
 
-Procedure TTestClassType.TestPropertyReadOnly;
+procedure TTestClassType.TestPropertyReadOnly;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read FSomething');
@@ -1056,7 +1112,7 @@ begin
   Assertequals('No default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyReadWrite;
+procedure TTestClassType.TestPropertyReadWrite;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read FSomething Write FSomething');
@@ -1071,7 +1127,7 @@ begin
   Assertequals('No default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyWriteOnly;
+procedure TTestClassType.TestPropertyWriteOnly;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Write FSomething');
@@ -1086,7 +1142,7 @@ begin
   Assertequals('No default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyDefault;
+procedure TTestClassType.TestPropertyDefault;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read FSomething Write FSomething default 1');
@@ -1101,7 +1157,7 @@ begin
   Assertequals('Default value','1',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyNoDefault;
+procedure TTestClassType.TestPropertyNoDefault;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read FSomething Write FSomething nodefault');
@@ -1116,7 +1172,7 @@ begin
   Assertequals('No Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyIndex;
+procedure TTestClassType.TestPropertyIndex;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Index 2 Read GetF Write SetF');
@@ -1131,7 +1187,7 @@ begin
   Assertequals('No Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyStored;
+procedure TTestClassType.TestPropertyStored;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read GetF Write SetF Stored CheckStored');
@@ -1146,7 +1202,7 @@ begin
   Assertequals('No Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyStoredFalse;
+procedure TTestClassType.TestPropertyStoredFalse;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : integer Read GetF Write SetF Stored False');
@@ -1161,7 +1217,7 @@ begin
   Assertequals('No Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyFullyQualifiedType;
+procedure TTestClassType.TestPropertyFullyQualifiedType;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : unita.typeb Read FSomething');
@@ -1176,7 +1232,7 @@ begin
   Assertequals('No default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyArrayReadOnly;
+procedure TTestClassType.TestPropertyArrayReadOnly;
 Var
   A : TPasArgument;
 begin
@@ -1200,7 +1256,7 @@ begin
   AssertEquals('Argument class type name','Integer',A.ArgType.Name);
 end;
 
-Procedure TTestClassType.TestPropertyArrayReadWrite;
+procedure TTestClassType.TestPropertyArrayReadWrite;
 Var
   A : TPasArgument;
 begin
@@ -1224,7 +1280,7 @@ begin
   AssertEquals('Argument class type name','Integer',A.ArgType.Name);
 end;
 
-Procedure TTestClassType.TestPropertyArrayReadOnlyDefault;
+procedure TTestClassType.TestPropertyArrayReadOnlyDefault;
 
 Var
   A : TPasArgument;
@@ -1249,7 +1305,7 @@ begin
   AssertEquals('Argument class type name','Integer',A.ArgType.Name);
 end;
 
-Procedure TTestClassType.TestPropertyArrayReadWriteDefault;
+procedure TTestClassType.TestPropertyArrayReadWriteDefault;
 Var
   A : TPasArgument;
 begin
@@ -1273,7 +1329,7 @@ begin
   AssertEquals('Argument class type name','Integer',A.ArgType.Name);
 end;
 
-Procedure TTestClassType.TestPropertyArrayMultiDimReadOnly;
+procedure TTestClassType.TestPropertyArrayMultiDimReadOnly;
 Var
   A : TPasArgument;
 begin
@@ -1305,7 +1361,7 @@ begin
   AssertEquals('Argument 2 class type name','Integer',A.ArgType.Name);
 end;
 
-Procedure TTestClassType.TestPropertyImplements;
+procedure TTestClassType.TestPropertyImplements;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : AInterface Read FSomething Implements ISomeInterface');
@@ -1321,7 +1377,7 @@ begin
 
 end;
 
-Procedure TTestClassType.TestPropertyImplementsFullyQualifiedName;
+procedure TTestClassType.TestPropertyImplementsFullyQualifiedName;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : AInterface Read FSomething Implements UnitB.ISomeInterface');
@@ -1336,7 +1392,7 @@ begin
   Assertequals('Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestPropertyReadFromRecordField;
+procedure TTestClassType.TestPropertyReadFromRecordField;
 begin
   StartVisibility(visPublished);
   AddMember('Property Something : Integer Read FPoint.X');
@@ -1366,7 +1422,7 @@ begin
   Assertequals('Default value','',Property1.DefaultValue);
 end;
 
-Procedure TTestClassType.TestLocalSimpleType;
+procedure TTestClassType.TestLocalSimpleType;
 begin
   StartVisibility(visPublic);
   FDecl.add('Type');
@@ -1381,7 +1437,7 @@ begin
   AssertEquals('method name','Something', Method2.Name);
 end;
 
-Procedure TTestClassType.TestLocalSimpleTypes;
+procedure TTestClassType.TestLocalSimpleTypes;
 begin
   StartVisibility(visPublic);
   FDecl.add('Type');
@@ -1401,7 +1457,7 @@ begin
   AssertEquals('method name','Something', Method3.Name);
 end;
 
-Procedure TTestClassType.TestLocalSimpleConst;
+procedure TTestClassType.TestLocalSimpleConst;
 begin
   StartVisibility(visPublic);
   FDecl.add('Const');
@@ -1417,7 +1473,7 @@ begin
   AssertEquals('method name','Something', Method2.Name);
 end;
 
-Procedure TTestClassType.TestLocalSimpleConsts;
+procedure TTestClassType.TestLocalSimpleConsts;
 begin
   StartVisibility(visPublic);
   FDecl.add('Const');

packages/fcl-process/src/simpleipc.pp

@@ -76,6 +76,7 @@ Type
     Procedure CheckActive;
     Procedure Activate; virtual; abstract;
     Procedure Deactivate; virtual; abstract;
+    Procedure Loaded; override;
     Property Busy : Boolean Read FBusy;
   Published
     Property Active : Boolean Read FActive Write SetActive;
@@ -238,24 +239,29 @@ end;
 
 procedure TSimpleIPC.CheckInactive;
 begin
-  If Active then
-    DoError(SErrActive,[]);
+  if not (csLoading in ComponentState) then
+    If Active then
+      DoError(SErrActive,[]);
 end;
 
 procedure TSimpleIPC.CheckActive;
 begin
-  If Not Active then
-    DoError(SErrInActive,[]);
+  if not (csLoading in ComponentState) then
+    If Not Active then
+      DoError(SErrInActive,[]);
 end;
 
 procedure TSimpleIPC.SetActive(const AValue: Boolean);
 begin
   if (FActive<>AValue) then
     begin
-    If AValue then
-      Activate
-    else
-      Deactivate;
+    if (csLoading in ComponentState) then
+      FActive:=AValue
+    else  
+      If AValue then
+        Activate
+      else
+        Deactivate;
     end;
 end;
 
@@ -268,6 +274,20 @@ begin
     end;
 end;
 
+Procedure TSimpleIPC.Loaded; 
+
+Var
+  B : Boolean;
+
+begin
+  B:=FActive;
+  if B then
+    begin
+    Factive:=False;
+    Activate;
+    end;
+end;
+
 { ---------------------------------------------------------------------
     TSimpleIPCServer
   ---------------------------------------------------------------------}
@@ -374,6 +394,9 @@ begin
   StopServer;
 end;
 
+
+
+
 { ---------------------------------------------------------------------
     TSimpleIPCClient
   ---------------------------------------------------------------------}

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

@@ -110,17 +110,13 @@ end;
 
 
 constructor TPipeClientComm.Create(AOWner: TSimpleIPCClient);
-
-Var
-  D : String;
-
 begin
   inherited Create(AOWner);
   FFileName:=Owner.ServerID;
   If (Owner.ServerInstance<>'') then
     FFileName:=FFileName+'-'+Owner.ServerInstance;
-  D:='/tmp/'; // Change to something better later
-  FFileName:=D+FFileName;
+  if FFileName[1]<>'/' then
+    FFileName:=GetTempDir(true)+FFileName;
 end;
 
 
@@ -200,17 +196,13 @@ Type
   end;
 
 constructor TPipeServerComm.Create(AOWner: TSimpleIPCServer);
-
-Var
-  D : String;
-
 begin
   inherited Create(AOWner);
   FFileName:=Owner.ServerID;
   If Not Owner.Global then
     FFileName:=FFileName+'-'+IntToStr(fpGetPID);
-  D:='/tmp/'; // Change to something better later
-  FFileName:=D+FFileName;
+  if FFileName[1]<>'/' then
+    FFileName:=GetTempDir(Owner.Global)+FFileName;
 end;
 
 

packages/fcl-res/src/versionresource.pp

@@ -256,12 +256,18 @@ var block : TVerBlockHeader;
     tmp : integer;
     vinfo : TVerTranslationInfo;
     before : int64;
+    isBlockHeaderRead: boolean;
 begin
   Result:=0;
+  isBlockHeaderRead:=false;
   while toread>0 do
   begin
     before:=RawData.Position;
-    ReadBlockHeader(block);
+    if not isBlockHeaderRead then
+    begin
+      ReadBlockHeader(block);
+      isBlockHeaderRead:=true;
+    end;
     if (block.valtype<>0) or (block.key<>'Translation') then
       RawData.Seek(block.vallength,soFromCurrent)
     else

packages/fcl-xml/src/xmlconf.pp

@@ -32,7 +32,7 @@ uses
   SysUtils, Classes, DOM, XMLRead, XMLWrite;
 
 resourcestring
-  SWrongRootName = 'XML file has wrong root element name';
+  SWrongRootName = 'XML file has wrong root element name: expected "%s" but was "%s"';
 
 type
   EXMLConfigError = class(Exception);
@@ -76,7 +76,10 @@ type
     procedure OpenKey(const aPath: DOMString);
     procedure CloseKey;
     procedure ResetKey;
-    procedure SaveToFile(AFileName: string);
+    procedure SaveToFile(Const AFileName: string);
+    procedure SaveToStream(S : TStream);
+    procedure LoadFromFile(Const AFileName: string);
+    procedure LoadFromStream(S : TStream);
 
     function  GetValue(const APath: DOMString; const ADefault: DOMString): DOMString; overload;
     function  GetValue(const APath: DOMString; ADefault: Integer): Integer; overload;
@@ -130,20 +133,54 @@ end;
 procedure TXMLConfig.Flush;
 begin
   if Modified and not FReadOnly then
-  begin
-    SaveToFile(FFilename)
+    if (FFileName<>'') then
+      SaveToFile(FFilename)
+end;
+
+procedure TXMLConfig.SaveToFile(const AFileName: string);
+
+Var
+  F : TFileStream;
+
+begin
+  F:=TFileStream.Create(AFileName,fmCreate);
+  try
+    SaveToStream(F);
+    FFileName:=AFileName;
+  finally
+    F.Free;
   end;
 end;
 
-procedure TXMLConfig.SaveToFile(AFileName: string);
+procedure TXMLConfig.SaveToStream(S: TStream);
 begin
-  if AFileName <> '' then
-  begin
-    WriteXMLFile(Doc, AFilename);
-    FModified := False;
+  WriteXMLFile(Doc,S);
+  FModified := False;
+end;
+
+procedure TXMLConfig.LoadFromFile(const AFileName: string);
+
+Var
+  F : TFileStream;
+
+begin
+  F:=TFileStream.Create(AFileName,fmOpenread or fmShareDenyWrite);
+  try
+    ReadXMLFile(Doc, AFilename);
+    FFileName:=AFileName;
+  finally
+    F.Free;
   end;
 end;
 
+procedure TXMLConfig.LoadFromStream(S: TStream);
+begin
+  ReadXMLFile(Doc,S);
+  FModified := False;
+  if (Doc.DocumentElement.NodeName<>FRootName) then
+    raise EXMLConfigError.CreateFmt(SWrongRootName,[FRootName,Doc.DocumentElement.NodeName]);
+end;
+
 function TXMLConfig.GetValue(const APath: DOMString; const ADefault: DOMString): DOMString;
 var
   Node: TDOMElement;
@@ -364,24 +401,16 @@ begin
     
   Flush;
   FreeAndNil(Doc);
-    
-  FFilename := AFilename;
-
   if csLoading in ComponentState then
     exit;
-
   if FileExists(AFilename) and not FStartEmpty then
-    ReadXMLFile(Doc, AFilename);
-
-  if not Assigned(Doc) then
+    LoadFromFile(AFilename)
+  else if not Assigned(Doc) then
+    begin
+    FFileName:=AFileName;
     Doc := TXMLDocument.Create;
-
-  if not Assigned(Doc.DocumentElement) then
     Doc.AppendChild(Doc.CreateElement(FRootName))
-  else
-    if Doc.DocumentElement.NodeName <> FRootName then
-      raise EXMLConfigError.Create(SWrongRootName);
-
+    end;
 end;
 
 procedure TXMLConfig.SetFilename(const AFilename: String);

packages/fcl-xml/tests/testxmlconf.lpi

@@ -0,0 +1,64 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<CONFIG>
+  <ProjectOptions>
+    <Version Value="9"/>
+    <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+        <MainUnitHasTitleStatement Value="False"/>
+      </Flags>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <Title Value="testxmlconf"/>
+      <UseAppBundle Value="False"/>
+      <ResourceType Value="res"/>
+    </General>
+    <i18n>
+      <EnableI18N LFM="False"/>
+    </i18n>
+    <VersionInfo>
+      <StringTable ProductVersion=""/>
+    </VersionInfo>
+    <BuildModes Count="1">
+      <Item1 Name="Default" Default="True"/>
+    </BuildModes>
+    <PublishOptions>
+      <Version Value="2"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+      </local>
+    </RunParams>
+    <Units Count="1">
+      <Unit0>
+        <Filename Value="testxmlconf.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="testxmlconf"/>
+      </Unit0>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="11"/>
+    <Target>
+      <Filename Value="testxmlconf"/>
+    </Target>
+    <SearchPaths>
+      <IncludeFiles Value="$(ProjOutDir)"/>
+      <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
+    </SearchPaths>
+  </CompilerOptions>
+  <Debugging>
+    <Exceptions Count="3">
+      <Item1>
+        <Name Value="EAbort"/>
+      </Item1>
+      <Item2>
+        <Name Value="ECodetoolError"/>
+      </Item2>
+      <Item3>
+        <Name Value="EFOpenError"/>
+      </Item3>
+    </Exceptions>
+  </Debugging>
+</CONFIG>

packages/fcl-xml/tests/testxmlconf.lpr

@@ -0,0 +1,31 @@
+program testxmlconf;
+
+uses xmlconf;
+
+begin
+  With TXMLConfig.Create(Nil) do
+  try
+    FileName:='test.xml';
+    OpenKey('General');
+    SetValue('one',1);
+    SetValue('two',2);
+    SetValue('extra/name','michael');
+    Flush;
+  finally
+    Free;
+  end;
+  With TXMLConfig.Create(Nil) do
+  try
+    FileName:='test.xml';
+    OpenKey('General');
+    If GetValue('one',0)<>1 then
+      Writeln('One does not match');
+    If GetValue('two',0)<>2 then
+      Writeln('Two does not match');
+    if GetValue('extra/name','')<>'michael' then
+      Writeln('Name does not match');
+  finally
+    Free;
+  end;
+end.
+

packages/gdbint/src/gdbcon.pp

@@ -32,6 +32,10 @@ type
   PGDBController=^TGDBController;
   TGDBController=object(TGDBInterface)
   private
+    SavedWindowWidth : longint;
+    { width }
+    procedure MaxWidth;
+    procedure NormWidth;
     { print }
     function InternalGetValue(Const expr : string) : AnsiString;
   public
@@ -441,28 +445,11 @@ begin
   SetCommand:=true;
 end;
 
-{ print }
-
-function TrimEnd(s: AnsiString): AnsiString;
-var
-  I: LongInt;
-begin
-  if (s<>'') and (s[Length(s)]=#10) then
-  begin
-    I:=Length(s);
-    while (i>1) and ((s[i-1]=' ') or (s[i-1]=#9)) do
-      dec(i);
-	delete(s,i,Length(s)-i+1);
-  end;
-  TrimEnd:=s;
-end;
+{ width }
 
-function TGDBController.InternalGetValue(Const expr : string) : AnsiString;
+procedure TGDBController.MaxWidth;
 var
   p,p2,p3 : pchar;
-  st : string;
-  WindowWidth : longint;
-  saved_got_error: Boolean;
 begin
   Command('show width');
   p:=GetOutput;
@@ -484,12 +471,49 @@ begin
   p3:=strpos(p,'.');
   if assigned(p3) then
     p3^:=#0;
-  WindowWidth:=-1;
-  val(strpas(p),WindowWidth);
-  if WindowWidth<>-1 then
+  SavedWindowWidth:=-1;
+  val(strpas(p),SavedWindowWidth);
+  if SavedWindowWidth<>-1 then
     Command('set width 0xffffffff');
-  Command('p '+expr);
+end;
+
+procedure TGDBController.NormWidth;
+var
+  st : string;
+  saved_got_error : boolean;
+begin
   saved_got_error:=got_error;
+  if SavedWindowWidth<>-1 then
+    begin
+      str(SavedWindowWidth,st);
+      Command('set width '+St);
+    end;
+  got_error:=saved_got_error;
+end;
+
+{ print }
+
+function TrimEnd(s: AnsiString): AnsiString;
+var
+  I: LongInt;
+begin
+  if (s<>'') and (s[Length(s)]=#10) then
+  begin
+    I:=Length(s);
+    while (i>1) and ((s[i-1]=' ') or (s[i-1]=#9)) do
+      dec(i);
+	delete(s,i,Length(s)-i+1);
+  end;
+  TrimEnd:=s;
+end;
+
+function TGDBController.InternalGetValue(Const expr : string) : AnsiString;
+var
+  p,p2 : pchar;
+begin
+  MaxWidth;
+
+  Command('p '+expr);
   p:=GetOutput;
   if assigned(p) then
     p2:=strpos(p,'=')
@@ -504,16 +528,12 @@ begin
     p:=strpos(p,')')+1;
   while p^ in [' ',#9] do
     inc(p);
-  if assigned(p) and not saved_got_error then
+  if assigned(p) and not got_error then
     InternalGetValue:=TrimEnd(AnsiString(p))
   else
     InternalGetValue:=TrimEnd(AnsiString(GetError));
-  if WindowWidth<>-1 then
-    begin
-      str(WindowWidth,st);
-      Command('set width '+St);
-    end;
-  got_error:=saved_got_error;
+
+  NormWidth;
 end;
 
 
@@ -617,7 +637,9 @@ begin
   { forget all old frames }
   clear_frames;
 
+  MaxWidth;
   Command('backtrace');
+  NormWidth;
 end;
 
 function TGDBController.SelectFrameCommand(level :longint) : boolean;

packages/graph/src/go32v2/graph.pp

@@ -2307,7 +2307,7 @@ End;
 
 
  procedure SetVisual200(page: word); {$ifndef fpc}far;{$endif fpc}
-  { two page supPort... }
+  { four page support... }
   begin
     if page > HardwarePages then exit;
     asm
@@ -2342,12 +2342,13 @@ End;
   end;
 
  procedure SetActive200(page: word); {$ifndef fpc}far;{$endif fpc}
-  { two page supPort... }
+  { four page support... }
   begin
     case page of
      0 : VideoOfs := 0;
      1 : VideoOfs := 16384;
      2 : VideoOfs := 32768;
+     3 : VideoOfs := 49152;
     else
       VideoOfs := 0;
     end;
@@ -3550,6 +3551,7 @@ const CrtAddress: word = 0;
       mode.GetRGBPalette := {$ifdef fpc}@{$endif}GetVESARGBPalette;
       mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisualVESA;
       mode.SetActivePage := {$ifdef fpc}@{$endif}SetActiveVESA;
+      mode.HLine := {$ifdef fpc}@{$endif}HLineVESA32kOr64k;
     end;
 
     procedure FillCommonVESA32k(var mode: TModeInfo);
@@ -3566,11 +3568,14 @@ const CrtAddress: word = 0;
     end;
 
    var
-    HGCDetected : Boolean;
-    CGADetected : Boolean; { TRUE means real CGA, *not* EGA or VGA }
-    EGADetected : Boolean; { TRUE means EGA or higher (VGA) }
-    VGADetected : Boolean;
+    HGCDetected : Boolean = FALSE;
+    CGADetected : Boolean = FALSE; { TRUE means real CGA, *not* EGA or VGA }
+    EGAColorDetected : Boolean = FALSE; { TRUE means true EGA with a color monitor }
+    EGAMonoDetected : Boolean = FALSE; { TRUE means true EGA with a monochrome (MDA) monitor }
+    MCGADetected : Boolean = FALSE;
+    VGADetected : Boolean = FALSE;
     mode: TModeInfo;
+    regs: TDPMIRegisters;
    begin
      QueryAdapterInfo := ModeList;
      { If the mode listing already exists... }
@@ -3579,92 +3584,83 @@ const CrtAddress: word = 0;
      if assigned(ModeList) then
        exit;
 
-
-     HGCDetected := FALSE;
-     CGADetected := FALSE;
-     EGADetected := FALSE;
-     VGADetected := FALSE;
-     { check if EGA adapter supPorted...       }
-     asm
-       mov ah,12h
-       mov bx,0FF10h
-{$ifdef fpc}
-       push ebx
-       push ebp
-       push esi
-       push edi
-{$endif fpc}
-       int 10h              { get EGA information }
-{$ifdef fpc}
-       pop edi
-       pop esi
-       pop ebp
-{$endif fpc}
-       cmp bh,0ffh
-{$ifdef fpc}
-       pop ebx
-{$endif fpc}
-       jz  @noega
-       mov [EGADetected],TRUE
-     @noega:
-     end ['EBX','EAX'];
-{$ifdef logging}
-     LogLn('EGA detected: '+strf(Longint(EGADetected)));
-{$endif logging}
-     { check if VGA adapter supPorted...       }
-     if EGADetected then
+     { check if VGA/MCGA adapter supported...       }
+     regs.ax:=$1a00;
+     RealIntr($10,regs);    { get display combination code...}
+     if regs.al=$1a then
+       begin
+         while regs.bx <> 0 do
+           begin
+             case regs.bl of
+               1: { monochrome adapter (MDA or HGC) }
+                 begin
+                   { check if Hercules adapter supported ... }
+                   HGCDetected:=Test6845($3B4);
+                 end;
+               2: CGADetected:=TRUE;
+               4: EGAColorDetected:=TRUE;
+               5: EGAMonoDetected:=TRUE;
+               {6: PGA, this is rare stuff, how do we handle it? }
+               7, 8: VGADetected:=TRUE;
+               10, 11, 12: MCGADetected:=TRUE;
+             end;
+             { check both primary and secondary display adapter }
+             regs.bx:=regs.bx shr 8;
+           end;
+       end;
+     if VGADetected then
        begin
-        asm
-         mov ax,1a00h
-{$ifdef fpc}
-         push ebp
-         push esi
-         push edi
-         push ebx
-{$endif fpc}
-         int 10h            { get display combination code...}
-{$ifdef fpc}
-         pop ebx
-         pop edi
-         pop esi
-         pop ebp
-{$endif fpc}
-         cmp al,1ah         { check if supPorted...          }
-         jne @novga
          { now check if this is the ATI EGA }
-         mov ax,1c00h       { get state size for save...     }
-                            { ... all imPortant data         }
-         mov cx,07h
-{$ifdef fpc}
-         push ebp
-         push esi
-         push edi
-         push ebx
-{$endif fpc}
-         int 10h
-{$ifdef fpc}
-         pop ebx
-         pop edi
-         pop esi
-         pop ebp
-{$endif fpc}
-         cmp al,1ch         { success?                       }
-         jne @novga
-         mov [VGADetected],TRUE
-        @novga:
-        end ['ECX','EAX'];
+         regs.ax:=$1c00; { get state size for save...     }
+                         { ... all important data         }
+         regs.cx:=$07;
+         RealIntr($10,regs);
+         VGADetected:=regs.al=$1c;
+       end;
+     if not VGADetected and not MCGADetected and
+        not EGAColorDetected and not EGAMonoDetected and
+        not CGADetected and not HGCDetected then
+       begin
+         { check if EGA adapter supported...       }
+         regs.ah:=$12;
+         regs.bx:=$FF10;
+         RealIntr($10,regs);     { get EGA information }
+         if regs.bh<>$FF then
+           case regs.cl of
+             0..3, { primary: MDA/HGC,   secondary: EGA color }
+             6..9: { primary: EGA color, secondary: MDA/HGC (optional) }
+               begin
+                 EGAColorDetected:=TRUE;
+                 { check if Hercules adapter supported ... }
+                 HGCDetected:=Test6845($3B4);
+               end;
+             4..5, { primary: CGA,        secondary: EGA mono }
+             10..11: { primary: EGA mono, secondary: CGA (optional) }
+               begin
+                 EGAMonoDetected:=TRUE;
+                 { check if CGA adapter supported ... }
+                 CGADetected := Test6845($3D4);
+               end;
+           end;
        end;
-{$ifdef logging}
-       LogLn('VGA detected: '+strf(Longint(VGADetected)));
-{$endif logging}
      { older than EGA? }
-     if not EGADetected then
+     if not VGADetected and not MCGADetected and
+        not EGAColorDetected and not EGAMonoDetected and
+        not CGADetected and not HGCDetected then
        begin
-         { check if Hercules adapter supPorted ... }
+         { check if Hercules adapter supported ... }
          HGCDetected := Test6845($3B4);
-         { check if CGA adapter supPorted ... }
+         { check if CGA adapter supported ... }
          CGADetected := Test6845($3D4);
        end;
+{$ifdef logging}
+     LogLn('HGC detected: '+strf(Longint(HGCDetected)));
+     LogLn('CGA detected: '+strf(Longint(CGADetected)));
+     LogLn('EGA color detected: '+strf(Longint(EGAColorDetected)));
+     LogLn('EGA mono detected: '+strf(Longint(EGAMonoDetected)));
+     LogLn('MCGA detected: '+strf(Longint(MCGADetected)));
+     LogLn('VGA detected: '+strf(Longint(VGADetected)));
+{$endif logging}
      if HGCDetected then
        begin
          { HACK:
@@ -3701,7 +3697,7 @@ const CrtAddress: word = 0;
          mode.YAspect := 10000;
          AddMode(mode);
        end;
-     if CGADetected or EGADetected then
+     if CGADetected or EGAColorDetected or MCGADetected or VGADetected then
        begin
          { HACK:
            until we create Save/RestoreStateCGA, we use Save/RestoreStateVGA
@@ -3754,7 +3750,7 @@ const CrtAddress: word = 0;
          AddMode(mode);
        end;
 
-     if EGADetected then
+     if EGAColorDetected or VGADetected then
        begin
          { HACK:
            until we create Save/RestoreStateEGA, we use Save/RestoreStateVGA
@@ -3772,7 +3768,7 @@ const CrtAddress: word = 0;
          mode.ModeName:='640 x 200 EGA';
          mode.MaxX := 639;
          mode.MaxY := 199;
-         mode.HardwarePages := 2;
+         mode.HardwarePages := 3;
          mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisual200;
          mode.SetActivePage := {$ifdef fpc}@{$endif}SetActive200;
          mode.InitMode := {$ifdef fpc}@{$endif}Init640x200x16;
@@ -3796,8 +3792,14 @@ const CrtAddress: word = 0;
          AddMode(mode);
        end;
 
-     if VGADetected then
+     if MCGADetected or VGADetected then
        begin
+         { HACK:
+           until we create Save/RestoreStateEGA, we use Save/RestoreStateVGA
+           with the inWindows flag enabled (so we only save the mode number
+           and nothing else) }
+         if not VGADetected then
+           inWindows := true;
          SaveVideoState := @SaveStateVGA;
 {$ifdef logging}
          LogLn('Setting VGA SaveVideoState to '+strf(longint(SaveVideoState)));
@@ -3896,7 +3898,18 @@ const CrtAddress: word = 0;
          mode.XAspect := 8333;
          mode.YAspect := 10000;
          AddMode(mode);
+       end;
 
+     if VGADetected then
+       begin
+         SaveVideoState := @SaveStateVGA;
+{$ifdef logging}
+         LogLn('Setting VGA SaveVideoState to '+strf(longint(SaveVideoState)));
+{$endif logging}
+         RestoreVideoState := @RestoreStateVGA;
+{$ifdef logging}
+         LogLn('Setting VGA RestoreVideoState to '+strf(longint(RestoreVideoState)));
+{$endif logging}
          { now add all standard VGA modes...       }
          InitMode(mode);
          mode.DriverNumber:= LowRes;
@@ -3928,7 +3941,7 @@ const CrtAddress: word = 0;
          mode.ModeName:='640 x 200 EGA'; { yes, it says 'EGA' even for the VGA driver; this is TP7 compatible }
          mode.MaxX := 639;
          mode.MaxY := 199;
-         mode.HardwarePages := 2;
+         mode.HardwarePages := 3;
          mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisual200;
          mode.SetActivePage := {$ifdef fpc}@{$endif}SetActive200;
          mode.InitMode := {$ifdef fpc}@{$endif}Init640x200x16;

packages/graph/src/go32v2/vesa.inc

@@ -479,14 +479,14 @@ end;
       If ((amount >= 4) and
           ((offs and 3) = 0)) or
          (amount >= 4+4-(offs and 3)) Then
-      { allign target }
+      { align target }
         Begin
           If (offs and 3) <> 0 then
           { this cannot go past a window boundary bacause the }
           { size of a window is always a multiple of 4        }
             Begin
               {$ifdef logging}
-              LogLn('Alligning by reading '+strf(4-(offs and 3))+' pixels');
+              LogLn('Aligning by reading '+strf(4-(offs and 3))+' pixels');
               {$endif logging}
               for l := 1 to 4-(offs and 3) do
                 WordArray(Data)[index+l-1] :=
@@ -498,7 +498,7 @@ end;
           {$ifdef logging}
           LogLn('Offset is now '+hexstr(offs,8)+', amount left: '+strf(amount));
           {$endif logging}
-          { offs is now 4-bytes alligned }
+          { offs is now 4-bytes aligned }
           If amount <= ($10000-(Offs and $ffff)) Then
              bankrest := amount
           else {the rest won't fit anymore in the current window }
@@ -599,24 +599,23 @@ end;
                     (HLength >= 4+4-(offs and 3)) Then
                  { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging2}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] And Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -669,26 +668,25 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] Xor Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -741,22 +739,21 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] Or Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      { it is possible that by aligningm we ended up in a new }
                      { bank, so set the correct bank again to make sure      }
                      setwritebank(offs shr 16);
@@ -764,7 +761,7 @@ end;
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -814,25 +811,24 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] := Byte(Mask);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -1092,7 +1088,6 @@ end;
            (amount > 7+8-(offs and 7))) Then
          Begin
            { align target }
-           l := 0;
            If (offs and 7) <> 0 then
            { this cannot go past a window boundary bacause the }
            { size of a window is always a multiple of 8        }
@@ -1107,13 +1102,13 @@ end;
                    Mem[WinWriteSeg:word(offs)+l-1] := fill.pat[patternPos and 7];
                    inc(patternPos)
                  end;
+               Dec(amount, l);
+               inc(offs, l);
              End;
-           Dec(amount, l);
-           inc(offs, l);
            {$ifdef logging2}
            LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(amount));
            {$endif logging2}
-           { offs is now 8-bytes alligned }
+           { offs is now 8-bytes aligned }
            If amount <= ($10000-(Offs and $ffff)) Then
               bankrest := amount
            else {the rest won't fit anymore in the current window }
@@ -1377,6 +1372,323 @@ end;
      End;
   end;
 
+  procedure HLineVESA32kOr64k(x,x2,y: smallint); {$ifndef fpc}far;{$endif fpc}
+
+   var Offs: Longint;
+       mask, l, bankrest: longint;
+       curbank, hlength: smallint;
+   Begin
+    { must we swap the values? }
+    if x > x2 then
+      Begin
+        x := x xor x2;
+        x2 := x xor x2;
+        x:= x xor x2;
+      end;
+    { First convert to global coordinates }
+    X   := X + StartXViewPort;
+    X2  := X2 + StartXViewPort;
+    Y   := Y + StartYViewPort;
+    if ClipPixels then
+      Begin
+         if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
+                StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
+            exit;
+      end;
+    {$ifdef logging2}
+    LogLn('hline '+strf(x)+' - '+strf(x2)+' on '+strf(y)+' in mode '+strf(currentwritemode));
+    {$endif logging2}
+    HLength := x2 - x + 1;
+    {$ifdef logging2}
+    LogLn('length: '+strf(hlength));
+    {$endif logging2}
+    if HLength>0 then
+      begin
+         Offs:=(Longint(y)+YOffset)*bytesperline+2*x;
+         {$ifdef logging2}
+         LogLn('Offs: '+strf(offs)+' -- '+hexstr(offs,8));
+         {$endif logging2}
+         Mask := longint(word(CurrentColor)+word(CurrentColor) shl 16);
+         Case CurrentWriteMode of
+           AndPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] And Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] And Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] And Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+           XorPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Xor Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] Xor Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Xor Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+           OrPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Or Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] Or Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Or Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End
+           Else
+             Begin
+               If CurrentWriteMode = NotPut Then
+                 Mask := Not(Mask);
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] := Word(Mask);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] := Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] := Word(Mask);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+         End;
+       end;
+   end;
+
 {$ifdef FPC}
  {************************************************************************}
  {*                    15/16bit pixels VESA mode routines  Linear mode   *}

packages/graph/src/msdos/graph.pp

@@ -216,16 +216,16 @@ var
   Offset: Word;
   B, Mask, Shift: Byte;
 begin
-  X:= X + StartXViewPort;
-  Y:= Y + StartYViewPort;
-  { convert to absolute coordinates and then verify clipping...}
+  { verify clipping and then convert to absolute coordinates...}
   if ClipPixels then
   begin
-    if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+    if (X < 0) or (X > ViewWidth) then
       exit;
-    if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+    if (Y < 0) or (Y > ViewHeight) then
       exit;
   end;
+  X:= X + StartXViewPort;
+  Y:= Y + StartYViewPort;
   Offset := (Y shr 2) * 90 + (X shr 3) + VideoOfs;
   case Y and 3 of
     1: Inc(Offset, $2000);
@@ -620,16 +620,16 @@ var
   Offset: Word;
   B, Mask, Shift: Byte;
 begin
-  X:= X + StartXViewPort;
-  Y:= Y + StartYViewPort;
-  { convert to absolute coordinates and then verify clipping...}
+  { verify clipping and then convert to absolute coordinates...}
   if ClipPixels then
   begin
-    if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+    if (X < 0) or (X > ViewWidth) then
       exit;
-    if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+    if (Y < 0) or (Y > ViewHeight) then
       exit;
   end;
+  X:= X + StartXViewPort;
+  Y:= Y + StartYViewPort;
   Offset := (Y shr 1) * 80 + (X shr 2);
   if (Y and 1) <> 0 then
     Inc(Offset, 8192);
@@ -930,16 +930,16 @@ var
   Offset: Word;
   B, Mask, Shift: Byte;
 begin
-  X:= X + StartXViewPort;
-  Y:= Y + StartYViewPort;
-  { convert to absolute coordinates and then verify clipping...}
+  { verify clipping and then convert to absolute coordinates...}
   if ClipPixels then
   begin
-    if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+    if (X < 0) or (X > ViewWidth) then
       exit;
-    if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+    if (Y < 0) or (Y > ViewHeight) then
       exit;
   end;
+  X:= X + StartXViewPort;
+  Y:= Y + StartYViewPort;
   Offset := (Y shr 1) * 80 + (X shr 3);
   if (Y and 1) <> 0 then
     Inc(Offset, 8192);
@@ -1238,16 +1238,16 @@ var
   Offset: Word;
   B, Mask, Shift: Byte;
 begin
-  X:= X + StartXViewPort;
-  Y:= Y + StartYViewPort;
-  { convert to absolute coordinates and then verify clipping...}
+  { verify clipping and then convert to absolute coordinates...}
   if ClipPixels then
   begin
-    if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+    if (X < 0) or (X > ViewWidth) then
       exit;
-    if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+    if (Y < 0) or (Y > ViewHeight) then
       exit;
   end;
+  X:= X + StartXViewPort;
+  Y:= Y + StartYViewPort;
   Offset := Y * 80 + (X shr 3);
   Shift := 7 - (X and 7);
   Mask := 1 shl Shift;
@@ -1548,16 +1548,16 @@ end;
      dummy: byte;
 {$endif asmgraph}
   Begin
+    { verify clipping and then convert to absolute coordinates...}
+    if ClipPixels then
+    begin
+      if (X < 0) or (X > ViewWidth) then
+        exit;
+      if (Y < 0) or (Y > ViewHeight) then
+        exit;
+    end;
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
-    { convert to absolute coordinates and then verify clipping...}
-    if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
-         exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
-         exit;
-     end;
 {$ifndef asmgraph}
      offset := y * 80 + (x shr 3) + VideoOfs;
      PortW[$3ce] := $0f01;       { Index 01 : Enable ops on all 4 planes }
@@ -2261,7 +2261,7 @@ End;
 
 
  procedure SetVisual200(page: word); {$ifndef fpc}far;{$endif fpc}
-  { two page supPort... }
+  { four page support... }
   begin
     if page > HardwarePages then exit;
     asm
@@ -2296,12 +2296,13 @@ End;
   end;
 
  procedure SetActive200(page: word); {$ifndef fpc}far;{$endif fpc}
-  { two page supPort... }
+  { four page support... }
   begin
     case page of
      0 : VideoOfs := 0;
      1 : VideoOfs := 16384;
      2 : VideoOfs := 32768;
+     3 : VideoOfs := 49152;
     else
       VideoOfs := 0;
     end;
@@ -2363,16 +2364,16 @@ End;
  Procedure PutPixel320(X,Y : smallint; Pixel: Word); {$ifndef fpc}far;{$endif fpc}
  { x,y -> must be in local coordinates. Clipping if required. }
   Begin
+    { verify clipping and then convert to absolute coordinates...}
+    if ClipPixels then
+    begin
+      if (X < 0) or (X > ViewWidth) then
+        exit;
+      if (Y < 0) or (Y > ViewHeight) then
+        exit;
+    end;
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
-    { convert to absolute coordinates and then verify clipping...}
-    if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
-         exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
-         exit;
-     end;
     asm
       mov    es, [SegA000]
       mov    ax, [Y]
@@ -2706,16 +2707,16 @@ const CrtAddress: word = 0;
  var offset: word;
 {$endif asmgraph}
   begin
+    { verify clipping and then convert to absolute coordinates...}
+    if ClipPixels then
+    begin
+      if (X < 0) or (X > ViewWidth) then
+        exit;
+      if (Y < 0) or (Y > ViewHeight) then
+        exit;
+    end;
     X:= X + StartXViewPort;
     Y:= Y + StartYViewPort;
-    { convert to absolute coordinates and then verify clipping...}
-    if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
-         exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
-         exit;
-     end;
 {$ifndef asmgraph}
     offset := y * 80 + x shr 2 + VideoOfs;
     PortW[$3c4] := (hi(word(FirstPlane)) shl 8) shl (x and 3)+ lo(word(FirstPlane));
@@ -3230,6 +3231,7 @@ const CrtAddress: word = 0;
       mode.GetRGBPalette := {$ifdef fpc}@{$endif}GetVESARGBPalette;
       mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisualVESA;
       mode.SetActivePage := {$ifdef fpc}@{$endif}SetActiveVESA;
+      mode.HLine := {$ifdef fpc}@{$endif}HLineVESA32kOr64k;
     end;
 
     procedure FillCommonVESA32k(var mode: TModeInfo);
@@ -3246,10 +3248,12 @@ const CrtAddress: word = 0;
     end;
 
    var
-    HGCDetected : Boolean;
-    CGADetected : Boolean; { TRUE means real CGA, *not* EGA or VGA }
-    EGADetected : Boolean; { TRUE means EGA or higher (VGA) }
-    VGADetected : Boolean;
+    HGCDetected : Boolean = FALSE;
+    CGADetected : Boolean = FALSE; { TRUE means real CGA, *not* EGA or VGA }
+    EGAColorDetected : Boolean = FALSE; { TRUE means true EGA with a color monitor }
+    EGAMonoDetected : Boolean = FALSE; { TRUE means true EGA with a monochrome (MDA) monitor }
+    MCGADetected : Boolean = FALSE;
+    VGADetected : Boolean = FALSE;
     mode: TModeInfo;
     regs: Registers;
    begin
@@ -3260,45 +3264,83 @@ const CrtAddress: word = 0;
      if assigned(ModeList) then
        exit;
 
-
-     HGCDetected := FALSE;
-     CGADetected := FALSE;
-     EGADetected := FALSE;
-     VGADetected := FALSE;
-     { check if EGA adapter supPorted...       }
-     regs.ah:=$12;
-     regs.bx:=$FF10;
-     intr($10,regs);     { get EGA information }
-     EGADetected:=regs.bh<>$FF;
-{$ifdef logging}
-     LogLn('EGA detected: '+strf(Longint(EGADetected)));
-{$endif logging}
-     { check if VGA adapter supPorted...       }
-     if EGADetected then
+     { check if VGA/MCGA adapter supported...       }
+     regs.ax:=$1a00;
+     intr($10,regs);    { get display combination code...}
+     if regs.al=$1a then
        begin
-         regs.ax:=$1a00;
-         intr($10,regs);    { get display combination code...}
-         if regs.al=$1a then
+         while regs.bx <> 0 do
            begin
-             { now check if this is the ATI EGA }
-             regs.ax:=$1c00; { get state size for save...     }
-                             { ... all imPortant data         }
-             regs.cx:=$07;
-             intr($10,regs);
-             VGADetected:=regs.al=$1c;
+             case regs.bl of
+               1: { monochrome adapter (MDA or HGC) }
+                 begin
+                   { check if Hercules adapter supported ... }
+                   HGCDetected:=Test6845($3B4);
+                 end;
+               2: CGADetected:=TRUE;
+               4: EGAColorDetected:=TRUE;
+               5: EGAMonoDetected:=TRUE;
+               {6: PGA, this is rare stuff, how do we handle it? }
+               7, 8: VGADetected:=TRUE;
+               10, 11, 12: MCGADetected:=TRUE;
+             end;
+             { check both primary and secondary display adapter }
+             regs.bx:=regs.bx shr 8;
+           end;
+       end;
+     if VGADetected then
+       begin
+         { now check if this is the ATI EGA }
+         regs.ax:=$1c00; { get state size for save...     }
+                         { ... all important data         }
+         regs.cx:=$07;
+         intr($10,regs);
+         VGADetected:=regs.al=$1c;
+       end;
+     if not VGADetected and not MCGADetected and
+        not EGAColorDetected and not EGAMonoDetected and
+        not CGADetected and not HGCDetected then
+       begin
+         { check if EGA adapter supported...       }
+         regs.ah:=$12;
+         regs.bx:=$FF10;
+         intr($10,regs);     { get EGA information }
+         if regs.bh<>$FF then
+           case regs.cl of
+             0..3, { primary: MDA/HGC,   secondary: EGA color }
+             6..9: { primary: EGA color, secondary: MDA/HGC (optional) }
+               begin
+                 EGAColorDetected:=TRUE;
+                 { check if Hercules adapter supported ... }
+                 HGCDetected:=Test6845($3B4);
+               end;
+             4..5, { primary: CGA,        secondary: EGA mono }
+             10..11: { primary: EGA mono, secondary: CGA (optional) }
+               begin
+                 EGAMonoDetected:=TRUE;
+                 { check if CGA adapter supported ... }
+                 CGADetected := Test6845($3D4);
+               end;
            end;
        end;
-{$ifdef logging}
-       LogLn('VGA detected: '+strf(Longint(VGADetected)));
-{$endif logging}
      { older than EGA? }
-     if not EGADetected then
+     if not VGADetected and not MCGADetected and
+        not EGAColorDetected and not EGAMonoDetected and
+        not CGADetected and not HGCDetected then
        begin
-         { check if Hercules adapter supPorted ... }
+         { check if Hercules adapter supported ... }
          HGCDetected := Test6845($3B4);
-         { check if CGA adapter supPorted ... }
+         { check if CGA adapter supported ... }
          CGADetected := Test6845($3D4);
        end;
+{$ifdef logging}
+     LogLn('HGC detected: '+strf(Longint(HGCDetected)));
+     LogLn('CGA detected: '+strf(Longint(CGADetected)));
+     LogLn('EGA color detected: '+strf(Longint(EGAColorDetected)));
+     LogLn('EGA mono detected: '+strf(Longint(EGAMonoDetected)));
+     LogLn('MCGA detected: '+strf(Longint(MCGADetected)));
+     LogLn('VGA detected: '+strf(Longint(VGADetected)));
+{$endif logging}
      if HGCDetected then
        begin
          { HACK:
@@ -3335,7 +3377,7 @@ const CrtAddress: word = 0;
          mode.YAspect := 10000;
          AddMode(mode);
        end;
-     if CGADetected or EGADetected then
+     if CGADetected or EGAColorDetected or MCGADetected or VGADetected then
        begin
          { HACK:
            until we create Save/RestoreStateCGA, we use Save/RestoreStateVGA
@@ -3388,7 +3430,7 @@ const CrtAddress: word = 0;
          AddMode(mode);
        end;
 
-     if EGADetected then
+     if EGAColorDetected or VGADetected then
        begin
          { HACK:
            until we create Save/RestoreStateEGA, we use Save/RestoreStateVGA
@@ -3406,7 +3448,7 @@ const CrtAddress: word = 0;
          mode.ModeName:='640 x 200 EGA';
          mode.MaxX := 639;
          mode.MaxY := 199;
-         mode.HardwarePages := 2;
+         mode.HardwarePages := 3;
          mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisual200;
          mode.SetActivePage := {$ifdef fpc}@{$endif}SetActive200;
          mode.InitMode := {$ifdef fpc}@{$endif}Init640x200x16;
@@ -3430,8 +3472,14 @@ const CrtAddress: word = 0;
          AddMode(mode);
        end;
 
-     if VGADetected then
+     if MCGADetected or VGADetected then
        begin
+         { HACK:
+           until we create Save/RestoreStateEGA, we use Save/RestoreStateVGA
+           with the inWindows flag enabled (so we only save the mode number
+           and nothing else) }
+         if not VGADetected then
+           inWindows := true;
          SaveVideoState := @SaveStateVGA;
 {$ifdef logging}
          LogLn('Setting VGA SaveVideoState to '+strf(longint(SaveVideoState)));
@@ -3530,7 +3578,18 @@ const CrtAddress: word = 0;
          mode.XAspect := 8333;
          mode.YAspect := 10000;
          AddMode(mode);
+       end;
 
+     if VGADetected then
+       begin
+         SaveVideoState := @SaveStateVGA;
+{$ifdef logging}
+         LogLn('Setting VGA SaveVideoState to '+strf(longint(SaveVideoState)));
+{$endif logging}
+         RestoreVideoState := @RestoreStateVGA;
+{$ifdef logging}
+         LogLn('Setting VGA RestoreVideoState to '+strf(longint(RestoreVideoState)));
+{$endif logging}
          { now add all standard VGA modes...       }
          InitMode(mode);
          mode.DriverNumber:= LowRes;
@@ -3562,7 +3621,7 @@ const CrtAddress: word = 0;
          mode.ModeName:='640 x 200 EGA'; { yes, it says 'EGA' even for the VGA driver; this is TP7 compatible }
          mode.MaxX := 639;
          mode.MaxY := 199;
-         mode.HardwarePages := 2;
+         mode.HardwarePages := 3;
          mode.SetVisualPage := {$ifdef fpc}@{$endif}SetVisual200;
          mode.SetActivePage := {$ifdef fpc}@{$endif}SetActive200;
          mode.InitMode := {$ifdef fpc}@{$endif}Init640x200x16;

packages/graph/src/msdos/vesa.inc

@@ -221,16 +221,16 @@ end;
   var
      offs : longint;
   begin
-     X:= X + StartXViewPort;
-     Y:= Y + StartYViewPort;
-     { convert to absolute coordinates and then verify clipping...}
+     { verify clipping and then convert to absolute coordinates...}
      if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+     begin
+       if (X < 0) or (X > ViewWidth) then
          exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+       if (Y < 0) or (Y > ViewHeight) then
          exit;
      end;
+     X:= X + StartXViewPort;
+     Y:= Y + StartYViewPort;
      Y := Y + YOffset; { adjust pixel for correct virtual page }
      offs := longint(y) * BytesPerLine + x;
        begin
@@ -305,14 +305,14 @@ end;
       If ((amount >= 4) and
           ((offs and 3) = 0)) or
          (amount >= 4+4-(offs and 3)) Then
-      { allign target }
+      { align target }
         Begin
           If (offs and 3) <> 0 then
           { this cannot go past a window boundary bacause the }
           { size of a window is always a multiple of 4        }
             Begin
               {$ifdef logging}
-              LogLn('Alligning by reading '+strf(4-(offs and 3))+' pixels');
+              LogLn('Aligning by reading '+strf(4-(offs and 3))+' pixels');
               {$endif logging}
               for l := 1 to 4-(offs and 3) do
                 WordArray(Data)[index+l-1] :=
@@ -324,7 +324,7 @@ end;
           {$ifdef logging}
           LogLn('Offset is now '+hexstr(offs,8)+', amount left: '+strf(amount));
           {$endif logging}
-          { offs is now 4-bytes alligned }
+          { offs is now 4-bytes aligned }
           If amount <= ($10000-(Offs and $ffff)) Then
              bankrest := amount
           else {the rest won't fit anymore in the current window }
@@ -425,24 +425,23 @@ end;
                     (HLength >= 4+4-(offs and 3)) Then
                  { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging2}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] And Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -495,26 +494,25 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] Xor Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -567,22 +565,21 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] :=
                              Mem[WinReadSeg:word(offs)+l-1] Or Byte(CurrentColor);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      { it is possible that by aligningm we ended up in a new }
                      { bank, so set the correct bank again to make sure      }
                      setwritebank(offs shr 16);
@@ -590,7 +587,7 @@ end;
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -640,25 +637,24 @@ end;
                  If ((HLength >= 4) and
                      ((offs and 3) = 0)) or
                     (HLength >= 4+4-(offs and 3)) Then
-                 { allign target }
+                 { align target }
                    Begin
-                     l := 0;
                      If (offs and 3) <> 0 then
                      { this cannot go past a window boundary bacause the }
                      { size of a window is always a multiple of 4        }
                        Begin
                          {$ifdef logging2}
-                         LogLn('Alligning by drawing '+strf(4-(offs and 3))+' pixels');
+                         LogLn('Aligning by drawing '+strf(4-(offs and 3))+' pixels');
                          {$endif logging}
                          for l := 1 to 4-(offs and 3) do
                            Mem[WinWriteSeg:word(offs)+l-1] := Byte(Mask);
+                         Dec(HLength, l);
+                         inc(offs, l);
                        End;
-                     Dec(HLength, l);
-                     inc(offs, l);
                      {$ifdef logging2}
                      LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
                      {$endif logging}
-                     { offs is now 4-bytes alligned }
+                     { offs is now 4-bytes aligned }
                      If HLength <= ($10000-(Offs and $ffff)) Then
                         bankrest := HLength
                      else {the rest won't fit anymore in the current window }
@@ -918,7 +914,6 @@ end;
            (amount > 7+8-(offs and 7))) Then
          Begin
            { align target }
-           l := 0;
            If (offs and 7) <> 0 then
            { this cannot go past a window boundary bacause the }
            { size of a window is always a multiple of 8        }
@@ -933,13 +928,13 @@ end;
                    Mem[WinWriteSeg:word(offs)+l-1] := fill.pat[patternPos and 7];
                    inc(patternPos)
                  end;
+               Dec(amount, l);
+               inc(offs, l);
              End;
-           Dec(amount, l);
-           inc(offs, l);
            {$ifdef logging2}
            LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(amount));
            {$endif logging2}
-           { offs is now 8-bytes alligned }
+           { offs is now 8-bytes aligned }
            If amount <= ($10000-(Offs and $ffff)) Then
               bankrest := amount
            else {the rest won't fit anymore in the current window }
@@ -998,16 +993,16 @@ end;
 {$ifdef logging}
      logln('putpixvesa32kor64k('+strf(x)+','+strf(y)+')');
 {$endif logging}
-     X:= X + StartXViewPort;
-     Y:= Y + StartYViewPort;
-     { convert to absolute coordinates and then verify clipping...}
+     { verify clipping and then convert to absolute coordinates...}
      if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+     begin
+       if (X < 0) or (X > ViewWidth) then
          exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+       if (Y < 0) or (Y > ViewHeight) then
          exit;
      end;
+     X:= X + StartXViewPort;
+     Y:= Y + StartYViewPort;
      Y := Y + YOffset; { adjust pixel for correct virtual page }
      offs := longint(y) * BytesPerLine + 2*x;
      bank := offs div 65536;
@@ -1076,6 +1071,323 @@ end;
      End;
   end;
 
+  procedure HLineVESA32kOr64k(x,x2,y: smallint); {$ifndef fpc}far;{$endif fpc}
+
+   var Offs: Longint;
+       mask, l, bankrest: longint;
+       curbank, hlength: smallint;
+   Begin
+    { must we swap the values? }
+    if x > x2 then
+      Begin
+        x := x xor x2;
+        x2 := x xor x2;
+        x:= x xor x2;
+      end;
+    { First convert to global coordinates }
+    X   := X + StartXViewPort;
+    X2  := X2 + StartXViewPort;
+    Y   := Y + StartYViewPort;
+    if ClipPixels then
+      Begin
+         if LineClipped(x,y,x2,y,StartXViewPort,StartYViewPort,
+                StartXViewPort+ViewWidth, StartYViewPort+ViewHeight) then
+            exit;
+      end;
+    {$ifdef logging2}
+    LogLn('hline '+strf(x)+' - '+strf(x2)+' on '+strf(y)+' in mode '+strf(currentwritemode));
+    {$endif logging2}
+    HLength := x2 - x + 1;
+    {$ifdef logging2}
+    LogLn('length: '+strf(hlength));
+    {$endif logging2}
+    if HLength>0 then
+      begin
+         Offs:=(Longint(y)+YOffset)*bytesperline+2*x;
+         {$ifdef logging2}
+         LogLn('Offs: '+strf(offs)+' -- '+hexstr(offs,8));
+         {$endif logging2}
+         Mask := longint(word(CurrentColor))+(longint(word(CurrentColor)) shl 16);
+         Case CurrentWriteMode of
+           AndPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] And Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] And Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] And Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+           XorPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Xor Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] Xor Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Xor Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+           OrPut:
+             Begin
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Or Word(CurrentColor);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] :=
+                         MemL[WinReadSeg:word(offs)+l*4] Or Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] :=
+                           MemW[WinReadSeg:word(offs)] Or Word(currentColor);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End
+           Else
+             Begin
+               If CurrentWriteMode = NotPut Then
+                 Mask := Not(Mask);
+               Repeat
+                 curbank := smallint(offs shr 16);
+                 SetWriteBank(curbank);
+                 SetReadBank(curbank);
+                 {$ifdef logging2}
+                 LogLn('set bank '+strf(curbank)+' for offset '+hexstr(offs,8));
+                 {$endif logging2}
+                 If ((HLength >= 2) and
+                     ((offs and 3) = 0)) or
+                    (HLength >= 3) Then
+                 { align target }
+                   Begin
+                     If (offs and 3) <> 0 then
+                     { this cannot go past a window boundary because the }
+                     { size of a window is always a multiple of 4        }
+                       Begin
+                         {$ifdef logging2}
+                         LogLn('Aligning by drawing 1 pixel');
+                         {$endif logging2}
+                         MemW[WinWriteSeg:word(offs)] := Word(Mask);
+                         Dec(HLength);
+                         inc(offs, 2);
+                       End;
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                     { offs is now 4-bytes aligned }
+                     If HLength <= (($10000-(Offs and $ffff)) shr 1) Then
+                        bankrest := HLength
+                     else {the rest won't fit anymore in the current window }
+                       bankrest := ($10000 - (Offs and $ffff)) shr 1;
+                     { it is possible that by aligningm we ended up in a new }
+                     { bank, so set the correct bank again to make sure      }
+                     setwritebank(offs shr 16);
+                     setreadbank(offs shr 16);
+                     {$ifdef logging2}
+                     LogLn('Rest to be drawn in this window: '+strf(bankrest));
+                     {$endif logging}
+                     For l := 0 to (Bankrest div 2)-1 Do
+                       MemL[WinWriteSeg:word(offs)+l*4] := Mask;
+                     inc(offs,l*4+4);
+                     dec(hlength,l*2+2);
+                     {$ifdef logging2}
+                     LogLn('Offset is now '+hexstr(offs,8)+', length left: '+strf(hlength));
+                     {$endif logging}
+                   End
+                 Else
+                   Begin
+                     {$ifdef logging2}
+                     LogLn('Drawing leftover: '+strf(HLength)+' at offset '+hexstr(offs,8));
+                     {$endif logging}
+                     if HLength > 0 then
+                       begin
+                         { this may cross a bank at any time, so adjust          }
+                         { because this loop always runs for very little pixels, }
+                         { there's little gained by splitting it up              }
+                         setreadbank(offs shr 16);
+                         setwritebank(offs shr 16);
+                         MemW[WinWriteSeg:word(offs)] := Word(Mask);
+                         HLength := 0
+                       end;
+                   End
+               Until HLength = 0;
+             End;
+         End;
+       end;
+   end;
+
 
  {************************************************************************}
  {*                     4-bit pixels VESA mode routines                  *}
@@ -1086,16 +1398,16 @@ end;
      offs : longint;
      dummy : byte;
   begin
-     X:= X + StartXViewPort;
-     Y:= Y + StartYViewPort;
-     { convert to absolute coordinates and then verify clipping...}
-    if ClipPixels then
-     Begin
-       if (X < StartXViewPort) or (X > (StartXViewPort + ViewWidth)) then
+     { verify clipping and then convert to absolute coordinates...}
+     if ClipPixels then
+     begin
+       if (X < 0) or (X > ViewWidth) then
          exit;
-       if (Y < StartYViewPort) or (Y > (StartYViewPort + ViewHeight)) then
+       if (Y < 0) or (Y > ViewHeight) then
          exit;
      end;
+     X:= X + StartXViewPort;
+     Y:= Y + StartYViewPort;
      Y := Y + YOffset; { adjust pixel for correct virtual page }
      { }
      offs := longint(y) * BytesPerLine + (x div 8);

packages/graph/src/ptcgraph/ptcgraph.pp

@@ -725,7 +725,7 @@ end;
 
 procedure ptc_Init640x200x16;
 begin
-  ptc_InitMode16_CGAEmu(640, 200, 3);
+  ptc_InitMode16_CGAEmu(640, 200, 4);
 end;
 
 procedure ptc_Init640x350x16;
@@ -1827,7 +1827,7 @@ end;
      begin
        ModeNumber:=EGALo;
        DriverNumber := EGA;
-       HardwarePages := 2;
+       HardwarePages := 3;
        ModeName:='640 x 200 EGA';
        MaxColor := 16;
        DirectColor := FALSE;
@@ -1887,7 +1887,7 @@ end;
      begin
        ModeNumber:=VGALo;
        DriverNumber := VGA;
-       HardwarePages := 2;
+       HardwarePages := 3;
        ModeName:='640 x 200 EGA';
        MaxColor := 16;
        DirectColor := FALSE;
@@ -2541,7 +2541,7 @@ end;
 
        InitMode(graphmode);
        with graphmode do
-       begin  
+       begin
          ModeNumber := m1280x1024x64k;
          DriverNumber := VESA;
          HardwarePages := 1;

packages/ncurses/examples/t1panel.pp

@@ -76,8 +76,8 @@ begin
     wins[i] := newwin(NLINES, NCOLS, y, x);
     FmtStr(lab, 'Window Number %d', [i + 1]);
     win_show(wins[i], lab, i + 1);
-    y += 3;
-    x += 7;
+    Inc(y,3);
+    Inc(x,7);
   end
 end;
 

packages/ncurses/examples/t2form.pp

@@ -3,18 +3,26 @@ program form_test_2;
 {$MODE OBJFPC}
 
 uses
-  ncurses, form, libc;
+  ncurses, form;
 
 
+{$linklib c}
+procedure setlocale(cat : integer; p : pchar); cdecl; external 'c';
+
+
+const
+  LC_ALL = 6;
+
 var
   my_bg: Smallint = COLOR_BLACK;
-
   field: array[0..5] of PFIELD;
   my_form: PFORM;
   i, ch: Longint;
+
 begin
 
-try
+  try
+
   setlocale(LC_ALL, ''); { Tested with Russian UTF-8 locale }
 
   (* Initialize curses *)

packages/ncurses/examples/t2menu.pp

@@ -20,7 +20,7 @@ var
 begin
   FmtStr(tstr, fmt, args);
   getmaxyx(win, my, mx);
-  mx -= startx;
+  dec(mx,startx);
 
   if (width > length(tstr)) OR  (width < 2) then
     width := length(tstr);

packages/ncurses/examples/t3form.pp

@@ -6,8 +6,14 @@ program form_test_3;
 {$MODE OBJFPC}
 
 uses
-  ncurses, form, libc;
+  ncurses, form;
 
+{$linklib c}
+procedure setlocale(cat : integer; p : pchar); cdecl; external 'c';
+
+
+const
+  LC_ALL = 6;
 
 
 function st_middle(scrlen, itemlen: Smallint): Smallint; inline;

packages/ncurses/examples/tclock.pp

@@ -2,7 +2,14 @@ program tclock;
 {$MODE OBJFPC}
 
 uses
-  libc, ncurses, sysutils;
+  ncurses, sysutils;
+
+{$linklib c}
+procedure setlocale(cat : integer; p : pchar); cdecl; external 'c';
+
+
+const
+  LC_ALL = 6;
 
 const
   ASPECT = 2.2;

packages/ncurses/examples/tnlshello.pp

@@ -8,7 +8,15 @@ program nlshello;
 {$mode objfpc}
 
 uses
-  gettext, libc, ncurses;
+  gettext, ncurses;
+
+{$linklib c}
+procedure setlocale(cat : integer; p : pchar); cdecl; external 'c';
+
+
+const
+  LC_ALL = 6;
+
 
 resourcestring
   hello_world = 'Hello world!';

packages/ncurses/src/ncurses.pp

@@ -1,4 +1,4 @@
-{ 
+{
   Interface to the ncurses library. Original ncurses library copyright:
 
 ****************************************************************************
@@ -8,13 +8,13 @@
  * copy of this software and associated documentation files (the            *
  * "Software"), to deal in the Software without restriction, including      *
  * without limitation the rights to use, copy, modify, merge, publish,      *
- * distribute, distribute with modifications, sublicense, and/or sell       *  
+ * distribute, distribute with modifications, sublicense, and/or sell       *
  * copies of the Software, and to permit persons to whom the Software is    *
  * furnished to do so, subject to the following conditions:                 *
  *                                                                          *
  * The above copyright notice and this permission notice shall be included  *
  * in all copies or substantial portions of the Software.                   *
- *                                                                          * 
+ *                                                                          *
  * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  *
  * OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               *
  * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   *
@@ -24,7 +24,7 @@
  * THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               *
  *                                                                          *
  * Except as contained in this notice, the name(s) of the above copyright   *
- * holders shall not be used in advertising or otherwise to promote the     *  
+ * holders shall not be used in advertising or otherwise to promote the     *
  * sale, use or other dealings in this Software without prior written       *
  * authorization.                                                           *
  ****************************************************************************}
@@ -35,6 +35,9 @@
 unit ncurses;
 interface
 
+uses
+  unixtype;
+
 {$PACKRECORDS C}
 {$LINKLIB ncursesw}
 {$LINKLIB c} // should be uses initc ?
@@ -52,10 +55,6 @@ type
    Bool = Byte;
 {$ENDIF USE_FPC_BYTEBOOL}
 
-type
-   wchar_t = Widechar;
-   pwchar_t = ^wchar_t;
-
 const
 {$IFDEF USE_FPC_BYTEBOOL}
    NC_FPC_TRUE  = true;
@@ -74,18 +73,18 @@ const
 
 type
    pchtype = ^chtype;
-   chtype  = Longint; {longword}
+   chtype  = culong;
    pmmask_t = ^mmask_t;
-   mmask_t  = Longint; {longword}
+   mmask_t  = culong;
 
 { colors  }
 var
 {$IFNDEF darwin}
-   COLORS : Longint cvar; external;
-   COLOR_PAIRS : Longint cvar; external;
+   COLORS : cint cvar; external;
+   COLOR_PAIRS : cint cvar; external;
 {$ELSE darwin}
-   COLORS : Longint external libncurses name 'COLORS';
-   COLOR_PAIRS : Longint external libncurses name 'COLOR_PAIRS';
+   COLORS : cint external libncurses name 'COLORS';
+   COLOR_PAIRS : cint external libncurses name 'COLOR_PAIRS';
 {$ENDIF darwin}
 
 const
@@ -205,7 +204,7 @@ type
      attr : attr_t;
      chars : array[0..CCHARW_MAX - 1] of wchar_t;
 {$IFDEF NCURSES_EXT_COLORS}
-     ext_color : Longint;  { color pair, must be more than 16-bits }
+     ext_color : cint;  { color pair, must be more than 16-bits }
 {$ENDIF NCURSES_EXT_COLORS}
    end;
 
@@ -237,14 +236,14 @@ type
      _immed : Bool;               { window in immed mode? (not yet used)  }
      _sync : Bool;                { window in sync mode?  }
      _use_keypad : Bool;          { process function keys into KEY_ symbols?  }
-     _delay : Longint;            { 0 = nodelay, <0 = blocking, >0 = delay  }
+     _delay : cint;               { 0 = nodelay, <0 = blocking, >0 = delay  }
      _line : ^ldat;               { the actual line data  }
 { global screen state  }
      _regtop : Smallint;          { top line of scrolling region  }
      _regbottom : Smallint;       { bottom line of scrolling region  }
 { these are used only if this is a sub-window  }
-     _parx : Longint;             { x coordinate of this window in parent  }
-     _pary : Longint;             { y coordinate of this window in parent  }
+     _parx : cint;                { x coordinate of this window in parent  }
+     _pary : cint;                { y coordinate of this window in parent  }
      _parent : PWINDOW;           { pointer to parent if a sub-window  }
 { these are used only if this is a pad  }
      _pad : record
@@ -258,7 +257,7 @@ type
         _yoffset : Smallint;     { real begy is _begy + _yoffset  }
         _bkgrnd : cchar_t;       { current background char/attribute pair  }
 {$IFDEF NCURSES_EXT_COLORS}
-     _color : Longint;           { current color-pair for non-space character }
+     _color : cint;              { current color-pair for non-space character }
 {$ENDIF NCURSES_EXT_COLORS}
      end;
 
@@ -429,7 +428,7 @@ function wattr_on(_para1:PWINDOW; _para2:attr_t; _para3:Pointer):Longint; cdecl;
 function wattr_off(_para1:PWINDOW; _para2:attr_t; _para3:Pointer):Longint; cdecl;external libncurses;
 function wbkgd(_para1:PWINDOW; _para2:chtype):Longint; cdecl;external libncurses;
 procedure wbkgdset(_para1:PWINDOW; _para2:chtype);cdecl;external libncurses;
-function wborder(_para1:PWINDOW; _para2:chtype; _para3:chtype; _para4:chtype; _para5:chtype; 
+function wborder(_para1:PWINDOW; _para2:chtype; _para3:chtype; _para4:chtype; _para5:chtype;
            _para6:chtype; _para7:chtype; _para8:chtype; _para9:chtype):Longint; cdecl;external libncurses;
 function wchgat(_para1:PWINDOW; _para2:Longint; _para3:attr_t; _para4:Smallint; _para5:Pointer):Longint; cdecl;external libncurses;
 function wclear(_para1:PWINDOW):Longint; cdecl;external libncurses;
@@ -502,7 +501,7 @@ function wadd_wchnstr(_para1:PWINDOW; _para2:Pcchar_t; _para3:Longint):longint;
 function waddnwstr(_para1:PWINDOW; _para2:Pwchar_t; _para3:Longint):longint; cdecl;external libncurses;
 function wbkgrnd(_para1:PWINDOW; _para2:Pcchar_t):longint; cdecl;external libncurses;
 procedure wbkgrndset(_para1:PWINDOW; _para2:Pcchar_t);cdecl;external  libncurses;
-function wborder_set(_para1:PWINDOW; _para2:Pcchar_t; _para3:Pcchar_t; _para4:Pcchar_t; _para5:Pcchar_t; 
+function wborder_set(_para1:PWINDOW; _para2:Pcchar_t; _para3:Pcchar_t; _para4:Pcchar_t; _para5:Pcchar_t;
            _para6:Pcchar_t; _para7:Pcchar_t; _para8:Pcchar_t; _para9:Pcchar_t):longint; cdecl;external libncurses;
 function wecho_wchar(_para1:PWINDOW; _para2:Pcchar_t):longint; cdecl;external libncurses;
 function wget_wch(_para1:PWINDOW; _para2:PLongint):longint; cdecl;external libncurses;
@@ -558,7 +557,7 @@ const
    WA_TOP = A_TOP;
    WA_VERTICAL = A_VERTICAL;
 
-function COLOR_PAIR(n: longint): longint; inline;
+function COLOR_PAIR(n: cint): cint; inline;
 function PAIR_NUMBER(attr: attr_t): longint; inline;
 function color_set(color_pair_number: Smallint; opts: Pointer): longint; inline;
 

packages/winunits-base/src/imm.pas

@@ -314,17 +314,17 @@ function ImmReleaseContext(wnd: HWND; imc: HIMC): LongBool; stdcall; external Im
 function ImmAssociateContext(wnd: HWND; imc: HIMC): HIMC; stdcall; external Imm name 'ImmAssociateContext';
 
 function ImmAssociateContextEx(wnd: HWND; imc: HIMC; dwFlags: DWORD): LongBool; stdcall; external Imm name 'ImmAssociateContextEx';
-function ImmGetCompositionStringA(imc: HIMC; dwIndex: DWORD;
+function ImmGetCompositionStringA(imc: HIMC; dwIndex: LONG;
     lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall; external Imm name 'ImmGetCompositionStringA';
-function ImmGetCompositionStringW(imc: HIMC; dwIndex: DWORD;
+function ImmGetCompositionStringW(imc: HIMC; dwIndex: LONG;
     lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall; external Imm name 'ImmGetCompositionStringW';
 
 {$ifndef UNICODE}
 function ImmGetCompositionString(imc: HIMC; dwIndex: DWORD;
-    lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall; external Imm name 'ImmGetCompositionStringA';
+    lpBuf: LPVOID; dwBufLen: DWORD): LONG; stdcall; external Imm name 'ImmGetCompositionStringA';
 {$else}
 function ImmGetCompositionString(imc: HIMC; dwIndex: DWORD;
-    lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall; external Imm name 'ImmGetCompositionStringW';
+    lpBuf: LPVOID; dwBufLen: DWORD): LONG; stdcall; external Imm name 'ImmGetCompositionStringW';
 {$endif}
 
 function ImmSetCompositionStringA(imc: HIMC; dwIndex: DWORD; lpComp: LPVOID;

packages/winunits-base/src/imm_dyn.pas

@@ -45,9 +45,9 @@ var
 
   ImmAssociateContextEx: function (wnd: HWND; imc: HIMC; dwFlags: DWORD): LongBool; stdcall = nil;
   ImmGetCompositionStringA: function (imc: HIMC; dwIndex: DWORD;
-    lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall = nil;
+    lpBuf: LPVOID; dwBufLen: DWORD): LONG; stdcall = nil;
   ImmGetCompositionStringW: function (imc: HIMC; dwIndex: DWORD;
-    lpBuf: LPVOID; dwBufLen: DWORD): Longword; stdcall = nil;
+    lpBuf: LPVOID; dwBufLen: DWORD): LONG; stdcall = nil;
 
   ImmSetCompositionStringA: function (imc: HIMC; dwIndex: DWORD; lpComp: LPVOID;
     dwCompLen: DWORD; lpRead: LPVOID; dwReadLen: DWORD): LongBool; stdcall = nil;

rtl/arm/arm.inc

@@ -534,11 +534,11 @@ asm
 {$endif}
   stmfd   sp!, {r1, lr}
   sub     r0, r1, #8
-{$if defined(CPUARM_HAS_BX) and not(defined(WINCE))}
+{$if defined(CPUARM_HAS_BLX_LABEL) and not(defined(WINCE))}
   blx     InterLockedDecrement
-{$else defined(CPUARM_HAS_BX) and not(defined(WINCE))}
+{$else defined(CPUARM_HAS_BLX_LABEL) and not(defined(WINCE))}
   bl      InterLockedDecrement
-{$endif defined(CPUARM_HAS_BX) and not(defined(WINCE))}
+{$endif defined(CPUARM_HAS_BLX_LABEL) and not(defined(WINCE))}
   // InterLockedDecrement is a nice guy and sets the z flag for us
   // if the reference count dropped to 0
   ldmnefd sp!, {r1, pc}

rtl/embedded/Makefile

@@ -1,5 +1,5 @@
 #
-# Don't edit, this file is generated by FPCMake Version 2.0.0 [2015-01-04 rev 29399]
+# Don't edit, this file is generated by FPCMake Version 2.0.0 [2015-02-24 rev 29972]
 #
 default: all
 MAKEFILETARGETS=i386-linux i386-go32v2 i386-win32 i386-os2 i386-freebsd i386-beos i386-haiku i386-netbsd i386-solaris i386-qnx i386-netware i386-openbsd i386-wdosx i386-darwin i386-emx i386-watcom i386-netwlibc i386-wince i386-embedded i386-symbian i386-nativent i386-iphonesim i386-android i386-aros m68k-linux m68k-freebsd m68k-netbsd m68k-amiga m68k-atari m68k-openbsd m68k-palmos m68k-embedded powerpc-linux powerpc-netbsd powerpc-amiga powerpc-macos powerpc-darwin powerpc-morphos powerpc-embedded powerpc-wii powerpc-aix sparc-linux sparc-netbsd sparc-solaris sparc-embedded x86_64-linux x86_64-freebsd x86_64-netbsd x86_64-solaris x86_64-openbsd x86_64-darwin x86_64-win64 x86_64-embedded x86_64-iphonesim x86_64-dragonfly arm-linux arm-palmos arm-darwin arm-wince arm-gba arm-nds arm-embedded arm-symbian arm-android powerpc64-linux powerpc64-darwin powerpc64-embedded powerpc64-aix avr-embedded armeb-linux armeb-embedded mips-linux mipsel-linux mipsel-embedded mipsel-android jvm-java jvm-android i8086-msdos aarch64-darwin
@@ -383,241 +383,241 @@ endif
 OBJPASDIR=$(RTL)/objpas
 GRAPHDIR=$(INC)/graph
 ifeq ($(FULL_TARGET),i386-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-go32v2)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-win32)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-os2)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-freebsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-beos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-haiku)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-netbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-solaris)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-qnx)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-netware)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-openbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-wdosx)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-emx)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-watcom)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-netwlibc)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-wince)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-symbian)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-nativent)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-iphonesim)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-android)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-aros)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-freebsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-netbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-amiga)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-atari)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-openbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-palmos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),m68k-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-netbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-amiga)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-macos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-morphos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-wii)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc-aix)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),sparc-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),sparc-netbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),sparc-solaris)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),sparc-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-freebsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-netbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-solaris)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-openbsd)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-win64)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-iphonesim)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),x86_64-dragonfly)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-palmos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-wince)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-gba)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-nds)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-symbian)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),arm-android)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc64-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc64-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc64-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),powerpc64-aix)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),avr-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),armeb-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),armeb-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),mips-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),mipsel-linux)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),mipsel-embedded)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),mipsel-android)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),jvm-java)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),jvm-android)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i8086-msdos)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),aarch64-darwin)
-override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+override TARGET_UNITS+=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) dos sysutils classes math typinfo ctypes charset cpall getopts types rtlconsts sysconst lineinfo fgl
 endif
 ifeq ($(FULL_TARGET),i386-linux)
 override TARGET_LOADERS+=$(LOADERS)
@@ -2575,6 +2575,8 @@ rtlconsts$(PPUEXT) : $(OBJPASDIR)/rtlconsts.pp $(SYSTEMUNIT)$(PPUEXT)
 	$(COMPILER) $(OBJPASDIR)/rtlconsts.pp
 sysconst$(PPUEXT) : $(OBJPASDIR)/sysconst.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 	$(COMPILER) $(OBJPASDIR)/sysconst.pp
+fgl$(PPUEXT): $(OBJPASDIR)/fgl.pp objpas$(PPUEXT) types$(PPUEXT) system$(PPUEXT) sysutils$(PPUEXT)
+	$(COMPILER) -Sg $(OBJPASDIR)/fgl.pp $(REDIR)
 dateutil$(PPUEXT) : $(OBJPASDIR)/dateutil.pp $(SYSTEMUNIT)$(PPUEXT)
 	$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/dateutil.pp
 macpas$(PPUEXT) : $(INC)/macpas.pp objpas$(PPUEXT) math$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)

rtl/embedded/Makefile.fpc

@@ -12,12 +12,13 @@ loaders=$(LOADERS)
 # not all targets include enough features to build all units so
 # the common units which are not compiled for all CPUs are stored in
 # CPU_SPECIFIC_COMMON_UNITS
-units=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS)
+units=$(SYSTEMUNIT) $(CPU_UNITS) uuchar objpas macpas iso7185 strings heapmgr consoleio $(CPU_SPECIFIC_COMMON_UNITS) \
 # macpas iso7185 strings
-#      dos \
-#       classes math typinfo varutils fmtbcd \
-#       charset cpall ucomplex getopts matrix \
-#       variants types rtlconsts sysconst dateutil
+       dos \
+       sysutils \
+       classes math typinfo ctypes \
+       charset cpall getopts \
+       types rtlconsts sysconst lineinfo fgl
 #implicitunits=exeinfo \
 #      cp1250 cp1251 cp1252 cp1253 cp1254 cp1255 cp1256 cp1257 cp1258 \
 #      cp437 cp646 cp850 cp856 cp866 cp874 cp932 cp936 cp949 cp950 cp8859_1 cp8859_5 cp8859_2 cp852
@@ -210,6 +211,9 @@ rtlconsts$(PPUEXT) : $(OBJPASDIR)/rtlconsts.pp $(SYSTEMUNIT)$(PPUEXT)
 sysconst$(PPUEXT) : $(OBJPASDIR)/sysconst.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
         $(COMPILER) $(OBJPASDIR)/sysconst.pp
 
+fgl$(PPUEXT): $(OBJPASDIR)/fgl.pp objpas$(PPUEXT) types$(PPUEXT) system$(PPUEXT) sysutils$(PPUEXT)
+        $(COMPILER) -Sg $(OBJPASDIR)/fgl.pp $(REDIR)
+
 dateutil$(PPUEXT) : $(OBJPASDIR)/dateutil.pp $(SYSTEMUNIT)$(PPUEXT)
         $(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/dateutil.pp
 

rtl/embedded/classes.pp

@@ -0,0 +1,46 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2002 by the Free Pascal development team
+
+    Classes unit for Embedded target
+    
+    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.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  rtlconsts,
+  types,
+{$ifdef FPC_TESTGENERICS}
+  fgl,
+{$endif}
+  typinfo;
+
+{$i classesh.inc}
+
+
+implementation
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+end.

rtl/embedded/dos.pp

@@ -0,0 +1,263 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2004 by Karoly Balogh for Genesi S.a.r.l.
+
+    Heavily based on the Commodore Amiga/m68k RTL by Nils Sjoholm and
+    Carl Eric Codere
+
+    MorphOS port was done on a free Pegasos II/G4 machine
+    provided by Genesi S.a.r.l. <www.genesi.lu>
+    
+    This unit is based on the MorphOS one and is adapted for Gameboy Advance
+    simply by stripping out all stuff inside funcs and procs. 
+    Copyright (c) 2006 by Francesco Lombardi
+    
+    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 Dos;
+
+interface
+
+{$MODE objfpc}
+
+type
+  SearchRec = Packed Record
+	AnchorPtr : Pointer;    { Pointer to the Anchorpath structure }
+	Fill: Array[1..15] of Byte; {future use}
+    {End of replacement for fill}
+    Attr : BYTE;        {attribute of found file}
+    Time : LongInt;     {last modify date of found file}
+    Size : LongInt;     {file size of found file}
+    Name : String[255]; {name of found file}
+  End;
+
+{$I dosh.inc}
+
+implementation
+
+{$I dos.inc}
+
+{******************************************************************************
+                           --- Internal routines ---
+******************************************************************************}
+
+function dosLock(const name: String; accessmode: Longint) : LongInt;
+begin
+  result := -1;
+end;
+
+function IsLeapYear(Source : Word) : Boolean;
+begin
+  result := false;
+end;
+
+function dosSetProtection(const name: string; mask:longint): Boolean;
+begin
+  result := false;
+end;
+
+function dosSetFileDate(name: string): Boolean;
+begin
+  result := false;
+end;
+
+
+{******************************************************************************
+                        --- Info / Date / Time ---
+******************************************************************************}
+
+function DosVersion: Word;
+begin
+  result := 0;
+end;
+
+procedure NewList ();
+begin
+end;
+
+function CreateExtIO (size: Longint): integer;
+begin
+  result := -1;
+end;
+
+procedure DeleteExtIO ();
+begin
+end;
+
+function Createport(name : PChar; pri : longint): integer;
+begin
+  result := -1;
+end;
+
+procedure DeletePort ();
+begin
+end;
+
+
+function Create_Timer(theUnit : longint) : integer;
+begin
+  result := -1;
+end;
+
+Procedure Delete_Timer();
+begin
+end;
+
+function set_new_time(secs, micro : longint): longint;
+begin
+  result := -1;
+end;
+
+function get_sys_time(): longint;
+begin
+  result := -1;
+end;
+
+procedure GetDate(Var Year, Month, MDay, WDay: Word);
+begin
+end;
+
+procedure SetDate(Year, Month, Day: Word);
+begin
+end;
+
+procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
+begin
+end;
+
+
+Procedure SetTime(Hour, Minute, Second, Sec100: Word);
+begin
+end;
+
+
+
+{******************************************************************************
+                               --- Exec ---
+******************************************************************************}
+procedure Exec(const Path: PathStr; const ComLine: ComStr);
+begin
+end;
+
+
+{******************************************************************************
+                               --- Disk ---
+******************************************************************************}
+
+Function DiskFree(Drive: Byte): int64;
+Begin
+  result := -1;
+end;
+
+
+
+Function DiskSize(Drive: Byte): int64;
+Begin
+  result := -1;
+end;
+
+
+procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
+begin
+end;
+
+
+procedure FindNext(Var f: SearchRec);
+begin
+end;
+
+procedure FindClose(Var f: SearchRec);
+begin
+end;
+
+
+{******************************************************************************
+                               --- File ---
+******************************************************************************}
+
+
+function FSearch(path: PathStr; dirlist: String) : PathStr;
+begin
+  result := '';
+end;
+
+
+Procedure getftime (var f; var time : longint);
+begin
+end;
+
+
+Procedure setftime(var f; time : longint);
+Begin
+End;
+
+procedure getfattr(var f; var attr : word);
+begin
+End;
+
+
+procedure setfattr(var f; attr : word);
+begin
+end;
+
+
+{******************************************************************************
+                             --- Environment ---
+******************************************************************************}
+
+function getpathstring: string;
+begin
+  result := '';
+end;
+
+
+function EnvCount: Longint;
+begin
+  result := -1;
+end;
+
+
+function EnvStr(Index: LongInt): String;
+begin
+  result := '';
+end;
+
+
+
+function GetEnv(envvar : String): String;
+begin
+  result := '';
+end;
+
+
+procedure AddDevice(str : String);
+begin
+end;
+
+function MakeDeviceName(str : pchar): string;
+begin
+  result := '';
+end;
+
+function IsInDeviceList(str : string): boolean;
+begin
+  result := false;
+end;
+
+procedure ReadInDevices;
+begin
+end;
+
+begin
+//  DosError:=0;
+//  numberofdevices := 0;
+//  StrOfPaths := '';
+//  ReadInDevices;
+end.

rtl/embedded/rtl.cfg

@@ -44,10 +44,12 @@
 -SfRTTI
 -SfWIDESTRINGS
 -SfDYNARRAYS
+-SfTHREADING
 -SfVARIANTS
 -SfOBJECTS
 -SfCOMMANDARGS
 -SfRANDOM
+-SfRESOURCES
 #endif CPUI386
 
 # arm is powerful enough to handle most object pascal constructs
@@ -60,10 +62,12 @@
 -SfRTTI
 -SfWIDESTRINGS
 -SfDYNARRAYS
+-SfTHREADING
 -SfVARIANTS
 -SfOBJECTS
 -SfCOMMANDARGS
 -SfRANDOM
+-SfRESOURCES
 #endif CPUARM
 
 # mipsel is powerful enough to handle most object pascal constructs
@@ -76,9 +80,11 @@
 -SfRTTI
 -SfWIDESTRINGS
 -SfDYNARRAYS
+-SfTHREADING
 -SfVARIANTS
 -SfOBJECTS
 -SfCOMMANDARGS
 -SfRANDOM
+-SfRESOURCES
 #endif CPUMIPSEL
 

rtl/embedded/system.pp

@@ -22,8 +22,9 @@ Unit System;
 
 {$define FPC_IS_SYSTEM}
 {$define HAS_CMDLINE}
-{$define USE_NOTHREADMANAGER}
+{ $define USE_NOTHREADMANAGER}
 
+{$define DISABLE_NO_THREAD_MANAGER}
 { Do not use standard memory manager }
 {$define HAS_MEMORYMANAGER}
 
@@ -245,7 +246,7 @@ begin
 
 {$ifdef FPC_HAS_FEATURE_THREADING}
   { threading }
-  InitSystemThreads;
+  //InitSystemThreads; // Empty call for embedded anyway
 {$endif FPC_HAS_FEATURE_THREADING}
 
 {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}

rtl/embedded/systhrd.inc

@@ -0,0 +1,21 @@
+{
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2002 by Peter Vreman,
+    member of the Free Pascal development team.
+
+    Embedded empty threading support implementation
+
+    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.
+
+ **********************************************************************}
+
+Procedure InitSystemThreads;
+begin
+end;
+
+

rtl/embedded/sysutils.pp

@@ -20,6 +20,9 @@ unit sysutils;
 
 interface
 
+{$DEFINE HAS_SLEEP}
+{$DEFINE HAS_OSERROR}
+
 { used OS file system APIs use ansistring }
 {$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL}
 { OS has an ansistring/single byte environment variable API }
@@ -28,6 +31,9 @@ interface
   { Include platform independent interface part }
   {$i sysutilh.inc}
 
+  var
+    SleepHandler: procedure(ms: cardinal) = nil;
+
 implementation
 
 uses
@@ -193,6 +199,17 @@ end;
                               Misc Functions
 ****************************************************************************}
 
+procedure sysBeep;
+begin
+end;
+
+
+Procedure Sleep(Milliseconds : Cardinal);
+begin
+  if assigned(SleepHandler) then
+    SleepHandler(Milliseconds);
+end;
+
 Function GetLastOSError : Integer;
 begin
   Result:=-1;

rtl/embedded/tthread.inc

@@ -0,0 +1,111 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2002 by the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TThread                                      *}
+{****************************************************************************}
+
+{$WARNING This file is only a stub, and will not work!}
+
+const
+ ThreadCount: longint = 0;
+
+(* Implementation of exported functions *)
+
+procedure AddThread (T: TThread);
+begin
+ Inc (ThreadCount);
+end;
+
+
+procedure RemoveThread (T: TThread);
+begin
+ Dec (ThreadCount);
+end;
+
+
+procedure TThread.CallOnTerminate;
+begin
+ FOnTerminate (Self);
+end;
+
+
+function TThread.GetPriority: TThreadPriority;
+begin
+  result := tpNormal;
+end;
+
+
+procedure TThread.SetPriority(Value: TThreadPriority);
+begin
+
+end;
+
+
+procedure TThread.SetSuspended(Value: Boolean);
+begin
+ if Value <> FSuspended then
+ begin
+  if Value then Suspend else Resume;
+ end;
+end;
+
+
+procedure TThread.DoTerminate;
+begin
+ if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
+end;
+
+
+procedure TThread.SysCreate(CreateSuspended: Boolean;
+                            const StackSize: SizeUInt);
+var
+  Flags: cardinal;
+begin
+  AddThread (Self);
+end;
+
+
+procedure TThread.SysDestroy;
+begin
+ if not FFinished and not Suspended then
+ begin
+  Terminate;
+  WaitFor;
+ end;
+end;
+
+procedure TThread.Resume;
+begin
+
+end;
+
+
+procedure TThread.Suspend;
+begin
+
+end;
+
+
+procedure TThread.Terminate;
+begin
+ FTerminated := true;
+end;
+
+
+function TThread.WaitFor: Integer;
+begin
+  result := -1;
+end;
+
+

rtl/objpas/classes/classesh.inc

@@ -609,6 +609,7 @@ type
     FAdapter: IStringsAdapter;
     FLBS : TTextLineBreakStyle;
     FStrictDelimiter : Boolean;
+    FLineBreak : String;
     function GetCommaText: string;
     function GetName(Index: Integer): string;
     function GetValue(const Name: string): string;
@@ -626,6 +627,8 @@ type
     Function GetDelimiter : Char;
     Function GetNameValueSeparator : Char;
     Function GetQuoteChar: Char;
+    Function GetLineBreak : String;
+    procedure SetLineBreak(const S : String);
   protected
     procedure DefineProperties(Filer: TFiler); override;
     procedure Error(const Msg: string; Data: Integer);
@@ -647,10 +650,14 @@ type
     Function GetValueFromIndex(Index: Integer): string;
     Procedure SetValueFromIndex(Index: Integer; const Value: string);
     Procedure CheckSpecialChars;
+    Class Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
+    Function GetNextLinebreak (Const Value : String; Var S : String; Var P : Integer) : Boolean;
   public
     destructor Destroy; override;
-    function Add(const S: string): Integer; virtual;
-    function AddObject(const S: string; AObject: TObject): Integer; virtual;
+    function Add(const S: string): Integer; virtual; overload;
+    function AddObject(const S: string; AObject: TObject): Integer; virtual; overload;
+    function Add(const Fmt : string; const Args : Array of const): Integer; overload;
+    function AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer; overload;
     procedure Append(const S: string);
     procedure AddStrings(TheStrings: TStrings); overload; virtual;
     procedure AddStrings(const TheStrings: array of string); overload; virtual;
@@ -682,6 +689,7 @@ type
     Property TextLineBreakStyle : TTextLineBreakStyle Read GetLBS Write SetLBS;
     property Delimiter: Char read GetDelimiter write SetDelimiter;
     property DelimitedText: string read GetDelimitedText write SetDelimitedText;
+    property LineBreak : string Read GetLineBreak write SetLineBreak;
     Property StrictDelimiter : Boolean Read FStrictDelimiter Write FStrictDelimiter;
     property QuoteChar: Char read GetQuoteChar write SetQuoteChar;
     Property NameValueSeparator : Char Read GetNameValueSeparator Write SetNameValueSeparator;

rtl/objpas/classes/streams.inc

@@ -192,7 +192,7 @@ end;
     repeat
       r:=Read(PByte(@Buffer)[t],Count);
       inc(t,r);
-    until (t=Count) or (r=0);
+    until (t=Count) or (r<=0);
     if (t<Count) then
       Raise EReadError.Create(SReadError);
   end;
@@ -207,7 +207,7 @@ end;
       Repeat
          r:=Write(PByte(@Buffer)[t],Count);
          inc(t,r);
-      Until (t=count) or (r=0);
+      Until (t=count) or (r<=0);
       if (t<Count) then
          Raise EWriteError.Create(SWriteError);
     end;
@@ -833,8 +833,11 @@ begin
   Result:=Length(FDataString)-FPosition;
   If Result>Count then Result:=Count;
   // This supposes FDataString to be of type AnsiString !
-  Move (Pchar(FDataString)[FPosition],Buffer,Result);
-  FPosition:=FPosition+Result;
+  if Result>0 then
+   begin
+   Move (Pchar(FDataString)[FPosition],Buffer,Result);
+   FPosition:=FPosition+Result;
+   end;
 end;
 
 

rtl/objpas/classes/stringl.inc

@@ -76,6 +76,7 @@ begin
     FNameValueSeparator:='=';
     FLBS:=DefaultTextLineBreakStyle;
     FSpecialCharsInited:=true;
+    FLineBreak:=sLineBreak;
     end;
 end;
 
@@ -103,6 +104,18 @@ begin
   Result:=FDelimiter;
 end;
 
+procedure TStrings.SetLineBreak(Const S : String);
+begin
+  CheckSpecialChars;
+  FLineBreak:=S;
+end;
+
+Function TStrings.GetLineBreak : String;
+begin
+  CheckSpecialChars;
+  Result:=FLineBreak;
+end;
+
 
 procedure TStrings.SetQuoteChar(c:Char);
 begin
@@ -487,11 +500,14 @@ Var P : Pchar;
 begin
   CheckSpecialChars;
   // Determine needed place
-  Case FLBS of
-    tlbsLF   : NL:=#10;
-    tlbsCRLF : NL:=#13#10;
-    tlbsCR   : NL:=#13; 
-  end;
+  if FLineBreak<>sLineBreak then
+    NL:=FLineBreak
+  else
+    Case FLBS of
+      tlbsLF   : NL:=#10;
+      tlbsCRLF : NL:=#13#10;
+      tlbsCR   : NL:=#13;
+    end;
   L:=0;
   NLS:=Length(NL);
   For I:=0 to count-1 do
@@ -541,7 +557,7 @@ begin
   // Empty.
 end;
 
-Function GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
+Class Function TStrings.GetNextLine (Const Value : String; Var S : String; Var P : Integer) : Boolean;
 
 Var 
   PS : PChar;
@@ -575,6 +591,28 @@ begin
   Result:=True;
 end;
 
+Function TStrings.GetNextLineBreak (Const Value : String; Var S : String; Var P : Integer) : Boolean;
+
+Var
+  PS,PC,PP : PChar;
+  IP,L : Integer;
+
+begin
+  S:='';
+  Result:=False;
+  If ((Length(Value)-P)<=0) then
+    exit;
+  PS:=@Value[P];
+  PC:=PS;
+  PP:=AnsiStrPos(PS,PChar(FLineBreak));
+  // Stop on #0.
+  While (PC^<>#0) and (PC<>PP) do
+    Inc(PC);
+  P:=P+(PC-PS)+Length(FLineBreak);
+  SetString(S,PS,PC-PS);
+  Result:=True;
+end;
+
 Procedure TStrings.DoSetTextStr(const Value: string; DoClear : Boolean);
 
 Var
@@ -587,8 +625,14 @@ begin
     if DoClear then
       Clear;
     P:=1;
-    While GetNextLine (Value,S,P) do
-      Add(S);
+    if FLineBreak=sLineBreak then
+      begin
+      While GetNextLine (Value,S,P) do
+        Add(S)
+      end
+    else
+      While GetNextLineBreak (Value,S,P) do
+        Add(S);
   finally
     EndUpdate;
   end;
@@ -597,12 +641,14 @@ end;
 Procedure TStrings.SetTextStr(const Value: string);
 
 begin
+  CheckSpecialChars;
   DoSetTextStr(Value,True);
 end;
 
 Procedure TStrings.AddText(const S: string);
 
 begin
+  CheckSpecialChars;
   DoSetTextStr(S,False);
 end;
 
@@ -629,6 +675,11 @@ begin
   Insert (Count,S);
 end;
 
+function TStrings.Add(const Fmt : string; const Args : Array of const): Integer;
+
+begin
+  Result:=Add(Format(Fmt,Args));
+end;
 
 
 Function TStrings.AddObject(const S: string; AObject: TObject): Integer;
@@ -638,6 +689,11 @@ begin
   Objects[result]:=AObject;
 end;
 
+function TStrings.AddObject(const Fmt: string; Args : Array of const; AObject: TObject): Integer;
+
+begin
+  Result:=AddObject(Format(Fmt,Args),AObject);
+end;
 
 
 Procedure TStrings.Append(const S: string);
@@ -695,6 +751,7 @@ begin
       FDelimiter:=S.FDelimiter;
       FNameValueSeparator:=S.FNameValueSeparator;
       FLBS:=S.FLBS;
+      FLineBreak:=S.FLineBreak;
       AddStrings(S);
     finally
       EndUpdate;

rtl/openbsd/ptypes.inc

@@ -52,8 +52,11 @@ type
     pid_t    = cint32;          { used as process identifier   }
     TPid     = pid_t;
     pPid     = ^pid_t;
-
+{$ifdef CPU64}
+    size_t   = cuint64;
+{$else}
     size_t   = cuint32;         { as definied in the C standard}
+{$endif}
     TSize    = size_t;
     pSize    = ^size_t;
     pSize_t  = ^size_t;
@@ -173,7 +176,7 @@ type
     end;
 
 // kernel statfs from mount.h
-  TStatfs = packed record
+  TStatfs = record
     flags,			  { copy of mount flags }
     bsize,			  { filesystem block size}
     iosize		: cint;   { optimal transfr block size }

rtl/win/wininc/base.inc

@@ -594,16 +594,16 @@
    }
 
 
-  function IMAGE_ORDINAL64(Ordinal : int64) : int64;
-  function IMAGE_ORDINAL32(Ordinal : longint) : longint;
-  function IMAGE_SNAP_BY_ORDINAL64(Ordinal : int64) : boolean;
-  function IMAGE_SNAP_BY_ORDINAL32(Ordinal : longint) : boolean;
+  function IMAGE_ORDINAL64(Ordinal : uint64) : uint64; inline;
+  function IMAGE_ORDINAL32(Ordinal : cardinal) : cardinal;inline;
+  function IMAGE_SNAP_BY_ORDINAL64(Ordinal : uint64) : boolean;  inline;
+  function IMAGE_SNAP_BY_ORDINAL32(Ordinal : cardinal) : boolean; inline;
   {$ifdef WIN64}
-    function IMAGE_ORDINAL(Ordinal : int64) : int64;
-    function IMAGE_SNAP_BY_ORDINAL(Ordinal : int64) : boolean;
+    function IMAGE_ORDINAL(Ordinal : uint64) : uint64; inline;
+    function IMAGE_SNAP_BY_ORDINAL(Ordinal : uint64) : boolean; inline;
   {$else}
-    function IMAGE_ORDINAL(Ordinal : longint) : longint;
-    function IMAGE_SNAP_BY_ORDINAL(Ordinal : longint) : boolean;
+    function IMAGE_ORDINAL(Ordinal : cardinal) : cardinal; inline;
+    function IMAGE_SNAP_BY_ORDINAL(Ordinal : cardinal) : boolean; inline;
   {$endif}
  
 
@@ -1072,46 +1072,46 @@ type
        PALETTERGB:=$02000000 or (RGB(r,g,b));
     end;
 
-  function IMAGE_ORDINAL64(Ordinal : int64) : int64;
+  function IMAGE_ORDINAL64(Ordinal : uint64) : uint64;
   begin
     IMAGE_ORDINAL64:=Ordinal and $ffff;
   end;
 
-  function IMAGE_ORDINAL32(Ordinal : longint) : longint;
+  function IMAGE_ORDINAL32(Ordinal : cardinal) : cardinal;
   begin
     IMAGE_ORDINAL32:=Ordinal and $ffff;
   end;
 
-  function IMAGE_SNAP_BY_ORDINAL64(Ordinal : int64) : boolean;
+  function IMAGE_SNAP_BY_ORDINAL64(Ordinal : uint64) : boolean;
   begin
     IMAGE_SNAP_BY_ORDINAL64:=(Ordinal and IMAGE_ORDINAL_FLAG64)<>0;
   end;
 
-  function IMAGE_SNAP_BY_ORDINAL32(Ordinal : longint) : boolean;
+  function IMAGE_SNAP_BY_ORDINAL32(Ordinal : cardinal) : boolean;
   begin
     IMAGE_SNAP_BY_ORDINAL32:=(Ordinal and IMAGE_ORDINAL_FLAG32)<>0;
   end;
 
   {$ifdef win64}
-  function IMAGE_ORDINAL(Ordinal : int64) : int64;
+  function IMAGE_ORDINAL(Ordinal : uint64) : uint64;
   begin
     IMAGE_ORDINAL:=IMAGE_ORDINAL64(Ordinal);
   end;
 
 
-  function IMAGE_SNAP_BY_ORDINAL(Ordinal : int64) : boolean;
+  function IMAGE_SNAP_BY_ORDINAL(Ordinal : uint64) : boolean;
   begin
     IMAGE_SNAP_BY_ORDINAL:=IMAGE_SNAP_BY_ORDINAL64(Ordinal);
   end;
 
   {$else}
 
-  function IMAGE_ORDINAL(Ordinal : longint) : longint;
+  function IMAGE_ORDINAL(Ordinal : cardinal) : cardinal;
   begin
     IMAGE_ORDINAL:=IMAGE_ORDINAL32(Ordinal);
   end;
 
-  function IMAGE_SNAP_BY_ORDINAL(Ordinal : longint) : boolean;
+  function IMAGE_SNAP_BY_ORDINAL(Ordinal : cardinal) : boolean;
   begin
     IMAGE_SNAP_BY_ORDINAL:=IMAGE_SNAP_BY_ORDINAL32(Ordinal);
   end;

rtl/win/wininc/struct.inc

@@ -8346,6 +8346,25 @@ type
 
 {$push}
 {$packrecords 4}
+
+    PIMAGE_EXPORT_DIRECTORY = ^TIMAGE_EXPORT_DIRECTORY;
+    IMAGE_EXPORT_DIRECTORY = record
+        Characteristics : DWORD;
+        TimeDateStamp   : DWORD;
+        MajorVersion    : WORD;
+        MinorVersion    : WORD;
+        Name 	        : DWORD;
+        Base 		    : DWORD;
+        NumberOfFunctions : DWORD;
+        NumberOfNames   : DWORD;
+        AddressOfFunctions : DWORD;     { RVA from base of image }
+        AddressOfNames  : DWORD;        { RVA from base of image }
+        AddressOfNameOrdinals : DWORD;  { RVA from base of image }
+      end;
+    TIMAGE_EXPORT_DIRECTORY = IMAGE_EXPORT_DIRECTORY; 
+    _IMAGE_EXPORT_DIRECTORY = IMAGE_EXPORT_DIRECTORY;
+    LPIMAGE_EXPORT_DIRECTORY= PIMAGE_EXPORT_DIRECTORY;
+
   P_IMAGE_IMPORT_BY_NAME = ^_IMAGE_IMPORT_BY_NAME;
   _IMAGE_IMPORT_BY_NAME =  record
       Hint : WORD;
@@ -8403,15 +8422,13 @@ type
       AddressOfIndex : ULONGLONG;               { PDWORD }
       AddressOfCallBacks : ULONGLONG;           { PIMAGE_TLS_CALLBACK *; }
       SizeOfZeroFill : DWORD;
-      DUMMYUNIONNAME : bitpacked  record
           case longint of
             0 : ( Characteristics : DWORD );
-            1 : ( DUMMYSTRUCTNAME :  record
-           Reserved0 : 0..$FFFFF; // 5 nibbles=20 bits
-           Alignment : 0..$F;      // 4 bits
-           Reserved1 : 0..$FF;     // 8 bits
+            1 : ( CharacteristicsFields:  bitpacked record
+                                  Reserved0 : 0..$FFFFF; // 5 nibbles=20 bits
+                                  Alignment : 0..$F;      // 4 bits
+                                  Reserved1 : 0..$FF;     // 8 bits
               end );
-          end;
     end;
   IMAGE_TLS_DIRECTORY64 = _IMAGE_TLS_DIRECTORY64;
   PIMAGE_TLS_DIRECTORY64 = ^IMAGE_TLS_DIRECTORY64;
@@ -8425,15 +8442,14 @@ type
       AddressOfIndex : DWORD;                      { PDWORD }
       AddressOfCallBacks : DWORD;                  { PIMAGE_TLS_CALLBACK * }
       SizeOfZeroFill : DWORD;
-      DUMMYUNIONNAME :  record
           case longint of
             0 : ( Characteristics : DWORD );
-            1 : ( DUMMYSTRUCTNAME : bitpacked  record
-                    Reserved0 : 0..$FFFFF; // 5 nibbles=20 bits
-                    Alignment : 0..$F;      // 4 bits
-                    Reserved1 : 0..$FF;     // 8 bits
+            1 : ( CharacteristicsFields : bitpacked  record
+                                 Reserved0 : 0..$FFFFF; // 5 nibbles=20 bits
+                                 Alignment : 0..$F;      // 4 bits
+                                 Reserved1 : 0..$FF;     // 8 bits
               end );
-          end;
+
     end;
   IMAGE_TLS_DIRECTORY32 = _IMAGE_TLS_DIRECTORY32;
   PIMAGE_TLS_DIRECTORY32 = ^IMAGE_TLS_DIRECTORY32;
@@ -8472,18 +8488,17 @@ type
 
   P_IMAGE_IMPORT_DESCRIPTOR = ^_IMAGE_IMPORT_DESCRIPTOR;
   _IMAGE_IMPORT_DESCRIPTOR =  record
-      DUMMYUNIONNAME :  bitpacked record
           case longint of
             0 : ( Characteristics : DWORD );     { 0 for terminating null import descriptor }
-            1 : ( OriginalFirstThunk : DWORD );  { RVA to original unbound IAT (PIMAGE_THUNK_DATA) }
-          end;
-      TimeDateStamp : DWORD;                     { 0 if not bound, }
+            1 : ( OriginalFirstThunk : DWORD;    { RVA to original unbound IAT (PIMAGE_THUNK_DATA) }
+                  TimeDateStamp : DWORD;         { 0 if not bound, }
                                                  // -1 if bound, and real date\time stamp
                                                  //     in IMAGE_DIRECTORY_ENTRY_BOUND_IMPORT (new BIND)
                                                  // O.W. date/time stamp of DLL bound to (Old BIND)
-      ForwarderChain : DWORD;                    // -1 if no forwarders
-      Name : DWORD;
-      FirstThunk : DWORD;                        // RVA to IAT (if bound this IAT has actual addresses)
+                  ForwarderChain : DWORD;        // -1 if no forwarders
+                  Name : DWORD;
+                  FirstThunk : DWORD;            // RVA to IAT (if bound this IAT has actual addresses)
+                );  
     end;
   IMAGE_IMPORT_DESCRIPTOR = _IMAGE_IMPORT_DESCRIPTOR;
   PIMAGE_IMPORT_DESCRIPTOR = ^IMAGE_IMPORT_DESCRIPTOR   {UNALIGNED  }     ;
@@ -8522,23 +8537,21 @@ type
   { Delay load version 2 }
 
   _IMAGE_DELAYLOAD_DESCRIPTOR = record
-    Attributes:record
         case longint of
-        0: (AllAttributes :Dword;);
-        1: (dummyrecord:bitpacked record
+        0: (AllAttributes :Dword;
+            DllNameRVA,                       // RVA to the name of the target library (NULL-terminate ASCII string)
+            ModuleHandleRVA,                  // RVA to the HMODULE caching location (PHMODULE)
+            ImportAddressTableRVA,            // RVA to the start of the IAT (PIMAGE_THUNK_DATA)
+            ImportNameTableRVA,               // RVA to the start of the name table (PIMAGE_THUNK_DATA::AddressOfData)
+            BoundImportAddressTableRVA,       // RVA to an optional bound IAT
+            UnloadInformationTableRVA,        // RVA to an optional unload info table
+            TimeDateStamp            : DWORD; // 0 if not bound,
+                                            // Otherwise, date/time of the target DLL
+         );
+        1: (Attributes:bitpacked record
              rvabased:0..1;  {1 bits}                 // Delay load version 2
              ReservedAttributes: 0..$7FFFFFF; {31 bits}
              end;)
-        end;
-
-    DllNameRVA,                       // RVA to the name of the target library (NULL-terminate ASCII string)
-    ModuleHandleRVA,                  // RVA to the HMODULE caching location (PHMODULE)
-    ImportAddressTableRVA,            // RVA to the start of the IAT (PIMAGE_THUNK_DATA)
-    ImportNameTableRVA,               // RVA to the start of the name table (PIMAGE_THUNK_DATA::AddressOfData)
-    BoundImportAddressTableRVA,       // RVA to an optional bound IAT
-    UnloadInformationTableRVA,        // RVA to an optional unload info table
-    TimeDateStamp            : DWORD; // 0 if not bound,
-                                            // Otherwise, date/time of the target DLL
      end;
 
   IMAGE_DELAYLOAD_DESCRIPTOR= _IMAGE_DELAYLOAD_DESCRIPTOR;

tests/webtbs/tw27517.pp

@@ -0,0 +1,11 @@
+program Project1;
+
+{$mode objfpc}{$H+}
+
+var
+  pTyped: PInteger;
+  p: Pointer;
+begin
+  p := nil;
+  pTyped := @(PByte(p)+1)^; //project1.lpr(21,23) Fatal: Syntax error, ")" expected but "+" found
+end.

tests/webtbs/tw27529.pp

@@ -0,0 +1,17 @@
+{ %OPT=-Sm -dMY_VAR:=123 }
+program test;
+
+{$IF DEFINED(MY_VAR)}
+  {$INFO MY_VAR defined}
+  {$IF MY_VAR=123}
+    {$INFO MY_VAR = 123}
+  {$ELSE}
+    {$INFO MY_VAR <> 123}
+  {$ENDIF}
+{$ENDIF}
+
+begin
+  writeln(MY_VAR);
+  if MY_VAR<>123 then
+    halt(1);
+end.

tests/webtbs/tw27691.pp

@@ -0,0 +1,6 @@
+{ %opt=-Seh -vh }
+
+{$modeswitch unicodestrings}
+
+begin
+end.

utils/fpcm/fpcmmain.pp

@@ -86,7 +86,7 @@ interface
       );
 
       CpuSuffix : array[TCpu] of string=(
-        '_i386','_m68k','_powerpc','_sparc','_x86_64','_arm','_powerpc64','avr','_armeb', '_armel', '_mips', '_mipsel', '_mips64', '_mips64el', '_jvm','_i8086','_aarch64'
+        '_i386','_m68k','_powerpc','_sparc','_x86_64','_arm','_powerpc64','_avr','_armeb', '_armel', '_mips', '_mipsel', '_mips64', '_mips64el', '_jvm','_i8086','_aarch64'
       );
 
       ppcSuffix : array[TCpu] of string=(

utils/tply/README.txt

@@ -16,7 +16,7 @@ available from the TPLY homepage:
 
 For information about the Free Pascal Compiler, please refer to:
 
-	http://tfdec1.fys.kuleuven.ac.be/~michael/fpc/fpc.html
+	http://www.freepascal.org/
 
 The manual can be found in the files tply.tex (TeX version) and tply.doc
 (ASCII version) contained in the package. An extended version of the manual
@@ -44,7 +44,7 @@ The original version of the TPLY package was written by Albert Graef
 4.0-6.0. Berend de Boer <[email protected]>, the current maintainer of the
 Turbo/Borland Pascal version, adapted TPLY to take advantage of the large
 memory models in Borland Pascal 7.0 and Delphi. Michael Van Canneyt
-<[email protected]>, who maintains the Linux version of
+<[email protected]>, who maintains the Linux version of
 the Free Pascal compiler, is the author of the Free Pascal port.
 
 
@@ -77,10 +77,9 @@ to store things :-) The 16-bit DPMI platforms have tables extended as large as
 possible without changing basic Lex or Yacc sources.
 
 This version was ported to Free Pascal by Michael Van Canneyt
-<[email protected]> (April 1998).
+<[email protected]> (April 1998).
 
-*** Version 4.1		Michael Van Canneyt
-			<[email protected]>
+*** Version 4.1		Michael Van Canneyt <[email protected]>
 			Albert Graef <[email protected]>
 
 May 1998. Merges the Turbo and Free Pascal versions into a single package.
@@ -142,6 +141,18 @@ from the lex.pas and yacc.pas programs), the Lex and Yacc code templates
 (*.cod files), and the LexLib and YaccLib library units (compiled from
 lexlib.pas and yacclib.pas).
 
+The plex and pyacc programs will look for the *.cod files in the following locations:
+For unix-like operating systems:
+1. Current directory.
+2. Directory given by FPCDIR
+3. Directory /usr/local/lib/fpc/lexyacc
+4. Directory /usr/lib/fpc/lexyacc
+
+For other operating systems (dos/windows-like) : 
+1. Current directory.
+2. Directory given by FPCDIR 
+3. Directory where the executable is located.
+
 For the Free Pascal/Linux version, a Makefile is provided. To install, issue
 the command `make' (maybe you have to edit the Makefile before this to reflect
 your setup) and then `make install'. Note that in the Linux version the