New unit

test system hatched

Copied from Perforce
 Change: 18174
 ServerID: perforce.ravenbrook.com

mps/qa/test/qa

@@ -0,0 +1,87 @@
+#!/usr/local/bin/perl -w
+#
+# First, we'll set up @INC so we can find the other
+# perl scripts we require. This program will be in the
+# test directory, and all the other scripts will be
+# in the script subdirectory.
+#
+# $0 contains the name of this program, as it was run
+# this means it may not be the full path, but should be
+# enough of the path for us to use it to locate other
+# perl scripts.
+# We assume the separator is / and the program name is
+# made only of A-Za-z0-9 and _.
+
+$test_dir = $0;
+
+$0 = "qa testing"; # this will show up in ps
+
+$test_dir =~ s/\/\w+$//;
+
+$script_dir = $test_dir."/script";
+$testlib_dir = $test_dir."/testlib"; &use($testlib_dir);
+
+$platform_class = `class`;
+chop($platform_class);
+$obj_dir = $test_dir."/obj/".$platform_class;
+unless (-e $obj_dir) {
+ mkdir($obj_dir,0777)
+  || die "Couldn't find or create obj dir: $obj_dir.";
+}
+$report_dir = $test_dir."/report"; &use($report_dir);
+
+foreach (@INC) {
+ if ($_ ne '.') { push(@newINC, $_) }
+}
+push(@newINC, $script_dir);
+@INC = @newINC;
+
+# Now we must process the command-line arguments
+# to qa. These specify:
+# 0: which qa command to run
+# 1,2,3.. it's parameters
+# except that -V, -I, -L (or lower-case) can be used to
+# define $MMQA_VERSION, $MPS_LINK_OBJ and $MPS_INCLUDE_DIR
+# which otherwise will be taken from environment variables.
+#
+# we'll set the relevant vars and pass the rest on in @qa_args
+
+@qa_args = ();
+
+%qa_options = ();
+$qa_options{"v"} = "MMQA_VERSION";
+$MMQA_VERSION = "MMQA_VERS_MO"; &use($MMQA_VERSION);
+$qa_options{"i"} = "MPS_INCLUDE_DIR";
+$qa_options{"l"} = "MPS_LINK_OBJ";
+
+while ($_ = shift(@ARGV)) {
+ if (/^\-(.*)$/i) {
+  unless ($qa_options{$1}) {
+   die "Unrecognised option: $1.\n";
+  }
+  $val = shift(@ARGV); &use($val);
+  $tetete="$".$qa_options{$1}." = \$val";
+  eval $tetete;
+ } else {
+  push(@qa_args, $_);
+ }
+}
+
+$qa_command = shift(@qa_args);
+
+foreach (keys %qa_options) {
+ unless (eval("$".$qa_options{$_})) {
+  die "Error: you must specify $qa_options{$_} (use the -$_ option).\n";
+ }
+}
+
+unless (-e "$script_dir/commands/".$qa_command) {
+ die "MM QA: unknown command '".$qa_command."'";
+}
+do "commands/".$qa_command;
+if ($@) {print $@};
+
+#################
+
+sub use {}
+

mps/qa/test/script/commands/clib

@@ -0,0 +1,22 @@
+#!/usr/local/bin/perl -w
+#
+# Compile all the .c files in $testlib_dir,
+# putting the resulting .o files in $obj_dir.
+#
+
+print "Compiling test libraries in $testlib_dir.\n";
+
+require "compile";
+
+while ($tlfile = <$testlib_dir/*.c>) {
+ $tlobj = $tlfile;
+ $tlobj =~ s/\.c/\.o/;
+ $tlobj =~ s/$testlib_dir/$obj_dir/;
+ print"$tlfile -> $tlobj";
+
+ if (&compile($tlfile, $tlobj)) {
+  print " ok\n";
+ } else {
+  print " failed\n";
+ }
+}

mps/qa/test/script/commands/try

@@ -0,0 +1,26 @@
+#!/usr/local/bin/perl
+#
+# run tests interactively (allows for user input, immediate results,
+# &c, but doesn't give results in standard format)
+
+require "headread";
+require "compile";
+
+foreach $testfile (@qa_args) {
+
+ print "Test file: $testfile.\n";
+
+ &readheader($testfile);
+ unless ($test_header{"language"} eq "c") {
+  die "Don't know how to run test in this language.\n";
+ }
+
+ $linkfiles = " ".$test_header{"link"};
+ $linkfiles =~ s/ +/ $obj_dir\//g;
+ $objfile = "$obj_dir/tmp_test";
+ unless (&compile_and_link($testfile, $objfile, $linkfiles)) {
+  die "Compilation failed on test ".$testfile.".\n";
+ }
+ system("sh -c \"$objfile\"");
+}
+

mps/qa/test/script/compile

@@ -0,0 +1,49 @@
+#!/usr/local/perl
+#
+# provides subroutines to compile or compile and link
+# tests and test libraries.
+#
+# In future, this will probably do some clever stuff
+# depending on the platform &c, but for now it's just
+# what works on SunOS.
+#
+
+1;
+
+sub compiler_settings {
+ $cc_command = "gcc";
+ $cc_opts = "-ansi -pedantic -Wall -Wstrict-prototypes \\
+  -Winline -Waggregate-return -Wnested-externs -Wcast-qual \\
+  -Wshadow -Wmissing-prototypes -Wredundant-decls -Wcast-align \\
+  -O -g -ggdb3 -D$MMQA_VERSION";
+ $cc_link = "$obj_dir/platform.o";
+ $cc_include = "-I$testlib_dir -I$MPS_INCLUDE_DIR";
+}
+
+sub compile {
+ local($srcfile, $objfile) = @_;
+ 
+ &compiler_settings;
+ $command = "$cc_command -c $cc_opts -o $objfile $srcfile $cc_include";
+
+ if (system($command)) {
+  return 0;
+ } else {
+  return 1;
+ }
+}
+
+sub compile_and_link {
+ local($srcfile, $exefile, $linkfiles) = @_;
+
+ &compiler_settings;
+ $command = "$cc_command $cc_opts -o $exefile $srcfile \\
+  $linkfiles $MPS_LINK_OBJ $cc_link $cc_include";
+
+ if (system($command)) {
+  return 0;
+ } else {
+  return 1;
+ }
+}
+

mps/qa/test/script/headread

@@ -0,0 +1,92 @@
+#!/usr/local/bin/perl
+#
+# subroutines to assist in
+#  1. reading test headers
+#  2. reading test output
+#  3. making pass/fail decision
+#
+# [returns 1 to make perl happy]
+1;
+
+# Example header:
+#
+# ... TEST_HEADER
+# summary=try lots of allocation to provoke errors
+# language=c; link=testlib.o
+# OUTPUT_SPEC
+# alloc=OK
+# size1>20
+# END_HEADER ...
+#
+# header information is stored in associative arrays:
+# %test_header
+# %spec_output
+# %spec_rel
+#
+# $test_header{key} = value;
+# $spec_output{key} = value;
+# $spec_rel{key} = relation;
+#
+
+sub readheader {
+ local($infile) = @_;
+ 
+ unless (open(IN, $infile)) {
+  die "File ".$infile." not found.";
+ }
+
+ $_ = "";
+ while (! /TEST_HEADER/) {
+  ($_ = <IN>) || die "Couldn't find start of test header.\n";
+ }
+ s/.*TEST_HEADER//;
+ $line = $_;
+ while (! /END_HEADER/) {
+  ($_ = <IN> || die "Couldn't find end of test header.\n");
+  chop;
+  $line = $line."; ".$_;
+ }
+ $line =~ s/END_HEADER.*//;
+
+ if ($line =~ /OUTPUT_SPEC/) {
+  $line =~ /(.*)OUTPUT_SPEC(.*)/;
+  $header = $1;
+  $outspec = $2;
+ } else {
+  print "No output specification -- assuming result=pass required.\n";
+  $header = $line;
+  $outspec = "result=pass";
+ }
+
+ &readvals($header, "=");
+ %test_header = %keyvalues;
+
+ &readvals($outspec, "=|<|>|<=|>=");
+ %spec_output = %keyvalues;
+ %spec_rel    = %keyrelations;
+
+ close(IN);
+}
+
+sub readvals {
+ local ($_, $relations) = @_;
+
+ %keyvalues = ();
+ %keyrelations = ();
+
+ s/([^\/]);/\1;;/g;
+
+ foreach (split(/\s*;;\s*/)) {
+  s/\\(\\|;)/\1/g;
+
+  if (m/^\W*(\w+)\s*($relations)\s*(.+)\s*/) {
+   $keyvalues{$1} = $3;
+   $keyrelations{$1} = $2;
+  } else {
+   unless (m/^\W*/) {
+    print "Bad header item: ".$_."\n";
+   }
+  }
+ }
+}
+

mps/qa/test/testlib/arg.h

@@ -0,0 +1,35 @@
+/* arg.h
+   useful things for arg-err tests
+*/
+
+#ifndef arg_h
+#define arg_h
+
+#include "mps.h"
+
+#define UNALIGNED ((mps_addr_t) (((char *) NULL) + 1))
+
+#define MPS_RANK_MIN 0
+#define MPS_RANK_MAX 3
+
+#define MPS_RM_MIN 0
+#define MPS_RM_MAX 3
+
+#define MPS_ALIGN_MIN 1
+
+/* possibly nasty values with high bits set */
+
+#define HIGHBIT_CHAR (~(((unsigned char)  -1) >> 1))
+#define HIGHBIT_INT (~(((unsigned int) -1) >> 1))
+#define HIGHBIT_SHORT (~(((unsigned short) -1) >> 1))
+#define HIGHBIT_LONG (~(((unsigned long) -1) >> 1))
+#define HIGHBIT_SIZE (~((~ (size_t) 0) >> 1))
+
+/* n.b. the last line above will work in ansi C because
+   size_t is an unsigned type. In sos libs, size_t, however
+   is a signed type; it still works tho', because in sos,
+   >> on a negative value is a logical (not arithmetical) shift.
+*/
+
+#endif
+

mps/qa/test/testlib/lofmt.c

@@ -0,0 +1,195 @@
+/* lofmt.c
+   A format for pool class LO
+*/
+
+#include "mps.h"
+#include "testlib.h"
+#include "lofmt.h"
+#include <string.h>
+
+/* some options on the format are controlled by global
+   variables. Of course for efficiency we'd do it in the
+   pre-processor, but that would require recompilation...
+
+ variable      default function
+
+ alloclocomments  comment on allocation (0)
+ allowlocopies    allow objects to be copied (1)
+*/
+
+int alloclocomments=0;
+int allowlocopies=1;
+
+long int nextid=0x2000000;
+
+/* a cell can be one of four things, depending on its type:
+  LOpadsingle - a single pad item, MPS_PF_ALIGN in size
+  LOpadmulti  - a longer pad item, at least 2*MPS_PF_ALIGN in size
+  LOheart     - a broken heart, aka forwarding object
+  LOdata      - a real object
+*/
+
+static mps_res_t myscan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit);
+static mps_addr_t myskip(mps_addr_t object);
+static void myfwd(mps_addr_t object, mps_addr_t to);
+static mps_addr_t myisfwd(mps_addr_t object);
+static void mycopy(mps_addr_t object, mps_addr_t to);
+static void mypad(mps_addr_t base, size_t size);
+
+struct mps_fmt_A_s fmtLO =
+{
+ MPS_PF_ALIGN,
+ &myscan,
+ &myskip,
+ &mycopy,
+ &myfwd,
+ &myisfwd,
+ &mypad
+};
+
+/* in the following, size is the size_t of the data element
+   of the lodata structure you want the object to have; i.e.
+   the number of bytes of storage you get in the object on top
+   of the headers.
+*/
+
+locell *alloclo(mps_ap_t ap, size_t size) {
+ mps_addr_t p;
+ locell *q;
+ size_t bytes;
+ size_t alignment;
+
+ bytes = offsetof(struct lodata, data) + size;
+
+ alignment = MPS_PF_ALIGN; /* needed to make it as wide as size_t */
+
+/* twiddle the value of size to make it aligned */
+ bytes = (bytes+alignment-1) & ~(alignment-1);
+
+ do {
+  die(mps_reserve(&p, ap, bytes), "Reserve: ");
+  q=p;
+  q->data.tag = LOdata;
+  q->data.id = nextid;
+  q->data.copycount = 0;
+  q->data.size = bytes;
+ }
+ while (!mps_commit(ap, p, bytes));
+ commentif(alloclocomments, "allocated id %li at %p.", nextid, q);
+ nextid += 1;
+
+ return q;
+}
+
+static mps_res_t myscan(mps_ss_t ss, mps_addr_t b, mps_addr_t l) {
+ error("Scan method in LO format called!");
+ return MPS_RES_OK;
+}
+
+static mps_addr_t myskip(mps_addr_t object) {
+ locell *obj = object;
+
+ switch(obj->tag)
+ {
+  case LOpadsingle:
+   return (mps_addr_t) ((char *) obj + MPS_PF_ALIGN);
+  case LOpadmany:
+   return obj->padmulti.next;
+  case LOheart:
+   return (mps_addr_t) ((char *) obj + (obj->heart.size));
+  case LOdata:
+   return (mps_addr_t) ((char *) obj + (obj->data.size));
+  default:
+   asserts(0, "loskip: bizarre obj tag at %p.", obj);
+   return 0; /* not reached */
+ }
+}
+
+static void mycopy(mps_addr_t object, mps_addr_t to)
+{
+ locell *boj = object;
+ locell *toj = to;
+
+ asserts(allowlocopies, "locopy on LO object");
+ asserts(boj->tag = LOdata, "locopy: non-data object");
+
+ memmove(to, object, boj->data.size);
+ toj->data.copycount = (toj->data.copycount)+1;
+}
+
+/* pad stores not its size but a pointer to the next object,
+   because we know we'll never be asked to copy it
+*/
+
+static void mypad(mps_addr_t base, size_t size)
+{
+ locell *obj = base;
+
+ asserts(size >= MPS_PF_ALIGN, "pad: size too small.");
+
+ if (size == MPS_PF_ALIGN)
+ {
+  asserts(sizeof(obj->padsingle) <= MPS_PF_ALIGN, "impossible pad");
+  obj->padsingle.tag = LOpadsingle;
+ }
+ else
+ {
+  asserts(size >= sizeof(struct lopadmulti), "pad: awkward size.");
+  obj->padmulti.tag = LOpadmany;
+  obj->padmulti.next = (mps_addr_t) ((char *) base + size);
+ }
+}
+
+static mps_addr_t myisfwd(mps_addr_t object)
+{
+ locell *obj = object;
+
+ if (obj->tag != LOheart)
+ {
+  return NULL;
+ }
+ else
+ {
+  return obj->heart.obj;
+ }
+}
+
+static void myfwd(mps_addr_t object, mps_addr_t to)
+{
+ locell *obj = object;
+ size_t size;
+
+ asserts(obj->tag == LOdata || obj->tag == LOheart,
+  "lofwd: unexpected object tag at %p.", obj);
+
+ if (obj->tag == LOdata)
+ {
+  size = obj->data.size;
+ }
+ else /* obj->tag == LOheart */
+ {
+  size = obj->heart.size;
+ }
+ obj->data.tag = LOheart;
+ obj->heart.obj = to;
+ obj->heart.size = size;
+}
+
+long int getloid(locell *obj)
+{
+ asserts(obj->tag = LOdata, "getloid: non-data object.");
+ return obj->data.id;
+}
+
+long int getlocopycount(locell *obj)
+{
+ asserts(obj->tag = LOdata, "getlocopycount: non-data object.");
+ return obj->data.copycount;
+}
+
+long int getlosize(locell *obj)
+{
+ asserts(obj->tag = LOdata, "getlosize: non-data object.");
+ return obj->data.size - offsetof(struct lodata, data);
+}
+

mps/qa/test/testlib/lofmt.h

@@ -0,0 +1,61 @@
+/* lofmt.h
+   A format for the LO pool class. We have to allow for copying
+   and forwarding, but scan should never be called.
+*/
+
+#ifndef lofmt_h
+#define lofmt_h
+
+#include "mps.h"
+
+extern int alloclocomments;
+extern int allowlocopies;
+
+/* the object format is visible so tests that want to
+   can hack around with it
+*/
+
+#define MAXSIZE 10000
+
+enum {LOpadsingle=(int) 0xBAD51497, LOpadmany=(int) 0xBAD3A41,
+      LOheart=(int) 0x8EA62, LOdata=(int) 0x7EAFDA2A};
+
+typedef union locell locell;
+
+typedef int tag;
+
+struct lopadsingle {tag tag;};
+
+struct lopadmulti {tag tag; mps_addr_t next;};
+
+struct loheart {tag tag; size_t size; mps_addr_t obj;};
+
+struct lodata
+{
+ tag tag;
+ size_t size;
+ long int id;
+ long int copycount;
+ size_t len;
+ char data[MAXSIZE];
+};
+
+union locell
+{
+ tag tag;
+ struct lopadsingle padsingle;
+ struct lopadmulti  padmulti;
+ struct loheart     heart;
+ struct lodata      data;
+};
+
+extern struct mps_fmt_A_s fmtLO;
+
+locell *alloclo(mps_ap_t ap, size_t bytes);
+
+long int getloid(locell *obj);
+long int getlocopycount(locell *obj);
+long int getlosize(locell *obj);
+
+#endif
+

mps/qa/test/testlib/myfmt.c

@@ -0,0 +1,220 @@
+/* myfmt.c
+   a format for scannable objects
+*/
+
+#include "mps.h"
+#include "testlib.h"
+#include "myfmt.h"
+#include <string.h>
+#include <stdio.h>
+
+enum {MCpadsingle, MCpadmany, MCheart, MCdata};
+
+/* some options on the format are controlled by global
+   variables. Of course for efficiency we'd do it in the
+   pre-processor, but that would require recompilation...
+
+ variable      default function
+
+ formatcomments   1   print comments on scanning, fixing, copying
+ copysurplus      1   copy the surplus space in objects when moving 
+
+*/
+
+int formatcomments=1;
+int copysurplus=1;
+
+/* we don't have a separate type for leaf nodes;
+   instead the scanning function doesn't fix null refs
+
+   the words after ref[1] are copied by mycopy,
+   (so you can use them to store data) as long as copysurplus=1
+*/
+
+static mps_res_t myscan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit);
+static mps_addr_t myskip(mps_addr_t object);
+static void myfwd(mps_addr_t object, mps_addr_t to);
+static mps_addr_t myisfwd(mps_addr_t object);
+static void mycopy(mps_addr_t object, mps_addr_t to);
+static void mypad(mps_addr_t base, size_t size);
+
+struct mps_fmt_A_s fmtA =
+{
+ MPS_PF_ALIGN,
+ &myscan,
+ &myskip,
+ &mycopy,
+ &myfwd,
+ &myisfwd,
+ &mypad
+};
+
+mycell *allocone(mps_ap_t ap, mps_word_t data,
+ mycell *ref0, mycell *ref1, size_t size)
+{
+ mps_addr_t p;
+ mycell *q;
+ size_t align;
+
+ align = MPS_PF_ALIGN; /* makes it long enough for ~ to work */
+
+ if (size < sizeof(mycell))
+ {
+  error("Tried to allocate too small an object.");
+ }
+
+/* twiddle the value of size to make it aligned */
+ size = (size+align-1) & ~(align-1);
+
+ do
+ {
+  die(mps_reserve(&p, ap, size), "Reserve: ");
+  q=p;
+  q->tag = MCdata;
+  q->data = data;
+  q->size = size;
+  q->ref[0] = ref0;
+  q->ref[1] = ref1;
+ }
+ while (!mps_commit(ap, p, size));
+ return q;
+}
+
+mps_res_t myscan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
+{
+ MPS_SCAN_BEGIN(ss)
+ {
+  while (base < limit)
+  {
+   mycell *obj = base;
+   mps_res_t res;
+
+   if (formatcomments) printf("Scan %p.\n", (void *)base);
+   switch (obj->tag)
+   {
+    case MCpadsingle:
+     base = (mps_addr_t) ((mps_word_t) obj + MPS_PF_ALIGN);
+     break;
+    case MCpadmany:
+     base = (mps_addr_t) (obj->data);
+     break;
+    case MCdata:
+     /* actual scanning is done in here */
+
+     if (obj->ref[0] != NULL)
+     {
+      if (formatcomments) printf("Fix: %x.\n", (int) &(obj->ref[0]));
+      res = MPS_FIX(ss, (mps_addr_t *) &(obj->ref[0])); /* pun! */
+      if (res != MPS_RES_OK)
+      {
+       return res;
+      }
+     }
+     if (obj->ref[1] != NULL)
+     {
+      if (formatcomments) printf("Fix: %x.\n", (int) &(obj->ref[1]));
+      res = MPS_FIX(ss, (mps_addr_t *) &(obj->ref[1])); /* pun! */
+      if (res != MPS_RES_OK)
+      {
+       return res;
+      }
+     }
+     /* \/ fall through \/ */
+
+    case MCheart:
+     base = (mps_addr_t) ((char *) obj + (obj->size));
+   }
+  }
+  asserts(base == limit, "base <> limit in scan!");
+ }
+ MPS_SCAN_END(ss);
+ return MPS_RES_OK;
+}
+
+mps_addr_t myskip(mps_addr_t object)
+{
+ mycell *obj = object;
+ 
+ switch(obj->tag)
+ {
+  case MCpadsingle:
+   return (mps_addr_t) ((mps_word_t) obj+MPS_PF_ALIGN);
+  case MCpadmany:
+   return (mps_addr_t) (obj->data);
+  case MCheart: case MCdata:
+   return (mps_addr_t) ((char *) obj + (obj->size));
+  default:
+   asserts(0, "skip: bizarre obj tag at %p.", obj);
+   return 0; /* just to satisfy the compiler! */
+ }
+}
+
+void mycopy(mps_addr_t object, mps_addr_t to)
+{
+ mycell *boj = object;
+/* mycell *toj = to;
+*/
+
+ if (formatcomments) printf("copy! %x -> %x\n", (int) object, (int) to);
+
+/* this line is bad, because the objects might overlap,
+   and then C doesn't guarantee to do the right thing!
+
+   *toj = *boj;
+*/
+
+ asserts(boj->tag == MCdata, "Bad object tag in copy");
+
+ if (copysurplus)
+ {
+  memmove(to, object, boj->size);
+ }
+ else
+ {
+  memmove(to, object, sizeof(mycell));
+ }
+
+/* it's guaranteed that we won't have to copy a pad, so we
+   don't have to worry about fiddling the pointer
+*/
+
+}
+
+void mypad(mps_addr_t base, size_t size)
+{
+ mycell *obj = base;
+
+ asserts(size >= MPS_PF_ALIGN, "size too small for pad");
+ if (size == MPS_PF_ALIGN)
+ {
+  obj->tag = MCpadsingle;
+ }
+ else
+ {
+  obj->tag = MCpadmany;
+  obj->data = ((mps_word_t) base) + size;
+ }
+}
+
+mps_addr_t myisfwd(mps_addr_t object)
+{
+ mycell *obj = object;
+ 
+ if (obj->tag != MCheart)
+ {
+  return NULL;
+ }
+ else
+ {
+  return (mps_addr_t) obj->data;
+ }
+}
+
+void myfwd(mps_addr_t object, mps_addr_t to)
+{
+ mycell *obj = object;
+
+ obj->tag = MCheart;
+ obj->data = (mps_word_t) to;
+}
+

mps/qa/test/testlib/myfmt.h

@@ -0,0 +1,46 @@
+/* myfmt.h
+   a format for scannable objects
+*/
+
+#ifndef myfmt_h
+#define myfmt_h
+
+#include "mps.h"
+#include "testlib.h"
+
+/* some options on the format are controlled by global
+   variables. Of course for efficiency we'd do it in the
+   pre-processor, but that would require recompilation...
+
+ variable      default function
+
+ formatcomments   1   print comments on scanning, fixing, copying
+ copysurplus      1   copy the surplus space in objects when moving 
+
+*/
+
+extern int formatcomments;
+extern int copysurplus;
+
+typedef struct mycell
+  {
+   mps_word_t    tag;
+   mps_word_t    data;
+   mps_word_t    size;
+   struct mycell *ref[2];
+  } mycell;
+
+/* we don't have a separate type for leaf nodes;
+   instead the scanning function doesn't fix null refs
+
+   the words after ref[1] are copied by mycopy,
+   (so you can use them to store data) as long as copysurplus=1
+*/
+
+extern struct mps_fmt_A_s fmtA;
+
+mycell *allocone(mps_ap_t ap, mps_word_t data,
+ mycell *ref0, mycell *ref1, size_t size);
+
+#endif
+

mps/qa/test/testlib/newfmt.c

@@ -0,0 +1,526 @@
+/* newfmt.c
+   My attempt to write a format using unions &c to avoid
+   nasty casting all over the place
+*/
+
+#include "mps.h"
+#include "testlib.h"
+#include "newfmt.h"
+#include <string.h>
+
+/* some options on the format are controlled by global
+   variables. Of course for efficiency we'd do it in the
+   pre-processor, but that would require recompilation...
+
+ variable      default function
+
+ formatcomments   1   print comments on scanning, fixing, copying
+ checkcomments    1   print comments on checking
+
+*/
+
+int formatcomments=0;
+int checkcomments=0;
+int countcomments=1;
+int alloccomments=0;
+int fixcomments=0;
+
+long int nextid=0x1000000;
+
+long int checkobjcount=0;
+
+enum
+{
+ SCANCALL_COUNT,
+ SCANOBJ_COUNT, /* = #objects scanned (real ones, that is) */
+ SCANPS_COUNT,  /* = #pad singles scanned */
+ SCANPM_COUNT,  /* etc ... */
+ SCANHEART_COUNT,
+ COPY_COUNT,
+ SKIP_COUNT,
+ FWD_COUNT,
+ ISFWD_COUNT,
+ RESERVE_COUNT,
+ ALLOC_COUNT,
+ PAD_SINGLE_COUNT,
+ PAD_MULTI_COUNT
+};
+
+int counters[PAD_MULTI_COUNT+1];
+int prevcounters[PAD_MULTI_COUNT+1];
+int maxcounters[PAD_MULTI_COUNT+1] = {0};
+
+static long int maxcopy = 0;
+static int freeze=0;
+
+#define INCCOUNT(c) do {if(!freeze) counters[c]+=1;} while (0)
+
+/* a cell can be one of four things, depending on its type:
+  MCpadsingle - a single pad item, MPS_PF_ALIGN in size
+  MCpadmulti  - a longer pad item, at least 2*MPS_PF_ALIGN in size
+  MCheart     - a broken heart, aka forwarding object
+  MCdata      - a real object
+*/
+
+/* the scanning function doesn't try to fix null refs
+
+   size is the total size of the object in bytes
+   every other word from ref onwards, including the word
+   at ref, is a reference; after each one comes the id
+   of the object referenced, so we can check the graph is
+   correct later!
+
+nb: This way of doing things is not really guaranteed to work
+   on all systems. It would be more correct to use an array
+   of structures, or an array of unions.
+*/
+
+static mps_res_t myscan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit);
+static mps_addr_t myskip(mps_addr_t object);
+static void myfwd(mps_addr_t object, mps_addr_t to);
+static mps_addr_t myisfwd(mps_addr_t object);
+static void mycopy(mps_addr_t object, mps_addr_t to);
+static void mypad(mps_addr_t base, size_t size);
+
+struct mps_fmt_A_s fmtA =
+{
+ MPS_PF_ALIGN,
+ &myscan,
+ &myskip,
+ &mycopy,
+ &myfwd,
+ &myisfwd,
+ &mypad
+};
+
+/* in the following, size is the number of refs you want
+   the allocated object to have
+*/
+
+mycell *allocdumb(mps_ap_t ap, size_t size)
+{
+ mps_addr_t p;
+ mycell *q;
+ size_t bytes;
+ size_t alignment;
+
+ bytes = offsetof(struct data, ref) + size;
+
+ alignment = MPS_PF_ALIGN; /* needed to make it as wide as size_t */
+
+/* twiddle the value of size to make it aligned */
+ bytes = (bytes+alignment-1) & ~(alignment-1);
+
+ do
+ {
+  die(mps_reserve(&p, ap, bytes), "Reserve: ");
+  INCCOUNT(RESERVE_COUNT);
+  q=p;
+  q->data.tag = MCdata;
+  q->data.id = nextid;
+  q->data.copycount = 0;
+  q->data.numrefs = 0;
+  q->data.checkedflag = 0;
+  q->data.size = bytes;
+ }
+ while (!mps_commit(ap, p, bytes));
+ INCCOUNT(ALLOC_COUNT);
+ commentif(alloccomments, "allocated id %li at %p.", nextid, q);
+ nextid += 1;
+
+ return q;
+}
+
+mycell *allocone(mps_ap_t ap, int size)
+{
+ mps_addr_t p;
+ mycell *q;
+ int i;
+ size_t bytes;
+ size_t alignment;
+
+ bytes = offsetof(struct data, ref) + size*sizeof(struct refitem);
+
+ alignment = MPS_PF_ALIGN; /* needed to make it as wide as size_t */
+
+/* twiddle the value of size to make it aligned */
+ bytes = (bytes+alignment-1) & ~(alignment-1);
+
+ do
+ {
+  die(mps_reserve(&p, ap, bytes), "Reserve: ");
+  INCCOUNT(RESERVE_COUNT);
+  q=p;
+  q->data.tag = MCdata;
+  q->data.id = nextid;
+  q->data.copycount = 0;
+  q->data.numrefs = size;
+  q->data.checkedflag = 0;
+  q->data.size = bytes;
+
+  for(i=0; i<size; i+=1)
+  {
+   q->data.ref[i].addr = NULL;
+   q->data.ref[i].id   = 0;
+  }
+ }
+ while (!mps_commit(ap, p, bytes));
+ INCCOUNT(ALLOC_COUNT);
+ commentif(alloccomments, "allocated id %li at %p.", nextid, q);
+ nextid += 1;
+
+ return q;
+}
+ 
+static mps_res_t myscan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit)
+{
+ int i;
+
+ INCCOUNT(SCANCALL_COUNT);
+ MPS_SCAN_BEGIN(ss)
+ {
+  while (base < limit)
+  {
+   mycell *obj = base;
+   mps_res_t res;
+   mps_addr_t p;
+
+   switch (obj->tag)
+   {
+    case MCpadsingle:
+     INCCOUNT(SCANPS_COUNT);
+     base = (mps_addr_t) ((char *) obj + MPS_PF_ALIGN);
+     break;
+    case MCpadmany:
+     INCCOUNT(SCANPM_COUNT);
+     base = (obj->padmulti.next);
+     break;
+    case MCdata:
+     INCCOUNT(SCANOBJ_COUNT);
+     /* actual scanning is done in here */
+
+     asserts(obj->data.id != MCerrorid, "scan on error object");
+     commentif(formatcomments, "scan %li at %p.", obj->data.id, base);
+     for (i=0; i<(obj->data.numrefs); i++)
+     {
+      p = obj->data.ref[i].addr;
+      if (p != NULL)
+      {
+       /* copy ref to p for fixing, to avoid a pun (although
+          the pun would probably work fine almost everywhere)
+       */
+       commentif(fixcomments, "fix %li[%i] -> %li",
+        obj->data.id, i, obj->data.ref[i].id);
+       res = MPS_FIX(ss, (mps_addr_t *) &p);
+       if (res != MPS_RES_OK) return res;
+       obj->data.ref[i].addr = p;
+      }
+     }
+     base = (mps_addr_t) ((char *) obj + (obj->data.size));
+     break;
+    case MCheart:
+     INCCOUNT(SCANHEART_COUNT);
+     base = (mps_addr_t) ((char *) obj + (obj->heart.size));
+     break;
+    default:
+     asserts(0, "scan: bizarre obj tag at %p.", obj);
+   }
+  }
+ }
+ MPS_SCAN_END(ss);
+ return MPS_RES_OK;
+}
+
+static mps_addr_t myskip(mps_addr_t object)
+{
+ mycell *obj = object;
+
+ INCCOUNT(SKIP_COUNT);
+ switch(obj->tag)
+ {
+  case MCpadsingle:
+   return (mps_addr_t) ((char *) obj + MPS_PF_ALIGN);
+  case MCpadmany:
+   return obj->padmulti.next;
+  case MCheart:
+   return (mps_addr_t) ((char *) obj + (obj->heart.size));
+  case MCdata:
+   return (mps_addr_t) ((char *) obj + (obj->data.size));
+  default:
+   asserts(0, "skip: bizarre obj tag at %p.", obj);
+   return 0; /* not reached */
+ }
+}
+
+static void mycopy(mps_addr_t object, mps_addr_t to)
+{
+ mycell *boj = object;
+ mycell *toj = to;
+
+ asserts(boj->tag = MCdata, "copy: non-data object");
+
+ INCCOUNT(COPY_COUNT);
+ commentif(formatcomments, "copy: %li: %p -> %p\n",
+  boj->data.id, object, to);
+
+/* this line would be bad, because the objects might overlap,
+   and then C doesn't guarantee to do the right thing!
+
+   *toj = *boj;
+*/
+
+ memmove(to, object, boj->data.size);
+ if (!freeze)
+ {
+  toj->data.copycount = (toj->data.copycount)+1;
+  if (toj->data.copycount > maxcopy) maxcopy = toj->data.copycount;
+ }
+}
+
+/* pad stores not its size but a pointer to the next object,
+   because we know we'll never be asked to copy it
+*/
+
+static void mypad(mps_addr_t base, size_t size)
+{
+ mycell *obj = base;
+
+ asserts(size >= MPS_PF_ALIGN, "pad: size too small.");
+
+ if (size == MPS_PF_ALIGN)
+ {
+  INCCOUNT(PAD_SINGLE_COUNT);
+  asserts(sizeof(obj->padsingle) <= MPS_PF_ALIGN, "impossible pad");
+  obj->padsingle.tag = MCpadsingle;
+ }
+ else
+ {
+  asserts(size >= sizeof(struct padmulti), "pad: awkward size.");
+  INCCOUNT(PAD_MULTI_COUNT);
+  obj->padmulti.tag = MCpadmany;
+  obj->padmulti.next = (mps_addr_t) ((char *) base + size);
+ }
+}
+
+static mps_addr_t myisfwd(mps_addr_t object)
+{
+ mycell *obj = object;
+
+ INCCOUNT(ISFWD_COUNT);
+ if (obj->tag != MCheart)
+ {
+  return NULL;
+ }
+ else
+ {
+  return obj->heart.obj;
+ }
+}
+
+static void myfwd(mps_addr_t object, mps_addr_t to)
+{
+ mycell *obj = object;
+ size_t size;
+
+ asserts(obj->tag == MCdata || obj->tag == MCheart,
+  "fwd: unexpected object tag at %p.", obj);
+ INCCOUNT(FWD_COUNT);
+
+ if (obj->tag == MCdata)
+ {
+  size = obj->data.size;
+ }
+ else /* obj->tag == MCheart */
+ {
+  size = obj->heart.size;
+ }
+ obj->data.tag = MCheart;
+ obj->heart.obj = to;
+ obj->heart.size = size;
+}
+
+
+/* ---------------------------------------------------------------
+   Access methods for mycell objects
+*/
+
+/* set the nth reference of obj to to (n from 0 to size-1) */
+
+void setref(mycell *obj, int n, mycell *to)
+{
+ asserts(obj->tag = MCdata, "setref: from non-data object.");
+ asserts((to==NULL)||(to->tag = MCdata), "setref: to non-data object.");
+ asserts(obj->data.numrefs > n, "setref: access beyond object size.");
+
+ obj->data.ref[n].addr = to;
+ obj->data.ref[n].id = (to==NULL ? 0 : to->data.id);
+}
+
+mycell *getref(mycell *obj, int n)
+{
+ asserts(obj->tag = MCdata, "getref: from non-data object.");
+ asserts(obj->data.numrefs > n, "getref: access beyond object size.");
+ return obj->data.ref[n].addr;
+}
+
+mps_addr_t getdata(mycell *obj)
+{
+ return (mps_addr_t) &(obj->data.ref[0]);
+}
+
+long int getid(mycell *obj)
+{
+ asserts(obj->tag = MCdata, "getid: non-data object.");
+ return obj->data.id;
+}
+
+long int getcopycount(mycell *obj)
+{
+ asserts(obj->tag = MCdata, "getcopycount: non-data object.");
+ return obj->data.copycount;
+}
+
+long int getsize(mycell *obj)
+{
+ asserts(obj->tag = MCdata, "getsize: non-data object.");
+ return obj->data.numrefs;
+}
+
+/* ---------------------------------------------------------------
+   Now the useful things specially for checking the graph
+*/
+
+/* recursively check the graph, starting at an object.
+   We do the check twice, so as to restore the
+   checkflags to zero.
+*/
+
+static void checkloop(mycell *obj, mps_word_t dir)
+{
+ mycell *toj;
+ int tid;
+ int i;
+
+ asserts(obj->tag = MCdata,
+  "checkfrom: non data object in graph at %p.", obj);
+
+ if (obj->data.checkedflag != dir)
+ {
+  commentif(checkcomments, "checking %p = %li", obj, obj->data.id);
+
+  checkobjcount += 1;
+
+  obj->data.checkedflag = dir;
+
+  for (i=0; i<(obj->data.numrefs); i+=1)
+  {
+   if (obj->data.ref[i].addr != NULL)
+   {
+    toj = (obj->data.ref[i].addr);
+    tid = (obj->data.ref[i].id);
+    asserts(toj->data.id = tid,
+     "checkfrom: corrupt graph at %p, %d.", obj, i);
+    checkloop(toj, dir);
+   }
+  }
+ }
+}
+
+void checkfrom(mycell *obj)
+{
+ int k;
+
+ freeze = 1; /* suspend counting while checking graph */
+ checkobjcount = 0;
+ checkloop(obj, 1);
+ comment("checkfrom: %li live objects checked", checkobjcount);
+ k = checkcomments;
+ checkcomments = 0;
+ checkloop(obj, 0);
+ checkcomments = k;
+ comment("checkfrom: graph ok from ID: %li.", obj->data.id);
+ freeze = 0; /* resume counting */
+}
+
+/* ----------------------------------------------------------
+   Now things to reset and display the counters
+*/
+
+void resetcounters(void)
+{
+ int i;
+ for (i=0; i < PAD_MULTI_COUNT+1; i++)
+ {
+  counters[i]=0;
+  prevcounters[i]=0;
+  maxcounters[i]=0;
+ }
+ maxcopy = 0;
+}
+
+void updatecounters(void)
+{
+ int i;
+ for (i=0; i < PAD_MULTI_COUNT+1; i++)
+ {
+  if (counters[i]-prevcounters[i] > maxcounters[i])
+  {
+   maxcounters[i]=counters[i]-prevcounters[i];
+  }
+  prevcounters[i]=counters[i];
+ }
+}
+
+
+static void d_c(int i, char *name)
+{
+ comment("%10d %s", counters[i], name);
+}
+
+static void d_mc(int i, char *name)
+{
+ comment("%10d %s", maxcounters[i], name);
+}
+
+void displaycounters(void)
+{
+ comment("--------");
+ comment("Counters:");
+ d_c(SCANCALL_COUNT, "scan calls");
+ d_c(SCANOBJ_COUNT, "object scans");
+ d_c(SCANHEART_COUNT, "heart scans");
+ d_c(SCANPS_COUNT, "pad scans (single word)");
+ d_c(SCANPM_COUNT, "pad scans (multi word)");
+ d_c(COPY_COUNT, "copys");
+ d_c(SKIP_COUNT, "skips");
+ d_c(FWD_COUNT, "fwds");
+ d_c(ISFWD_COUNT, "isfwds");
+ d_c(PAD_SINGLE_COUNT, "pads (single word)");
+ d_c(PAD_MULTI_COUNT, "pads (multi word)");
+ d_c(RESERVE_COUNT, "reserve calls");
+ d_c(ALLOC_COUNT, "allocations");
+ comment("--------");
+}
+
+void displaymaxcounters(void)
+{
+ comment("--------");
+ comment("Maximum counter values:");
+ d_mc(SCANCALL_COUNT, "scan calls");
+ d_mc(SCANOBJ_COUNT, "object scans");
+ d_mc(SCANHEART_COUNT, "heart scans");
+ d_mc(SCANPS_COUNT, "pad scans (single word)");
+ d_mc(SCANPM_COUNT, "pad scans (multi word)");
+ d_mc(COPY_COUNT, "copys");
+ d_mc(SKIP_COUNT, "skips");
+ d_mc(FWD_COUNT, "fwds");
+ d_mc(ISFWD_COUNT, "isfwds");
+ d_mc(RESERVE_COUNT, "reserve calls");
+ d_mc(ALLOC_COUNT, "allocations");
+ d_mc(PAD_SINGLE_COUNT, "pads (single word)");
+ d_mc(PAD_MULTI_COUNT, "pads (multi word)");
+ comment("--------");
+ comment("max copies of a single object: %li.", maxcopy);
+ comment("--------");
+}
+

mps/qa/test/testlib/newfmt.h

@@ -0,0 +1,87 @@
+/* newfmt.h
+   A nice format with graph checking and statistics
+*/
+
+#ifndef newfmt_h
+#define newfmt_h
+
+#include "mps.h"
+
+extern int formatcomments;
+extern int checkcomments;
+extern int countcomments;
+extern int alloccomments;
+extern int fixcomments;
+
+/* the object format is visible so tests that want to
+   can hack around with it
+*/
+
+#define MAXSIZE 10000
+
+enum {MCpadsingle=(int) 0xBAD51497, MCpadmany=(int) 0xBAD3A41,
+      MCheart=(int) 0x8EA62, MCdata=(int) 0xDA2A};
+
+enum {MCerrorid=(int) 0xE660E};
+
+/* n.b. MCerrorid < 0x1000000 so it won't clash with id of
+   any ordinary object
+*/
+
+typedef union mycell mycell;
+
+typedef int tag;
+
+struct padsingle {tag tag;};
+
+struct padmulti {tag tag; mps_addr_t next;};
+
+struct heart {tag tag; size_t size; mps_addr_t obj;};
+
+struct data
+{
+ tag tag;
+ size_t size;
+ long int id;
+ long int copycount;
+ long int numrefs;
+ int checkedflag;
+ struct refitem {mycell *addr; long int id;} ref[MAXSIZE];
+};
+
+union mycell
+{
+ tag tag;
+ struct padsingle padsingle;
+ struct padmulti  padmulti;
+ struct heart     heart;
+ struct data      data;
+};
+
+extern struct mps_fmt_A_s fmtA;
+
+mycell *allocone(mps_ap_t ap, int size);
+mycell *allocdumb(mps_ap_t ap, size_t bytes);
+
+mps_addr_t getdata(mycell *obj);
+void setref(mycell *obj, int n, mycell *to);
+mycell *getref(mycell *obj, int n);
+
+long int getid(mycell *obj);
+long int getcopycount(mycell *obj);
+long int getsize(mycell *obj);
+
+void checkfrom(mycell *obj);
+
+#define RC resetcounters()
+#define UC updatecounters()
+#define DC displaycounters()
+#define DMC displaymaxcounters()
+
+void resetcounters(void);
+void updatecounters(void);
+void displaycounters(void);
+void displaymaxcounters(void);
+
+#endif
+

mps/qa/test/testlib/ossu.h

@@ -0,0 +1,78 @@
+/*  ==== SUNOS ANSI COMPATABILITY HEADER ====
+ *
+ *  $HopeName: MMsrc!ossu.h(trunk.3) $
+ *
+ *  Copyright (C) 1994,1995 Harlequin Group, all rights reserved
+ *
+ *  This header defines some things which are part of the ANSI standard but
+ *  missing from the C compiler / environment.
+ *
+ *  See also syscalls.h, which contains prototypes for system calls
+ *  which are not prototyped in include files
+ *
+ *  This header was imported from the MLWorks runtime system, when it
+ *  had the following id:
+ *    src:OS:SunOS:ansi.h,v 1.2 1994/06/09 14:24:35 nickh
+ */
+
+#ifndef ansi_h
+#define ansi_h
+
+#include <stdarg.h>
+#include <stdio.h>
+#include <sys/types.h>
+#include <time.h>
+
+/* on the Suns, the include files in /usr/include do not include
+declarations for a large number of ANSI functions. We remedy that
+here. */
+
+/* stdio.h things */
+
+extern int fclose (FILE *stream);
+extern int fflush (FILE *stream);
+extern int fgetc (FILE *stream);
+extern int ungetc (int c, FILE *stram);
+extern int fputc (int c, FILE *stream);
+extern int printf (const char *format, ...);
+extern int fprintf (FILE *stream, const char *format, ...);
+extern int vfprintf (FILE *stream, const char *format, va_list arg);
+extern int vsprintf (char *s, const char *format, va_list arg);
+extern int fputs (const char *s, FILE *stream);
+extern int fscanf (FILE *stream, const char *format, ...);
+extern int sscanf (const char *s, const char *format, ...);
+extern int fseek (FILE *stream, long int offset, int whence);
+extern size_t fread (void *ptr, size_t size, size_t nmemb, FILE *stream);
+extern size_t fwrite (const void *ptr, size_t size, size_t nmemb,
+                      FILE *stream);
+
+/* these functions are used in the macro definitions of putc and getc
+but not declared in stdio.h */
+
+extern int _filbuf(FILE *stream);
+
+#ifdef __GNUC__
+extern int _flsbuf(unsigned char c, FILE *stream);
+#else
+extern int _flsbuf(FILE *stream);
+#endif
+
+/* time.h things */
+
+#ifndef __GNUC__
+typedef long clock_t;
+#endif
+extern size_t strftime (char *s, size_t maxsize, const char *format,
+                        const struct tm *timeptr);
+extern time_t time (time_t *timer);
+extern clock_t clock(void);
+
+/* stdlib.h things */
+
+extern int system(const char *string);
+
+/* string.h things */
+
+extern void *memset(void *, int, size_t);
+
+#endif

mps/qa/test/testlib/platform.c

@@ -0,0 +1,12 @@
+#include "mps.h"
+#include "platform.h"
+
+#ifdef MPS_OS_SU
+
+void *memmove(void *to, void *from, size_t bytes)
+{
+ bcopy((char *)from, (char *)to, (int)bytes);
+ return to;
+}
+
+#endif

mps/qa/test/testlib/platform.h

@@ -0,0 +1,30 @@
+/* platform.h
+   load appropriate header files to do platform-specific
+   stuff.
+*/
+
+#ifdef MPS_OS_SU
+
+/* SunOS (4) doesn't have memmove, which would be handy for
+   writing copy functions in formats. So...
+*/
+
+/* (I copied ossu.h from the mps header files for
+    thursday afternoon)
+*/
+
+#include "ossu.h"
+
+#define EXIT_FAILURE 1
+#define EXIT_SUCCESS 0
+
+#define CLOCKS_PER_SEC 1000000
+
+int scanf(const char *format, ...);
+
+void bcopy(char* from, char* to, int bytes);
+
+void *memmove(void *to, void *from, size_t bytes);
+
+#endif
+

mps/qa/test/testlib/testlib.c

@@ -0,0 +1,243 @@
+/* some useful functions for testing the MPS */
+
+#include <stdio.h>
+#include <assert.h>
+#include <math.h>
+#include "testlib.h"
+
+/* err_text
+   mps_res_t -> textual description
+   uses case rather than array lookup 'cos we don't want to
+   rely on the representation, which might change
+*/
+
+const char *err_text(mps_res_t err)
+{
+ switch (err)
+ {
+  case MPS_RES_OK: return "OK";
+  case MPS_RES_FAIL: return "FAIL";
+  case MPS_RES_RESOURCE: return "RESOURCE";
+  case MPS_RES_MEMORY: return "MEMORY";
+  case MPS_RES_LIMIT: return "LIMIT";
+  case MPS_RES_UNIMPL: return "UNIMPL";
+  case MPS_RES_IO: return "IO";
+ }
+ asserts(0, "Unknown result code");
+ return "*** Unknown result code ***";
+}
+
+/* pass 
+   report result=pass and exit(0)
+*/
+
+void pass(void)
+{
+ report("result", "pass");
+ exit(0);
+}
+
+/* fail
+   report result=fail and exit(1)
+*/   
+
+void fail(void)
+{
+ report("result", "fail");
+ exit(1);
+}
+
+/* report
+   write a var=value line on stdout
+*/
+
+void report(const char *str, const char *format, ...)
+{
+ va_list args;
+
+ va_start(args, format);
+ vreport(str, format, args);
+ va_end(args);
+}
+
+void vreport(const char *str, const char *format, va_list args)
+{
+ fprintf(stdout, "!%s=", str);
+ vfprintf(stdout, format, args);
+ fprintf(stdout, "\n");
+}
+
+/* cdie
+   report mps result code, and exit if it's not ok
+*/
+
+void cdie(mps_res_t err, const char *str)
+{
+ if (err != MPS_RES_OK)
+ {
+  error("%s: %s\n", str, err_text(err));
+ }
+ else comment("%s: OK", str);
+}
+
+/* die
+   check mps result code it ok; it not, report and exit 
+*/
+
+void die(mps_res_t err, const char *str)
+{
+ if (err != MPS_RES_OK)
+ {
+  error("%s: %s\n", str, err_text(err));
+ }
+}
+
+/* adie
+   report mps result code as error, whatever it is
+*/
+
+void adie(mps_res_t err, const char *str)
+{
+ error("%s: %s\n", str, err_text(err));
+}
+
+/* comment
+   print comment on stdout
+*/
+
+void comment(const char *format, ...)
+{
+ va_list args;
+
+ va_start(args, format);
+ vcomment(format, args);
+ va_end(args);
+}
+
+void vcomment(const char *format, va_list args)
+{
+ fprintf(stdout, "%% ");
+ vfprintf(stdout, format, args);
+ fprintf(stdout, "\n");
+}
+
+/* commentif(boolean, "comment")
+*/
+
+void commentif(int cond, const char *format, ...)
+{
+ va_list args;
+
+ if (cond)
+ {
+  va_start(args, format);
+  vcomment(format, args);
+  va_end(args);
+ }
+}
+
+/* error
+   print error on stdout and exit
+*/
+
+void error(const char *format, ...)
+{
+ va_list args;
+
+ va_start(args, format);
+ verror(format, args);
+ va_end(args);
+}
+
+void verror(const char *format, va_list args)
+{
+ fprintf(stdout, "%% ERROR \n!error=true\n");
+ fprintf(stdout, "!errtext=");
+ vfprintf(stdout, format, args);
+ fprintf(stdout, "\n");
+ exit(1);
+}
+
+/* asserts(1=0, "Axiom violation.");
+   assert, with textual message instead of expr printed
+*/
+
+void asserts(int expr, const char *format, ...)
+{
+ va_list args;
+
+ if (!expr)
+ {
+  va_start(args, format);
+  fprintf(stdout, "%% ASSERTION FAILED \n!assert=true\n");
+  fprintf(stdout, "!asserttext=");
+  vfprintf(stdout, format, args);
+  fprintf(stdout, "\n");
+  va_end(args);
+  exit(1);
+ }
+}
+
+/* routines for easy use of the MPS */
+
+/* easy_tramp
+   simplified trampoline, for those who don't want to
+   pass anything into or out of it -- it takes
+   a function with no arguments returning nothing
+*/
+
+static void *call_f(void *p, size_t s)
+{
+ void (**f)(void) = p;
+
+ (**f)(); 
+ return NULL;
+}
+
+
+void easy_tramp(void (*f)(void))
+{
+ void *result;
+
+ mps_tramp(&result, call_f, &f, (size_t)0);
+}
+
+/* nabbed from "ML for the Working Programmer"
+ * Originally from:
+ * Stephen K Park & Keith W Miller (1988). Random number generators:
+ * good ones are to find.  Communications of the ACM, 31:1192-1201
+ */
+
+static unsigned long rnd(void)
+{
+  static unsigned long seed = 1;
+  double s;
+  s = seed;
+  s *= 16807.0;
+  s = fmod(s, 2147483647.0);  /* 2^31 - 1 */
+  seed = (unsigned long)s;
+  return seed;
+}
+
+unsigned long ranint(unsigned long x)
+{
+ unsigned long y;
+ unsigned long max;
+
+ asserts(x>0, "ranint needs positive parameter");
+
+ if (x==1) return 0;
+
+ max = (2147483647/x)*x;
+
+ do y = rnd();
+ while (y>max-1);
+
+ return y%x;
+}
+
+unsigned long ranrange(unsigned long min, unsigned long max)
+{
+ return min+ranint(max-min);
+}
+

mps/qa/test/testlib/testlib.h

@@ -0,0 +1,70 @@
+/* test_lib.h
+   various handy things for reporting errors &c
+*/
+
+#ifndef test_lib_h
+#define test_lib_h
+
+#include "mps.h"
+#include "versind.h"
+#include "platform.h"
+
+/* Give textual description of mps error code */
+
+const char *err_text(mps_res_t err);
+
+/* pass, fail: write result=pass/fail to stdout and
+   exit (0 or 1 as appropriate)
+*/
+
+void pass(void);
+void fail(void);
+
+/* report: print variable and value to stdout
+*/
+
+void report(const char *str, const char *format, ...);
+void vreport(const char *str, const char *format, va_list args);
+
+/* adie: print text and err code to stderr by calling error
+    die: as above, but if err is MPS_RES_OK do nothing
+   cdie: print text and err code to stderr as comment, or as error
+         if err isn't MPS_RES_OK
+*/
+
+void cdie(mps_res_t err, const char *str);
+void  die(mps_res_t err, const char *str);
+void adie(mps_res_t err, const char *str);
+
+/* Prints text to stderr */
+
+void comment(const char *format, ...);
+void vcomment(const char *format, va_list args);
+
+/* Prints text to stderr if cond is true */
+
+void commentif(int cond, const char *format, ...);
+
+/* Prints text to stderr and aborts */
+
+void error(const char *format, ...);
+void verror(const char *format, va_list args);
+
+/* If exp is false, prints text to stderr and aborts */
+
+void asserts(int expr, const char *format, ...);
+
+/* Easy way of entering the trampoline, for when you don't
+   want to pass any information in or out. If you have a
+   function void foo(void), just go easy_tramp(foo).
+*/
+
+void easy_tramp(void (*f)(void));
+
+/* Random number from 0 to x-1
+*/
+
+unsigned long ranint(unsigned long limit);
+unsigned long ranrange(unsigned long min, unsigned long max);
+
+#endif

mps/qa/test/testlib/versind.h

@@ -0,0 +1,17 @@
+/* versind.h
+   lead appropriate header files to do version-specific
+   interface things
+
+   valid versions are:
+    MO : modern -- i.e. as in thursday afternoon
+    OS : oldstyle -- dylan.incr.patch.11
+*/
+
+#if defined(MMQA_VERS_MO)
+#elif defined(MMQA_VERS_OS)
+
+#include "oldstyle.h"
+
+#endif
+
+