Merged revisions 6805-6806,6808-6809,6815,6824,6831,6842-6843,6864-6866,6868-6869,6872,6882-6883,6889,6891,6893-6894,6896,6898,6901-6903,6908,6916,6921-6922,6924-6925,6927-6928,6930,6943-6946,6952,6954,6956,6974,6976,6996-6997,7002,7007,7016,7020-7021,7033,7037,7040,7042,7045,7068-7069,7075-7079,7087,7094,7098-7099,7101,7103-7104,7109,7115-7119,7128,7136-7137,7139,7150,7160-7162,7175,7179,7190-7195,7198,7202,7205-7206,7208-7217,7220-7222,7225-7228,7230,7233,7239-7241,7244,7246,7263,7275,7277,7279-7281,7285,7288-7289,7291-7293,7296,7300,7303,7310,7318,7340-7341,7343,7345,7372-7373,7375-7376,7379,7381,7383-7388,7391-7392,7400,7404-7406,7411,7422,7425,7436,7441-7442,7444-7445,7450,7456,7463,7467,7475,7479,7486,7504,7506-7509,7522,7527,7534-7536,7558-7559,7563-7565,7567,7570-7571,7573-7576,7586,7589,7592-7594,7607,7612,7615,7619-7620,7622-7623,7626,7628,7631,7633,7646,7663,7677,7681-7683,7689,7697,7704-7712,7725,7736,7738,7740,7744-7746,7751,7753,7764,7767,7769-7770,7776-7777,7788,7830,7836-7839,7846,7849,7862,7864-7865,7869,7872,7877,7882,7927-7929,7953,7961,7967,7971,7986-7987,7990-7994,7998-8000,8004-8006,8008-8012,8016,8027,8034,8036-8037,8039,8044,8046,8048,8051,8060,8071,8075-8076,8082-8083,8087-8089,8095-8096,8099-8100,8136,8187,8190,8203,8206-8207,8212-8213,8215,8225,8227,8233-8239,8262,8302,8307,8309,8316,8318-8319,8336,8338-8340,8404,8410-8411,8430,8438-8442,8445-8446,8448,8450-8454,8456-8457,8459,8462,8469-8470,8472-8483,8486-8488,8490-8491,8493,8495-8496,8498-8502,8506,8508-8509,8526,8531,8535-8537,8539-8546,8554-8555,8557,8560,8563,8565,8568,8575-8576,8579-8587,8589 via svnmerge from

http://svn.freepascal.org/svn/fpc/trunk

........
  r6805 | florian | 2007-03-12 20:47:04 +0100 (Mon, 12 Mar 2007) | 2 lines
  
  + more cse invariant nodes added
........
  r6831 | jonas | 2007-03-13 22:56:41 +0100 (Tue, 13 Mar 2007) | 2 lines
  
    * docompare -> isequal
........
  r7104 | florian | 2007-04-15 16:41:00 +0200 (Sun, 15 Apr 2007) | 2 lines
  
  * some node optimizer stuff cleaned up
........
  r8491 | jonas | 2007-09-15 09:21:56 +0200 (Sat, 15 Sep 2007) | 2 lines
  
    * fixed compilation after r8349
........
  r8495 | jonas | 2007-09-16 11:14:21 +0200 (Sun, 16 Sep 2007) | 2 lines
  
    * sparc compiles again
........
  r8498 | florian | 2007-09-16 12:08:53 +0200 (Sun, 16 Sep 2007) | 2 lines
  
  * formatting
........
  r8499 | florian | 2007-09-16 12:20:16 +0200 (Sun, 16 Sep 2007) | 2 lines
  
  + define DEFAULT_DOUBLE on m68k
........
  r8500 | florian | 2007-09-16 12:21:17 +0200 (Sun, 16 Sep 2007) | 2 lines
  
  * small m68k cleanups
........
  r8501 | florian | 2007-09-16 12:47:28 +0200 (Sun, 16 Sep 2007) | 2 lines
  
  + printnode shortcut for lazy people
........
  r8502 | karoly | 2007-09-16 13:07:47 +0200 (Sun, 16 Sep 2007) | 2 lines
  
  + removed a define which seems unnecessary
........
  r8508 | jonas | 2007-09-16 18:15:42 +0200 (Sun, 16 Sep 2007) | 2 lines
  
    * properties
........
  r8509 | jonas | 2007-09-16 18:16:54 +0200 (Sun, 16 Sep 2007) | 3 lines
  
    * disabled testing of -0 because its (mostly harmless) failure
      can mask other more important failures
........
  r8526 | peter | 2007-09-17 21:40:36 +0200 (Mon, 17 Sep 2007) | 2 lines
  
    * invalid typecast
........
  r8531 | peter | 2007-09-17 22:52:51 +0200 (Mon, 17 Sep 2007) | 2 lines
  
    * only freetemp when there were registers saved
........
  r8555 | karoly | 2007-09-18 21:42:54 +0200 (Tue, 18 Sep 2007) | 2 lines
  
  + changed this one to contain real 68k headers (based on MOS version of the headers)
........
  r8557 | peter | 2007-09-18 23:05:40 +0200 (Tue, 18 Sep 2007) | 2 lines
  
    * fix temp release for 64bit compare
........
  r8563 | peter | 2007-09-19 17:41:47 +0200 (Wed, 19 Sep 2007) | 3 lines
  
    * don't overwrite cai_align with tai_align_abstract
    * check that tai_align is used and not tai_align_abstract
........
  r8565 | jonas | 2007-09-19 18:37:49 +0200 (Wed, 19 Sep 2007) | 5 lines
  
    * avoid writing the stabs for a child class before those of a parent
      class in case the parent class has a field with as type the (forward
      defined) child class, because this crashes gdb
    + (interactive) test for this
........
  r8568 | peter | 2007-09-20 00:37:49 +0200 (Thu, 20 Sep 2007) | 5 lines
  
    * added get_local_or_para_sym to search in parast and localst
      for self and vmt. The new function uses the owner of procdef
      instead of the parsing symtablestack used by searchsym
........
  r8579 | tom_at_work | 2007-09-20 22:35:35 +0200 (Thu, 20 Sep 2007) | 2 lines
  
  * added missing assignment check when searching for a symbol in a class, fixing bug #9673
  * test program for above
........
  r8580 | peter | 2007-09-20 23:08:08 +0200 (Thu, 20 Sep 2007) | 2 lines
  
    * move systems_darwin constant to correct location
........
  r8589 | peter | 2007-09-21 00:30:29 +0200 (Fri, 21 Sep 2007) | 2 lines
  
    * version 2.3
........

git-svn-id: branches/fixes_2_2@8590 -

.gitattributes

@@ -280,6 +280,7 @@ compiler/ogcoff.pas svneol=native#text/plain
 compiler/ogelf.pas svneol=native#text/plain
 compiler/oglx.pas svneol=native#text/plain
 compiler/ogmap.pas svneol=native#text/plain
+compiler/optbase.pas svneol=native#text/plain
 compiler/optcse.pas svneol=native#text/plain
 compiler/options.pas svneol=native#text/plain
 compiler/opttail.pas svneol=native#text/plain
@@ -7143,7 +7144,7 @@ tests/test/units/system/tslice2.pp svneol=native#text/plain
 tests/test/units/system/tstring.pp svneol=native#text/plain
 tests/test/units/system/ttrig.pas svneol=native#text/plain
 tests/test/units/system/ttrunc.pp svneol=native#text/plain
-tests/test/units/system/tval.inc -text
+tests/test/units/system/tval.inc svneol=native#text/plain
 tests/test/units/system/tval.pp -text
 tests/test/units/system/tval1.pp -text
 tests/test/units/system/tval2.pp -text

compiler/aasmtai.pas

@@ -2301,6 +2301,10 @@ implementation
        begin
           inherited Create;
           typ:=ait_align;
+{$ifdef EXTDEBUG}
+          if upper(classname)='TAI_ALIGN_ABSTRACT' then
+            internalerror(200709191);
+{$endif EXTDEBUG}
           if b in [1,2,4,8,16,32] then
             aligntype := b
           else
@@ -2369,5 +2373,8 @@ implementation
 
 begin
   cai_cpu:=tai_cpu_abstract;
-  cai_align:=tai_align_abstract;
+  { aasmcpu is earlier in the unit order and can
+    already set the cai_align }
+  if not assigned(cai_align) then
+    cai_align:=tai_align_abstract;
 end.

compiler/cgobj.pas

@@ -3301,11 +3301,13 @@ implementation
 
     procedure tcg.g_restore_standard_registers(list:TAsmList);
       var
-        href : treference;
-        r : integer;
-        hreg : tregister;
+        href     : treference;
+        r        : integer;
+        hreg     : tregister;
+        freetemp : boolean;
       begin
         { Copy registers from temp }
+        freetemp:=false;
         href:=current_procinfo.save_regs_ref;
         for r:=low(saved_standard_registers) to high(saved_standard_registers) do
           if saved_standard_registers[r] in rg[R_INTREGISTER].used_in_proc then
@@ -3315,8 +3317,10 @@ implementation
               a_reg_alloc(list,hreg);
               a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,hreg);
               inc(href.offset,sizeof(aint));
+              freetemp:=true;
             end;
-        tg.UnGetTemp(list,current_procinfo.save_regs_ref);
+        if freetemp then
+          tg.UnGetTemp(list,current_procinfo.save_regs_ref);
       end;
 
 

compiler/dbgstabs.pas

@@ -271,7 +271,7 @@ implementation
 
         { Stab must already be written, or we must be busy writing it }
         if writing_def_stabs and
-           not(def.dbg_state in [dbg_state_writing,dbg_state_written]) then
+           not(def.dbg_state in [dbg_state_writing,dbg_state_written,dbg_state_queued]) then
           internalerror(200403091);
 
         { Keep track of used stabs, this info is only usefull for stabs
@@ -904,6 +904,29 @@ implementation
               insertdef(list,tenumdef(def).basedef);
           objectdef :
             begin
+              { make sure we don't write child classdefs before their parent }
+              { classdefs, because this crashes gdb                          }
+              anc:=tobjectdef(def);
+              while assigned(anc.childof) do
+                begin
+                  anc:=anc.childof;
+                  if (anc.dbg_state=dbg_state_writing) then
+                    { happens in case a field of a parent is of the (forward }
+                    { defined) child type                                    }
+                    begin
+                      { We don't explicitly requeue it, but the fact that  }
+                      { a child type was used in a parent before the child }
+                      { type was fully defined means that it was forward   }
+                      { declared, and will still be encountered later (it  }
+                      { cannot have been declared in another unit, because }
+                      { then this and that other unit would depend on      }
+                      { eachother's interface)                             }
+                      { Setting the state to queued however allows us to   }
+                      { get the def number already without an IE           }
+                      def.dbg_state:=dbg_state_queued;
+                      exit;
+                    end;
+                end;
               insertdef(list,vmtarraytype);
               if assigned(tobjectdef(def).ImplementedInterfaces) then
                 for i:=0 to tobjectdef(def).ImplementedInterfaces.Count-1 do
@@ -970,7 +993,7 @@ implementation
            for i:=0 to st.DefList.Count-1 do
              begin
                def:=tdef(st.DefList[i]);
-               if (def.dbg_state=dbg_state_used) then
+               if (def.dbg_state in [dbg_state_used,dbg_state_queued]) then
                  insertdef(list,def);
              end;
          end;

compiler/i386/n386add.pas

@@ -278,6 +278,7 @@ interface
                  hregister:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
                  hregister2:=cg.getintregister(current_asmdata.CurrAsmList,OS_INT);
                  cg64.a_load64_loc_reg(current_asmdata.CurrAsmList,left.location,joinreg64(hregister,hregister2));
+                 location_freetemp(current_asmdata.CurrAsmList,left.location);
                  location_reset(left.location,LOC_REGISTER,OS_64);
                  left.location.register64.reglo:=hregister;
                  left.location.register64.reghi:=hregister2;
@@ -332,8 +333,6 @@ interface
            end;
          end;
 
-        location_freetemp(current_asmdata.CurrAsmList,left.location);
-
         { we have LOC_JUMP as result }
         location_reset(location,LOC_JUMP,OS_NO)
       end;

compiler/m68k/cpuinfo.pas

@@ -1,7 +1,7 @@
 {
     Copyright (c) 1998-2002 by the Free Pascal development team
 
-    Basic Processor information for the PowerPC
+    Basic Processor information for the m68k
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -20,7 +20,7 @@ Interface
     globtype;
 
 Type
-   bestreal = real;
+   bestreal = double;
    ts32real = single;
    ts64real = double;
    ts80real = extended;

compiler/ncgset.pas

@@ -921,7 +921,7 @@ implementation
          { generate the instruction blocks }
          for i:=0 to blocks.count-1 do
            begin
-              current_asmdata.CurrAsmList.concat(Tai_align_abstract.create(current_settings.alignment.jumpalign));
+              current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
               cg.a_label(current_asmdata.CurrAsmList,pcaseblock(blocks[i])^.blocklabel);
               secondpass(pcaseblock(blocks[i])^.statement);
               { don't come back to case line }
@@ -931,7 +931,7 @@ implementation
 {$endif OLDREGVARS}
               cg.a_jmp_always(current_asmdata.CurrAsmList,endlabel);
            end;
-         current_asmdata.CurrAsmList.concat(Tai_align_abstract.create(current_settings.alignment.jumpalign));
+         current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
          { ...and the else block }
          cg.a_label(current_asmdata.CurrAsmList,elselabel);
          if assigned(elseblock) then
@@ -941,7 +941,7 @@ implementation
               load_all_regvars(current_asmdata.CurrAsmList);
 {$endif OLDREGVARS}
            end;
-         current_asmdata.CurrAsmList.concat(Tai_align_abstract.create(current_settings.alignment.jumpalign));
+         current_asmdata.CurrAsmList.concat(cai_align.create(current_settings.alignment.jumpalign));
          cg.a_label(current_asmdata.CurrAsmList,endlabel);
 
          { Reset labels }

compiler/node.pas

@@ -30,7 +30,8 @@ interface
        globtype,globals,
        cpubase,cgbase,cgutils,
        aasmbase,
-       symtype;
+       symtype,
+       optbase;
 
     type
        tnodetype = (
@@ -262,165 +263,167 @@ interface
        tnodelist = class
        end;
 
-       { later (for the newcg) tnode will inherit from tlinkedlist_item }
-       tnode = class
-       public
-          { type of this node }
-          nodetype : tnodetype;
-          { type of the current code block, general/const/type }
-          blocktype : tblock_type;
-          { expected location of the result of this node (pass1) }
-          expectloc : tcgloc;
-          { the location of the result of this node (pass2) }
-          location : tlocation;
-          { the parent node of this is node    }
-          { this field is set by concattolist  }
-          parent : tnode;
-          { there are some properties about the node stored }
-          flags  : tnodeflags;
-          ppuidx : longint;
-          { the number of registers needed to evalute the node }
-          registersint,registersfpu,registersmm : longint;  { must be longint !!!! }
+      pnode = ^tnode;
+      { basic class for the intermediated representation fpc uses }
+      tnode = class
+      public
+         { type of this node }
+         nodetype : tnodetype;
+         { type of the current code block, general/const/type }
+         blocktype : tblock_type;
+         { expected location of the result of this node (pass1) }
+         expectloc : tcgloc;
+         { the location of the result of this node (pass2) }
+         location : tlocation;
+         { the parent node of this is node    }
+         { this field is set by concattolist  }
+         parent : tnode;
+         { there are some properties about the node stored }
+         flags  : tnodeflags;
+         ppuidx : longint;
+         { the number of registers needed to evalute the node }
+         registersint,registersfpu,registersmm : longint;  { must be longint !!!! }
 {$ifdef SUPPORT_MMX}
-          registersmmx  : longint;
+         registersmmx  : longint;
 {$endif SUPPORT_MMX}
-          resultdef     : tdef;
-          resultdefderef : tderef;
-          fileinfo      : tfileposinfo;
-          localswitches : tlocalswitches;
+         resultdef     : tdef;
+         resultdefderef : tderef;
+         fileinfo      : tfileposinfo;
+         localswitches : tlocalswitches;
+         optinfo : poptinfo;
 {$ifdef extdebug}
-          maxfirstpasscount,
-          firstpasscount : longint;
+         maxfirstpasscount,
+         firstpasscount : longint;
 {$endif extdebug}
-          constructor create(t:tnodetype);
-          { this constructor is only for creating copies of class }
-          { the fields are copied by getcopy                      }
-          constructor createforcopy;
-          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);virtual;
-          destructor destroy;override;
-          procedure ppuwrite(ppufile:tcompilerppufile);virtual;
-          procedure buildderefimpl;virtual;
-          procedure derefimpl;virtual;
-          procedure derefnode;virtual;
-
-          { toggles the flag }
-          procedure toggleflag(f : tnodeflag);
-
-          { the 1.1 code generator may override pass_1 }
-          { and it need not to implement det_* then    }
-          { 1.1: pass_1 returns a value<>0 if the node has been transformed }
-          { 2.0: runs pass_typecheck and det_temp                           }
-          function pass_1 : tnode;virtual;abstract;
-          { dermines the resultdef of the node }
-          function pass_typecheck : tnode;virtual;abstract;
-
-          { tries to simplify the node, returns a value <>nil if a simplified
-            node has been created }
-          function simplify : tnode;virtual;
+         constructor create(t:tnodetype);
+         { this constructor is only for creating copies of class }
+         { the fields are copied by getcopy                      }
+         constructor createforcopy;
+         constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);virtual;
+         destructor destroy;override;
+         procedure ppuwrite(ppufile:tcompilerppufile);virtual;
+         procedure buildderefimpl;virtual;
+         procedure derefimpl;virtual;
+         procedure derefnode;virtual;
+
+         { toggles the flag }
+         procedure toggleflag(f : tnodeflag);
+
+         { the 1.1 code generator may override pass_1 }
+         { and it need not to implement det_* then    }
+         { 1.1: pass_1 returns a value<>0 if the node has been transformed }
+         { 2.0: runs pass_typecheck and det_temp                           }
+         function pass_1 : tnode;virtual;abstract;
+         { dermines the resultdef of the node }
+         function pass_typecheck : tnode;virtual;abstract;
+
+         { tries to simplify the node, returns a value <>nil if a simplified
+           node has been created }
+         function simplify : tnode;virtual;
 {$ifdef state_tracking}
-          { Does optimizations by keeping track of the variable states
-            in a procedure }
-          function track_state_pass(exec_known:boolean):boolean;virtual;
+         { Does optimizations by keeping track of the variable states
+           in a procedure }
+         function track_state_pass(exec_known:boolean):boolean;virtual;
 {$endif}
-          { For a t1:=t2 tree, mark the part of the tree t1 that gets
-            written to (normally the loadnode) as write access. }
-          procedure mark_write;virtual;
-          { dermines the number of necessary temp. locations to evaluate
-            the node }
-          procedure det_temp;virtual;abstract;
-
-          procedure pass_generate_code;virtual;abstract;
-
-          { comparing of nodes }
-          function isequal(p : tnode) : boolean;
-          { to implement comparisation, override this method }
-          function docompare(p : tnode) : boolean;virtual;
-          { wrapper for getcopy }
-          function getcopy : tnode;
-
-          { does the real copying of a node }
-          function dogetcopy : tnode;virtual;
-
-          procedure insertintolist(l : tnodelist);virtual;
-          { writes a node for debugging purpose, shouldn't be called }
-          { direct, because there is no test for nil, use printnode  }
-          { to write a complete tree }
-          procedure printnodeinfo(var t:text);virtual;
-          procedure printnodedata(var t:text);virtual;
-          procedure printnodetree(var t:text);virtual;
-          procedure concattolist(l : tlinkedlist);virtual;
-          function ischild(p : tnode) : boolean;virtual;
-       end;
-
-       tnodeclass = class of tnode;
-
-       tnodeclassarray = array[tnodetype] of tnodeclass;
-
-       { this node is the anchestor for all nodes with at least   }
-       { one child, you have to use it if you want to use         }
-       { true- and current_procinfo.CurrFalseLabel                                     }
-       punarynode = ^tunarynode;
-       tunarynode = class(tnode)
-          left : tnode;
-          constructor create(t:tnodetype;l : tnode);
-          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
-          destructor destroy;override;
-          procedure ppuwrite(ppufile:tcompilerppufile);override;
-          procedure buildderefimpl;override;
-          procedure derefimpl;override;
-          procedure derefnode;override;
-          procedure concattolist(l : tlinkedlist);override;
-          function ischild(p : tnode) : boolean;override;
-          function docompare(p : tnode) : boolean;override;
-          function dogetcopy : tnode;override;
-          procedure insertintolist(l : tnodelist);override;
-          procedure left_max;
-          procedure printnodedata(var t:text);override;
-       end;
-
-       pbinarynode = ^tbinarynode;
-       tbinarynode = class(tunarynode)
-          right : tnode;
-          constructor create(t:tnodetype;l,r : tnode);
-          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
-          destructor destroy;override;
-          procedure ppuwrite(ppufile:tcompilerppufile);override;
-          procedure buildderefimpl;override;
-          procedure derefimpl;override;
-          procedure derefnode;override;
-          procedure concattolist(l : tlinkedlist);override;
-          function ischild(p : tnode) : boolean;override;
-          function docompare(p : tnode) : boolean;override;
-          procedure swapleftright;
-          function dogetcopy : tnode;override;
-          procedure insertintolist(l : tnodelist);override;
-          procedure left_right_max;
-          procedure printnodedata(var t:text);override;
-          procedure printnodelist(var t:text);
-       end;
-
-       ptertiarynode = ^ttertiarynode;
-       ttertiarynode = class(tbinarynode)
-          third : tnode;
-          constructor create(_t:tnodetype;l,r,t : tnode);
-          constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
-          destructor destroy;override;
-          procedure ppuwrite(ppufile:tcompilerppufile);override;
-          procedure buildderefimpl;override;
-          procedure derefimpl;override;
-          procedure derefnode;override;
-          procedure concattolist(l : tlinkedlist);override;
-          function ischild(p : tnode) : boolean;override;
-          function docompare(p : tnode) : boolean;override;
-          function dogetcopy : tnode;override;
-          procedure insertintolist(l : tnodelist);override;
-          procedure printnodedata(var t:text);override;
-       end;
-
-       tbinopnode = class(tbinarynode)
-          constructor create(t:tnodetype;l,r : tnode);virtual;
-          function docompare(p : tnode) : boolean;override;
-       end;
+         { For a t1:=t2 tree, mark the part of the tree t1 that gets
+           written to (normally the loadnode) as write access. }
+         procedure mark_write;virtual;
+         { dermines the number of necessary temp. locations to evaluate
+           the node }
+         procedure det_temp;virtual;abstract;
+
+         procedure pass_generate_code;virtual;abstract;
+
+         { comparing of nodes }
+         function isequal(p : tnode) : boolean;
+         { to implement comparisation, override this method }
+         function docompare(p : tnode) : boolean;virtual;
+         { wrapper for getcopy }
+         function getcopy : tnode;
+
+         { does the real copying of a node }
+         function dogetcopy : tnode;virtual;
+
+         procedure insertintolist(l : tnodelist);virtual;
+         { writes a node for debugging purpose, shouldn't be called }
+         { direct, because there is no test for nil, use printnode  }
+         { to write a complete tree }
+         procedure printnodeinfo(var t:text);virtual;
+         procedure printnodedata(var t:text);virtual;
+         procedure printnodetree(var t:text);virtual;
+         procedure concattolist(l : tlinkedlist);virtual;
+         function ischild(p : tnode) : boolean;virtual;
+      end;
+
+      tnodeclass = class of tnode;
+
+      tnodeclassarray = array[tnodetype] of tnodeclass;
+
+      { this node is the anchestor for all nodes with at least   }
+      { one child, you have to use it if you want to use         }
+      { true- and current_procinfo.CurrFalseLabel                                     }
+      punarynode = ^tunarynode;
+      tunarynode = class(tnode)
+         left : tnode;
+         constructor create(t:tnodetype;l : tnode);
+         constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
+         destructor destroy;override;
+         procedure ppuwrite(ppufile:tcompilerppufile);override;
+         procedure buildderefimpl;override;
+         procedure derefimpl;override;
+         procedure derefnode;override;
+         procedure concattolist(l : tlinkedlist);override;
+         function ischild(p : tnode) : boolean;override;
+         function docompare(p : tnode) : boolean;override;
+         function dogetcopy : tnode;override;
+         procedure insertintolist(l : tnodelist);override;
+         procedure left_max;
+         procedure printnodedata(var t:text);override;
+      end;
+
+      pbinarynode = ^tbinarynode;
+      tbinarynode = class(tunarynode)
+         right : tnode;
+         constructor create(t:tnodetype;l,r : tnode);
+         constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
+         destructor destroy;override;
+         procedure ppuwrite(ppufile:tcompilerppufile);override;
+         procedure buildderefimpl;override;
+         procedure derefimpl;override;
+         procedure derefnode;override;
+         procedure concattolist(l : tlinkedlist);override;
+         function ischild(p : tnode) : boolean;override;
+         function docompare(p : tnode) : boolean;override;
+         procedure swapleftright;
+         function dogetcopy : tnode;override;
+         procedure insertintolist(l : tnodelist);override;
+         procedure left_right_max;
+         procedure printnodedata(var t:text);override;
+         procedure printnodelist(var t:text);
+      end;
+
+      ptertiarynode = ^ttertiarynode;
+      ttertiarynode = class(tbinarynode)
+         third : tnode;
+         constructor create(_t:tnodetype;l,r,t : tnode);
+         constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
+         destructor destroy;override;
+         procedure ppuwrite(ppufile:tcompilerppufile);override;
+         procedure buildderefimpl;override;
+         procedure derefimpl;override;
+         procedure derefnode;override;
+         procedure concattolist(l : tlinkedlist);override;
+         function ischild(p : tnode) : boolean;override;
+         function docompare(p : tnode) : boolean;override;
+         function dogetcopy : tnode;override;
+         procedure insertintolist(l : tnodelist);override;
+         procedure printnodedata(var t:text);override;
+      end;
+
+      tbinopnode = class(tbinarynode)
+         constructor create(t:tnodetype;l,r : tnode);virtual;
+         function docompare(p : tnode) : boolean;override;
+      end;
 
     var
       { array with all class types for tnodes }
@@ -443,6 +446,7 @@ interface
     procedure printnodeindent;
     procedure printnodeunindent;
     procedure printnode(var t:text;n:tnode);
+    procedure printnode(n:tnode);
 
     function is_constnode(p : tnode) : boolean;
     function is_constintnode(p : tnode) : boolean;
@@ -614,6 +618,12 @@ implementation
       end;
 
 
+    procedure printnode(n:tnode);
+      begin
+        printnode(output,n);
+      end;
+
+
     function is_constnode(p : tnode) : boolean;
       begin
         is_constnode:=(p.nodetype in [niln,ordconstn,realconstn,stringconstn,setconstn,guidconstn]);

compiler/nutils.pas

@@ -313,6 +313,31 @@ implementation
       end;
 
 
+    function get_local_or_para_sym(const aname:string):tsym;
+      var
+        pd : tprocdef;
+      begin
+        { we can't use searchsym here, because the
+          symtablestack is not fully setup when pass1
+          is run for nested procedures }
+        pd:=current_procinfo.procdef;
+        repeat
+          result := tsym(pd.localst.Find(aname));
+          if assigned(result) then
+            break;
+          result := tsym(pd.parast.Find(aname));
+          if assigned(result) then
+            break;
+          { try the parent of a nested function }
+          if assigned(pd.owner.defowner) and
+             (pd.owner.defowner.typ=procdef) then
+            pd:=tprocdef(pd.owner.defowner)
+          else
+            break;
+        until false;
+      end;
+
+
     function load_high_value_node(vs:tparavarsym):tnode;
       var
         srsym : tsym;
@@ -332,13 +357,13 @@ implementation
     function load_self_node:tnode;
       var
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
         result:=nil;
-        searchsym('self',srsym,srsymtable);
+
+        srsym:=get_local_or_para_sym('self');
         if assigned(srsym) then
           begin
-            result:=cloadnode.create(srsym,srsymtable);
+            result:=cloadnode.create(srsym,srsym.owner);
             include(result.flags,nf_is_self);
           end
         else
@@ -353,12 +378,11 @@ implementation
     function load_result_node:tnode;
       var
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
         result:=nil;
-        searchsym('result',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('result');
         if assigned(srsym) then
-          result:=cloadnode.create(srsym,srsymtable)
+          result:=cloadnode.create(srsym,srsym.owner)
         else
           begin
             result:=cerrornode.create;
@@ -371,13 +395,12 @@ implementation
     function load_self_pointer_node:tnode;
       var
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
         result:=nil;
-        searchsym('self',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('self');
         if assigned(srsym) then
           begin
-            result:=cloadnode.create(srsym,srsymtable);
+            result:=cloadnode.create(srsym,srsym.owner);
             include(result.flags,nf_load_self_pointer);
           end
         else
@@ -392,12 +415,11 @@ implementation
     function load_vmt_pointer_node:tnode;
       var
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
         result:=nil;
-        searchsym('vmt',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('vmt');
         if assigned(srsym) then
-          result:=cloadnode.create(srsym,srsymtable)
+          result:=cloadnode.create(srsym,srsym.owner)
         else
           begin
             result:=cerrornode.create;

compiler/optbase.pas

@@ -0,0 +1,45 @@
+{
+    Basic node optimizer stuff
+
+    Copyright (c) 2007 by Florian Klaempfl
+
+    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 optbase;
+
+{$i fpcdefs.inc}
+
+  interface
+
+    uses
+      globtype;
+
+    type
+      tdfaset = array of byte;
+
+      toptinfo = record
+        { index of the current node inside the dfa sets, aword(-1) if no entry }
+        index : aword;
+        defined_nodes : tdfaset;
+        used_nodes : tdfaset;
+      end;
+
+      poptinfo = ^toptinfo;
+
+  implementation
+
+end.

compiler/optcse.pas

@@ -23,14 +23,177 @@ unit optcse;
 
 {$i fpcdefs.inc}
 
+{ $define csedebug}
+
   interface
 
-    procedure docse(rootnode : tnode);
+    uses
+      node;
+
+    function do_optcse(var rootnode : tnode) : tnode;
 
   implementation
 
-    procedure docse(rootnode : tnode);
+    uses
+      globtype,
+      cclasses,
+      nutils,
+      nbas,nld,
+      pass_1,
+      symtype,symdef;
+
+    const
+      cseinvariant : set of tnodetype = [loadn,addn,muln,subn,divn,slashn,modn,andn,orn,xorn,notn,vecn,
+        derefn,equaln,unequaln,ltn,gtn,lten,gten,typeconvn,subscriptn,
+        inn,symdifn,shrn,shln,ordconstn,realconstn,unaryminusn,pointerconstn,stringconstn,setconstn,
+        isn,asn,starstarn,nothingn];
+
+    function searchsubdomain(var n:tnode; arg: pointer) : foreachnoderesult;
+      begin
+        if not(n.nodetype in cseinvariant) then
+          begin
+            pboolean(arg)^:=false;
+            result:=fen_norecurse_true;
+          end
+        else
+          result:=fen_true;
+      end;
+
+    type
+      tlists = record
+        nodelist : tfplist;
+        locationlist : tfplist;
+      end;
+
+      plists = ^tlists;
+
+    function collectnodes(var n:tnode; arg: pointer) : foreachnoderesult;
+      begin
+        { node worth to add? }
+        if (node_complexity(n)>1) and (tstoreddef(n.resultdef).is_intregable or tstoreddef(n.resultdef).is_fpuregable) then
+          begin
+            plists(arg)^.nodelist.Add(n);
+            plists(arg)^.locationlist.Add(@n);
+            result:=fen_false;
+          end
+        else
+          result:=fen_norecurse_false;
+      end;
+
+
+    function searchcsedomain(var n: tnode; arg: pointer) : foreachnoderesult;
+      var
+        csedomain : boolean;
+        lists : tlists;
+        templist : tfplist;
+        i,j : longint;
+        def : tstoreddef;
+        nodes : tblocknode;
+        creates,
+        statements : tstatementnode;
+        hp : ttempcreatenode;
+      begin
+        result:=fen_false;
+        if n.nodetype in cseinvariant then
+          begin
+            csedomain:=true;
+            foreachnodestatic(pm_postprocess,n,@searchsubdomain,@csedomain);
+            { found a cse domain }
+            if csedomain then
+              begin
+                statements:=nil;
+                result:=fen_norecurse_true;
+{$ifdef csedebug}
+                writeln('============ cse domain ==================');
+                printnode(output,n);
+{$endif csedebug}
+
+                lists.nodelist:=tfplist.create;
+                lists.locationlist:=tfplist.create;
+                foreachnodestatic(pm_postprocess,n,@collectnodes,@lists);
+
+                templist:=tfplist.create;
+                templist.count:=lists.nodelist.count;
+
+                { this is poorly coded, just comparing every node with all other nodes }
+                for i:=0 to lists.nodelist.count-1 do
+                  for j:=i+1 to lists.nodelist.count-1 do
+                    begin
+                      if tnode(lists.nodelist[i]).isequal(tnode(lists.nodelist[j])) then
+                        begin
+                          if not(assigned(statements)) then
+                            begin
+                              nodes:=internalstatements(statements);
+                              addstatement(statements,internalstatements(creates));
+                            end;
+{$ifdef csedebug}
+                          writeln('    ====     ');
+                          printnode(output,tnode(lists.nodelist[i]));
+                          writeln('    equals   ');
+                          printnode(output,tnode(lists.nodelist[j]));
+                          writeln('    ====     ');
+{$endif csedebug}
+
+                          def:=tstoreddef(tnode(lists.nodelist[i]).resultdef);
+                          if assigned(templist[i])  then
+                            begin
+                              templist[j]:=templist[i];
+                              pnode(lists.locationlist[j])^.free;
+                              pnode(lists.locationlist[j])^:=ctemprefnode.create(ttempcreatenode(templist[j]));
+                              do_firstpass(pnode(lists.locationlist[j])^);
+                            end
+                          else
+                            begin
+                              templist[i]:=ctempcreatenode.create(def,def.size,tt_persistent,
+                                def.is_intregable or def.is_fpuregable);
+                              addstatement(creates,tnode(templist[i]));
+
+                              { properties can't be passed by var }
+                              hp:=ttempcreatenode(templist[i]);
+                              do_firstpass(tnode(hp));
+
+                              addstatement(statements,cassignmentnode.create(ctemprefnode.create(ttempcreatenode(templist[i])),
+                                tnode(lists.nodelist[i])));
+                              pnode(lists.locationlist[i])^:=ctemprefnode.create(ttempcreatenode(templist[i]));
+                              do_firstpass(pnode(lists.locationlist[i])^);
+
+                              templist[j]:=templist[i];
+
+                              pnode(lists.locationlist[j])^.free;
+                              pnode(lists.locationlist[j])^:=ctemprefnode.create(ttempcreatenode(templist[j]));
+                              do_firstpass(pnode(lists.locationlist[j])^);
+{$ifdef csedebug}
+                              printnode(output,statements);
+{$endif csedebug}
+                            end;
+                        end;
+                    end;
+                if assigned(statements) then
+                  begin
+                    addstatement(statements,n);
+                    n:=nodes;
+                    do_firstpass(n);
+{$ifdef csedebug}
+                    printnode(output,nodes);
+{$endif csedebug}
+                  end;
+{$ifdef csedebug}
+                writeln('nodes: ',lists.nodelist.count);
+                writeln('==========================================');
+{$endif csedebug}
+                lists.nodelist.free;
+                lists.locationlist.free;
+                templist.free;
+              end
+          end;
+      end;
+
+
+    function do_optcse(var rootnode : tnode) : tnode;
       begin
+        foreachnodestatic(pm_postprocess,rootnode,@searchcsedomain,nil);
+        result:=nil;
+(*
         { create a linear list of nodes }
 
         { create hash values }
@@ -47,7 +210,7 @@ unit optcse;
             j:=i+1;
             { collect equal nodes }
             while (j<=nodelist.length-1) and
-              nodelist[i].docompare(nodelist[j]) do
+              nodelist[i].isequal(nodelist[j]) do
               inc(j);
             dec(j);
             if j>i then
@@ -74,6 +237,7 @@ unit optcse;
                   delete the temp. }
               end;
           end;
+*)
       end;
 
 end.

compiler/options.pas

@@ -2141,9 +2141,6 @@ begin
   def_system_macro('CPU87');
   def_system_macro('CPU386');
 {$endif}
-{$ifdef m68k}
-  def_system_macro('CPU68');
-{$endif}
 
 { new processor stuff }
 {$ifdef i386}
@@ -2155,6 +2152,7 @@ begin
   def_system_macro('FPC_HAS_RESOURCES');
 {$endif}
 {$ifdef m68k}
+  def_system_macro('CPU68');
   def_system_macro('CPU68K');
   def_system_macro('CPUM68K');
   def_system_macro('CPU32');

compiler/optunrol.pas

@@ -106,7 +106,7 @@ unit optunrol;
                 for i:=1 to unrolls do
                   begin
                     { create and insert copy of the statement block }
-                    addstatement(unrollstatement,tfornode(tfornode(node).t2).getcopy);
+                    addstatement(unrollstatement,tfornode(node).t2.getcopy);
 
                     { set and insert entry label? }
                     if (counts mod unrolls<>0) and

compiler/sparc/ncpucnv.pas

@@ -55,7 +55,7 @@ interface
 implementation
 
    uses
-      verbose,globals,systems,
+      verbose,globals,systems,globtype,
       symconst,symdef,aasmbase,aasmtai,aasmdata,
       defutil,
       cgbase,cgutils,pass_1,pass_2,

compiler/sparc/ncpuinln.pas

@@ -44,7 +44,7 @@ interface
 implementation
 
     uses
-      systems,
+      systems,globtype,
       cutils,verbose,
       symconst,symdef,
       aasmtai,aasmdata,aasmcpu,

compiler/symconst.pas

@@ -460,7 +460,8 @@ type
     dbg_state_unused,
     dbg_state_used,
     dbg_state_writing,
-    dbg_state_written
+    dbg_state_written,
+    dbg_state_queued
   );
 
 

compiler/symtable.pas

@@ -1620,7 +1620,7 @@ implementation
       begin
         result:=false;
         hashedid.id:=s;
-        if assigned(current_procinfo.procdef) then
+        if assigned(current_procinfo) and assigned(current_procinfo.procdef) then
           currentclassh:=current_procinfo.procdef._class
         else
           currentclassh:=nil;

compiler/systems.pas

@@ -143,6 +143,7 @@ interface
              system_x86_64_darwin       { 61 }
        );
 
+     type
        tasm = (as_none
              ,as_gas                   { standard gnu assembler }
              ,as_i386_as_aout
@@ -378,9 +379,10 @@ interface
        system_all_windows = [system_i386_win32,system_x86_64_win64,system_ia64_win64,
                              system_arm_wince,system_i386_wince];
 
+       { all darwin systems }
        systems_darwin = [system_powerpc_darwin,system_i386_darwin,
                          system_powerpc64_darwin,system_x86_64_darwin];
-				     
+
        { all systems supporting exports from programs or units }
        system_unit_program_exports = [system_i386_win32,
                                          system_i386_wdosx,

rtl/amiga/m68k/utilf.inc

@@ -1,8 +1,8 @@
 {
     This file is part of the Free Pascal run time library.
-    Copyright (c) 2006 by Karoly Balogh
 
-    utility.library functions for AmigaOS 4.x/PowerPC
+    utility functions for AmigaOS/m68k
+    Copyright (c) 2007 Karoly Balogh
 
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -14,6 +14,152 @@
  **********************************************************************}
 
 
-procedure Amiga2Date(date_amiga: longword; cd: PClockData); syscall IUtility 172;
-function CheckDate(date: PClockData): longword; syscall IUtility 176;
-function Date2Amiga(date: PClockData): longword; syscall IUtility 180;
+function FindTagItem(tagVal : Cardinal location 'd0';
+                     tagList: PTagItem location 'a0'): PTagItem;
+SysCall AOS_UtilityBase 030;
+
+function GetTagData(tagValue  : Cardinal location 'd0';
+                    defaultVal: Cardinal location 'd1';
+                    tagList   : PTagItem location 'a0'): Cardinal;
+SysCall AOS_UtilityBase 036;
+
+function PackBoolTags(initialFlags: Cardinal location 'd0';
+                      tagList     : PTagItem location 'a0';
+                      boolMap     : PTagItem location 'a1'): Cardinal;
+SysCall AOS_UtilityBase 042;
+
+function NextTagItem(tagListPtr: pPTagItem location 'a0'): PTagItem;
+SysCall AOS_UtilityBase 048;
+
+procedure FilterTagChanges(changeList  : PTagItem location 'a0';
+                           originalList: PTagItem location 'a1';
+                           apply       : Cardinal location 'd0');
+SysCall AOS_UtilityBase 054;
+
+procedure MapTags(tagList: PTagItem location 'a0';
+                  mapList: PTagItem location 'a1';
+                  mapType: Cardinal location 'd0');
+SysCall AOS_UtilityBase 060;
+
+function AllocateTagItems(numTags: Cardinal location 'd0'): PTagItem;
+SysCall AOS_UtilityBase 066;
+
+function CloneTagItems(tagList: PTagItem location 'a0'): PTagItem;
+SysCall AOS_UtilityBase 072;
+
+procedure FreeTagItems(tagList: PTagItem location 'a0');
+SysCall AOS_UtilityBase 078;
+
+procedure RefreshTagItemClones(clone   : PTagItem location 'a0';
+                               original: PTagItem location 'a1');
+SysCall AOS_UtilityBase 084;
+
+function TagInArray(tagValue    : Cardinal location 'd0';
+                    var tagArray: Cardinal location 'a0'): Boolean;
+SysCall AOS_UtilityBase 090;
+
+function FilterTagItems(tagList        : PTagItem location 'a0';
+                        var filterArray: Cardinal location 'a1';
+                        logic          : Cardinal location 'd0'): Cardinal;
+SysCall AOS_UtilityBase 096;
+
+function CallHookPkt(hook       : PHook   location 'a0';
+                     hobject    : Pointer location 'a2';
+                     paramPacket: Pointer location 'a1'): Cardinal;
+SysCall AOS_UtilityBase 102;
+
+procedure Amiga2Date(seconds: Cardinal   location 'd0';
+                     result : PClockData location 'a0');
+SysCall AOS_UtilityBase 120;
+
+function Date2Amiga(date: PClockData location 'a0'): Cardinal;
+SysCall AOS_UtilityBase 126;
+
+function CheckDate(date: PClockData location 'a0'): Cardinal;
+SysCall AOS_UtilityBase 132;
+
+function SMult32(arg1: LongInt location 'd0';
+                 arg2: LongInt location 'd1'): LongInt;
+SysCall AOS_UtilityBase 138;
+
+function UMult32(arg1: Cardinal location 'd0';
+                 arg2: Cardinal location 'd1'): Cardinal;
+SysCall AOS_UtilityBase 144;
+
+function SDivMod32(dividend: LongInt location 'd0';
+                    divisor: LongInt location 'd1'): LongInt;
+SysCall AOS_UtilityBase 150;
+
+function UDivMod32(dividend: Cardinal location 'd0';
+                   divisor : Cardinal location 'd1'): Cardinal;
+SysCall AOS_UtilityBase 156;
+
+function Stricmp(string1: PChar location 'a0';
+                 string2: PChar location 'a1'): LongInt;
+SysCall AOS_UtilityBase 162;
+
+function Strnicmp(string1: PChar   location 'a0';
+                  string2: PChar   location 'a1';
+                  length : LongInt location 'd0'): LongInt;
+SysCall AOS_UtilityBase 168;
+
+function ToUpper(character: Cardinal location 'd0'): Char;
+SysCall AOS_UtilityBase 174;
+
+function ToLower(character: Cardinal location 'd0'): Char;
+SysCall AOS_UtilityBase 180;
+
+procedure ApplyTagChanges(list      : PTagItem location 'a0';
+                          changeList: PTagItem location 'a1');
+SysCall AOS_UtilityBase 186;
+
+function SMult64(arg1: LongInt location 'd0';
+                 arg2: LongInt location 'd1'): LongInt;
+SysCall AOS_UtilityBase 198;
+
+function UMult64(arg1: Cardinal location 'd0';
+                 arg2: Cardinal location 'd1'): Cardinal;
+SysCall AOS_UtilityBase 204;
+
+function PackStructureTags(pack         : Pointer  location 'a0';
+                           var packTable: Cardinal location 'a1';
+                           tagList      : PTagItem location 'a2'): Cardinal;
+SysCall AOS_UtilityBase 210;
+
+function UnpackStructureTags(pack         : Pointer  location 'a0';
+                             var packTable: Cardinal location 'a1';
+                             tagList      : PTagItem location 'a2'): Cardinal;
+SysCall AOS_UtilityBase 216;
+
+function AddNamedObject(nameSpace: PNamedObject location 'a0';
+                        nobject  : PNamedObject location 'a1'): Boolean;
+SysCall AOS_UtilityBase 222;
+
+function AllocNamedObjectA(name   : PChar    location 'a0';
+                           tagList: PTagItem location 'a1'): PNamedObject;
+SysCall AOS_UtilityBase 228;
+
+function AttemptRemNamedObject(nobject: PNamedObject location 'a0'): LongInt;
+SysCall AOS_UtilityBase 234;
+
+function FindNamedObject(nameSpace : PNamedObject location 'a0';
+                         name      : PChar        location 'a1';
+                         lastObject: PNamedObject location 'a2'): PNamedObject;
+SysCall AOS_UtilityBase 240;
+
+procedure FreeNamedObject(nobject: PNamedObject location 'a0');
+SysCall AOS_UtilityBase 246;
+
+function NamedObjectName(nobject: PNamedObject location 'a0'): PChar;
+SysCall AOS_UtilityBase 252;
+
+procedure ReleaseNamedObject(nobject: pNamedObject location 'a0');
+SysCall AOS_UtilityBase 258;
+
+procedure RemNamedObject(nobject: PNamedObject location 'a0';
+                         message: PMessage     location 'a1');
+SysCall AOS_UtilityBase 264;
+
+function GetUniqueID: Cardinal;
+SysCall AOS_UtilityBase 270;
+

rtl/amiga/system.pp

@@ -93,7 +93,6 @@ implementation
 {$define FPC_SYSTEM_HAS_extractFloat64Frac0}
 {$define FPC_SYSTEM_HAS_extractFloat64Frac1}
 {$define FPC_SYSTEM_HAS_extractFloat64Exp}
-{$define FPC_SYSTEM_HAS_extractFloat64Frac}
 {$define FPC_SYSTEM_HAS_extractFloat64Sign}
 {$define FPC_SYSTEM_HAS_ExtractFloat32Frac}
 {$define FPC_SYSTEM_HAS_extractFloat32Exp}

rtl/inc/softfpu.pp

@@ -131,7 +131,6 @@ TYPE
     high: bits32;
   end;
 
-
   int64rec = packed record
     low: bits32;
     high: bits32;
@@ -147,13 +146,13 @@ TYPE
     high : qword;
   end;
 {$else}
- float64 = packed record
-   high,low : bits32;
- end;
+  float64 = packed record
+    high,low : bits32;
+  end;
 
- int64rec = packed record
-   high,low : bits32;
- end;
+  int64rec = packed record
+    high,low : bits32;
+  end;
 
   floatx80 = packed record
     high : word;

rtl/inc/systemh.inc

@@ -130,11 +130,13 @@ Type
 {$endif CPUX86_64}
 
 {$ifdef CPUM68K}
-  ValReal = Real;
+  {$define DEFAULT_DOUBLE}
 
   {$define SUPPORT_SINGLE}
   {$define SUPPORT_DOUBLE}
 
+  ValReal = Real;
+
   { Comp type does not exist on fpu }
   Comp    = int64;
   PComp = ^Comp;
@@ -899,4 +901,3 @@ const
 {$ifdef fpdocsystem}
 {$i system.fpd}
 {$endif}
-

tests/test/units/system/tval.inc

@@ -1,262 +1,262 @@
-
-{ Included by several source with different
-  definitions of the type
-  IntegerType
-  to check that the test is working for
-  all basic integer types }
-
-
-procedure TestVal(comment,s : string; ExpectedRes : ValTestType; expected : IntegerType);
-var
-  i : IntegerType;
-  err,err1 : word;
-  OK : boolean;
-begin
-  OK:=false;
-  if not silent and (Comment<>'') then
-    Writeln(Comment);
-  Val(s,i,err);
-  if ExpectedRes=ValShouldFail then
-    begin
-      if err=0 then
-        begin
-          if not silent or not HasErrors then
-            Writeln('Error: string ',Display(s),
-              ' is a valid input for val function');
-          HasErrors:=true;
-        end
-      else
-        begin
-          OK:=true;
-          if not silent then
-            Writeln('Correct: string ',Display(s),
-              ' is a not valid input for val function');
-        end;
-    end
-  else if ExpectedRes=ValShouldSucceed then
-    begin
-      if err=0 then
-        begin
-          OK:=true;
-          if not silent then
-            Writeln('Correct: string ',Display(s),
-              ' is a valid input for val function');
-        end
-      else
-        begin
-          if not silent or not HasErrors then
-            Writeln('Error: string ',Display(s),
-              ' is a not valid input for val function',
-              ' error pos=',err);
-          HasErrors:=true;
-        end;
-    end
-  else if ExpectedRes=ValShouldSucceedAfterRemovingTrail then
-    begin
-      if err=0 then
-        begin
-          if not silent or not HasErrors then
-            Writeln('Error: string ',Display(s),
-              ' is a valid input for val function');
-          HasErrors:=true;
-        end
-      else
-        begin
-          err1:=err;
-          Val(Copy(s,1,err1-1),i,err);
-          if err=0 then
-            begin
-              OK:=true;
-              if not silent then
-                Writeln('Correct: string ',Display(s),
-                  ' is a valid input for val function up to position ',err1);
-            end
-          else
-            begin
-              if not silent or not HasErrors then
-                Writeln('Error: string ',Display(Copy(s,1,err1-1)),
-                  ' is a not valid input for val function',
-                  ' error pos=',err);
-              HasErrors:=true;
-            end;
-        end;
-    end;
-  if (err=0) and CheckVal and (i<>expected) then
-    begin
-      OK:=false;
-      if not silent or not HasErrors then
-        Writeln('Error: string ',Display(s),
-          ' value is ',i,' <> ',expected);
-      HasErrors:=true;
-    end;
-  if OK then
-    inc(SuccessCount)
-  else
-    inc(FailCount);
-end;
-
-Procedure TestBase(Const Prefix : string;ValidChars : TCharSet);
-var
-  i,j : longint;
-  st : string;
-begin
-  CheckVal:=false;
-  Silent:=true;
-  for i:=0 to 255 do
-    begin
-      st:=prefix+chr(i);
-      if chr(i) in ValidChars then
-        TestVal('',st,ValShouldSucceed,0)
-      else
-        TestVal('',st,ValShouldFail,0);
-    end;
-  for i:=0 to 255 do
-    for j:=0 to 255 do
-      begin
-        st:=prefix+chr(i)+chr(j);
-        if (chr(i) in ValidChars) and
-           (chr(j) in ValidChars) then
-          TestVal('',st,ValShouldSucceed,0)
-        else
-          begin
-            if ((prefix<>'') or
-               (not (chr(i) in SpecialCharsFirst))) and
-                not (chr(j) in SpecialCharsSecond) then
-              TestVal('',st,ValShouldFail,0);
-          end;
-      end;
-end;
-
-
-Function TestAll : boolean;
-
-var
-  S : string;
-begin
-  TestVal('Testing empty string','',ValShouldFail,0);
-  TestVal('Testing string with #0',#0,ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','0x',ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','x',ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','X',ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','$',ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','%',ValShouldFail,0);
-  TestVal('Testing string with base prefix and no value','&',ValShouldFail,0);
-  TestVal('Testing string with base prefix and #0','0x'#0,ValShouldFail,0);
-  TestVal('Testing normal ''''0'''' string','0',ValShouldSucceed,0);
-  TestVal('Testing leading space',' 0',ValShouldSucceed,0);
-  TestVal('Testing leading 2 spaces','  0',ValShouldSucceed,0);
-  TestVal('Testing leading 2 tabs',#9#9'0',ValShouldSucceed,0);
-  TestVal('Testing leading 3 spaces','   0',ValShouldSucceed,0);
-  TestVal('Testing leading 3 tabs',#9#9#9'0',ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination',#9' 0',ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination',' '#9'0',ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination',' '#9' 0',ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination',#9' '#9' 0',ValShouldSucceed,0);
-  TestVal('Testing #0 following normal ''''0''','0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading space with trailing #0',' 0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading 2 spaces with trailing #0','  0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading 2 tabs with trailing #0',#9#9'0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading 3 spaces with trailing #0','   0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading 3 tabs with trailing #0',#9#9#9'0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination with trailing #0',#9' 0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination with trailing #0',' '#9'0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination with trailing #0',' '#9' 0'#0,ValShouldSucceed,0);
-  TestVal('Testing leading space/tab combination with trailing #0',#9' '#9' 0'#0,ValShouldSucceed,0);
-  TestVal('Testing trailing space','0 ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing 2 spaces','0  ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing 2 tabs','0'#9#9,ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing 3 spaces','0   ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing 3 tabs','0'#9#9#9,ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing space/tab combination','0'#9' ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing space/tab combination','0 '#9,ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing space/tab combination','0 '#9' ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing trailing space/tab combination','0'#9' '#9' ',ValShouldSucceedAfterRemovingTrail,0);
-  TestVal('Testing several zeroes',' 00'#0,ValShouldSucceed,0);
-  TestVal('Testing normal zero','0',ValShouldSucceed,0);
-  TestVal('Testing several zeroes','00',ValShouldSucceed,0);
-  TestVal('Testing normal zero with leading space',' 0',ValShouldSucceed,0);
-  TestVal('Testing several zeroes with leading space',' 00',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','0x0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','x0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','X0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','$0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','%0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and zero','&0',ValShouldSucceed,0);
-  TestVal('Testing string with base prefix and one','0x1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and one','x1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and one','X1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and one','$1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and one','%1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and one','&1',ValShouldSucceed,1);
-  TestVal('Testing string with base prefix and two','0x2',ValShouldSucceed,2);
-  TestVal('Testing string with base prefix and two','x2',ValShouldSucceed,2);
-  TestVal('Testing string with base prefix and two','X2',ValShouldSucceed,2);
-  TestVal('Testing string with base prefix and two','$2',ValShouldSucceed,2);
-  TestVal('Testing string with base prefix and two','%2',ValShouldFail,0);
-  TestVal('Testing string with base prefix and two','&2',ValShouldSucceed,2);
-  TestVal('Testing string with base prefix and seven','0x7',ValShouldSucceed,7);
-  TestVal('Testing string with base prefix and seven','x7',ValShouldSucceed,7);
-  TestVal('Testing string with base prefix and seven','X7',ValShouldSucceed,7);
-  TestVal('Testing string with base prefix and seven','$7',ValShouldSucceed,7);
-  TestVal('Testing string with base prefix and seven','%7',ValShouldFail,0);
-  TestVal('Testing string with base prefix and seven','&7',ValShouldSucceed,7);
-  TestVal('Testing string with base prefix and eight','0x8',ValShouldSucceed,8);
-  TestVal('Testing string with base prefix and eight','x8',ValShouldSucceed,8);
-  TestVal('Testing string with base prefix and eight','X8',ValShouldSucceed,8);
-  TestVal('Testing string with base prefix and eight','$8',ValShouldSucceed,8);
-  TestVal('Testing string with base prefix and eight','%8',ValShouldFail,0);
-  TestVal('Testing string with base prefix and eight','&8',ValShouldFail,0);
-  TestVal('Testing string with base prefix and nine','0x9',ValShouldSucceed,9);
-  TestVal('Testing string with base prefix and nine','x9',ValShouldSucceed,9);
-  TestVal('Testing string with base prefix and nine','X9',ValShouldSucceed,9);
-  TestVal('Testing string with base prefix and nine','$9',ValShouldSucceed,9);
-  TestVal('Testing string with base prefix and nine','%9',ValShouldFail,0);
-  TestVal('Testing string with base prefix and nine','&9',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "a"','0xa',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "a"','xa',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "a"','Xa',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "a"','$a',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "a"','%a',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "a"','&a',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "A"','0xA',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "A"','xA',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "A"','XA',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "A"','$A',ValShouldSucceed,10);
-  TestVal('Testing string with base prefix and "A"','%A',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "A"','&A',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "f"','0xf',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "f"','xf',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "f"','Xf',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "f"','$f',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "f"','%f',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "f"','&f',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "F"','0xF',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "F"','xF',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "F"','XF',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "F"','$F',ValShouldSucceed,15);
-  TestVal('Testing string with base prefix and "F"','%F',ValShouldFail,0);
-  TestVal('Testing string with base prefix and "F"','&F',ValShouldFail,0);
-
-  TestVal('Testing -zero','-0',ValShouldSucceed,0);
-  TestVal('Testing +zero','+0',ValShouldSucceed,0);
-  TestVal('Testing - zero','- 0',ValShouldFail,0);
-  TestVal('Testing + zero','+ 0',ValShouldFail,0);
-  TestVal('Testing --zero','--0',ValShouldFail,0);
-  TestVal('Testing ++zero','++0',ValShouldFail,0);
-  TestVal('Testing -+zero','-+0',ValShouldFail,0);
-
-  TestBase('%', ValidNumeralsBase2);
-  TestBase('&', ValidNumeralsBase8);
-  TestBase('', ValidNumeralsBase10);
-  TestBase('0x', ValidNumeralsBase16);
-
-  if HasErrors then
-    begin
-      Writeln(FailCount,' tests failed over ',SuccessCount+FailCount);
-    end
-  else
-    Writeln('All tests succeeded count=',SuccessCount);
-  TestAll:=HasErrors;
-
-end;
-
+
+{ Included by several source with different
+  definitions of the type
+  IntegerType
+  to check that the test is working for
+  all basic integer types }
+
+
+procedure TestVal(comment,s : string; ExpectedRes : ValTestType; expected : IntegerType);
+var
+  i : IntegerType;
+  err,err1 : word;
+  OK : boolean;
+begin
+  OK:=false;
+  if not silent and (Comment<>'') then
+    Writeln(Comment);
+  Val(s,i,err);
+  if ExpectedRes=ValShouldFail then
+    begin
+      if err=0 then
+        begin
+          if not silent or not HasErrors then
+            Writeln('Error: string ',Display(s),
+              ' is a valid input for val function');
+          HasErrors:=true;
+        end
+      else
+        begin
+          OK:=true;
+          if not silent then
+            Writeln('Correct: string ',Display(s),
+              ' is a not valid input for val function');
+        end;
+    end
+  else if ExpectedRes=ValShouldSucceed then
+    begin
+      if err=0 then
+        begin
+          OK:=true;
+          if not silent then
+            Writeln('Correct: string ',Display(s),
+              ' is a valid input for val function');
+        end
+      else
+        begin
+          if not silent or not HasErrors then
+            Writeln('Error: string ',Display(s),
+              ' is a not valid input for val function',
+              ' error pos=',err);
+          HasErrors:=true;
+        end;
+    end
+  else if ExpectedRes=ValShouldSucceedAfterRemovingTrail then
+    begin
+      if err=0 then
+        begin
+          if not silent or not HasErrors then
+            Writeln('Error: string ',Display(s),
+              ' is a valid input for val function');
+          HasErrors:=true;
+        end
+      else
+        begin
+          err1:=err;
+          Val(Copy(s,1,err1-1),i,err);
+          if err=0 then
+            begin
+              OK:=true;
+              if not silent then
+                Writeln('Correct: string ',Display(s),
+                  ' is a valid input for val function up to position ',err1);
+            end
+          else
+            begin
+              if not silent or not HasErrors then
+                Writeln('Error: string ',Display(Copy(s,1,err1-1)),
+                  ' is a not valid input for val function',
+                  ' error pos=',err);
+              HasErrors:=true;
+            end;
+        end;
+    end;
+  if (err=0) and CheckVal and (i<>expected) then
+    begin
+      OK:=false;
+      if not silent or not HasErrors then
+        Writeln('Error: string ',Display(s),
+          ' value is ',i,' <> ',expected);
+      HasErrors:=true;
+    end;
+  if OK then
+    inc(SuccessCount)
+  else
+    inc(FailCount);
+end;
+
+Procedure TestBase(Const Prefix : string;ValidChars : TCharSet);
+var
+  i,j : longint;
+  st : string;
+begin
+  CheckVal:=false;
+  Silent:=true;
+  for i:=0 to 255 do
+    begin
+      st:=prefix+chr(i);
+      if chr(i) in ValidChars then
+        TestVal('',st,ValShouldSucceed,0)
+      else
+        TestVal('',st,ValShouldFail,0);
+    end;
+  for i:=0 to 255 do
+    for j:=0 to 255 do
+      begin
+        st:=prefix+chr(i)+chr(j);
+        if (chr(i) in ValidChars) and
+           (chr(j) in ValidChars) then
+          TestVal('',st,ValShouldSucceed,0)
+        else
+          begin
+            if ((prefix<>'') or
+               (not (chr(i) in SpecialCharsFirst))) and
+                not (chr(j) in SpecialCharsSecond) then
+              TestVal('',st,ValShouldFail,0);
+          end;
+      end;
+end;
+
+
+Function TestAll : boolean;
+
+var
+  S : string;
+begin
+  TestVal('Testing empty string','',ValShouldFail,0);
+  TestVal('Testing string with #0',#0,ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','0x',ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','x',ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','X',ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','$',ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','%',ValShouldFail,0);
+  TestVal('Testing string with base prefix and no value','&',ValShouldFail,0);
+  TestVal('Testing string with base prefix and #0','0x'#0,ValShouldFail,0);
+  TestVal('Testing normal ''''0'''' string','0',ValShouldSucceed,0);
+  TestVal('Testing leading space',' 0',ValShouldSucceed,0);
+  TestVal('Testing leading 2 spaces','  0',ValShouldSucceed,0);
+  TestVal('Testing leading 2 tabs',#9#9'0',ValShouldSucceed,0);
+  TestVal('Testing leading 3 spaces','   0',ValShouldSucceed,0);
+  TestVal('Testing leading 3 tabs',#9#9#9'0',ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination',#9' 0',ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination',' '#9'0',ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination',' '#9' 0',ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination',#9' '#9' 0',ValShouldSucceed,0);
+  TestVal('Testing #0 following normal ''''0''','0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading space with trailing #0',' 0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading 2 spaces with trailing #0','  0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading 2 tabs with trailing #0',#9#9'0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading 3 spaces with trailing #0','   0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading 3 tabs with trailing #0',#9#9#9'0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination with trailing #0',#9' 0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination with trailing #0',' '#9'0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination with trailing #0',' '#9' 0'#0,ValShouldSucceed,0);
+  TestVal('Testing leading space/tab combination with trailing #0',#9' '#9' 0'#0,ValShouldSucceed,0);
+  TestVal('Testing trailing space','0 ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing 2 spaces','0  ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing 2 tabs','0'#9#9,ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing 3 spaces','0   ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing 3 tabs','0'#9#9#9,ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing space/tab combination','0'#9' ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing space/tab combination','0 '#9,ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing space/tab combination','0 '#9' ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing trailing space/tab combination','0'#9' '#9' ',ValShouldSucceedAfterRemovingTrail,0);
+  TestVal('Testing several zeroes',' 00'#0,ValShouldSucceed,0);
+  TestVal('Testing normal zero','0',ValShouldSucceed,0);
+  TestVal('Testing several zeroes','00',ValShouldSucceed,0);
+  TestVal('Testing normal zero with leading space',' 0',ValShouldSucceed,0);
+  TestVal('Testing several zeroes with leading space',' 00',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','0x0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','x0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','X0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','$0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','%0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and zero','&0',ValShouldSucceed,0);
+  TestVal('Testing string with base prefix and one','0x1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and one','x1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and one','X1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and one','$1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and one','%1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and one','&1',ValShouldSucceed,1);
+  TestVal('Testing string with base prefix and two','0x2',ValShouldSucceed,2);
+  TestVal('Testing string with base prefix and two','x2',ValShouldSucceed,2);
+  TestVal('Testing string with base prefix and two','X2',ValShouldSucceed,2);
+  TestVal('Testing string with base prefix and two','$2',ValShouldSucceed,2);
+  TestVal('Testing string with base prefix and two','%2',ValShouldFail,0);
+  TestVal('Testing string with base prefix and two','&2',ValShouldSucceed,2);
+  TestVal('Testing string with base prefix and seven','0x7',ValShouldSucceed,7);
+  TestVal('Testing string with base prefix and seven','x7',ValShouldSucceed,7);
+  TestVal('Testing string with base prefix and seven','X7',ValShouldSucceed,7);
+  TestVal('Testing string with base prefix and seven','$7',ValShouldSucceed,7);
+  TestVal('Testing string with base prefix and seven','%7',ValShouldFail,0);
+  TestVal('Testing string with base prefix and seven','&7',ValShouldSucceed,7);
+  TestVal('Testing string with base prefix and eight','0x8',ValShouldSucceed,8);
+  TestVal('Testing string with base prefix and eight','x8',ValShouldSucceed,8);
+  TestVal('Testing string with base prefix and eight','X8',ValShouldSucceed,8);
+  TestVal('Testing string with base prefix and eight','$8',ValShouldSucceed,8);
+  TestVal('Testing string with base prefix and eight','%8',ValShouldFail,0);
+  TestVal('Testing string with base prefix and eight','&8',ValShouldFail,0);
+  TestVal('Testing string with base prefix and nine','0x9',ValShouldSucceed,9);
+  TestVal('Testing string with base prefix and nine','x9',ValShouldSucceed,9);
+  TestVal('Testing string with base prefix and nine','X9',ValShouldSucceed,9);
+  TestVal('Testing string with base prefix and nine','$9',ValShouldSucceed,9);
+  TestVal('Testing string with base prefix and nine','%9',ValShouldFail,0);
+  TestVal('Testing string with base prefix and nine','&9',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "a"','0xa',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "a"','xa',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "a"','Xa',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "a"','$a',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "a"','%a',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "a"','&a',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "A"','0xA',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "A"','xA',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "A"','XA',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "A"','$A',ValShouldSucceed,10);
+  TestVal('Testing string with base prefix and "A"','%A',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "A"','&A',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "f"','0xf',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "f"','xf',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "f"','Xf',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "f"','$f',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "f"','%f',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "f"','&f',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "F"','0xF',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "F"','xF',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "F"','XF',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "F"','$F',ValShouldSucceed,15);
+  TestVal('Testing string with base prefix and "F"','%F',ValShouldFail,0);
+  TestVal('Testing string with base prefix and "F"','&F',ValShouldFail,0);
+
+//  TestVal('Testing -zero','-0',ValShouldSucceed,0);
+  TestVal('Testing +zero','+0',ValShouldSucceed,0);
+  TestVal('Testing - zero','- 0',ValShouldFail,0);
+  TestVal('Testing + zero','+ 0',ValShouldFail,0);
+  TestVal('Testing --zero','--0',ValShouldFail,0);
+  TestVal('Testing ++zero','++0',ValShouldFail,0);
+  TestVal('Testing -+zero','-+0',ValShouldFail,0);
+
+  TestBase('%', ValidNumeralsBase2);
+  TestBase('&', ValidNumeralsBase8);
+  TestBase('', ValidNumeralsBase10);
+  TestBase('0x', ValidNumeralsBase16);
+
+  if HasErrors then
+    begin
+      Writeln(FailCount,' tests failed over ',SuccessCount+FailCount);
+    end
+  else
+    Writeln('All tests succeeded count=',SuccessCount);
+  TestAll:=HasErrors;
+
+end;
+

tests/webtbs/tw9059.pp

@@ -1,3 +1,4 @@
+{ %version=2.3 }
 { %opt=-Oodfa -vw -Sew}
 program DoesNotSeemToBeInited;