Merged revisions 6810,6999,7015,7123,7197,7305,7382,7390,7401,7409,7423,7487,7494,7500 via svnmerge from

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

........
r6810 | florian | 2007-03-12 21:04:27 +0100 (Mon, 12 Mar 2007) | 2 lines

* test fixed, hopefully

........
r6999 | daniel | 2007-03-25 17:30:07 +0200 (Sun, 25 Mar 2007) | 2 lines

  + Test for open arrays.

........
r7015 | jonas | 2007-03-28 15:42:18 +0200 (Wed, 28 Mar 2007) | 3 lines

  * made less complex for sparc so it compiles there too without running
    out of registers

........
r7123 | pierre | 2007-04-17 17:39:28 +0200 (Tue, 17 Apr 2007) | 1 line

 * test val input
........
r7197 | daniel | 2007-04-29 21:19:16 +0200 (Sun, 29 Apr 2007) | 2 lines

  + Meteor benchmark

........
r7305 | peter | 2007-05-10 18:54:40 +0200 (Thu, 10 May 2007) | 2 lines

  * new test

........
r7382 | peter | 2007-05-17 22:28:24 +0200 (Thu, 17 May 2007) | 2 lines

   * new test

........
r7390 | pierre | 2007-05-18 16:18:44 +0200 (Fri, 18 May 2007) | 1 line

 * improve Run Comparison
........
r7401 | jonas | 2007-05-20 10:54:10 +0200 (Sun, 20 May 2007) | 2 lines

  * test now fails under FPC

........
r7409 | peter | 2007-05-21 09:54:18 +0200 (Mon, 21 May 2007) | 2 lines

  * new tests

........
r7423 | peter | 2007-05-22 22:55:28 +0200 (Tue, 22 May 2007) | 2 lines

  * new test

........
r7487 | jonas | 2007-05-27 12:57:24 +0200 (Sun, 27 May 2007) | 2 lines

  + some more property assignment tests (which already/still work)

........
r7494 | peter | 2007-05-28 13:59:10 +0200 (Mon, 28 May 2007) | 2 lines

  * multiple fpc version support for shootout

........
r7500 | peter | 2007-05-28 18:10:15 +0200 (Mon, 28 May 2007) | 2 lines

  * new implementation

........

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

.gitattributes

@@ -5409,6 +5409,7 @@ tests/bench/drystone.pas svneol=native#text/plain
 tests/bench/pi.c -text
 tests/bench/pi.pp svneol=native#text/plain
 tests/bench/shootout/README.txt svneol=native#text/plain
+tests/bench/shootout/fpascal2.diff svneol=native#text/plain
 tests/bench/shootout/io/binarytrees-output.txt svneol=native#text/plain
 tests/bench/shootout/io/knucleotide-output.txt svneol=native#text/plain
 tests/bench/shootout/io/moments.in -text
@@ -5459,9 +5460,11 @@ tests/bench/shootout/obsolete/takfp.pp svneol=native#text/plain
 tests/bench/shootout/obsolete/wc.pp svneol=native#text/plain
 tests/bench/shootout/src/bench.c -text
 tests/bench/shootout/src/binarytrees.pp svneol=native#text/plain
+tests/bench/shootout/src/chameneos.pp svneol=native#text/plain
 tests/bench/shootout/src/hello.pp svneol=native#text/plain
 tests/bench/shootout/src/knucleotide.pp svneol=native#text/plain
 tests/bench/shootout/src/mandelbrot.pp svneol=native#text/plain
+tests/bench/shootout/src/meteorshower.pp svneol=native#text/x-pascal
 tests/bench/shootout/src/nsieve.pp svneol=native#text/plain
 tests/bench/shootout/src/partialsums.pp svneol=native#text/plain
 tests/bench/shootout/src/recursive.pp svneol=native#text/plain
@@ -6806,6 +6809,7 @@ tests/test/tprocext.pp svneol=native#text/plain
 tests/test/tprocvar1.pp svneol=native#text/plain
 tests/test/tprocvar2.pp svneol=native#text/plain
 tests/test/tprocvar3.pp svneol=native#text/plain
+tests/test/tprop.pp svneol=native#text/plain
 tests/test/tprop1.pp svneol=native#text/plain
 tests/test/tprop2.pp svneol=native#text/plain
 tests/test/trange1.pp svneol=native#text/plain
@@ -7978,6 +7982,7 @@ tests/webtbs/tw5094.pp svneol=native#text/plain
 tests/webtbs/tw5100.pp svneol=native#text/plain
 tests/webtbs/tw5100a.pp svneol=native#text/plain
 tests/webtbs/tw5641.pp svneol=native#text/plain
+tests/webtbs/tw5800.pp svneol=native#text/plain
 tests/webtbs/tw5896.pp svneol=native#text/plain
 tests/webtbs/tw6129.pp svneol=native#text/plain
 tests/webtbs/tw6184.pp svneol=native#text/plain
@@ -8060,6 +8065,7 @@ tests/webtbs/tw8140f.pp svneol=native#text/plain
 tests/webtbs/tw8140g.pp svneol=native#text/plain
 tests/webtbs/tw8140h.pp svneol=native#text/plain
 tests/webtbs/tw8141.pp svneol=native#text/plain
+tests/webtbs/tw8144.pp svneol=native#text/plain
 tests/webtbs/tw8145.pp svneol=native#text/plain
 tests/webtbs/tw8148.pp svneol=native#text/plain
 tests/webtbs/tw8150a.pp svneol=native#text/plain
@@ -8071,9 +8077,12 @@ tests/webtbs/tw8156.pp svneol=native#text/plain
 tests/webtbs/tw8171.pp svneol=native#text/plain
 tests/webtbs/tw8172.pp svneol=native#text/plain
 tests/webtbs/tw8177.pp svneol=native#text/plain
+tests/webtbs/tw8177a.pp -text
 tests/webtbs/tw8180.pp svneol=native#text/plain
 tests/webtbs/tw8183.pp svneol=native#text/plain
 tests/webtbs/tw8187.pp svneol=native#text/plain
+tests/webtbs/tw8195a.pp svneol=native#text/plain
+tests/webtbs/tw8195b.pp svneol=native#text/plain
 tests/webtbs/tw8199.pp svneol=native#text/plain
 tests/webtbs/tw8222.pp svneol=native#text/plain
 tests/webtbs/tw8222a.pp svneol=native#text/plain
@@ -8094,11 +8103,13 @@ tests/webtbs/tw8434.pp svneol=native#text/plain
 tests/webtbs/tw8462.pp svneol=native#text/plain
 tests/webtbs/tw8465.pp svneol=native#text/plain
 tests/webtbs/tw8513.pp svneol=native#text/plain
+tests/webtbs/tw8523.pp svneol=native#text/plain
 tests/webtbs/tw8573.pp svneol=native#text/plain
 tests/webtbs/tw8615.pp svneol=native#text/plain
 tests/webtbs/tw8633.pp svneol=native#text/plain
 tests/webtbs/tw8660.pp svneol=native#text/plain
 tests/webtbs/tw8664.pp svneol=native#text/plain
+tests/webtbs/tw8677.pp svneol=native#text/plain
 tests/webtbs/tw8685.pp svneol=native#text/plain
 tests/webtbs/tw8757.pp svneol=native#text/plain
 tests/webtbs/tw8810.pp svneol=native#text/plain

tests/bench/shootout/README.txt

@@ -15,4 +15,19 @@ log       Logs from shootout tests on website.
 io        Input and expected output files for some tests.
 
 
+Files:
+fpascal2.diff   Patch for shootout CVS checkout to add a second FPC release for
+                comparison with 2 FPC versions
 
+Running shootout tip:
+
+If you want to run the tests for FPC and GCC don't forget to include a * in front of the name
+otherwise it will not newer revisions (called benchmark.lang-#.lang) of some benchmarks
+
+To run multiple languages use:
+
+make SELECT_LANGS='{*fpascal,*fpascal2,*gcc}' clean plot
+
+to run a single language don't use the { }:
+
+make SELECT_LANGS='*fpascal' clean plot

tests/bench/shootout/fpascal2.diff

@@ -0,0 +1,156 @@
+Index: Make.header
+===================================================================
+RCS file: /cvsroot/shootout/shootout/Make.header,v
+retrieving revision 1.95
+diff -u -r1.95 Make.header
+--- Make.header	18 May 2007 03:09:48 -0000	1.95
++++ Make.header	28 May 2007 10:36:22 -0000
+@@ -26,6 +26,7 @@
+ ERLANG := /usr/bin/erl
+ FELIX := /usr/bin/flx
+ FPASCAL := /usr/bin/fpc
++FPASCAL2 := /usr/bin/fpc2
+ G95 := /usr/bin/g95
+ GFORTRAN := /usr/bin/gfortran
+ GAWK := /usr/bin/gawk
+@@ -113,7 +114,7 @@
+ XEMACS := /usr/bin/xemacs
+ 
+ LANGS := $(BASH) $(BIGLOO) $(CHICKEN) $(CIAOC) $(CLM) $(CMUCL) $(CURRY) $(CYCLONE) \
+-	 $(DLANG) $(ERLANG) $(FELIX) $(FPASCAL) $(G95) $(GFORTRAN) \
++	 $(DLANG) $(ERLANG) $(FELIX) $(FPASCAL) $(FPASCAL2) $(G95) $(GFORTRAN) \
+ 	 $(GAWK) $(GCC) $(GCL) $(GCJ) $(GFORTH) $(GHC) $(GPC) $(GST) $(GUILE) \
+ 	 $(GWYDION) $(GXX) $(HUGS) $(ICON) $(ICPP) $(IFC) $(IO) $(IRON) $(GIJ) \
+ 	 $(JAVA14) $(JAVA15) $(KAFFE) $(JAVASCRIPT) $(LUA) $(MAWK) $(MERCURY) \
+Index: Minibench.conf
+===================================================================
+RCS file: /cvsroot/shootout/shootout/Minibench.conf,v
+retrieving revision 1.101
+diff -u -r1.101 Minibench.conf
+--- Minibench.conf	18 May 2007 03:09:48 -0000	1.101
++++ Minibench.conf	28 May 2007 10:36:22 -0000
+@@ -6,7 +6,7 @@
+ tabdir       data
+ 
+ automake     bigloo,chicken,ciao,clean,cmucl,csharp,curry,cyc,dlang,erlang,
+-automake     felix,fpascal,g95,gpp,gcc,gcj,gcl,gfortran,ghc,gij,gnat,gpc,
++automake     felix,fpascal,fpascal2,g95,gpp,gcc,gcj,gcl,gfortran,ghc,gij,gnat,gpc,
+ automake     gprolog,gwydion,hipe,hugs,icc,icon,icpp,ifc,iron,java,java14,javaxint,
+ automake     javaclient,kaffe,mercury,mlton,mzscheme,mzc,
+ automake     nhc98,nice,objc,ocaml,ocamlb,ooc,oz,parrot,pike,poly,python,psyco,
+Index: langs.pl
+===================================================================
+RCS file: /cvsroot/shootout/shootout/langs.pl,v
+retrieving revision 1.100
+diff -u -r1.100 langs.pl
+--- langs.pl	1 May 2007 20:43:32 -0000	1.100
++++ langs.pl	28 May 2007 10:36:22 -0000
+@@ -932,6 +932,22 @@
+        },
+      },
+ 
++     fpascal2 =>
++     { Lang => 'Pascal2',
++       Name => 'Free Pascal',
++       Status => '+',
++       Home => 'http://www.freepascal.org',
++       Down => 'http://www.freepascal.org/download.html',
++       Type => 'native compiled',
++       Note => 'Structured programming plus objects',
++       Ext  => 'pas',
++       Verfun => sub {
++           my $ver = `$ENV{FPASCAL2} -i`;
++	   $ver =~ /(Free Pascal.*version [\d\.]+)/;
++	   return $1;
++       },
++     },
++
+      php =>
+      { Lang => 'PHP',
+        Home => 'http://www.php.net/',
+Index: bench/Makefile.mb
+===================================================================
+RCS file: /cvsroot/shootout/shootout/bench/Makefile.mb,v
+retrieving revision 1.148
+diff -u -r1.148 Makefile.mb
+--- bench/Makefile.mb	8 Apr 2007 06:17:43 -0000	1.148
++++ bench/Makefile.mb	28 May 2007 10:36:22 -0000
+@@ -23,6 +23,7 @@
+ DLANGOPTS := -O -inline -release $(DLANGOPTS)
+ FLXOPTS := -c --optimize --static
+ FPCOPTS := -XX -Xs -O3p3r -Fi../../Include/fpascal -Fu../../Include/fpascal -I../../Include/fpascal $(FPCOPTS)
++FPC2OPTS := -XX -Xs -O3 -Fi../../Include/fpascal -Fu../../Include/fpascal -I../../Include/fpascal $(FPC2OPTS)
+ G95OPTS := -pipe -Wall $(COPTS) $(G95OPTS)
+ GCCOPTS := -pipe -Wall $(COPTS) $(GCCOPTS)
+ GCJOPTS := $(COPTS) $(GCJOPTS)
+@@ -665,6 +666,15 @@
+ 	-mv FPASCAL_RUN $@
+ 	-@rm -f $*.o
+ 
++%.pas: $(MB_SRCDIR)/%.fpascal2 $(FPASCAL2)
++	-cp $< $@
++
++%.fpascal2_run: %.pas
++	-@rm -f $@ 
++	-$(FPASCAL2) $(FPC2OPTS) -oFPASCAL_RUN $<
++	-mv FPASCAL_RUN $@
++	-@rm -f $*.o
++
+ ########################################
+ # gpc (GNU Pascal Compiler)
+ ########################################
+Index: bench/hello/Minibench.conf
+===================================================================
+RCS file: /cvsroot/shootout/shootout/bench/hello/Minibench.conf,v
+retrieving revision 1.76
+diff -u -r1.76 Minibench.conf
+--- bench/hello/Minibench.conf	18 May 2007 03:09:48 -0000	1.76
++++ bench/hello/Minibench.conf	28 May 2007 10:36:23 -0000
+@@ -2,7 +2,7 @@
+ #
+ 
+ automake     bigloo,chicken,ciao,clean,cmucl,csharp,cyc,dlang,erlang,felix,
+-automake     fpascal,g95,gfortran,gpp,gcc,gcj,gcl,ghc,gij,gnat,gprolog,gwydion,hipe,hugs,
++automake     fpascal,fpascal2,g95,gfortran,gpp,gcc,gcj,gcl,ghc,gij,gnat,gprolog,gwydion,hipe,hugs,
+ automake     icon,icc,icpp,ifc,iron,java,java14,javaxint,javaclient,kaffe,mercury,
+ automake     mlton,mzc,nhc98,nice,oberon2,objc,ocaml,ocamlb,ooc,oz,parrot,pike,
+ automake     python,poly,psyco,rep,sablevm,sbcl,scala,se,smlnj,stalin,swiprolog,
+@@ -27,6 +27,7 @@
+ commandline  gwydion: repeat %A ./%X
+ commandline  felix: repeat %A %X
+ commandline  fpascal: repeat %A %X
++commandline  fpascal2: repeat %A %X
+ commandline  erlang: repeat %A $ERLANG $ERLFLAGS -noinput -run %T main
+ commandline  gawk: repeat %A $GAWK -f ../%X
+ commandline  g95: repeat %A %X
+Index: bench/lists/Minibench.conf
+===================================================================
+RCS file: /cvsroot/shootout/shootout/bench/lists/Minibench.conf,v
+retrieving revision 1.29
+diff -u -r1.29 Minibench.conf
+--- bench/lists/Minibench.conf	3 Nov 2006 15:16:11 -0000	1.29
++++ bench/lists/Minibench.conf	28 May 2007 10:36:23 -0000
+@@ -6,7 +6,7 @@
+ tabdir       data
+ 
+ automake     bigloo,chicken,ciao,clean,cmucl,csharp,curry,cyc,dlang,erlang,
+-automake     felix,fpascal,g95,gfortran,gpp,gcc,gcj,gcl,ghc,gij,gnat,gprolog,
++automake     felix,fpascal,fpascal2,g95,gfortran,gpp,gcc,gcj,gcl,ghc,gij,gnat,gprolog,
+ automake     gwydion,hipe,hugs,icon,icc,icpp,iron,java,java14,kaffe,mercury,mlton,
+ automake     mzc,nhc98,nice,oberon2,objc,ocaml,ocamlb,ooc,oz,poly,python,psyco,
+ automake     rep,sablevm,sbcl,scala,se,smlnj,stalin,tcc,xds,xemacs,njs
+Index: bin/make_links
+===================================================================
+RCS file: /cvsroot/shootout/shootout/bin/make_links,v
+retrieving revision 1.11
+diff -u -r1.11 make_links
+--- bin/make_links	6 Oct 2006 17:00:29 -0000	1.11
++++ bin/make_links	28 May 2007 10:36:24 -0000
+@@ -11,6 +11,7 @@
+ 
+    cmucl =>    [ 'sbcl', 'gcl' ],
+    erlang =>   [ 'hipe' ],
++   fpascal =>  [ 'fpascal2' ],
+    ghc =>      [ 'nhc98', 'hugs' ],
+    gcc =>      [ 'icc', 'tcc' ],
+    gpp =>      [ 'icpp' ],

tests/bench/shootout/src/chameneos.pp

@@ -0,0 +1,139 @@
+{ The Computer Language Shootout
+  http://shootout.alioth.debian.org
+  contributed by Marc Weustink
+}
+program chameneos;
+{$mode objfpc}{$h-}
+uses
+  PThreads;
+
+type
+  TColor = (Blue, Red, Yellow, Faded);
+
+var
+  waitfirst,
+  waitsecond   : TSemaphore;
+  first,second : TColor;
+  MeetingsLeft : Integer;
+  ThreadInfo   : array[0..3] of record
+    Id: TThreadId;
+    StartColor: TColor;
+    Count: Integer;
+  end;
+
+
+function Complement(c1,c2:TColor):TColor;
+begin
+  if c2=Faded then
+    begin
+      result:=Faded;
+      exit;
+    end;
+  if c1=c2 then
+    begin
+      result:=c1;
+      exit;
+    end;
+  case c1 of
+    Blue :
+      if c2=Red then
+        result:=Yellow
+      else
+        result:=Red;
+    Red :
+      if c2=Blue then
+        result:=Yellow
+      else
+        result:=Blue;
+    Yellow :
+      if c2=Blue then
+        result:=Red
+      else
+        result:=Blue;
+    else
+      result:=c1;
+  end;
+end;
+
+
+function OtherCreaturesColor(me:TColor):TColor;
+const
+  firstcall : boolean = true;
+begin
+  result:=Faded;
+  sem_wait(waitfirst);
+
+  if firstCall then
+    begin
+      if MeetingsLeft>0 then
+        begin
+          first:=me;
+          firstcall:=false;
+          sem_post(waitfirst);
+          sem_wait(waitsecond);
+          result:=second;
+          dec(MeetingsLeft);
+        end;
+      sem_post(waitfirst);
+    end
+  else
+    begin
+      firstcall:=true;
+      second:=me;
+      result:=first;
+      sem_post(waitsecond);
+    end;
+end;
+
+
+function ThreadFunc(AIndex: PtrInt): Pointer; cdecl;
+var
+  Meetings : Integer;
+  me,other : TColor;
+begin
+  me := ThreadInfo[AIndex].StartColor;
+  Meetings := 0;
+
+  while (me<>Faded) do
+    begin
+      other:=OtherCreaturesColor(me);
+      if other=Faded then
+        break;
+      inc(Meetings);
+      me:=Complement(me,other);
+    end;
+
+  ThreadInfo[AIndex].Count := Meetings;
+  result:=nil;
+end;
+
+
+const
+  COLOR: array[0..3] of TColor = (Blue, Red, Yellow, Blue);
+
+var
+  n: Integer;
+  Attr: TThreadAttr;
+  p: Pointer;
+begin
+  Val(paramstr(1), MeetingsLeft, n);
+  if n <> 0 then exit;
+
+  sem_init(waitfirst,0,1);
+  sem_init(waitsecond,0,0);
+
+  pthread_attr_init(Attr);
+  pthread_attr_setdetachstate(Attr, 0);
+  pthread_attr_setstacksize(Attr, 1024 * 16);
+
+  for n := 0 to 3 do begin
+    ThreadInfo[n].Count := 0;
+    ThreadInfo[n].StartColor := COLOR[n];
+    pthread_create(ThreadInfo[n].Id, Attr, TStartRoutine(@ThreadFunc), Pointer(n));
+  end;
+
+  for n := 0 to 3 do
+    pthread_join(ThreadInfo[n].Id, p);
+
+  WriteLN(ThreadInfo[0].Count + ThreadInfo[1].Count + ThreadInfo[2].Count + ThreadInfo[3].Count);
+end.

tests/bench/shootout/src/meteorshower.pp

@@ -0,0 +1,887 @@
+program meteorshower;
+
+{Shootout Meteor puzzle implementation
+
+ by Daniel Mantione
+
+ mostly based on Ben St. John's implementation.}
+
+{$Q-}
+
+uses dos;
+
+const N_COL = 5;
+      N_ROW = 10;
+      N_CELL = N_COL * N_ROW;
+      N_PIECE_TYPE = 10;
+
+      N_ELEM=5;
+      N_ORIENT=12;
+      ALL_PIECE_MASK=[0..N_PIECE_TYPE-1];
+      SKIP_PIECE=5;
+
+      no_piece=high(byte);
+
+      L_EDGE_MASK=[0,5,10,15,20,25,30];
+      R_EDGE_MASK=[4,9,14,19,24,29];
+      TOP_ROW    = [0*N_COL..1*N_COL-1];
+      SECOND_ROW = [1*N_COL..2*N_COL-1];
+      THIRD_ROW  = [2*N_COL..3*N_COL-1];
+      FOURTH_ROW = [3*N_COL..4*N_COL-1];
+      FIFTH_ROW  = [4*N_COL..5*N_COL-1];
+      SIXTH_ROW  = [5*N_COL..6*N_COL-1];
+      LAST_ROW   = SIXTH_ROW;
+      ROW_0_MASK=[0..N_COL-1,10..N_COL+10-1,20..N_COL+20-1,30,31];
+      ROW_1_MASK=[5..N_COL+5-1,15..N_COL+15-1,25..N_COL+25-1];
+      BOARD_MASK=[0..29];
+
+
+type  bitvec=set of 0..31;
+      dimensions=(dimx,dimy);
+      parity=(even,odd);
+      goodbad=(good,bad,always_bad);
+      piecenr=type 0..N_PIECE_TYPE-1;
+      orientation=type 0..N_ORIENT-1;
+
+      piece_placement=record
+        vec:bitvec;
+        ipiece:piecenr;
+        row:byte;
+      end;
+
+type Soln=object
+       m_pieces:array[piecenr] of piece_placement;
+       m_npiece:byte;
+       m_cells:array[0..N_ROW-1,0..N_COL-1] of piecenr;
+       m_synched:boolean;
+       constructor init(fillval:byte);
+       procedure setCells;
+       function lessThan(var r:Soln):boolean;
+       procedure write(var f:text);
+       procedure fill(value:byte);
+       procedure spin(var spun:Soln);
+
+       function isEmpty:boolean;
+       procedure popPiece;inline;
+       procedure pushPiece(Avec:bitvec;AiPiece:piecenr;Arow:byte);
+     end;
+
+     instance=record
+       m_allowed:set of byte;
+       m_vec:bitvec;
+       m_offset:longint;
+     end;
+
+     TPts=array[0..N_ELEM-1,dimensions] of shortint;
+     piece=object
+       m_instance:array[parity] of instance;
+       procedure set_ok_positions(isOdd:parity;w,h:longint);
+     end;
+
+     OkPieces=record
+       nPieces:array[piecenr] of byte;
+       pieceVec:array[piecenr,orientation] of bitvec;
+     end;
+
+
+type  fixed=(OPEN, CLOSED);
+      islandinfo=record
+        has_bad:array[fixed,parity] of bitvec;
+        is_known:array[fixed,parity] of bitvec;
+        alwaysBad:array[parity] of bitvec;
+      end;
+
+const MAX_ISLAND_OFFSET=1024;
+
+type cacherec=record
+       krow,kpiecevec:word;
+       kboardvec:bitvec;
+     end;
+
+var s_basePiece:array[piecenr,orientation] of piece;
+    g_okPieces:array[0..N_ROW-1,0..N_COL-1] of OkPieces;
+    g_islandInfo:array[0..MAX_ISLAND_OFFSET-1] of islandinfo;
+    g_nIslandInfo:cardinal=0;
+    cache:array[0..1024*128-1] of cacherec;
+
+    m_curSoln,m_minSoln,m_maxSoln:Soln;
+    m_nSoln:cardinal;
+
+const basevecs:array [0..9] of bitvec= (
+        [0,1,2,3,8],
+        [0,1,3,6,7],
+        [0,1,2,7,12],
+        [0,1,2,5,10],
+        [0,2,5,6,10],
+        [0,1,2,6,7],
+        [0,1,5,10,15],
+        [0,1,2,5,7],
+        [0,1,2,7,8],
+        [0,1,2,3,7]
+      );
+
+
+constructor soln.init(fillval:byte);
+
+begin
+  fill(fillval);
+end;
+
+procedure Soln.fill(value:byte);
+
+begin
+   m_synched:=false;
+   fillchar(m_cells,N_CELL,value);
+end;
+
+function soln.isEmpty:boolean;
+
+begin
+  isempty:=m_nPiece=0;
+end;
+
+procedure soln.pushPiece(Avec:bitvec;AiPiece:piecenr;Arow:byte);
+
+begin
+  with m_pieces[m_npiece] do
+    begin
+      vec:=Avec;
+      iPiece:=AiPiece;
+      row:=Arow;
+    end;
+  inc(m_npiece);
+end;
+
+procedure soln.popPiece;inline;
+
+begin
+  dec(m_nPiece);
+  m_synched := false;
+end;
+
+procedure soln.write(var f:text);
+
+var x,y:byte;
+
+begin
+  for y:=0 to N_ROW-1 do
+    begin
+      {indent every second line}
+      if y mod 2=1 then
+        system.write(f,' ');
+      for x:=0 to N_COL-1 do
+        if m_cells[y,x]=no_piece then
+          system.write(f,'. ')
+        else
+          system.write(f,char(byte('0')+m_cells[y,x]),' ');
+      writeln(f);
+    end;
+end;
+
+
+procedure Soln.setCells;
+
+var c,i,x,y,newcells:byte;
+
+begin
+   if m_synched then
+     exit;
+   for i:=1 to m_nPiece do
+     with m_pieces[i-1] do
+       begin
+         newcells:=0;
+         c:=0;
+         for y:=row to N_ROW do
+           begin
+             for x:=0 to N_COL-1 do
+               begin
+                 if c in vec then
+                   begin
+                     m_cells[y,x]:=ipiece;
+                     inc(NewCells);
+                   end;
+                 inc(c);
+               end;
+             if NewCells=N_ELEM then
+               break;
+           end;
+       end;
+   m_synched:=true;
+end;
+
+function Soln.lessThan(var r:Soln):boolean;
+
+var x,y,lval,rval:byte;
+
+begin
+   if m_pieces[0].iPiece<>r.m_pieces[0].iPiece then
+     begin
+       lessthan:=m_pieces[0].iPiece < r.m_pieces[0].iPiece;
+       exit;
+     end;
+
+   setCells();
+   r.setCells();
+
+   for y:=0 to N_ROW-1 do
+      for x:=0 to N_COL-1 do
+        begin
+         lval:=m_cells[y,x];
+         rval:=r.m_cells[y,x];
+
+         if lval <> rval then
+           begin
+             lessthan:=lval<rval;
+             exit;
+           end;
+        end;
+
+   lessthan:=false; {solutions are equal}
+end;
+
+procedure Soln.spin(var spun:Soln);
+
+var x,y:byte;
+
+begin
+   setCells;
+   {swap cells}
+   for y:=0 to N_ROW-1 do
+      for x:=0 to N_COL-1 do
+        spun.m_cells[y,x]:=m_cells[N_ROW-y-1,N_COL-x-1];
+
+   {swap first and last pieces (the rest aren't used)}
+   spun.m_pieces[0].iPiece:=m_pieces[N_PIECE_TYPE-1].iPiece;
+   spun.m_synched:=true;
+end;
+
+function floor(top,bot:longint):longint;
+
+begin
+   floor:=top div bot;
+   {negative numbers should be rounded down, not towards zero}
+   if (floor*bot<>top) and ((top<0) xor (bot<=0)) then
+      dec(floor);
+end;
+
+const s_firstOne:array[0..31] of byte=(
+   0, 0, 1, 0,   2, 0, 1, 0,
+   3, 0, 1, 0,   2, 0, 1, 0,
+
+   4, 0, 1, 0,   2, 0, 1, 0,
+   3, 0, 1, 0,   2, 0, 1, 0
+);
+
+function first_set_bit(v:bitvec):cardinal;inline;
+
+{$ifdef endian_little}
+const l=0;
+      h=1;
+{$else}
+const l=1;
+      h=0;
+{$endif}
+
+var d:double;
+    u:array[0..1] of bitvec absolute d;
+
+begin
+  first_set_bit:=0;
+  if v<>[] then
+    begin
+      u[l]:=v;
+      u[h]:=[30,25,24,21,20];
+      d:=d-4503599627370496;
+      first_set_bit:=cardinal(u[h]) shr 20-$3ff;
+    end;
+end;
+
+function count_ones(v:bitvec):cardinal;inline;
+
+begin
+   count_ones:=0;
+   while v<>[] do
+     begin
+       inc(count_ones);
+       cardinal(v):=cardinal(v) and (cardinal(v)-1);
+     end;
+end;
+
+procedure setCoordList(vec:bitvec;var pts:Tpts);
+
+var iPt,n:longint;
+    x,y:byte;
+
+begin
+   iPt:=0;
+   n:=0;
+   for y:=0 to N_ROW-1 do
+     for x:=0 to N_COL-1 do
+       begin
+         if n in vec then
+           begin
+             pts[iPt,dimx]:=x;
+             pts[iPt,dimy]:=y;
+             inc(iPt);
+           end;
+         inc(n);
+         if n=32 then
+           exit;
+       end;
+end;
+
+function toBitVector(const pts:Tpts):bitvec;
+
+var x,y,iPt:byte;
+
+begin
+   tobitvector:=[];
+   for iPt:=low(pts) to high(pts) do
+     begin
+       x:=pts[iPt,dimx];
+       y:=pts[iPt,dimy];
+       include(tobitvector,y*N_COL+x);
+     end;
+end;
+
+procedure shiftUpLines(var pts:Tpts;shift:longint);
+
+var iPt:byte;
+
+begin
+   {vertical shifts have a twist}
+   for iPt:=low(pts) to high(pts) do
+     begin
+       if pts[iPt,dimy] and shift and 1<>0 then
+         inc(pts[iPt,dimx]);
+       dec(pts[iPt,dimy],shift);
+     end;
+end;
+
+function shiftToX0(var pts:Tpts;var Ainstance:instance;offsetRow:longint):shortint;
+
+var x,y,xmin,xmax,iPt,offset:shortint;
+
+begin
+   { .. determine shift}
+   xMin:=pts[0,dimx];
+   xMax:=xMin;
+   for iPt:=low(pts)+1 to high(pts) do
+     begin
+       x:=pts[iPt,dimx];
+       y:=pts[iPt,dimy];
+       if x<xMin then
+         xMin:=x
+       else if x > xMax then
+         xMax:=x;
+     end;
+
+   offset:=N_ELEM;
+   for iPt:=low(pts) to high(pts) do
+     begin
+      dec(pts[iPt,dimx],xMin);
+      {check offset -- leftmost cell on top line}
+      if (pts[iPt,dimy]=offsetRow) and (pts[iPt,dimx]<offset) then
+         offset:=pts[iPt,dimx];
+   end;
+
+   Ainstance.m_offset := offset;
+   Ainstance.m_vec := toBitVector(pts);
+   shifttox0:=xMax - xMin;
+end;
+
+function badregion(var to_fill:bitvec;rnew:bitvec):boolean;
+
+var region,even_region,odd_region:bitvec;
+    cell_count:cardinal;
+
+begin
+   {Grow empty region, until it doesn't change any more.}
+   repeat
+      region:=rnew;
+      even_region:=region*(ROW_0_MASK*([0..31]-L_EDGE_MASK));
+      odd_region:=region*(ROW_1_MASK*([0..31]-R_EDGE_MASK));
+
+      rnew:=to_fill*(rnew
+                    {simple grow up/down}
+                    +bitvec(cardinal(region) shr N_COL)
+                    +bitvec(cardinal(region) shl N_COL)
+                    {grow right/left}
+                    +bitvec(cardinal(region) and not cardinal(L_EDGE_MASK) shr 1)
+                    +bitvec(cardinal(region) and not cardinal(R_EDGE_MASK) shl 1)
+                    {tricky growth}
+                    +bitvec(cardinal(even_Region) shr (N_COL+1))
+                    +bitvec(cardinal(even_Region) shl (N_COL-1))
+                    +bitvec(cardinal(odd_Region) shr (N_COL-1))
+                    +bitvec(cardinal(odd_Region) shl (N_COL+1))
+                    );
+   until (rnew=to_fill) or (rnew=region);
+
+   {Subtract empty region from board.}
+   to_fill:=to_fill-rnew;
+
+   cell_count:=count_ones(to_fill);
+   {Optimize 'cell_count mod 5<>0' by hand...}
+   badregion:=cell_count<>((cell_count*$cccd) shr 18)*5;
+end;
+
+function has_bad_islands_single(boardVec:bitvec;row:longint):boolean;
+
+var tofill,startregion,bmask:bitvec;
+    isodd:boolean;
+
+begin
+   tofill:=[0..31]-boardvec;
+   isOdd:=row and 1<>0;
+   if isOdd then
+     begin
+       dec(row);
+       toFill:=bitvec(cardinal(tofill) shl N_COL); {shift to even aligned}
+       toFill:= tofill + TOP_ROW;
+     end;
+
+   startRegion := TOP_ROW;
+   bMask := BOARD_MASK; {all but the first two bits}
+   if row>=4 then
+      cardinal(bMask):=cardinal(bmask) shr ((row-4)*N_COL)
+   else if isOdd or (row = 0) then
+      startRegion := LAST_ROW;
+
+   toFill:=tofill*bMask;
+   startRegion:=startregion*toFill;
+
+   has_bad_islands_single:=true;
+   while toFill<>[] do
+     begin
+       if badRegion(toFill, startRegion) then
+         exit;
+       startRegion:=[first_set_bit(toFill)];
+     end;
+   has_bad_islands_single:=false;
+end;
+
+
+procedure piece.set_ok_positions(isOdd:parity;w,h:longint);
+
+var x,y,xpos,pos:byte;
+
+begin
+   pos:=byte(isodd)*N_COL;
+   with m_instance[isOdd] do
+     begin
+       m_allowed:=[];
+       y:=byte(isOdd);
+       while y<N_ROW-h do
+         begin
+           if m_offset<>0 then
+             inc(pos,m_offset);
+           for xPos:=0 to N_COL-1-m_offset do
+             begin
+               {check if the new position is on the board}
+               if (xPos<N_COL-w) and not has_bad_islands_single(bitvec(cardinal(m_vec) shl xPos),y) then
+                 begin
+                   {position is allowed}
+                   include(m_allowed,pos);
+                 end;
+               inc(pos);
+             end;
+           y:=y+2;
+           {Skip row with wrong parity:}
+           inc(pos,N_COL);
+         end;
+   end;
+end;
+
+procedure gen_orientation(vec:bitvec;iOrient:cardinal;var target:Piece);
+
+var pts:Tpts;
+    x,y,ymin,ymax,h,w:shortint;
+    rot,iPt:byte;
+    flip:boolean;
+
+begin
+   {get (x,y) coordinates}
+   setCoordList(vec, pts);
+
+   rot := iOrient mod 6;
+   flip := iOrient >= 6;
+   if flip then
+     for iPt:=0 to N_ELEM-1 do
+       pts[iPt,dimy]:=-pts[iPt,dimy];
+
+   {rotate as necessary}
+   while rot>0 do
+     begin
+       for iPt:=0 to N_ELEM-1 do
+         begin
+           x:=pts[iPt,dimx];
+           y:=pts[iPt,dimy];
+           pts[iPt,dimx]:=floor(2*x-3*y+1,4);
+           pts[iPt,dimy]:=floor(2*x+y+1,2);
+         end;
+      dec(rot);
+   end;
+
+   {determine vertical shift}
+   yMin := pts[0,dimy];
+   yMax := yMin;
+   for iPt:= 1 to N_ELEM-1 do
+     begin
+       y := pts[iPt,dimy];
+
+       if y < yMin then
+         yMin := y
+       else if y > yMax then
+         yMax := y;
+     end;
+   h:=yMax-yMin;
+
+   shiftUpLines(pts, yMin);
+   w := shiftToX0(pts, target.m_instance[EVEN], 0);
+   target.set_ok_positions(EVEN, w, h);
+   cardinal(target.m_instance[EVEN].m_vec) := cardinal(target.m_instance[EVEN].m_vec) shr target.m_instance[EVEN].m_offset;
+
+   {shift down one line}
+   shiftUpLines(pts, -1);
+   w := shiftToX0(pts, target.m_instance[ODD], 1);
+   {shift the bitmask back one line}
+   cardinal(target.m_instance[ODD].m_vec) :=cardinal(target.m_instance[ODD].m_vec) shr N_COL;
+   target.set_ok_positions(ODD, w, h);
+   cardinal(target.m_instance[ODD].m_vec):= cardinal(target.m_instance[ODD].m_vec) shr target.m_instance[ODD].m_offset;
+end;
+
+function getPiece(iPiece,iOrient:cardinal;iParity:parity):instance;inline;
+
+begin
+  getpiece:=s_basePiece[iPiece][iOrient].m_instance[iParity];
+end;
+
+procedure gen_all_orientations;
+
+var ipiece:piecenr;
+    iorient:orientation;
+    irow,icol:byte;
+    refpiece:bitvec;
+    n,npiece:byte;
+
+begin
+   for iPiece:=low(ipiece) to high(ipiece) do
+     begin
+       refPiece:=BaseVecs[iPiece];
+       for iOrient:=low(iorient) to high(iorient) do
+         begin
+           gen_orientation(refPiece, iOrient, s_basePiece[iPiece,iOrient]);
+           with s_basePiece[iPiece,iOrient] do
+             begin
+               if (iPiece=SKIP_PIECE) and (iOrient in [3..5,9..11]) then
+                 begin
+                   m_instance[odd].m_allowed := [];
+                   m_instance[even].m_allowed := [];
+                 end;
+             end;
+         end;
+     end;
+
+   for iPiece:=low(ipiece) to high(ipiece) do
+     begin
+      for iOrient:=low(iorient) to high(iorient) do
+        begin
+         n:=0;
+         for iRow:=0 to N_ROW-1 do
+           begin
+            with getPiece(iPiece, iOrient, parity(iRow and 1)) do
+              for iCol:=0 to N_COL-1 do
+                begin
+                  if n in m_allowed then
+                    begin
+                      nPiece:=g_okPieces[iRow,iCol].nPieces[iPiece];
+                      g_okPieces[iRow,iCol].pieceVec[iPiece,nPiece]:=bitvec(cardinal(m_vec) shl iCol);
+                      inc(g_okPieces[iRow,iCol].nPieces[iPiece]);
+                    end;
+                  inc(n);
+                end;
+          end
+      end
+   end
+end;
+
+procedure init_board;
+
+begin
+  m_cursoln.init(NO_PIECE);
+  m_minsoln.init(NO_PIECE);
+  m_maxsoln.init(NO_PIECE);
+  m_nsoln:=0;
+end;
+
+const g_firstRegion:array[0..31] of bitvec=(
+        [],      [0],      [1],       [0,1],
+        [2],     [0],      [1,2],     [0,1,2],
+        [3],     [0],      [1],       [0,1],
+        [2,3],   [0],      [1,2,3],   [0,1,2,3],
+        [4],     [0],      [1],       [0,1],
+        [2],     [0],      [1,2],     [0,1,2],
+        [3,4],   [0],      [1],       [1,2],
+        [2,3,4], [0],      [1,2,3,4], [0,1,2,3,4]
+);
+
+function calc_bad_islands(boardVec:bitvec;row:longint):goodbad;
+
+var tofill,boardmask,bottom,startregion:bitvec;
+    filled:boolean;
+
+begin
+   toFill:=[0..31]-boardVec;
+   {Compensate for odd rows.}
+   if row and 1<>0 then
+     begin
+       dec(row);
+       cardinal(toFill):=cardinal(tofill) shl N_COL;
+     end;
+
+   boardMask := BOARD_MASK; {all but the first two bits}
+   if row>4 then
+      cardinal(boardMask):=cardinal(boardmask) shr ((row-4)*N_COL);
+   toFill:=tofill*boardMask;
+
+   {a little pre-work to speed things up}
+   filled:=toFill*LAST_ROW=LAST_ROW;
+   bottom:=LAST_ROW;
+   while bottom*toFill=bottom do
+     begin
+       toFill:=tofill-bottom;
+       cardinal(bottom):=cardinal(bottom) shr N_COL;
+     end;
+
+   if filled or (row<4) then
+      startRegion := bottom * toFill
+   else
+     begin
+       startRegion := g_firstRegion[cardinal(toFill*TOP_ROW)];
+       if startRegion=[] then
+          begin
+            startRegion := bitvec(cardinal(toFill) shr N_COL)*TOP_ROW;
+            startRegion := g_firstRegion[cardinal(startRegion)];
+            cardinal(startRegion) := cardinal(startregion) shl N_COL;
+          end;
+        startRegion:=startregion+bitvec(cardinal(startRegion) shl N_COL)*toFill;
+     end;
+
+   while toFill<>[] do
+     begin
+       if badRegion(toFill, startRegion) then
+          begin
+            if toFill<>[] then
+              calc_bad_islands:=ALWAYS_BAD
+            else
+              calc_bad_islands:=BAD;
+            exit;
+          end;
+       startRegion := [first_set_bit(toFill)];
+     end;
+
+   calc_bad_islands:=GOOD;
+end;
+
+
+function has_bad_islands(boardvec:bitvec;row:longint):goodbad;
+
+var last_row:bitvec;
+    isodd:parity;
+    isclosed:fixed;
+
+begin
+   {skip over any filled rows}
+   while boardVec*TOP_ROW=TOP_ROW do
+     begin
+       cardinal(boardVec):=cardinal(boardvec) shr N_COL;
+       inc(row);
+     end;
+
+   has_bad_islands:=bad;
+   with g_islandInfo[cardinal(boardvec*(TOP_ROW+SECOND_ROW))] do
+     begin
+       last_row:=bitvec(cardinal(boardvec) shr (2*N_COL))*TOP_ROW;
+       isOdd:=parity(row and 1);
+
+       if not(cardinal(last_row) in alwaysBad[parity(row and 1)]) then
+         if boardVec*bitvec(cardinal(TOP_ROW) shl N_COL*3)=[] then
+           begin
+             isClosed:=fixed(row>6); {because we track 3 rows}
+               if not(cardinal(last_row) in is_known[isClosed,isOdd]) then
+                 if boardVec<>[] then
+                   begin
+                     has_bad_islands:=calc_bad_islands(boardvec,row);
+                     include(is_known[isClosed,isOdd],cardinal(last_row));
+                     if has_bad_islands<>good then
+                       include(is_known[isClosed,isOdd],cardinal(last_row));
+                   end
+                 else
+                   has_bad_islands:=good
+               else
+                 if not(cardinal(last_row) in has_bad[isClosed,isOdd]) then
+                   has_bad_islands:=good;
+           end
+         else
+           has_bad_islands:=calc_bad_islands(boardvec,row);
+     end;
+end;
+
+const g_flip:array[0..31] of bitvec=(
+        [],        [4],        [3],        [3,4],
+        [2],       [2,4],      [2,3],      [2,3,4],
+        [1],       [1,4],      [1,3],      [1,3,4],
+        [1,2],     [1,2,4],    [1,2,3],    [1,2,3,4],
+        [0],       [0,4],      [0,3],      [0,3,4],
+        [0,2],     [0,2,4],    [0,2,3],    [0,2,3,4],
+        [0,1],     [0,1,4],    [0,1,3],    [0,1,3,4],
+        [0,1,2],   [0,1,2,4],  [0,1,2,3],  [0,1,2,3,4]
+);
+
+function flipTwoRows(bits:bitvec):bitvec;inline;
+
+var flipped:cardinal;
+
+begin
+   flipped:=cardinal(g_flip[cardinal(bits) shr N_COL]) shl N_COL;
+   fliptworows:=bitvec(flipped or cardinal(g_flip[cardinal(bits*TOP_ROW)]));
+end;
+
+procedure mark_bad(var info:IslandInfo;n:byte;eo:parity;always:boolean);inline;
+
+begin
+  with info do
+   begin
+     include(has_bad[OPEN,eo],n);
+     include(has_bad[CLOSED,eo],n);
+
+     if always then
+       include(alwaysBad[eo],n);
+   end;
+end;
+
+procedure calc_always_bad;
+
+var i,iWord:cardinal;
+    boardvec:bitvec;
+    hasbad:goodbad;
+    always:boolean;
+    flipped:^islandinfo;
+
+begin
+   for iWord:=1 to MAX_ISLAND_OFFSET-1 do
+     begin
+      flipped := @g_islandInfo[cardinal(flipTwoRows(bitvec(iWord)))];
+      for i:=0 to 31 do
+        begin
+          boardvec:=bitvec((i shl (2*N_COL)) or iWord);
+          if not(i in g_islandInfo[iWord].is_known[OPEN,EVEN]) then
+            begin
+              hasBad:=calc_bad_islands(boardvec,0);
+              if hasBad<>good then
+                begin
+                 always:=hasBad=ALWAYS_BAD;
+                 mark_bad(g_islandInfo[iWord], i, EVEN, always);
+                 mark_bad(flipped^,cardinal(g_flip[i]), ODD, always);
+              end;
+            end;
+      end;
+      flipped^.is_known[OPEN,odd]:=[0..31];
+      g_islandInfo[iWord].is_known[OPEN,even]:=[0..31];
+   end
+end;
+
+procedure record_solution(var s:Soln);
+
+var spun:soln;
+
+begin
+   s.setcells;
+   inc(m_nSoln,2); {add solution and its rotation}
+
+   if m_minSoln.isEmpty then
+     begin
+       m_minSoln := s;
+       m_maxSoln := s;
+       exit;
+     end;
+
+   if s.lessThan(m_minSoln) then
+      m_minSoln := s
+   else if m_maxSoln.lessThan(s) then
+      m_maxSoln := s;
+
+   s.spin(spun);
+   if spun.lessThan(m_minSoln) then
+      m_minSoln := spun
+   else if m_maxSoln.lessThan(spun) then
+      m_maxSoln := spun;
+end;
+
+function gen_all_solutions(boardVec,placedPieces:bitvec;row:byte):cardinal;
+
+var ipiece:piecenr;
+    iorient:byte;
+    piece:bitvec;
+
+begin
+   while boardVec*TOP_ROW=TOP_ROW do
+     begin
+       cardinal(boardVec):=cardinal(boardvec) shr N_COL;
+       inc(row);
+     end;
+   gen_all_solutions:=0;
+   with cache[((cardinal(boardvec)*
+              (cardinal(placedpieces) {shl 3} + 1)
+              xor row shl 5)) mod 131071] do
+     if (krow<>row) or (bitvec(cardinal(kpiecevec))<>placedpieces) or (kboardvec<>boardvec) then
+       begin
+         with g_okpieces[row,s_firstOne[cardinal([0..N_COL-1]-boardVec)]] do
+           for ipiece:=0 to N_PIECE_TYPE-1 do
+             if not(ipiece in placedpieces) then
+               for iorient:=1 to npieces[ipiece] do {start with 1, npieces[x] can be zero}
+                 begin
+                   piece:=pieceVec[iPiece,iOrient-1];
+                   {check if piece conflicts with other pieces or if we get a bad island.}
+                   if (piece*boardVec=[]) and (has_bad_islands(boardVec+piece,row)=good) then
+                     begin
+                       m_curSoln.pushPiece(piece,iPiece,row);
+                       {recurse or record solution}
+                       if placedPieces+[ipiece]<>ALL_PIECE_MASK then
+                         inc(gen_all_solutions,gen_all_solutions(boardVec+piece,placedPieces+[ipiece],row))
+                       else
+                         begin
+                           record_solution(m_curSoln);
+                           inc(gen_all_solutions);
+                         end;
+                       m_curSoln.popPiece();
+                     end;
+                end;
+         if gen_all_solutions=0 then
+           begin
+             krow:=row;
+             kpiecevec:=word(cardinal(placedpieces));
+             kboardvec:=boardvec;
+           end;
+      end;
+end;
+
+begin
+   if paramcount > 2 then
+     halt(1); {spec says this is an error}
+
+   textrec(output).flushfunc:=nil;
+
+   gen_all_orientations;
+   calc_always_bad;
+   init_board;
+   filldword(cache,sizeof(cache) shr 2,$ffffffff);
+   gen_all_solutions([], [], 0);
+
+   writeln(m_nSoln,' solutions found');
+   writeln;
+   m_minSoln.write(output);
+   writeln;
+   m_maxSoln.write(output);
+   writeln;
+end.

tests/test/tparray18.pp

@@ -1,3 +1,9 @@
+{ %fail }
+
+{ currently fails under FPC, because parameters to read(ln) have to be  }
+{ var parameters, and you cannot pass bitpacked record fields and array }
+{ elements as var parameters                                            }
+
 { from gpc tests, original name: bitfields.pas }
 
 {$ifdef fpc}

tests/test/tprop.pp

@@ -0,0 +1,59 @@
+{$ifdef fpc}
+{$mode delphi}
+{$endif}
+
+uses
+  variants;
+
+type
+  tdynarr = array of byte;
+
+  tc = class
+   private
+    fda: tdynarr;
+    fva: variant;
+   public
+    property da: tdynarr read fda write fda;
+    property va: variant read fva write fva;
+  end;
+
+var
+  c: tc;
+  v: variant;
+  d: tdynarr;
+begin
+  c:=tc.create;
+
+  v:=5;
+  c.va:=v;
+  if (c.fva <> 5) then
+    halt(1);
+  v:='abc';
+  v:=c.va;
+  if (v <> 5) then
+    halt(2);
+
+  setlength(d,4);
+  d[0]:=245;
+  d[1]:=1;
+  d[2]:=38;
+  d[3]:=115;
+  c.da:=d;
+  if (length(c.fda)<>4) or
+     (c.fda[0]<>245) or
+     (c.fda[1]<>1) or
+     (c.fda[2]<>38) or
+     (c.fda[3]<>115) then
+    halt(3);
+  d:=nil;
+  d:=c.da;
+  c.fda:=nil;
+  if (length(d)<>4) or
+     (d[0]<>245) or
+     (d[1]<>1) or
+     (d[2]<>38) or
+     (d[3]<>115) then
+    halt(4);
+  
+  c.free;
+end.

tests/utils/testsuite/utests.pp

@@ -108,7 +108,23 @@ begin
             ShowRunComparison;
         2 : CreateRunPie;
         3 : ShowOneTest;
-      end;
+{$ifdef TEST}        
+        98 :
+          begin
+            EmitOverviewForm;
+            Writeln(stdout,'<PRE>');
+            FreeMem(pointer($ffffffff));
+            Writeln(stdout,'</PRE>');
+          end;
+        99 : 
+          begin
+            EmitOverviewForm;
+            Writeln(stdout,'<PRE>');
+            Dump_stack(stdout,get_frame);
+            Writeln(stdout,'</PRE>');
+          end;
+{$endif TEST}
+        end;
     finally
       EmitEnd; 
       DisConnectFromDB;
@@ -515,7 +531,8 @@ end;
 Function TTestSuite.ShowRunData : Boolean;
 
 Const
-  SGetRunData = 'SELECT TU_ID,TU_DATE,TC_NAME,TO_NAME,TU_COMMENT,TV_VERSION '+
+  SGetRunData = 'SELECT TU_ID,TU_DATE,TC_NAME,TO_NAME,' +
+                'TU_SUBMITTER,TU_MACHINE,TU_COMMENT,TV_VERSION '+
                 ' FROM TESTRUN,TESTCPU,TESTOS,TESTVERSION '+
                 'WHERE '+
                 ' (TC_ID=TU_CPU_FK) AND '+
@@ -592,6 +609,24 @@ begin
               if Q2 <> nil then
                 Write(Q2.FieldByName('TU_COMMENT').AsString);
             CellEnd;
+          RowNext;
+            CellStart;
+              Write('Machine:');
+            CellNext;
+              Write(Q1.FieldByName('TU_MACHINE').AsString);
+            CellNext;
+              if Q2 <> nil then
+                Write(Q2.FieldByName('TU_MACHINE').AsString);
+            CellEnd;
+          RowNext;
+            CellStart;
+              Write('Submitter:');
+            CellNext;
+              Write(Q1.FieldByName('TU_SUBMITTER').AsString);
+            CellNext;
+              if Q2 <> nil then
+                Write(Q2.FieldByName('TU_SUBMITTER').AsString);
+            CellEnd;
           RowNext;
             CellStart;
               Write('Date:');
@@ -906,7 +941,7 @@ begin
                   if Log='' then
                     begin
                       HeaderStart(2);
-                      Write('No log.');
+                      Write('No log of '+FRunId+'.');
                       HeaderEnd(2);
                     end;  
                 end;  
@@ -931,7 +966,7 @@ begin
                   if Log='' then
                     begin
                       HeaderStart(2);
-                      Write('No alternate log.');
+                      Write('No log of '+FCompareRunId+'.');
                       HeaderEnd(2);
                     end;  
                 end;  
@@ -955,8 +990,18 @@ begin
             if Source='' then
               begin
                 HeaderStart(3);
-                DumpLn('<P>No Source.</P>');
-                DumpLn('Link to CVS view of '+
+                DumpLn('<P>No Source in TestSuite DataBase.</P>');
+                DumpLn('Link to SVN view of '+
+                  '<A HREF="http://www.freepascal.org'+
+                  '/cgi-bin/viewcvs.cgi/trunk/tests/'+
+                  FTestFileName+'?view=markup'+
+                  '" TARGET="_blank"> '+FTestFileName+'</A> source. ');
+                HeaderEnd(3);
+              end
+            else
+              begin
+                HeaderStart(3);
+                DumpLn('Link to SVN view of '+
                   '<A HREF="http://www.freepascal.org'+
                   '/cgi-bin/viewcvs.cgi/trunk/tests/'+
                   FTestFileName+'?view=markup'+
@@ -1031,12 +1076,15 @@ begin
          +'tr2.TR_OK as Run2_OK, tr1.TR_Result as Run1_Result,'
          +'tr2.TR_RESULT as Run2_Result '
          +'FROM TESTS, tr2 LEFT JOIN tr1 USING (TR_TEST_FK) '
-         +'WHERE ((tr1.TR_SKIP IS NULL) or (%s(tr1.TR_OK<>tr2.TR_OK)))'
+         +'WHERE ((tr1.TR_SKIP IS NULL) or'
+         +' (tr2.TR_SKIP IS NULL) or '
+         +' (%s (tr1.TR_Result<>tr2.TR_Result)))'
          +'and (T_ID=tr2.TR_TEST_FK)';
       If FNoSkipped then
         begin
-        S:=S+' and (tr2.TR_SKIP<>"+")';
-        Qry:='(tr1.TR_SKIP<>"+") and';
+        Qry:='(((tr1.TR_SKIP="+") and (tr2.TR_OK="-") and (tr2.TR_SKIP="-")) or '
+           +'((tr1.TR_OK="-") and (tr1.TR_SKIP="-") and (tr2.TR_SKIP="+")) or '
+           +'((tr1.TR_SKIP="-") and (tr2.TR_SKIP="-"))) and ';
         end
       else
         Qry:='';
@@ -1129,16 +1177,18 @@ begin
       BGColor:='yellow';    // Yellow
       end
     else If Run2Field.AsString='+' then
+      begin
       if Run1Field.AsString='' then
         BGColor:='#68DFB8'
-      else
-        BGColor:='#98FB98'    // pale Green
-    else
+      else if Run1Field.ASString<>'+' then
+        BGColor:='#98FB98';    // pale Green
+      end  
+    else if Run2Field.AsString='-' then
       begin
       Inc(FRunFailedCount);
       if Run1Field.AsString='' then
         BGColor:='#FF82AB'    // Light red
-      else
+      else if Run1Field.AsString<>'-' then
         BGColor:='#FF225B';
       end;
     end;

tests/webtbs/tw5800.pp

@@ -0,0 +1,57 @@
+{$IFDEF FPC}{$mode objfpc}{$ENDIF}
+
+uses
+	sysutils;
+
+type
+{$INTERFACES CORBA}
+	IAny1 = interface
+		//['{949041BD-BEC9-468A-93AA-96B158EF97E0}']
+		procedure x;
+	end;
+
+	IAny2 = interface
+        //['{4743E9F5-74B2-411D-94CE-AAADDB8F45E0}']
+		procedure y;
+	end;
+
+	TAny = class(TInterfacedObject, IAny1, IAny2)
+		procedure x;
+		procedure y;
+	end;
+
+
+procedure TAny.x;
+begin
+	WriteLn('x');
+end;
+
+procedure TAny.y;
+begin
+	WriteLn('y');
+end;
+
+procedure any(const z : IAny1); overload;
+begin
+	z.x;
+end;
+
+procedure any(const z : IAny2); overload;
+begin
+	z.y;
+end;
+
+
+var
+	a : TAny;
+
+begin
+	a := TAny.Create();
+
+	if (supports(a, IAny1)) then begin end; // remove this line to get it compile
+
+	any(a as IAny1);
+	any(a as IAny2);
+
+	//a.Free();
+end.

tests/webtbs/tw8144.pp

@@ -0,0 +1,19 @@
+
+function DoCheck(Key:WideChar):boolean;
+begin
+ DoCheck:=(Key in [WideChar(#0), WideChar(#8), WideChar(#10),
+    WideChar(#13), WideChar(#27), WideChar(#127)]);
+end;
+
+var
+  Key:WideChar;
+  err : boolean;
+begin
+  for Key:=WideChar(128) to WideChar(2048) do
+   if DoCheck(Key) then
+    begin
+     writeln(word(Key),' (',Key,') in set');
+     err:=true;
+    end;
+  if err then halt(1);
+end.

tests/webtbs/tw8177a.pp

@@ -0,0 +1,30 @@
+
+
+var
+  S : string;
+  i : longint;
+  err : word;
+begin
+  S:='';
+  val(S,i,err);
+  if err=0 then
+    begin
+      Writeln('Error: empty string is a valid input for val function');
+      Halt(1);
+    end
+  else
+    begin
+      Writeln('Correct: empty string is a not valid input for val function');
+    end;
+  S:=#0;
+  val(S,i,err);
+  if err=0 then
+    begin
+      Writeln('Error: #0 string is a valid input for val function');
+      Halt(1);
+    end
+  else
+    begin
+      Writeln('Correct: #0 string is a not valid input for val function');
+    end;
+end.

tests/webtbs/tw8195a.pp

@@ -0,0 +1,129 @@
+{ %cpu=i386 }
+
+{$APPTYPE CONSOLE}
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+program AsmTest;
+
+type
+  TMyObject = class(TObject)
+    Field1 : Integer;
+    Field2 : Integer;
+    procedure VirtualMethod1; virtual;
+    procedure VirtualMethod2; virtual;
+  end;
+
+  TMyRecord = record
+    EAX : Integer;
+    EBX : Integer;
+    ECX : Integer;
+    EDX : Integer;
+  end;
+
+{ TMyObject }
+
+procedure TMyObject.VirtualMethod1;
+begin
+
+end;
+
+procedure TMyObject.VirtualMethod2;
+begin
+
+end;
+
+function VirtualMethodVMTOFFSET1: Integer;
+asm
+  mov eax, VMTOFFSET TMyObject.VirtualMethod1;
+end;
+
+function VirtualMethodVMTOFFSET2: Integer;
+asm
+  mov eax, VMTOFFSET TMyObject.VirtualMethod2;
+end;
+
+function IUnknownAddRefVMTOFFSET1: Integer;
+asm
+  mov eax, VMTOFFSET IUnknown._AddRef;
+end;
+
+function Field1: Integer;
+asm
+  mov eax, TMyObject.Field1;
+end;
+
+function Field1OFFSET: Integer;
+asm
+  mov eax, OFFSET TMyObject.Field1;
+end;
+
+var
+  _Test: Integer;
+
+function Test: Integer;
+asm
+  mov eax, _Test;
+end;
+
+function TestOFFSET: Integer;
+asm
+  mov eax, OFFSET _Test;
+end;
+
+function LabelOFFSET: Integer;
+asm
+  mov eax, OFFSET @@Exit
+  ret
+ @@Exit:
+end;
+
+function TMyObjectTYPE: Integer;
+asm
+  mov eax, TYPE TMyObject
+end;
+
+function TMyRecordTYPE: Integer;
+asm
+  mov eax, TYPE TMyRecord
+end;
+
+function FillMyRecord: TMyRecord;
+asm
+  mov [eax + TMyRecord.&eax], eax
+  mov [eax + TMyRecord.&ebx], ebx
+  mov [eax + TMyRecord.&ecx], ecx
+  mov [eax + TMyRecord.&edx], edx
+end;
+
+var
+  MyRecord : TMyRecord;
+
+begin
+  _Test := 123;
+
+  WriteLn('VirtualMethodVMTOFFSET1: ', VirtualMethodVMTOFFSET1);
+  WriteLn('VirtualMethodVMTOFFSET2: ', VirtualMethodVMTOFFSET2);
+  WriteLn('IUnknownAddRefVMTOFFSET1: ', IUnknownAddRefVMTOFFSET1);
+  WriteLn('Field1: ', Field1);
+  WriteLn('Field1OFFSET: ', Field1OFFSET);
+  WriteLn('Test: ', Test);
+  WriteLn('TestOFFSET: ', TestOFFSET);
+  WriteLn('LabelOFFSET: ', LabelOFFSET);
+  WriteLn('TMyObjectTYPE: ', TMyObjectTYPE);
+  WriteLn('TMyRecordTYPE: ', TMyRecordTYPE);
+
+  MyRecord.eax := 0;
+  MyRecord.ebx := 0;
+  MyRecord.ecx := 0;
+  MyRecord.edx := 0;
+
+  MyRecord := FillMyRecord;
+
+  WriteLn('MyRecord.eax: ', MyRecord.eax);
+  WriteLn('MyRecord.ebx: ', MyRecord.ebx);
+  WriteLn('MyRecord.ecx: ', MyRecord.ecx);
+  WriteLn('MyRecord.edx: ', MyRecord.edx);
+end.

tests/webtbs/tw8195b.pp

@@ -0,0 +1,26 @@
+{ %cpu=i386 }
+
+{$APPTYPE CONSOLE}
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+
+function Expression1: Integer;
+asm
+//  mov eax, 4 * 3 - 2 + (-1) / 2
+end;
+
+function Expression2: Integer;
+asm
+  mov eax, NOT 4 OR 3 AND 2 XOR 1 MOD 6 SHL 4 SHR 2
+end;
+
+
+begin
+  WriteLn('Expression1: ', Expression1);
+  WriteLn('Expression2: ', Expression2);
+  if (Expression1<>10) or (Expression2<>-1) then
+    halt(1);
+end.
+

tests/webtbs/tw8523.pp

@@ -0,0 +1,15 @@
+{$MODE DELPHI}
+
+type
+TDADataTable =class(TObject)
+public
+function GetAsCurrency(Index: integer): Currency;safecall;
+end;
+
+function TDADataTable.GetAsCurrency(Index: integer): Currency;
+begin
+Result:=0;
+end;
+
+begin
+end.

tests/webtbs/tw8677.pp

@@ -0,0 +1,23 @@
+{$mode delphi}
+
+function REGVAR(InputBuffer : Pointer): double;
+var
+  x: integer;
+  temp, y: double;
+begin
+  x := 1;
+  y := 1;
+
+  temp := exp((x/y));
+
+  Result:= Temp;
+end;
+
+var
+   Ptr1: pointer;
+begin
+    Ptr1 := 0;
+    REGVAR(Ptr1);
+    writeln('Test Complete.');
+end.
+