Browse Source

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 -

peter 18 years ago
parent
commit
5a73be13e7

+ 2 - 1
.gitattributes

@@ -280,6 +280,7 @@ compiler/ogcoff.pas svneol=native#text/plain
 compiler/ogelf.pas svneol=native#text/plain
 compiler/ogelf.pas svneol=native#text/plain
 compiler/oglx.pas svneol=native#text/plain
 compiler/oglx.pas svneol=native#text/plain
 compiler/ogmap.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/optcse.pas svneol=native#text/plain
 compiler/options.pas svneol=native#text/plain
 compiler/options.pas svneol=native#text/plain
 compiler/opttail.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/tstring.pp svneol=native#text/plain
 tests/test/units/system/ttrig.pas 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/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/tval.pp -text
 tests/test/units/system/tval1.pp -text
 tests/test/units/system/tval1.pp -text
 tests/test/units/system/tval2.pp -text
 tests/test/units/system/tval2.pp -text

+ 8 - 1
compiler/aasmtai.pas

@@ -2301,6 +2301,10 @@ implementation
        begin
        begin
           inherited Create;
           inherited Create;
           typ:=ait_align;
           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
           if b in [1,2,4,8,16,32] then
             aligntype := b
             aligntype := b
           else
           else
@@ -2369,5 +2373,8 @@ implementation
 
 
 begin
 begin
   cai_cpu:=tai_cpu_abstract;
   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.
 end.

+ 8 - 4
compiler/cgobj.pas

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

+ 25 - 2
compiler/dbgstabs.pas

@@ -271,7 +271,7 @@ implementation
 
 
         { Stab must already be written, or we must be busy writing it }
         { Stab must already be written, or we must be busy writing it }
         if writing_def_stabs and
         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);
           internalerror(200403091);
 
 
         { Keep track of used stabs, this info is only usefull for stabs
         { Keep track of used stabs, this info is only usefull for stabs
@@ -904,6 +904,29 @@ implementation
               insertdef(list,tenumdef(def).basedef);
               insertdef(list,tenumdef(def).basedef);
           objectdef :
           objectdef :
             begin
             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);
               insertdef(list,vmtarraytype);
               if assigned(tobjectdef(def).ImplementedInterfaces) then
               if assigned(tobjectdef(def).ImplementedInterfaces) then
                 for i:=0 to tobjectdef(def).ImplementedInterfaces.Count-1 do
                 for i:=0 to tobjectdef(def).ImplementedInterfaces.Count-1 do
@@ -970,7 +993,7 @@ implementation
            for i:=0 to st.DefList.Count-1 do
            for i:=0 to st.DefList.Count-1 do
              begin
              begin
                def:=tdef(st.DefList[i]);
                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);
                  insertdef(list,def);
              end;
              end;
          end;
          end;

+ 1 - 2
compiler/i386/n386add.pas

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

+ 2 - 2
compiler/m68k/cpuinfo.pas

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

+ 3 - 3
compiler/ncgset.pas

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

+ 164 - 154
compiler/node.pas

@@ -30,7 +30,8 @@ interface
        globtype,globals,
        globtype,globals,
        cpubase,cgbase,cgutils,
        cpubase,cgbase,cgutils,
        aasmbase,
        aasmbase,
-       symtype;
+       symtype,
+       optbase;
 
 
     type
     type
        tnodetype = (
        tnodetype = (
@@ -262,165 +263,167 @@ interface
        tnodelist = class
        tnodelist = class
        end;
        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}
 {$ifdef SUPPORT_MMX}
-          registersmmx  : longint;
+         registersmmx  : longint;
 {$endif SUPPORT_MMX}
 {$endif SUPPORT_MMX}
-          resultdef     : tdef;
-          resultdefderef : tderef;
-          fileinfo      : tfileposinfo;
-          localswitches : tlocalswitches;
+         resultdef     : tdef;
+         resultdefderef : tderef;
+         fileinfo      : tfileposinfo;
+         localswitches : tlocalswitches;
+         optinfo : poptinfo;
 {$ifdef extdebug}
 {$ifdef extdebug}
-          maxfirstpasscount,
-          firstpasscount : longint;
+         maxfirstpasscount,
+         firstpasscount : longint;
 {$endif extdebug}
 {$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}
 {$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}
 {$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
     var
       { array with all class types for tnodes }
       { array with all class types for tnodes }
@@ -443,6 +446,7 @@ interface
     procedure printnodeindent;
     procedure printnodeindent;
     procedure printnodeunindent;
     procedure printnodeunindent;
     procedure printnode(var t:text;n:tnode);
     procedure printnode(var t:text;n:tnode);
+    procedure printnode(n:tnode);
 
 
     function is_constnode(p : tnode) : boolean;
     function is_constnode(p : tnode) : boolean;
     function is_constintnode(p : tnode) : boolean;
     function is_constintnode(p : tnode) : boolean;
@@ -614,6 +618,12 @@ implementation
       end;
       end;
 
 
 
 
+    procedure printnode(n:tnode);
+      begin
+        printnode(output,n);
+      end;
+
+
     function is_constnode(p : tnode) : boolean;
     function is_constnode(p : tnode) : boolean;
       begin
       begin
         is_constnode:=(p.nodetype in [niln,ordconstn,realconstn,stringconstn,setconstn,guidconstn]);
         is_constnode:=(p.nodetype in [niln,ordconstn,realconstn,stringconstn,setconstn,guidconstn]);

+ 34 - 12
compiler/nutils.pas

@@ -313,6 +313,31 @@ implementation
       end;
       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;
     function load_high_value_node(vs:tparavarsym):tnode;
       var
       var
         srsym : tsym;
         srsym : tsym;
@@ -332,13 +357,13 @@ implementation
     function load_self_node:tnode;
     function load_self_node:tnode;
       var
       var
         srsym : tsym;
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
       begin
         result:=nil;
         result:=nil;
-        searchsym('self',srsym,srsymtable);
+
+        srsym:=get_local_or_para_sym('self');
         if assigned(srsym) then
         if assigned(srsym) then
           begin
           begin
-            result:=cloadnode.create(srsym,srsymtable);
+            result:=cloadnode.create(srsym,srsym.owner);
             include(result.flags,nf_is_self);
             include(result.flags,nf_is_self);
           end
           end
         else
         else
@@ -353,12 +378,11 @@ implementation
     function load_result_node:tnode;
     function load_result_node:tnode;
       var
       var
         srsym : tsym;
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
       begin
         result:=nil;
         result:=nil;
-        searchsym('result',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('result');
         if assigned(srsym) then
         if assigned(srsym) then
-          result:=cloadnode.create(srsym,srsymtable)
+          result:=cloadnode.create(srsym,srsym.owner)
         else
         else
           begin
           begin
             result:=cerrornode.create;
             result:=cerrornode.create;
@@ -371,13 +395,12 @@ implementation
     function load_self_pointer_node:tnode;
     function load_self_pointer_node:tnode;
       var
       var
         srsym : tsym;
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
       begin
         result:=nil;
         result:=nil;
-        searchsym('self',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('self');
         if assigned(srsym) then
         if assigned(srsym) then
           begin
           begin
-            result:=cloadnode.create(srsym,srsymtable);
+            result:=cloadnode.create(srsym,srsym.owner);
             include(result.flags,nf_load_self_pointer);
             include(result.flags,nf_load_self_pointer);
           end
           end
         else
         else
@@ -392,12 +415,11 @@ implementation
     function load_vmt_pointer_node:tnode;
     function load_vmt_pointer_node:tnode;
       var
       var
         srsym : tsym;
         srsym : tsym;
-        srsymtable : TSymtable;
       begin
       begin
         result:=nil;
         result:=nil;
-        searchsym('vmt',srsym,srsymtable);
+        srsym:=get_local_or_para_sym('vmt');
         if assigned(srsym) then
         if assigned(srsym) then
-          result:=cloadnode.create(srsym,srsymtable)
+          result:=cloadnode.create(srsym,srsym.owner)
         else
         else
           begin
           begin
             result:=cerrornode.create;
             result:=cerrornode.create;

+ 45 - 0
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.

+ 167 - 3
compiler/optcse.pas

@@ -23,14 +23,177 @@ unit optcse;
 
 
 {$i fpcdefs.inc}
 {$i fpcdefs.inc}
 
 
+{ $define csedebug}
+
   interface
   interface
 
 
-    procedure docse(rootnode : tnode);
+    uses
+      node;
+
+    function do_optcse(var rootnode : tnode) : tnode;
 
 
   implementation
   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
       begin
+        foreachnodestatic(pm_postprocess,rootnode,@searchcsedomain,nil);
+        result:=nil;
+(*
         { create a linear list of nodes }
         { create a linear list of nodes }
 
 
         { create hash values }
         { create hash values }
@@ -47,7 +210,7 @@ unit optcse;
             j:=i+1;
             j:=i+1;
             { collect equal nodes }
             { collect equal nodes }
             while (j<=nodelist.length-1) and
             while (j<=nodelist.length-1) and
-              nodelist[i].docompare(nodelist[j]) do
+              nodelist[i].isequal(nodelist[j]) do
               inc(j);
               inc(j);
             dec(j);
             dec(j);
             if j>i then
             if j>i then
@@ -74,6 +237,7 @@ unit optcse;
                   delete the temp. }
                   delete the temp. }
               end;
               end;
           end;
           end;
+*)
       end;
       end;
 
 
 end.
 end.

+ 1 - 3
compiler/options.pas

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

+ 1 - 1
compiler/optunrol.pas

@@ -106,7 +106,7 @@ unit optunrol;
                 for i:=1 to unrolls do
                 for i:=1 to unrolls do
                   begin
                   begin
                     { create and insert copy of the statement block }
                     { 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? }
                     { set and insert entry label? }
                     if (counts mod unrolls<>0) and
                     if (counts mod unrolls<>0) and

+ 1 - 1
compiler/sparc/ncpucnv.pas

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

+ 1 - 1
compiler/sparc/ncpuinln.pas

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

+ 2 - 1
compiler/symconst.pas

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

+ 1 - 1
compiler/symtable.pas

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

+ 3 - 1
compiler/systems.pas

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

+ 151 - 5
rtl/amiga/m68k/utilf.inc

@@ -1,8 +1,8 @@
 {
 {
     This file is part of the Free Pascal run time library.
     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,
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
     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;
+

+ 0 - 1
rtl/amiga/system.pp

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

+ 6 - 7
rtl/inc/softfpu.pp

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

+ 3 - 2
rtl/inc/systemh.inc

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

+ 262 - 262
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;
+

+ 1 - 0
tests/webtbs/tw9059.pp

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