code:
/* meas.c -- measure qt stuff. */

#include "copyright.h"

/* Need this to get assertions under Mach on the Sequent/i386: */
#ifdef __i386__
#define assert(ex) \
  do { \
    if (!(ex)) { \
      fprintf (stderr, "[%s:%d] Assertion " #ex " failed\n", __FILE__, __LINE__); \
      abort(); \
    } \
  } while (0)
#else
#include <assert.h>
#endif

/* This really ought to be defined in some ANSI include file (*I*
   think...), but it's defined here instead, which leads us to another
   machine dependency.

   The `iaddr_t' type is an integer representation of a pointer,
   suited for doing arithmetic on addresses, e.g. to round an address
   to an alignment boundary. */
typedef unsigned long iaddr_t;

#include <stdarg.h>	/* For varargs tryout. */
#include <stdio.h>
#include "b.h"
#include "qt.h"
#include "stp.h"

extern void exit (int status);
extern int atoi (char const *s);
extern int fprintf (FILE *out, char const *fmt, ...);
extern int fputs (char const *s, FILE *fp);
extern void free (void *sto);
extern void *malloc (unsigned nbytes);
extern void perror (char const *s);

void usage (void);
void tracer(void);

/* Round `v' to be `a'-aligned, assuming `a' is a power of two. */
#define ROUND(v, a)	(((v) + (a) - 1) & ~((a)-1))

typedef struct thread_t {
  qt_t *qt;		/* Pointer to thread of function... */
  void *stk;
  void *top;		/* Set top of stack if reuse. */
  struct thread_t *next;
} thread_t;

  static thread_t *
t_alloc (void)
{
  thread_t *t;
  int ssz = 0x1000;

  t = malloc (sizeof(thread_t));
  if (!t) {
    perror ("malloc");
    exit (1);
  }
  assert (ssz > QT_STKBASE);
  t->stk = malloc (ssz);
  t->stk = (void *)ROUND (((iaddr_t)t->stk), QT_STKALIGN);
  if (!t->stk) {
    perror ("malloc");
    exit (1);
  }
  assert ((((iaddr_t)t->stk) & (QT_STKALIGN-1)) == 0);
  t->top = QT_SP (t->stk, ssz - QT_STKBASE);

  return (t);
}

  static thread_t *
t_create (qt_only_t *starter, void *p0, qt_userf_t *f)
{
  thread_t *t;

  t = t_alloc();
  t->qt = QT_ARGS (t->top, p0, t, f, starter);
  return (t);
}

  static void
t_free (thread_t *t)
{
  free (t->stk);
  free (t);
}

  static void *
t_null (qt_t *old, void *p1, void *p2)
{
  /* return (garbage); */
}

  static void *
t_splat (qt_t *old, void *oldp, void *null)
{
  *(qt_t **)oldp = old;
  /* return (garbage); */
}

static char const test01_msg[] =
  "*QT_SP(sto,sz), QT_ARGS(top,p0,p1,userf,first)";

static char const *test01_descr[] = {
  "Performs 1 QT_SP and one QT_ARGS per iteration.",
  NULL
};

/* This test gives a guess on how long it takes to initalize
   a thread. */

  static void
test01 (int n)
{
  char stack[QT_STKBASE+QT_STKALIGN];
  char *stk;
  qt_t *top;

  stk = (char *)ROUND (((iaddr_t)stack), QT_STKALIGN);

  {
    int i;

    for (i=0; i<QT_STKBASE; ++i) {
      stk[i] = 0;
    }
  }

  while (n>0) {
    /* RETVALUSED */
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
#ifdef NDEF
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);

    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);
    top = QT_SP (stk, QT_STKBASE);	QT_ARGS (top, 0, 0, 0, 0);

    n -= 10;
#else
    n -= 1;
#endif
  }
}

static char const test02_msg[] = "QT_BLOCKI (0, 0, test02_aux, t->qt)";
static qt_t *rootthread;

  static void
test02_aux1 (void *pu, void *pt, qt_userf_t *f)
{
  QT_ABORT (t_null, 0, 0, rootthread);
}

  static void *
test02_aux2 (qt_t *old, void *farg1, void *farg2)
{
  rootthread = old;
  /* return (garbage); */
}

  static void
test02 (int n)
{
  thread_t *t;

  while (n>0) {
  t = t_create (test02_aux1, 0, 0);
    QT_BLOCKI (test02_aux2, 0, 0, t->qt);
  t_free (t);
  t = t_create (test02_aux1, 0, 0);
    QT_BLOCKI (test02_aux2, 0, 0, t->qt);
  t_free (t);
  t = t_create (test02_aux1, 0, 0);
    QT_BLOCKI (test02_aux2, 0, 0, t->qt);
  t_free (t);
  t = t_create (test02_aux1, 0, 0);
    QT_BLOCKI (test02_aux2, 0, 0, t->qt);
  t_free (t);
  t = t_create (test02_aux1, 0, 0);
    QT_BLOCKI (test02_aux2, 0, 0, t->qt);
  t_free (t);

    n -= 5;
  }
}

static char const test03_msg[] = "QT_BLOCKI (...) test vals are right.";

/* Called by the thread function when it wants to shut down.
   Return a value to the main thread. */

  static void *
test03_aux0 (qt_t *old_is_garbage, void *farg1, void *farg2)
{
  assert (farg1 == (void *)5);
  assert (farg2 == (void *)6);
  return ((void *)15);		/* Some unlikely value. */
}

/* Called during new thread startup by main thread.  Since the new
   thread has never run before, return value is ignored. */

  static void *
test03_aux1 (qt_t *old, void *farg1, void *farg2)
{
  assert (old != NULL);
  assert (farg1 == (void *)5);
  assert (farg2 == (void *)6);
  rootthread = old;
  return ((void *)16);		/* Different than `15'. */
}

  static void
test03_aux2 (void *pu, void *pt, qt_userf_t *f)
{
  assert (pu == (void *)1);
  assert (f == (qt_userf_t *)4);
  QT_ABORT (test03_aux0, (void *)5, (void *)6, rootthread);
}

  static void
test03 (int n)
{
  thread_t *t;
  void *rv;

  while (n>0) {
    t = t_create (test03_aux2, (void *)1, (qt_userf_t *)4);
    rv = QT_BLOCKI (test03_aux1, (void *)5, (void *)6, t->qt);
    assert (rv == (void *)15);
    t_free (t);

    --n;
  }
}

static char const test04_msg[] = "stp_start w/ no threads.";

  static void
test04 (int n)
{
  while (n>0) {
    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();

    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();
    stp_init();	stp_start();

    n -= 10;
  }
}

static char const test05_msg[] = "stp w/ 2 yielding thread.";

  static void
test05_aux (void *null)
{
  stp_yield();
  stp_yield();
}

  static void
test05 (int n)
{
  while (n>0) {
    stp_init();
    stp_create (test05_aux, 0);
    stp_create (test05_aux, 0);
    stp_start();

    --n;
  }
}

static char const test06_msg[] = "*QT_ARGS(...), QT_BLOCKI one thread";

static char const *test06_descr[] = {
  "Does a QT_ARGS, QT_BLOCKI to a helper function that saves the",
  "stack pointer of the main thread, calls an `only' function that",
  "saves aborts the thread, calling a null helper function.",
  ":: start/stop = QT_ARGS + QT_BLOCKI + QT_ABORT + 3 procedure calls.",
  NULL
};

/* This test initializes a thread, runs it, then returns to the main
   program, which reinitializes the thread, runs it again, etc.  Each
   iteration corresponds to 1 init, 1 abort, 1 block. */

static qt_t *test06_sp;

  static void
test06_aux2 (void *null0a, void *null1b, void *null2b, qt_userf_t *null)
{
  QT_ABORT (t_null, 0, 0, test06_sp);
}

  static void *
test06_aux3 (qt_t *sp, void *null0c, void *null1c)
{
  test06_sp = sp;
  /* return (garbage); */
}

  static void
test06 (int n)
{
  thread_t *t;

  t = t_create (0, 0, 0);

  while (n>0) {
    /* RETVALUSED */
    QT_ARGS (t->top, 0, 0, 0, test06_aux2);
    QT_BLOCKI (test06_aux3, 0, 0, t->qt);
#ifdef NDEF
    /* RETVALUSED */
    QT_ARGS (t->top, 0, 0, 0, test06_aux2);
    QT_BLOCKI (test06_aux3, 0, 0, t->qt);

    /* RETVALUSED */
    QT_ARGS (t->top, 0, 0, 0, test06_aux2);
    QT_BLOCKI (test06_aux3, 0, 0, t->qt);

    /* RETVALUSED */
    QT_ARGS (t->top, 0, 0, 0, test06_aux2);
    QT_BLOCKI (test06_aux3, 0, 0, t->qt);

    /* RETVALUSED */
    QT_ARGS (t->top, 0, 0, 0, test06_aux2);
    QT_BLOCKI (test06_aux3, 0, 0, t->qt);

    n -= 5;
#else
    --n;
#endif
  }
}

static char test07_msg[] = "*cswap between threads";

static char const *test07_descr[] = {
  "Build a chain of threads where each thread has a fixed successor.",
  "There is no scheduling performed.  Each thread but one is a loop",
  "that simply blocks with QT_BLOCKI, calling a helper that saves the",
  "current stack pointer.  The last thread decrements a count, and,",
  "if zero, aborts back to the main thread.  Else it continues with",
  "the blocking chain.  The count is divided by the number of threads",
  "in the chain, so `n' is the number of integer block operations.",
  ":: integer cswap = QT_BLOCKI + a procedure call.",
  NULL
};

/* This test repeatedly blocks a bunch of threads.
   Each iteration corresponds to one block operation.

   The threads are arranged so that there are TEST07_N-1 of them that
   run `test07_aux2'.  Each one of those blocks saving it's sp to
   storage owned by the preceding thread; a pointer to that storage is
   passed in via `mep'.  Each thread has a handle on it's own storage
   for the next thread, referenced by `nxtp', and it blocks by passing
   control to `*nxtp', telling the helper function to save its state
   in `*mep'.  The last thread in the chain decrements a count and, if
   it's gone below zero, returns to `test07'; otherwise, it invokes
   the first thread in the chain. */

static qt_t *test07_heavy;

#define TEST07_N (4)

  static void
test07_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
{
  qt_t *nxt;

  while (1) {
    nxt = *(qt_t **)nxtp;
#ifdef NDEF
    printf ("Helper 0x%p\n", nxtp);
#endif
    QT_BLOCKI (t_splat, mep, 0, nxt);
  }
}

  static void
test07_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
{
  int n;

  n = *(int *)np;
  while (1) {
    n -= TEST07_N;
    if (n<0) {
      QT_ABORT (t_splat, mep, 0, test07_heavy);
    }
    QT_BLOCKI (t_splat, mep, 0, *(qt_t **)nxtp);
  }
}

  static void
test07 (int n)
{
  int i;
  thread_t *t[TEST07_N];

  for (i=0; i<TEST07_N; ++i) {
    t[i] = t_create (0, 0, 0);
  }
  for (i=0; i<TEST07_N-1; ++i) {
    /* RETVALUSED */
    QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test07_aux2);
  }
  /* RETVALUSED */
  QT_ARGS (t[i]->top, &n, &t[TEST07_N-1]->qt, &t[0]->qt, test07_aux3);
  QT_BLOCKI (t_splat, &test07_heavy, 0, t[0]->qt);
}

static char test08_msg[] = "Floating-point cswap between threads";

static char const *test08_descr[] = {
  "Measure context switch times including floating-point, use QT_BLOCK.",
  NULL
};

static qt_t *test08_heavy;

#define TEST08_N (4)

  static void
test08_aux2 (void *null0, void *mep, void *nxtp, qt_userf_t *null)
{
  qt_t *nxt;

  while (1) {
    nxt = *(qt_t **)nxtp;
    QT_BLOCK (t_splat, mep, 0, nxt);
  }
}

  static void
test08_aux3 (void *np, void *mep, void *nxtp, qt_userf_t *null)
{
  int n;

  n = *(int *)np;
  while (1) {
    n -= TEST08_N;
    if (n<0) {
      QT_ABORT (t_splat, mep, 0, test08_heavy);
    }
    QT_BLOCK (t_splat, mep, 0, *(qt_t **)nxtp);
  }
}

  static void
test08 (int n)
{
  int i;
  thread_t *t[TEST08_N];

  for (i=0; i<TEST08_N; ++i) {
    t[i] = t_create (0, 0, 0);
  }
  for (i=0; i<TEST08_N-1; ++i) {
    /* RETVALUSED */
    QT_ARGS (t[i]->top, 0, &t[i]->qt, &t[i+1]->qt, test08_aux2);
  }
  /* RETVALUSED */
  QT_ARGS (t[i]->top, &n, &t[TEST08_N-1]->qt, &t[0]->qt, test08_aux3);
  QT_BLOCK (t_splat, &test08_heavy, 0, t[0]->qt);
}

/* Test the varargs procedure calling. */

char const test09_msg[] = { "Start and run threads using varargs." };

thread_t *test09_t0, *test09_t1, *test09_t2, *test09_main;

  thread_t *
test09_create (qt_startup_t *start, qt_vuserf_t *f,
	       qt_cleanup_t *cleanup, int nbytes, ...)
{
  va_list ap;
  thread_t *t;

  t = t_alloc();
  va_start (ap, nbytes);
  t->qt = QT_VARGS (t->top, nbytes, ap, t, start, f, cleanup);
  va_end (ap);
  return (t);
}

  static void
test09_cleanup (void *pt, void *vuserf_retval)
{
  assert (vuserf_retval == (void *)17);
  QT_ABORT (t_splat, &((thread_t *)pt)->qt, 0,
	    ((thread_t *)pt)->next->qt);
}

  static void
test09_start (void *pt)
{
}

  static void *
test09_user0 (void)
{
  QT_BLOCKI (t_splat, &test09_t0->qt, 0, test09_t1->qt);
  return ((void *)17);
}

  static void *
test09_user2 (int one, int two)
{
  assert (one == 1);
  assert (two == 2);
  QT_BLOCKI (t_splat, &test09_t1->qt, 0, test09_t2->qt);
  assert (one == 1);
  assert (two == 2);
  return ((void *)17);
}

  static void *
test09_user10 (int one, int two, int three, int four, int five,
	      int six, int seven, int eight, int nine, int ten)
{
  assert (one == 1);
  assert (two == 2);
  assert (three == 3);
  assert (four == 4);
  assert (five == 5);
  assert (six == 6);
  assert (seven == 7);
  assert (eight == 8);
  assert (nine == 9);
  assert (ten == 10);
  QT_BLOCKI (t_splat, &test09_t2->qt, 0, test09_main->qt);
  assert (one == 1);
  assert (two == 2);
  assert (three == 3);
  assert (four == 4);
  assert (five == 5);
  assert (six == 6);
  assert (seven == 7);
  assert (eight == 8);
  assert (nine == 9);
  assert (ten == 10);
  return ((void *)17);
}

  void
test09 (int n)
{
  thread_t main;

  test09_main = &main;

  while (--n >= 0) {
    test09_t0 = test09_create (test09_start, (qt_vuserf_t*)test09_user0,
			       test09_cleanup, 0);
    test09_t1 = test09_create (test09_start, (qt_vuserf_t*)test09_user2,
			       test09_cleanup, 2 * sizeof(qt_word_t), 1, 2);
    test09_t2 = test09_create (test09_start, (qt_vuserf_t*)test09_user10,
			       test09_cleanup, 10 * sizeof(qt_word_t),
			       1, 2, 3, 4, 5, 6, 7, 8, 9, 10);

    /* Chaining used by `test09_cleanup' to determine who is next. */
    test09_t0->next = test09_t1;
    test09_t1->next = test09_t2;
    test09_t2->next = test09_main;

    QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);
    QT_BLOCKI (t_splat, &test09_main->qt, 0, test09_t0->qt);

    t_free (test09_t0);
    t_free (test09_t1);
    t_free (test09_t2);
  }
}

/* Test 10/11/12: time the cost of various number of args. */

char const test10_msg[] = { "*Test varargs init & startup w/ 0 args." };

char const *test10_descr[] = {
  "Start and stop threads that use variant argument lists (varargs).",
  "Each thread is initialized by calling a routine that calls",
  "QT_VARARGS.  Then runs the thread by calling QT_BLOCKI to hald the",
  "main thread, a helper that saves the main thread's stack pointer,",
  "a null startup function, a null user function, a cleanup function",
  "that calls QT_ABORT and restarts the main thread.  Copies no user",
  "parameters.",
  ":: varargs start/stop = QT_BLOCKI + QT_ABORT + 6 function calls.",
  NULL
};

/* Helper function to send control back to main.
   Don't save anything. */

/* Helper function for starting the varargs thread.  Save the stack
   pointer of the main thread so we can get back there eventually. */

/* Startup function for a varargs thread. */

  static void
test10_startup (void *pt)
{
}

/* User function for a varargs thread. */

  static void *
test10_run (int arg0, ...)
{
  /* return (garbage); */
}

/* Cleanup function for a varargs thread.  Send control
   back to the main thread.  Don't save any state from the thread that
   is halting. */

  void
test10_cleanup (void *pt, void *vuserf_retval)
{
  QT_ABORT (t_null, 0, 0, ((thread_t *)pt)->qt);
}

  void
test10_init (thread_t *new, thread_t *next, int nbytes, ...)
{
  va_list ap;

  va_start (ap, nbytes);
  new->qt = QT_VARGS (new->top, nbytes, ap, next, test10_startup,
		      test10_run, test10_cleanup);
  va_end (ap);
}

  void
test10 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 0);
    QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
  }
  t_free (t);
}

char const test11_msg[] = { "*Test varargs init & startup w/ 2 args." };

char const *test11_descr[] = {
  "Varargs initialization/run.  Copies 2 user arguments.",
  ":: varargs 2 start/stop = QT_VARGS(2 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
  NULL
};

  void
test11 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 2 * sizeof(int), 2, 1);
    QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
  }
  t_free (t);
}

char const test12_msg[] = { "*Test varargs init & startup w/ 4 args." };

char const *test12_descr[] = {
  "Varargs initialization/run.  Copies 4 user arguments.",
  ":: varargs 4 start/stop = QT_VARGS(4 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
  NULL
};

  void
test12 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
    QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
  }
  t_free (t);
}

char const test13_msg[] = { "*Test varargs init & startup w/ 8 args." };

char const *test13_descr[] = {
  "Varargs initialization/run.  Copies 8 user arguments.",
  ":: varargs 8 start/stop = QT_VARGS(8 args), QT_BLOCKI, QT_ABORT, 6 f() calls.",
  NULL
};

  void
test13 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
    QT_BLOCKI (t_splat, &main.qt, 0, t->qt);
  }
  t_free (t);
}

char const test14_msg[] = { "*Test varargs initialization w/ 0 args." };

char const *test14_descr[] = {
  "Varargs initialization without running the thread.  Just calls",
  "QT_VARGS.",
  ":: varargs 0 init = QT_VARGS()",
  NULL
};

  void
test14 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 0 * sizeof(int));
  }
  t_free (t);
}

char const test15_msg[] = { "*Test varargs initialization w/ 2 args." };

char const *test15_descr[] = {
  "Varargs initialization without running the thread.  Just calls",
  "QT_VARGS.",
  ":: varargs 2 init = QT_VARGS(2 args)",
  NULL
};

  void
test15 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 2 * sizeof(int), 2, 1);
  }
  t_free (t);
}

char const test16_msg[] = { "*Test varargs initialization w/ 4 args." };

char const *test16_descr[] = {
  "Varargs initialization without running the thread.  Just calls",
  "QT_VARGS.",
  ":: varargs 4 init = QT_VARGS(4 args)",
  NULL
};

  void
test16 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 4 * sizeof(int), 4, 3, 2, 1);
  }
  t_free (t);
}

char const test17_msg[] = { "*Test varargs initialization w/ 8 args." };

char const *test17_descr[] = {
  "Varargs initialization without running the thread.  Just calls",
  "QT_VARGS.",
  ":: varargs 8 init = QT_VARGS(8 args)",
  NULL
};

  void
test17 (int n)
{
  thread_t main;
  thread_t *t;

  t = t_alloc();
  t->next = &main;

  while (--n >= 0) {
    test10_init (t, &main, 8 * sizeof(int), 8, 7, 6, 5, 4, 3, 2, 1);
  }
  t_free (t);
}

/* Test times for basic machine operations. */

char const test18_msg[] = { "*Call register indirect." };
char const *test18_descr[] = { NULL };

  void
test18 (int n)
{
  b_call_reg (n);
}

char const test19_msg[] = { "*Call immediate." };
char const *test19_descr[] = { NULL };

  void
test19 (int n)
{
  b_call_imm (n);
}

char const test20_msg[] = { "*Add register-to-register." };
char const *test20_descr[] = { NULL };

  void
test20 (int n)
{
  b_add (n);
}

char const test21_msg[] = { "*Load memory to a register." };
char const *test21_descr[] = { NULL };

  void
test21 (int n)
{
  b_load (n);
}

/* Driver. */

typedef struct foo_t {
    char const *msg;	/* Message to print for generic help. */
    char const **descr;	/* A description of what is done by the test. */
    void (*f)(int n);
} foo_t;

static foo_t foo[] = {
  { "Usage:\n", NULL, (void(*)(int n))usage },
  { test01_msg, test01_descr, test01 },
  { test02_msg, NULL, test02 },
  { test03_msg, NULL, test03 },
  { test04_msg, NULL, test04 },
  { test05_msg, NULL, test05 },
  { test06_msg, test06_descr, test06 },
  { test07_msg, test07_descr, test07 },
  { test08_msg, test08_descr, test08 },
  { test09_msg, NULL, test09 },
  { test10_msg, test10_descr, test10 },
  { test11_msg, test11_descr, test11 },
  { test12_msg, test12_descr, test12 },
  { test13_msg, test13_descr, test13 },
  { test14_msg, test14_descr, test14 },
  { test15_msg, test15_descr, test15 },
  { test16_msg, test16_descr, test16 },
  { test17_msg, test17_descr, test17 },
  { test18_msg, test18_descr, test18 },
  { test19_msg, test19_descr, test19 },
  { test20_msg, test20_descr, test20 },
  { test21_msg, test21_descr, test21 },
  { 0, 0 }
};

static int tv = 0;

  void
tracer ()
{

  fprintf (stderr, "tracer\t%d\n", tv++);
  fflush (stderr);
}

  void
tracer2 (void *val)
{
  fprintf (stderr, "tracer2\t%d val=0x%p", tv++, val);
  fflush (stderr);
}

  void
describe()
{
  int i;
  FILE *out = stdout;

  for (i=0; foo[i].msg; ++i) {
    if (foo[i].descr) {
      int j;

      putc ('\n', out);
      fprintf (out, "[%d]\n", i);
      for (j=0; foo[i].descr[j]; ++j) {
	fputs (foo[i].descr[j], out);
	putc ('\n', out);
      }
    }
  }
  exit (0);
}

  void
usage()
{
  int i;

  fputs (foo[0].msg, stderr);
  for (i=1; foo[i].msg; ++i) {
    fprintf (stderr, "%2d\t%s\n", i, foo[i].msg);
  }
  exit (1);
}

  void
args (int *which, int *n, int argc, char **argv)
{
  static int nfuncs = 0;

  if (argc == 2 && argv[1][0] == '-' && argv[1][1] == 'h') {
    describe();
  }

  if (nfuncs == 0) {
    for (nfuncs=0; foo[nfuncs].msg; ++nfuncs)
      ;
  }

  if (argc != 2 && argc != 3) {
    usage();
  }

  *which = atoi (argv[1]);
  if (*which < 0 || *which >= nfuncs) {
    usage();
  }
  *n = (argc == 3)
    ? atoi (argv[2])
    : 1;
}

  int
main (int argc, char **argv)
{
  int which, n;
  args (&which, &n, argc, argv);
  (*(foo[which].f))(n);
  exit (0);
  return (0);
}


code:
#include "qt/copyright.h"
#include "qt/qt.h"

#ifdef QT_VARGS_DEFAULT

/* If the stack grows down, `vargs' is a pointer to the lowest
   address in the block of arguments.  If the stack grows up, it is a
   pointer to the highest address in the block. */

  qt_t *
qt_vargs (qt_t *sp, int nbytes, void *vargs,
	  void *pt, qt_startup_t *startup,
	  qt_vuserf_t *vuserf, qt_cleanup_t *cleanup)
{
  int i;

  sp = QT_VARGS_MD0 (sp, nbytes);
#ifdef QT_GROW_UP
    for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
      QT_SPUT (QT_VARGS_ADJUST(sp), i, ((qt_word_t *)vargs)[-i]);
    }
#else
    for (i=nbytes/sizeof(qt_word_t); i>0; --i) {
      QT_SPUT (QT_VARGS_ADJUST(sp), i-1, ((qt_word_t *)vargs)[i-1]);
    }
#endif

  QT_VARGS_MD1 (QT_VADJ(sp));
  QT_SPUT (QT_VADJ(sp), QT_VARGT_INDEX, pt);
  QT_SPUT (QT_VADJ(sp), QT_VSTARTUP_INDEX, startup);
  QT_SPUT (QT_VADJ(sp), QT_VUSERF_INDEX, vuserf);
  QT_SPUT (QT_VADJ(sp), QT_VCLEANUP_INDEX, cleanup);
  return ((qt_t *)QT_VADJ(sp));
}
#endif /* def QT_VARGS_DEFAULT */

  void
qt_null (void)
{
}

  void
qt_error (void)
{
  extern void abort(void);

  abort();
}

license: unknown


code:
#ifndef QT_H
#define QT_H

#if defined (QT_IMPORT)
# define QT_API __declspec (dllimport) extern
#elif defined (QT_EXPORT) || defined (DLL_EXPORT)
# define QT_API __declspec (dllexport) extern
#else
# define QT_API extern
#endif

#ifdef __cplusplus
extern "C" {
#endif

#include <qt/@qtmd_h@>

/* A QuickThreads thread is represented by it's current stack pointer.
   To restart a thread, you merely need pass the current sp (qt_t*) to
   a QuickThreads primitive.  `qt_t*' is a location on the stack.  To
   improve type checking, represent it by a particular struct. */

typedef struct qt_t {
  char dummy;
} qt_t;

/* Alignment is guaranteed to be a power of two. */
#ifndef QT_STKALIGN
  #error "Need to know the machine-dependent stack alignment."
#endif

#define QT_STKROUNDUP(bytes) \
  (((bytes)+QT_STKALIGN) & ~(QT_STKALIGN-1))

/* Find ``top'' of the stack, space on the stack. */
#ifndef QT_SP
#ifdef QT_GROW_DOWN
#define QT_SP(sto, size)	((qt_t *)(&((char *)(sto))[(size)]))
#endif
#ifdef QT_GROW_UP
#define QT_SP(sto, size)	((void *)(sto))
#endif
#if !defined(QT_SP)
  #error "QT_H: Stack must grow up or down!"
#endif
#endif

/* The type of the user function:
   For non-varargs, takes one void* function.
   For varargs, takes some number of arguments. */
typedef void *(qt_userf_t)(void *pu);
typedef void *(qt_vuserf_t)(int arg0, ...);

/* For non-varargs, just call a client-supplied function,
   it does all startup and cleanup, and also calls the user's
   function. */
typedef void (qt_only_t)(void *pu, void *pt, qt_userf_t *userf);

/* For varargs, call `startup', then call the user's function,
   then call `cleanup'. */
typedef void (qt_startup_t)(void *pt);
typedef void (qt_cleanup_t)(void *pt, void *vuserf_return);

/* Internal helper for putting stuff on stack. */
#ifndef QT_SPUT
#define QT_SPUT(top, at, val)	\
    (((qt_word_t *)(top))[(at)] = (qt_word_t)(val))
#endif

/* Push arguments for the non-varargs case. */
#ifndef QT_ARGS

#ifndef QT_ARGS_MD
#define QT_ARGS_MD (0)
#endif

#ifndef QT_STKBASE
  #error "Need to know the machine-dependent stack allocation."
#endif

/* All things are put on the stack relative to the final value of
   the stack pointer. */
#ifdef QT_GROW_DOWN
#define QT_ADJ(sp)	(((char *)sp) - QT_STKBASE)
#else
#define QT_ADJ(sp)	(((char *)sp) + QT_STKBASE)
#endif

#define QT_ARGS(sp, pu, pt, userf, only) \
    (QT_ARGS_MD (QT_ADJ(sp)), \
     QT_SPUT (QT_ADJ(sp), QT_ONLY_INDEX, only), \
     QT_SPUT (QT_ADJ(sp), QT_USER_INDEX, userf), \
     QT_SPUT (QT_ADJ(sp), QT_ARGT_INDEX, pt), \
     QT_SPUT (QT_ADJ(sp), QT_ARGU_INDEX, pu), \
     ((qt_t *)QT_ADJ(sp)))

#endif

/* Push arguments for the varargs case.
   Has to be a function call because initialization is an expression
   and we need to loop to copy nbytes of stuff on to the stack.
   But that's probably OK, it's not terribly cheap, anyway. */

#ifdef QT_VARGS_DEFAULT
#ifndef QT_VARGS_MD0
#define QT_VARGS_MD0(sp, vasize)	(sp)
#endif
#ifndef QT_VARGS_MD1
#define QT_VARGS_MD1(sp)	do { ; } while (0)
#endif

#ifndef QT_VSTKBASE
  #error "Need base stack size for varargs functions."
#endif

/* Sometimes the stack pointer needs to munged a bit when storing
   the list of arguments. */
#ifndef QT_VARGS_ADJUST
#define QT_VARGS_ADJUST(sp)	(sp)
#endif

/* All things are put on the stack relative to the final value of
   the stack pointer. */
#ifdef QT_GROW_DOWN
#define QT_VADJ(sp)	(((char *)sp) - QT_VSTKBASE)
#else
#define QT_VADJ(sp)	(((char *)sp) + QT_VSTKBASE)
#endif

QT_API qt_t *qt_vargs (qt_t *sp, int nbytes, void *vargs,
		       void *pt, qt_startup_t *startup,
		       qt_vuserf_t *vuserf, qt_cleanup_t *cleanup);

#ifndef QT_VARGS
#define QT_VARGS(sp, nbytes, vargs, pt, startup, vuserf, cleanup) \
      (qt_vargs (sp, nbytes, vargs, pt, startup, vuserf, cleanup))
#endif

#endif

QT_API void qt_null (void);
QT_API void qt_error (void);

/* Save the state of the thread and call the helper function
   using the stack of the new thread. */
typedef void *(qt_helper_t)(qt_t *old, void *a0, void *a1);
typedef void *(qt_block_t)(qt_helper_t *helper, void *a0, void *a1,
			  qt_t *newthread);

/* Rearrange the parameters so that things passed to the helper
   function are already in the right argument registers. */
#ifndef QT_ABORT
QT_API void qt_abort (qt_helper_t *h, void *a0, void *a1, qt_t *newthread);
/* The following does, technically, `return' a value, but the
   user had better not rely on it, since the function never
   returns. */
#define QT_ABORT(h, a0, a1, newthread) \
    do { qt_abort (h, a0, a1, newthread); } while (0)
#endif

#ifndef QT_BLOCK
QT_API void *qt_block (qt_helper_t *h, void *a0, void *a1,
		       qt_t *newthread);
#define QT_BLOCK(h, a0, a1, newthread) \
    (qt_block (h, a0, a1, newthread))
#endif

#ifndef QT_BLOCKI
QT_API void *qt_blocki (qt_helper_t *h, void *a0, void *a1,
			qt_t *newthread);
#define QT_BLOCKI(h, a0, a1, newthread) \
    (qt_blocki (h, a0, a1, newthread))
#endif

#ifdef __cplusplus
}		/* Match `extern "C" {' at top. */
#endif

#endif /* ndef QT_H */


code:
#include "copyright.h"
#include "qt.h"
#include "stp.h"

#ifndef NULL
#define NULL	0
#endif

#define STP_STKSIZE (0x1000)

/* `alignment' must be a power of 2. */
#define STP_STKALIGN(sp, alignment) \
  ((void *)((((qt_word_t)(sp)) + (alignment) - 1) & ~((alignment)-1)))

/* The notion of a thread is merged with the notion of a queue.
   Thread stuff: thread status (sp) and stuff to use during
   (re)initialization.  Queue stuff: next thread in the queue
   (next). */

struct stp_t {
  qt_t *sp;              /* QuickThreads handle. */
  void *sto;             /* `malloc'-allocated stack. */
  struct stp_t *next;    /* Next thread in the queue. */
};

/* A queue is a circular list of threads.  The queue head is a
   designated list element.  If this is a uniprocessor-only
   implementation we can store the `main' thread in this, but in a
   multiprocessor there are several `heavy' threads but only one run
   queue.  A fancier implementation might have private run queues,
   which would lead to a simpler (trivial) implementation */

typedef struct stp_q_t {
  stp_t t;
  stp_t *tail;
} stp_q_t;

/* Helper functions. */

extern void *malloc (unsigned size);
extern void perror (char const *msg);
extern void free (void *sto);

  void *
xmalloc (unsigned size)
{
  void *sto;

  sto = malloc (size);
  if (!sto) {
    perror ("malloc");
    exit (1);
  }
  return (sto);
}

/* Queue access functions. */

  static void
stp_qinit (stp_q_t *q)
{
  q->t.next = q->tail = &q->t;
}

  static stp_t *
stp_qget (stp_q_t *q)
{
  stp_t *t;

  t = q->t.next;
  q->t.next = t->next;
  if (t->next == &q->t) {
    if (t == &q->t) {		/* If it was already empty .. */
      return (NULL);		/* .. say so. */
    }
    q->tail = &q->t;		/* Else now it is empty. */
  }
  return (t);
}

  static void
stp_qput (stp_q_t *q, stp_t *t)
{
  q->tail->next = t;
  t->next = &q->t;
  q->tail = t;
}

/* Thread routines. */

static stp_q_t stp_global_runq;	/* A queue of runable threads. */
static stp_t stp_global_main;   /* Thread for the process. */
static stp_t *stp_global_curr;	/* Currently-executing thread. */

static void *stp_starthelp (qt_t *old, void *ignore0, void *ignore1);
static void stp_only (void *pu, void *pt, qt_userf_t *f);
static void *stp_aborthelp (qt_t *sp, void *old, void *null);
static void *stp_yieldhelp (qt_t *sp, void *old, void *blockq);

  void
stp_init()
{
  stp_qinit (&stp_global_runq);
}

  void
stp_start()
{
  stp_t *next;

  while ((next = stp_qget (&stp_global_runq)) != NULL) {
    stp_global_curr = next;
    QT_BLOCK (stp_starthelp, 0, 0, next->sp);
  }
}

  static void *
stp_starthelp (qt_t *old, void *ignore0, void *ignore1)
{
  stp_global_main.sp = old;
  stp_qput (&stp_global_runq, &stp_global_main);
  /* return (garbage); */
}

  void
stp_create (stp_userf_t *f, void *pu)
{
  stp_t *t;
  void *sto;

  t = xmalloc (sizeof(stp_t));
  t->sto = xmalloc (STP_STKSIZE);
  sto = STP_STKALIGN (t->sto, QT_STKALIGN);
  t->sp = QT_SP (sto, STP_STKSIZE - QT_STKALIGN);
  t->sp = QT_ARGS (t->sp, pu, t, (qt_userf_t *)f, stp_only);
  stp_qput (&stp_global_runq, t);
}

  static void
stp_only (void *pu, void *pt, qt_userf_t *f)
{
  stp_global_curr = (stp_t *)pt;
  (*(stp_userf_t *)f)(pu);
  stp_abort();
  /* NOTREACHED */
}

  void
stp_abort (void)
{
  stp_t *old, *newthread;

  newthread = stp_qget (&stp_global_runq);
  old = stp_global_curr;
  stp_global_curr = newthread;
  QT_ABORT (stp_aborthelp, old, (void *)NULL, newthread->sp);
}

  static void *
stp_aborthelp (qt_t *sp, void *old, void *null)
{
  free (((stp_t *)old)->sto);
  free (old);
  /* return (garbage); */
}

  void
stp_yield()
{
  stp_t *old, *newthread;

  newthread = stp_qget (&stp_global_runq);
  old = stp_global_curr;
  stp_global_curr = newthread;
  QT_BLOCK (stp_yieldhelp, old, &stp_global_runq, newthread->sp);
}

  static void *
stp_yieldhelp (qt_t *sp, void *old, void *blockq)
{
  ((stp_t *)old)->sp = sp;
  stp_qput ((stp_q_t *)blockq, (stp_t *)old);
  /* return (garbage); */
}


code:
#ifndef STP_H
#define STP_H

/*
 * QuickThreads -- Threads-building toolkit.
 * Copyright (c) 1993 by David Keppel
 *
 * Permission to use, copy, modify and distribute this software and
 * its documentation for any purpose and without fee is hereby
 * granted, provided that the above copyright notice and this notice
 * appear in all copies.  This software is provided as a
 * proof-of-concept and for demonstration purposes; there is no
 * representation about the suitability of this software for any
 * purpose.
 */

typedef struct stp_t stp_t;

/* Each thread starts by calling a user-supplied function of this
   type. */

typedef void (stp_userf_t)(void *p0);

/* Call this before any other primitives. */
extern void stp_init();

/* When one or more threads are created by the main thread,
   the system goes multithread when this is called.  It is done
   (no more runable threads) when this returns. */

extern void stp_start (void);

/* Create a thread and make it runable.  When the thread starts
   running it will call `f' with the argument `p0'. */

extern void stp_create (stp_userf_t *f, void *p0);

/* The current thread stops running but stays runable.
   It is an error to call `stp_yield' before `stp_start'
   is called or after `stp_start' returns. */

extern void stp_yield (void);

/* Like `stp_yield' but the thread is discarded.  Any intermediate
   state is lost.  The thread can also terminate by simply
   returning. */

extern void stp_abort (void);

#endif /* ndef STP_H */


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 1998, 2006 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE is distributed in the hope that it will be useful, but
##   WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
##   You should have received a copy of the GNU General Public
##   License along with GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

EXTRA_DIST = README.time assim cswap go init prim raw


code:
The program `raw', when run in `..' runs the program `run' produced
from `meas.c'.  It produces a raw output file (see `../tmp/*.raw').
`raw' will die with an error if run in the current directory.  Note
that some versions of `time' produce output in an unexpected format;
edit them by hand.

`prim', `init', `cswap' and `go' produce formatted table entries used
in the documentation (in `../doc').  For example, from `..',

	foreach i (tmp/*.raw)
	  time/prim $i
	end

See notes in the QuickThreads document about the applicability of
these microbenchmark measurements -- in general, you can expect all
QuickThreads operations to be a bit slower when used in a real
application.


code:
#! /bin/awk -f

BEGIN {
  nmach = 0;

  init_test = "1";
  abort_test = "6";
  blocki_test = "7";
  block_test = "8";
}

{
  mach = $1
  test = $2
  iter = $3
  time = $6 + $8

  if (machi[mach] == 0) {
    machn[nmach] = mach;
    machi[mach] = 1;
    ++nmach;
  }

  us_per_op = time / iter * 1000000
  times[mach "_" test] = us_per_op;
}

END {
  for (i=0; i<nmach; ++i) {
    m = machn[i];
    init = times[m "_" init_test];
    printf ("init %s | %f\n", m, init);

    init_abort_blocki = times[m "_" abort_test];
    abort_blocki = init_abort_blocki - init;
    blocki = times[m "_" blocki_test];
    abort = abort_blocki - blocki;
    blockf = times[m "_" block_test];
    printf ("swap %s | %f | %f | %f\n", m, abort, blocki, blockf);
  }
}

path: qt/time/assim


code:
#! /bin/awk -f

BEGIN {
  purpose = "report time used by int only and int+fp cswaps";

  nmach = 0;

  test_int = "7";
  test_fp = "8";
}

{
  mach = $1
  test = $2
  iter = $3
  time = $6 + $8

  if (machi[mach] == 0) {
    machn[nmach] = mach;
    machi[mach] = 1;
    ++nmach;
  }

  us_per_op = time / iter * 1000000
  times[mach "_" test] = us_per_op;
}

END {
  for (i=0; i<nmach; ++i) {
    m = machn[i];

    integer = times[m "_" test_int];
    fp = times[m "_" test_fp];
    printf ("%s|%3.1f|%3.1f\n", m, integer, fp);
  }
}

path: qt/time/cswap


code:
#! /bin/awk -f

BEGIN {
  purpose = "report times used for init/start/stop";

  nmach = 0;

  test_single = "6";
  test_v0 = "10";
  test_v2 = "11";
  test_v4 = "12";
  test_v8 = "13";
}

{
  mach = $1
  test = $2
  iter = $3
  time = $6 + $8

  if (machi[mach] == 0) {
    machn[nmach] = mach;
    machi[mach] = 1;
    ++nmach;
  }

  us_per_op = time / iter * 1000000
  times[mach "_" test] = us_per_op;
}

END {
  for (i=0; i<nmach; ++i) {
    m = machn[i];

    single = times[m "_" test_single];
    v0 = times[m "_" test_v0];
    v2 = times[m "_" test_v2];
    v4 = times[m "_" test_v4];
    v8 = times[m "_" test_v8];
    printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
  }
}

path: qt/time/go


code:
#! /bin/awk -f

BEGIN {
  purpose = "Report time used to initialize a thread."
  nmach = 0;

  test_single = "1";
  test_v0 = "14";
  test_v2 = "15";
  test_v4 = "16";
  test_v8 = "17";
}

{
  mach = $1
  test = $2
  iter = $3
  time = $6 + $8

  if (machi[mach] == 0) {
    machn[nmach] = mach;
    machi[mach] = 1;
    ++nmach;
  }

  us_per_op = time / iter * 1000000
  times[mach "_" test] = us_per_op;
}

END {
  for (i=0; i<nmach; ++i) {
    m = machn[i];

    single = times[m "_" test_single];
    v0 = times[m "_" test_v0];
    v2 = times[m "_" test_v2];
    v4 = times[m "_" test_v4];
    v8 = times[m "_" test_v8];
    printf ("%s|%3.1f|%3.1f|%3.1f|%3.1f|%3.1f\n", m, single, v0, v2, v4, v8);
  }
}

path: qt/time/init


code:
#! /bin/awk -f

BEGIN {
  purpose = "report times for microbenchmarks"

  nmach = 0;

  test_callind = "18";
  test_callimm = "18";
  test_addreg = "20";
  test_loadreg = "21";
}

{
  mach = $1
  test = $2
  iter = $3
  time = $6 + $8

  if (machi[mach] == 0) {
    machn[nmach] = mach;
    machi[mach] = 1;
    ++nmach;
  }

  ns_per_op = time / iter * 1000000
  times[mach "_" test] = ns_per_op;
}

END {
  for (i=0; i<nmach; ++i) {
    m = machn[i];

    ind = times[m "_" test_callind];
    imm = times[m "_" test_callimm];
    add = times[m "_" test_addreg];
    load = times[m "_" test_loadreg];
    printf ("%s|%1.3f|%1.3f|%1.3f|%1.3f\n", m, ind, imm, add, load);
  }
}

path: qt/time/prim


code:
#! /bin/csh

rm -f timed

set init=1
set runone=6
set blockint=7
set blockfloat=8
set vainit0=14
set vainit2=15
set vainit4=16
set vainit8=17
set vastart0=10
set vastart2=11
set vastart4=12
set vastart8=13
set bench_regcall=18
set bench_immcall=19
set bench_add=20
set bench_load=21

source configuration

echo -n $config_machine $init $config_init
/bin/time run $init $config_init
echo -n $config_machine $runone $config_runone
/bin/time run $runone $config_runone
echo -n $config_machine $blockint $config_blockint
/bin/time run $blockint $config_blockint
echo -n $config_machine $blockfloat $config_blockfloat
/bin/time run $blockfloat $config_blockfloat

echo -n $config_machine $vainit0 $config_vainit0
/bin/time run $vainit0 $config_vainit0
echo -n $config_machine $vainit2 $config_vainit2
/bin/time run $vainit2 $config_vainit2
echo -n $config_machine $vainit4 $config_vainit4
/bin/time run $vainit4 $config_vainit4
echo -n $config_machine $vainit8 $config_vainit8
/bin/time run $vainit8 $config_vainit8

echo -n $config_machine $vastart0 $config_vastart0
/bin/time run $vastart0 $config_vastart0
echo -n $config_machine $vastart2 $config_vastart2
/bin/time run $vastart2 $config_vastart2
echo -n $config_machine $vastart4 $config_vastart4
/bin/time run $vastart4 $config_vastart4
echo -n $config_machine $vastart8 $config_vastart8
/bin/time run $vastart8 $config_vastart8

echo -n $config_machine $bench_regcall $config_bcall_reg
/bin/time run $bench_regcall $config_bcall_reg
echo -n $config_machine $bench_immcall $config_bcall_imm
/bin/time run $bench_immcall $config_bcall_imm
echo -n $config_machine $bench_add $config_b_add
/bin/time run $bench_add $config_b_add
echo -n $config_machine $bench_load $config_b_load
/bin/time run $bench_load $config_b_load

path: qt/time/raw


code:
2004-11-09  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* snarf-check-and-output-texi (process-multiline-directive): Allow
	the fname attribute to a sequence of strings and append them all
	to form the fname.  This is needed for string literals like
	"u8""vector?".

2004-09-08  Marius Vollmer  <marius.vollmer@uni-dortmund.de>

	* Makefile.am (scripts_sources): Added snarf-guile-m4-docs.

2004-08-06  Kevin Ryde  <user42@zip.com.au>

	* scripts/read-rfc822 (parse-message): Correction to header
	continuation, loop with read-line not cdr lines.

2002-12-08  Rob Browning  <rlb@defaultvalue.org>

	* Makefile.am (subpkgdatadir): VERSION -> GUILE_EFFECTIVE_VERSION.

2002-10-26  Neil Jerram  <neil@ossau.uklinux.net>

	* lint (lint): Add message telling resolved module name.

2002-10-05  Marius Vollmer  <mvo@zagadka.ping.de>

	* snarf-check-and-output-texi (end-multiline): Use '*function-name*'
	instead of nonexisting 'name'.

2002-10-04  Rob Browning  <rlb@defaultvalue.org>

	* summarize-guile-TODO (as-leaf): make #\: a char-set.

2002-05-18  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* api-diff (group-diff): Also output +N and -N adds and subs
	details, respectively.

2002-05-13  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* read-rfc822: New script.

	* Makefile.am (scripts_sources): Add api-diff and read-rfc822.

	* scan-api (scan-api): No longer include timestamp.

2002-05-11  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (scan-api): Fix bug: No longer omit `C' and `Scheme' in
	groups in the presence of the grouper.

	* api-diff: Use modules (ice-9 format), (ice-9 getopt-long).
	Autoload module (srfi srfi-13).
	No longer export `diff-alists'.

	(diff, diff-alists, display-list): Remove.
	(put, get, read-api-alist-file, hang-by-the-roots, diff?,
	diff+note!, group-diff): New procs.
	(api-diff): Rewrite.

2002-05-10  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (add-props): New proc.
	(make-grok-proc): Renamed from `make-grok-hook'.
	(make-members-proc): Renamed from `make-members-hook'.
	(make-grouper): Renamed from `make-grouping-hook'.  Update callers.
	Add handling for multiple grouping-defs files.
	(scan-api): Add handling for multiple grouping-defs files.
	Cache `symbol->string' result; adjust `sort' usage.

2002-05-09  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api (scan-C!): Use more robust regexp.

2002-05-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* scan-api: New script.
	(scan-api): Handle case where `grouping-hook' is #f.

	Remove top-level `debug-enable' form.
	Add TODO comment; nfc.

	* Makefile.am (scripts_sources): Add "scan-api".

2002-04-30  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO (make-display-item):
	Hoist some lambdas; nfc.

2002-04-29  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Fix commentary typo; nfc.

2002-04-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Use (ice-9 getopt-long).
	Autoload (ice-9 common-list).

	(select-items): New proc.
	(make-display-item): New proc.
	(display-item): Delete.
	(display-items): Use `make-display-item'.
	(summarize-guile-TODO): Add option handling.

2002-04-07  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: Add "Bugs" section to commentary.
	Autoload (srfi srfi-13) on `string-tokenize'.

	(as-leaf): New proc.
	(hang-by-the-leaves): Use `as-leaf'.
	(read-TODO-file): Expand regexp and specs
	to handle "D", "X" and "N%".  Fix regexp
	to make isolating `who' easier.
	(display-item): Handle "D", "X" and "N%".

2002-04-06  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* summarize-guile-TODO: New script.

	* Makefile.am (scripts_sources): Add "summarize-guile-TODO".

2002-04-05  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* read-text-outline (display-outline-tree): No longer export this proc.

	(*depth-cue-rx*, *subm-number*, *level-divisor*, >>,
	display-outline-tree): Delete these vars and procs.

	(??, msub, ??-predicates, make-line-parser,
	make-text-outline-reader): New procs.

	(make-text-outline-reader): Export.
	(read-text-outline-silently): Rewrite
	using `make-text-outline-reader'.

2002-04-04  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* lint: New script.

	* Makefile.am (scripts_sources): Add "lint".

2002-04-02  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* PROGRAM: Update copyright; nfc.

	* read-text-outline: New script.

	* Makefile.am (scripts_sources): Add "read-text-outline".

	* read-text-outline (read-text-outline-silently):
	Move `tp' inside `loop'; nfc.

2002-03-12  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-check-and-output-texi (snarf-check-and-output-texi): If
	supplied, the `--manual' flag arrives as a string, not a symbol,
	so test for it as such.

2002-03-03  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-guile-m4-docs (display-texi): Strip off `# ' from start of
	docstring lines if possible, rather than just `#'.

2002-02-26  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am: Update path to pre-inst-guile automake frag.

2002-02-22  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* api-diff: New script.

2002-02-05  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Include $(top_srcdir)/pre-inst-guile.am.

	(overview): Use $(preinstguiletool).

2002-01-11  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am (scripts_sources): Add autofrisk.

	* autofrisk: New script.

	* frisk: Fix typo in commentary; nfc.

	* use2dot: Autoload module (ice-9 getopt-long).
	Use module (srfi srfi-13).
	Export `use2dot'.

	(string-append/separator, mapconcat): Delete.
	(vv): Now take list of pairs, and return the mapping..
	(>>header): Use `string-join'.
	(>>): New proc.
	(use2dot): Use `getopt-long'.  Use `>>'.

2002-01-08  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* Makefile.am (scripts_sources): Add frisk.
	(list): New target.
	(overview): Also report module interfaces.

	* use2dot: Rewrite using (scripts frisk).

	* frisk: Initial revision.

2002-01-02  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* snarf-guile-m4-docs: New script.

2001-11-28  Thien-Thi Nguyen  <ttn@giblet.glug.org>

	* punify (write-punily): Handle symbols w/ ":" prefix specially.

	* use2dot (ferret): New proc.
	(grok): Use `ferret'.

2001-11-16  Neil Jerram  <neil@ossau.uklinux.net>

	* snarf-check-and-output-texi: Change generated @deffn categories
	from "function" and "primitive" to "C Function" and "Scheme
	Procedure".
	(end-multiline): Take out @findex generation again; not needed
	since index entries are implicit in @deffn forms.

	These changes add a @deffnx C function declaration and function
	index entries for each Guile primitive to the copy of the doc
	snarf output that is used for reference manual synchronization.
	Online help is unchanged.

	* snarf-check-and-output-texi (*manual-flag*,
	snarf-check-and-output-texi): Handle `--manual' invocation arg
	passed through from libguile/Makefile.am.
	(*c-function-name*, begin-multiline, do-command): Pick out C
	function name from snarfed token stream.
	(end-multiline): Add @deffnx C declaration and function index
	entries to output.
	(*primitive-deffnx-signature*, *primitive-deffnx-sig-length*):
	Fluff to help insert the C declaration after any "@deffnx
	primitive" lines in the snarfed docstring.

2001-10-05  Thien-Thi Nguyen  <ttn@glug.org>

	* read-scheme-source (quoted?, clump): New procs, exported.

2001-09-30  Thien-Thi Nguyen  <ttn@glug.org>

	* display-commentary (module-name->filename-frag,
	display-module-commentary): New procs.
	(display-commentary): Also handle refs that look like module
	names.

2001-08-25  Marius Vollmer  <mvo@zagadka.ping.de>

	* Makefile.am (AUTOMAKE_OPTIONS): Change "foreign" to "gnu".

2001-08-07  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: print optional args in a prettier
	manner.

2001-08-01  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, README, display-commentary, doc-snarf,
	generate-autoload, punify, read-scheme-source,
	snarf-check-and-output-texi, use2dot:
	In boilerplate, use -l$0.
	Thanks to Daniel Skarda.

2001-07-22  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* generate-autoload (autoload-info):
	Also handle `defmacro-public' forms.

2001-07-14  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, display-commentary, doc-snarf, generate-autoload,
	punify, read-scheme-source, snarf-check-and-output-texi, use2dot:
	Re-add authorship info.

2001-07-12  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi (do-argpos): complain to the stderr,
	not stdout.  thanks to Dale P. Smith!
	(nice-sig): cosmetic fix.

2001-07-09  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, generate-autoload, use2dot, punify, display-commentary,
	doc-snarf, read-scheme-source, snarf-check-and-output-texi:
	Remove authorship info.

2001-06-25  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: rewrite.

2001-05-31  Michael Livshin  <mlivshin@bigfoot.com>

	* snarf-check-and-output-texi: new file.

	* Makefile.am (scripts_sources): add snarf-check-and-output-texi.

2001-05-14  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* PROGRAM, display-commentary, doc-snarf, generate-autoload,
	punify, read-scheme-source, use2dot: Move author tag outside
	commentary; nfc.

2001-05-08  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* read-scheme-source: New file

	* Makefile.am (scripts_sources): Add read-scheme-source.

2001-04-29  Thien-Thi Nguyen  <ttn@revel.glug.org>

	* Makefile.am, PROGRAM, README, display-commentary,
	doc-snarf, generate-autoload, punify, use2dot: New file


code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE is distributed in the hope that it will be useful, but
##   WITHOUT ANY WARRANTY; without even the implied warranty of
##   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##   GNU General Public License for more details.
##
##   You should have received a copy of the GNU General Public
##   License along with GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

# These should be installed and distributed.
scripts_sources =				\
	PROGRAM					\
	autofrisk				\
	display-commentary			\
	doc-snarf				\
	frisk					\
	generate-autoload			\
	lint					\
	punify					\
	read-scheme-source			\
	read-text-outline			\
	use2dot					\
	snarf-check-and-output-texi		\
	summarize-guile-TODO			\
	scan-api				\
	api-diff				\
	read-rfc822				\
	snarf-guile-m4-docs

subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/scripts
subpkgdata_SCRIPTS = $(scripts_sources)

EXTRA_DIST = $(scripts_sources) ChangeLog-2008

list:
	@echo $(scripts_sources)

include $(top_srcdir)/am/pre-inst-guile

overview: $(scripts_sources)
	@echo '----------------------------'
	@echo Overview
	@echo I. Commentaries
	@echo II. Module Interfaces
	@echo '----------------------------'
	@echo I. Commentaries
	@echo '----------------------------'
	$(preinstguiletool)/display-commentary $^
	@echo '----------------------------'
	@echo II. Module Interfaces
	@echo '----------------------------'
	$(preinstguiletool)/frisk $^

# Makefile.am ends here


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; PROGRAM --- Does something

;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: J.R.Hacker

;;; Commentary:

;; Usage: PROGRAM [ARGS]
;;
;; PROGRAM does something.
;;
;; TODO: Write it!

;;; Code:

(define-module (scripts PROGRAM)
  :export (PROGRAM))

(define (PROGRAM . args)
  #t)

(define main PROGRAM)

;;; PROGRAM ends here

path: scripts/PROGRAM


code:
Overview and Usage
------------------

This directory contains Scheme programs, some useful in maintaining Guile.
On "make install", these programs are copied to PKGDATADIR/VERSION/scripts.

You can invoke a program from the shell, or alternatively, load its file
as a Guile Scheme module, and use its exported procedure(s) from Scheme code.
Typically for any PROGRAM:

  (use-modules (scripts PROGRAM))
  (PROGRAM ARG1 ARG2 ...)

For programs that write to stdout, you might try, instead:

  (use-modules (scripts PROGRAM))
  (with-output-to-string (lambda () (PROGRAM ARG1 ARG2 ...)))

Note that all args must be strings.

To see PROGRAM's commentary, which may or may not be helpful:

  (help (scripts PROGRAM))

To see all commentaries and module dependencies, try: "make overview".

If you want to try the programs before installing Guile, you will probably
need to set environment variable GUILE_LOAD_PATH to be the parent directory.
This can be done in Bourne-compatible shells like so:

  GUILE_LOAD_PATH=`(cd .. ; pwd)`
  export GUILE_LOAD_PATH

[FIXME: Can someone supply the csh-compatible equivalent?]

How to Contribute
-----------------

See template file PROGRAM for a quick start.

Programs must follow the "executable module" convention, documented here:

- The file name must not end in ".scm".

- The file must be executable (chmod +x).

- The module name must be "(scripts PROGRAM)".  A procedure named PROGRAM w/
  signature "(PROGRAM . args)" must be exported.  Basically, use some variant
  of the form:

  (define-module (scripts PROGRAM)
    :export (PROGRAM))

  Feel free to export other definitions useful in the module context.

- There must be the alias:

  (define main PROGRAM)

  However, `main' must NOT be exported.

- The beginning of the file must use the following invocation sequence:

  #!/bin/sh
  main='(module-ref (resolve-module '\''(scripts PROGRAM)) '\'main')'
  exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
  !#

Following these conventions allows the program file to be used as module
(scripts PROGRAM) in addition to as a standalone executable.  Please also
include a helpful Commentary section w/ some usage info.

[README ends here]

path: scripts/README


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts api-diff)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; api-diff --- diff guile-api.alist files

;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: api-diff [-d GROUPS] ALIST-FILE-A ALIST-FILE-B
;;
;; Read in the alists from files ALIST-FILE-A and ALIST-FILE-B
;; and display a (count) summary of the groups defined therein.
;; Optional arg "--details" (or "-d") specifies a comma-separated
;; list of groups, in which case api-diff displays instead the
;; elements added and deleted for each of the specified groups.
;;
;; For scheme programming, this module exports the proc:
;;  (api-diff A-file B-file)
;;
;; Note that the convention is that the "older" alist/file is
;; specified first.
;;
;; TODO: Develop scheme interface.

;;; Code:

(define-module (scripts api-diff)
  :use-module (ice-9 common-list)
  :use-module (ice-9 format)
  :use-module (ice-9 getopt-long)
  :autoload (srfi srfi-13) (string-tokenize)
  :export (api-diff))

(define (read-alist-file file)
  (with-input-from-file file
    (lambda () (read))))

(define put set-object-property!)
(define get object-property)

(define (read-api-alist-file file)
  (let* ((alist (read-alist-file file))
         (meta (assq-ref alist 'meta))
         (interface (assq-ref alist 'interface)))
    (put interface 'meta meta)
    (put interface 'groups (let ((ht (make-hash-table 31)))
                             (for-each (lambda (group)
                                         (hashq-set! ht group '()))
                                       (assq-ref meta 'groups))
                             ht))
    interface))

(define (hang-by-the-roots interface)
  (let ((ht (get interface 'groups)))
    (for-each (lambda (x)
                (for-each (lambda (group)
                            (hashq-set! ht group
                                        (cons (car x)
                                              (hashq-ref ht group))))
                          (assq-ref x 'groups)))
              interface))
  interface)

(define (diff? a b)
  (let ((result (set-difference a b)))
    (if (null? result)
        #f                              ; CL weenies bite me
        result)))

(define (diff+note! a b note-removals note-additions note-same)
  (let ((same? #t))
    (cond ((diff? a b) => (lambda (x) (note-removals x) (set! same? #f))))
    (cond ((diff? b a) => (lambda (x) (note-additions x) (set! same? #f))))
    (and same? (note-same))))

(define (group-diff i-old i-new . options)
  (let* ((i-old (hang-by-the-roots i-old))
         (g-old (hash-fold acons '() (get i-old 'groups)))
         (g-old-names (map car g-old))
         (i-new (hang-by-the-roots i-new))
         (g-new (hash-fold acons '() (get i-new 'groups)))
         (g-new-names (map car g-new)))
    (cond ((null? options)
           (diff+note! g-old-names g-new-names
                       (lambda (removals)
                         (format #t "groups-removed: ~A\n" removals))
                       (lambda (additions)
                         (format #t "groups-added: ~A\n" additions))
                       (lambda () #t))
           (for-each (lambda (group)
                       (let* ((old (assq-ref g-old group))
                              (new (assq-ref g-new group))
                              (old-count (and old (length old)))
                              (new-count (and new (length new)))
                              (delta (and old new (- new-count old-count))))
                         (format #t " ~5@A  ~5@A  :  "
                                 (or old-count "-")
                                 (or new-count "-"))
                         (cond ((and old new)
                                (let ((add-count 0) (sub-count 0))
                                  (diff+note!
                                   old new
                                   (lambda (subs)
                                     (set! sub-count (length subs)))
                                   (lambda (adds)
                                     (set! add-count (length adds)))
                                   (lambda () #t))
                                  (format #t "~5@D ~5@D : ~5@D"
                                          add-count (- sub-count) delta)))
                               (else
                                (format #t "~5@A ~5@A : ~5@A" "-" "-" "-")))
                         (format #t "     ~A\n" group)))
                     (sort (union g-old-names g-new-names)
                           (lambda (a b)
                             (string<? (symbol->string a)
                                       (symbol->string b))))))
          ((assq-ref options 'details)
           => (lambda (groups)
                (for-each (lambda (group)
                            (let* ((old (or (assq-ref g-old group) '()))
                                   (new (or (assq-ref g-new group) '()))
                                   (>>! (lambda (label ls)
                                          (format #t "~A ~A:\n" group label)
                                          (for-each (lambda (x)
                                                      (format #t " ~A\n" x))
                                                    ls))))
                              (diff+note! old new
                                          (lambda (removals)
                                            (>>! 'removals removals))
                                          (lambda (additions)
                                            (>>! 'additions additions))
                                          (lambda ()
                                            (format #t "~A: no changes\n"
                                                    group)))))
                          groups)))
          (else
           (error "api-diff: group-diff: bad options")))))

(define (api-diff . args)
  (let* ((p (getopt-long (cons 'api-diff args)
                         '((details (single-char #\d)
                                    (value #t))
                           ;; Add options here.
                           )))
         (rest (option-ref p '() '("/dev/null" "/dev/null")))
         (i-old (read-api-alist-file (car rest)))
         (i-new (read-api-alist-file (cadr rest)))
         (options '()))
    (cond ((option-ref p 'details #f)
           => (lambda (groups)
                (set! options (cons (cons 'details
                                          (map string->symbol
                                               (string-tokenize
                                                groups
                                                #\,)))
                                    options)))))
    (apply group-diff i-old i-new options)))

(define main api-diff)

;;; api-diff ends here

path: scripts/api-diff


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts autofrisk)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; autofrisk --- Generate module checks for use with auto* tools

;; 	Copyright (C) 2002, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: autofrisk [file]
;;
;; This program looks for the file modules.af in the current directory
;; and writes out modules.af.m4 containing autoconf definitions.
;; If given, look for FILE instead of modules.af and output to FILE.m4.
;;
;; After running autofrisk, you should add to configure.ac the lines:
;;   AUTOFRISK_CHECKS
;;   AUTOFRISK_SUMMARY
;; Then run "aclocal -I ." to update aclocal.m4, and finally autoconf.
;;
;; The modules.af file consists of a series of configuration forms (Scheme
;; lists), which have one of the following formats:
;;   (files-glob PATTERN ...)
;;   (non-critical-external MODULE ...)
;;   (non-critical-internal MODULE ...)
;;   (programs (MODULE PROG ...) ...)
;;   (pww-varname VARNAME)
;; PATTERN is a string that may contain "*" and "?" characters to be
;; expanded into filenames.  MODULE is a list of symbols naming a
;; module, such as `(srfi srfi-1)'.  VARNAME is a shell-safe name to use
;; instead of "probably_wont_work", the default.  This var is passed to
;; `AC_SUBST'.  PROG is a string.
;;
;; Only the `files-glob' form is required.
;;
;; TODO: Write better commentary.
;;       Make "please see README" configurable.

;;; Code:

(define-module (scripts autofrisk)
  :autoload (ice-9 popen) (open-input-pipe)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-8)
  :use-module (srfi srfi-13)
  :use-module (srfi srfi-14)
  :use-module (scripts read-scheme-source)
  :use-module (scripts frisk)
  :export (autofrisk))

(define *recognized-keys* '(files-glob
                            non-critical-external
                            non-critical-internal
                            programs
                            pww-varname))

(define (canonical-configuration forms)
  (let ((chk (lambda (condition . x)
               (or condition (apply error "syntax error:" x)))))
    (chk (list? forms) "input not a list")
    (chk (every list? forms) "non-list element")
    (chk (every (lambda (form) (< 1 (length form))) forms) "list too short")
    (let ((un #f))
      (chk (every (lambda (form)
                    (let ((key (car form)))
                      (and (symbol? key)
                           (or (eq? 'quote key)
                               (memq key *recognized-keys*)
                               (begin
                                 (set! un key)
                                 #f)))))
                  forms)
           "unrecognized key:" un))
    (let ((bunched (map (lambda (key)
                          (fold (lambda (form so-far)
                                  (or (and (eq? (car form) key)
                                           (cdr form)
                                           (append so-far (cdr form)))
                                      so-far))
                                (list key)
                                forms))
                        *recognized-keys*)))
      (lambda (key)
        (assq-ref bunched key)))))

(define (>>strong modules)
  (for-each (lambda (module)
              (format #t "GUILE_MODULE_REQUIRED~A\n" module))
            modules))

(define (safe-name module)
  (let ((var (object->string module)))
    (string-map! (lambda (c)
                   (if (char-set-contains? char-set:letter+digit c)
                       c
                       #\_))
                 var)
    var))

(define *pww* "probably_wont_work")

(define (>>weak weak-edges)
  (for-each (lambda (edge)
              (let* ((up (edge-up edge))
                     (down (edge-down edge))
                     (var (format #f "have_guile_module~A" (safe-name up))))
                (format #t "GUILE_MODULE_AVAILABLE(~A, ~A)\n" var up)
                (format #t "test \"$~A\" = no &&\n  ~A=\"~A $~A\"~A"
                        var *pww* down *pww* "\n\n")))
            weak-edges))

(define (>>program module progs)
  (let ((vars (map (lambda (prog)
                     (format #f "guile_module~Asupport_~A"
                             (safe-name module)
                             prog))
                   progs)))
    (for-each (lambda (var prog)
                (format #t "AC_PATH_PROG(~A, ~A)\n" var prog))
              vars progs)
    (format #t "test \\\n")
    (for-each (lambda (var)
                (format #t " \"$~A\" = \"\" -o \\\n" var))
              vars)
    (format #t "~A &&\n~A=\"~A $~A\"\n\n"
            (list-ref (list "war = peace"
                            "freedom = slavery"
                            "ignorance = strength")
                      (random 3))
            *pww* module *pww*)))

(define (>>programs programs)
  (for-each (lambda (form)
              (>>program (car form) (cdr form)))
            programs))

(define (unglob pattern)
  (let ((p (open-input-pipe (format #f "echo '(' ~A ')'" pattern))))
    (map symbol->string (read p))))

(define (>>checks forms)
  (let* ((cfg (canonical-configuration forms))
         (files (apply append (map unglob (cfg 'files-glob))))
         (ncx (cfg 'non-critical-external))
         (nci (cfg 'non-critical-internal))
         (prog (cfg 'non-critical))
         (report ((make-frisker) files))
         (external (report 'external)))
    (let ((pww-varname (cfg 'pww-varname)))
      (or (null? pww-varname) (set! *pww* (car pww-varname))))
    (receive (weak strong)
        (partition (lambda (module)
                     (or (member module ncx)
                         (every (lambda (i)
                                  (member i nci))
                                (map edge-down (mod-down-ls module)))))
                   external)
      (format #t "AC_DEFUN([AUTOFRISK_CHECKS],[\n\n")
      (>>strong strong)
      (format #t "\n~A=~S\n\n" *pww* "")
      (>>weak (fold (lambda (module so-far)
                      (append so-far (mod-down-ls module)))
                    (list)
                    weak))
      (>>programs (cfg 'programs))
      (format #t "AC_SUBST(~A)\n])\n\n" *pww*))))

(define (>>summary)
  (format #t
          (symbol->string
           '#{
AC_DEFUN([AUTOFRISK_SUMMARY],[
if test ! "$~A" = "" ; then
    p="         ***"
    echo "$p"
    echo "$p NOTE:"
    echo "$p The following modules probably won't work:"
    echo "$p   $~A"
    echo "$p They can be installed anyway, and will work if their"
    echo "$p dependencies are installed later.  Please see README."
    echo "$p"
fi
])
}#)
          *pww* *pww*))

(define (autofrisk . args)
  (let ((file (if (null? args) "modules.af" (car args))))
    (or (file-exists? file)
        (error "could not find input file:" file))
    (with-output-to-file (format #f "~A.m4" file)
      (lambda ()
        (>>checks (read-scheme-source-silently file))
        (>>summary)))))

(define main autofrisk)

;; Local variables:
;; eval: (put 'receive 'scheme-indent-function 2)
;; End:

;;; autofrisk ends here

path: scripts/autofrisk


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts display-commentary)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; display-commentary --- As advertized

;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Thien-Thi Nguyen

;;; Commentary:

;; Usage: display-commentary REF1 REF2 ...
;;
;; Display Commentary section from REF1, REF2 and so on.
;; Each REF may be a filename or module name (list of symbols).
;; In the latter case, a filename is computed by searching `%load-path'.

;;; Code:

(define-module (scripts display-commentary)
  :use-module (ice-9 documentation)
  :export (display-commentary))

(define (display-commentary-one file)
  (format #t "~A commentary:\n~A" file (file-commentary file)))

(define (module-name->filename-frag ls) ; todo: export or move
  (let ((ls (map symbol->string ls)))
    (let loop ((ls (cdr ls)) (acc (car ls)))
      (if (null? ls)
          acc
          (loop (cdr ls) (string-append acc "/" (car ls)))))))

(define (display-module-commentary module-name)
  (cond ((%search-load-path (module-name->filename-frag module-name))
         => (lambda (file)
              (format #t "module ~A\n" module-name)
              (display-commentary-one file)))))

(define (display-commentary . refs)
  (for-each (lambda (ref)
              (cond ((string? ref)
                     (if (equal? 0 (string-index ref #\())
                         (display-module-commentary
                          (with-input-from-string ref read))
                         (display-commentary-one ref)))
                    ((list? ref)
                     (display-module-commentary ref))))
            refs))

(define main display-commentary)

;;; display-commentary ends here

path: scripts/display-commentary


code:
#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(scripts doc-snarf)) '\'main')'
exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; doc-snarf --- Extract documentation from source files

;; 	Copyright (C) 2001, 2006 Free Software Foundation, Inc.
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301 USA

;;; Author: Martin Grabmueller

;;; Commentary:

;; Usage: doc-snarf FILE
;;
;; This program reads in a Scheme source file and extracts docstrings
;; in the format specified below.  Additionally, a procedure protoype
;; is infered from the procedure definition line starting with
;; (define... ).
;;
;; Currently, two output modi are implemented: texinfo and plaintext.
;; Default is plaintext, texinfo can be switched on with the
;; `--texinfo, -t' command line option.
;;
;; Format: A docstring can span multiple lines and a docstring line
;; begins with `;; ' (two semicoli and a space). A docstring is ended
;; by either a line beginning with (define ...) or one or more lines
;; beginning with `;;-' (two semicoli and a dash). These lines are
;; called `options' and begin with a keyword, followed by a colon and
;; a string.
;;
;; Additionally, "standard internal docstrings" (for Scheme source) are
;; recognized and output as "options".  The output formatting is likely
;; to change in the future.
;;
;; Example:

;; This procedure foos, or bars, depending on the argument @var{braz}.
;;-Author: Martin Grabmueller
(define (foo/bar braz)
  (if braz 'foo 'bar))

;;; Which results in the following docstring if texinfo output is
;;; enabled:
#!
foo/bar
@deffn procedure foo/bar braz
This procedure foos, or bars, depending on the argument @var{braz}.
@c Author: Martin Grabmueller
@end deffn
!#

;;; Or in this if plaintext output is used:
#!
Procedure: foo/bar braz
This procedure foos, or bars, depending on the argument @var{braz}.
;; Author: Martin Grabmueller
^L
!#

;; TODO: Convert option lines to alist.
;;       More parameterization.
;;       ../libguile/guile-doc-snarf emulation

(define doc-snarf-version "0.0.2") ; please update before publishing!

;;; Code:

(define-module (scripts doc-snarf)
  :use-module (ice-9 getopt-long)
  :use-module (ice-9 regex)
  :use-module (ice-9 string-fun)
  :use-module (ice-9 rdelim)
  :export (doc-snarf))

(define command-synopsis
  '((version (single-char #\v) (value #f))
    (help    (single-char #\h) (value #f))
    (output  (single-char #\o) (value #t))
    (texinfo (single-char #\t) (value #f))
    (lang    (single-char #\l) (value #t))))

;; Display version information and exit.
;;-ttn-mod: use var
(define (display-version)
  (display "doc-snarf ") (display doc-snarf-version) (newline))

;; Display the usage help message and exit.
;;-ttn-mod: change option "source" to "lang"
(define (display-help)
  (display "Usage: doc-snarf [options...] inputfile\n")
  (display "  --help, -h              Show this usage information\n")
  (display "  --version, -v           Show version information\n")
  (display
   "  --output=FILE, -o       Specify output file [default=stdout]\n")
  (display "  --texinfo, -t           Format output as texinfo\n")
  (display "  --lang=[c,scheme], -l   Specify the input language\n"))

;; Main program.
;;-ttn-mod: canonicalize lang
(define (doc-snarf . args)
  (let ((options (getopt-long (cons "doc-snarf" args) command-synopsis)))
    (let ((help-wanted (option-ref options 'help #f))
	  (version-wanted (option-ref options 'version #f))
	  (texinfo-wanted (option-ref options 'texinfo #f))
	  (lang (string->symbol
                 (string-downcase (option-ref options 'lang "scheme")))))
      (cond
       (version-wanted (display-version))
       (help-wanted (display-help))
       (else
	(let ((input (option-ref options '() #f))
	      (output (option-ref options 'output #f)))
	  (if
           ;; Bonard B. Timmons III says `(pair? input)' alone is sufficient.
           ;; (and input (pair? input))
           (pair? input)
           (snarf-file (car input) output texinfo-wanted lang)
           (display-help))))))))

(define main doc-snarf)

;; Supported languages and their parameters.  Each element has form:
;; (LANG DOC-START DOC-END DOC-PREFIX OPT-PREFIX SIG-START STD-INT-DOC?)
;; LANG is a symbol, STD-INT-DOC? is a boolean indicating whether or not
;; LANG supports "standard internal docstring" (a string after the formals),
;; everything else is a string specifying a regexp.
;;-ttn-mod: new var
(define supported-languages
  '((c
     "^/\\*(.*)"
     "^ \\*/"
     "^ \\* (.*)"
     "^ \\*-(.*)"
     "NOTHING AT THIS TIME!!!"
     #f
     )
    (scheme
     "^;; (.*)"
     "^;;\\."
     "^;; (.*)"
     "^;;-(.*)"
     "^\\(define"
     #t
     )))

;; Get @var{lang}'s @var{parameter}.  Both args are symbols.
;;-ttn-mod: new proc
(define (lang-parm lang parm)
  (list-ref (assq-ref supported-languages lang)
            (case parm
              ((docstring-start)  0)
              ((docstring-end)    1)
              ((docstring-prefix) 2)
              ((option-prefix)    3)
              ((signature-start)  4)
              ((std-int-doc?)     5))))

;; Snarf all docstrings from the file @var{input} and write them to
;; file @var{output}.  Use texinfo format for the output if
;; @var{texinfo?} is true.
;;-ttn-mod: don't use string comparison, consult table instead
(define (snarf-file input output texinfo? lang)
  (or (memq lang (map car supported-languages))
      (error "doc-snarf: input language must be c or scheme."))
  (write-output (snarf input lang) output
                (if texinfo? format-texinfo format-plain)))

;; fixme: this comment is required to trigger standard internal
;; docstring snarfing...  ideally, it wouldn't be necessary.
;;-ttn-mod: new proc, from snarf-docs (aren't these names fun?)
(define (find-std-int-doc line input-port)
  "Unread @var{line} from @var{input-port}, then read in the entire form and
return the standard internal docstring if found.  Return #f if not."
  (unread-string line input-port)       ; ugh
  (let ((form (read input-port)))
    (cond ((and (list? form)            ; (define (PROC ARGS) "DOC" ...)
                (< 3 (length form))
                (eq? 'define (car form))
                (pair? (cadr form))
                (symbol? (caadr form))
                (string? (caddr form)))
           (caddr form))
          ((and (list? form)            ; (define VAR (lambda ARGS "DOC" ...))
                (< 2 (length form))
                (eq? 'define (car form))
                (symbol? (cadr form))
                (list? (caddr form))
                (< 3 (length (caddr form)))
                (eq? 'lambda (car (caddr form)))
                (string? (caddr (caddr form))))
           (caddr (caddr form)))
          (else #f))))

;; Split @var{string} into lines, adding @var{prefix} to each.
;;-ttn-mod: new proc
(define (split-prefixed string prefix)
  (separate-fields-discarding-char
   #\newline string
   (lambda lines
     (map (lambda (line)
            (string-append prefix line))
          lines))))

;; snarf input-file output-file
;; Extract docstrings from the input file @var{input}, presumed
;; to be written in language @var{lang}.
;;-Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;-Created: 2001-02-17
;;-ttn-mod: regluarize lang parm lookup, add "std int doc" snarfing (2 places)
(define (snarf input-file lang)
  (let* ((i-p (open-input-file input-file))
         (parm-regexp (lambda (parm) (make-regexp (lang-parm lang parm))))
         (docstring-start  (parm-regexp 'docstring-start))
         (docstring-end    (parm-regexp 'docstring-end))
         (docstring-prefix (parm-regexp 'docstring-prefix))
         (option-prefix    (parm-regexp 'option-prefix))
         (signature-start  (parm-regexp 'signature-start))
         (augmented-options
          (lambda (line i-p options)
            (let ((int-doc (and (lang-parm lang 'std-int-doc?)
                                (let ((d (find-std-int-doc line i-p)))
                                  (and d (split-prefixed d "internal: "))))))
              (if int-doc
                  (append (reverse int-doc) options)
                  options)))))

    (let lp ((line (read-line i-p)) (state 'neutral) (doc-strings '())
	     (options '()) (entries '()) (lno 0))
      (cond
       ((eof-object? line)
	(close-input-port i-p)
	(reverse entries))

       ;; State 'neutral: we're currently not within a docstring or
       ;; option section
       ((eq? state 'neutral)
	(let ((m (regexp-exec docstring-start line)))
	  (if m
	    (lp (read-line i-p) 'doc-string
		(list (match:substring m 1)) '() entries (+ lno 1))
	    (lp (read-line i-p) state '() '() entries (+ lno 1)))))

       ;; State 'doc-string: we have started reading a docstring and
       ;; are waiting for more, for options or for a define.
       ((eq? state 'doc-string)
	(let ((m0 (regexp-exec docstring-prefix line))
	      (m1 (regexp-exec option-prefix line))
	      (m2 (regexp-exec signature-start line))
	      (m3 (regexp-exec docstring-end line)))
	  (cond
	   (m0
	    (lp (read-line i-p) 'doc-string
		(cons (match:substring m0 1) doc-strings) '() entries
		(+ lno 1)))
	   (m1
	    (lp (read-line i-p) 'options
		doc-strings (cons (match:substring m1 1) options) entries
		(+ lno 1)))
	   (m2
            (let ((options (augmented-options line i-p options))) ; ttn-mod
              (lp (read-line i-p) 'neutral '() '()
                  (cons (parse-entry doc-strings options line input-file lno)
                        entries)
                  (+ lno 1))))
           (m3
	    (lp (read-line i-p) 'neutral '() '()
		(cons (parse-entry doc-strings options #f input-file lno)
		      entries)
		(+ lno 1)))
	   (else
	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))

       ;; State 'options: We're waiting for more options or for a
       ;; define.
       ((eq? state 'options)
	(let ((m1 (regexp-exec option-prefix line))
	      (m2 (regexp-exec signature-start line))
	      (m3 (regexp-exec docstring-end line)))
	  (cond
	   (m1
	    (lp (read-line i-p) 'options
		doc-strings (cons (match:substring m1 1) options) entries
		(+ lno 1)))
	   (m2
            (let ((options (augmented-options line i-p options))) ; ttn-mod
              (lp (read-line i-p) 'neutral '() '()
                  (cons (parse-entry doc-strings options line input-file lno)
                        entries)
                  (+ lno 1))))
	   (m3
	    (lp (read-line i-p) 'neutral '() '()
		(cons (parse-entry doc-strings options #f input-file lno)
		      entries)
		(+ lno 1)))
	   (else
	    (lp (read-line i-p) 'neutral '() '() entries (+ lno 1))))))))))

(define (make-entry symbol signature docstrings options filename line)
  (vector 'entry symbol signature docstrings options filename line))
(define (entry-symbol e)
  (vector-ref e 1))
(define (entry-signature e)
  (vector-ref e 2))
(define (entry-docstrings e)
  (vector-ref e 3))
(define (entry-options e)
  (vector-ref e 4))
(define (entry-filename e)
  (vector-ref e 5))
(define (entry-line e)
  "This docstring will not be snarfed, unfortunately..."
  (vector-ref e 6))

;; Create a docstring entry from the docstring line list
;; @var{doc-strings}, the option line list @var{options} and the
;; define line @var{def-line}
(define (parse-entry docstrings options def-line filename line-no)
;  (write-line docstrings)
  (cond
   (def-line
     (make-entry (get-symbol def-line)
		 (make-prototype def-line) (reverse docstrings)
		 (reverse options) filename
		 (+ (- line-no (length docstrings) (length options)) 1)))
   ((> (length docstrings) 0)
    (make-entry (string->symbol (car (reverse docstrings)))
		(car (reverse docstrings))
		(cdr (reverse docstrings))
		(reverse options) filename
		(+ (- line-no (length docstrings) (length options)) 1)))
   (else
    (make-entry 'foo "" (reverse docstrings) (reverse options) filename
		(+ (- line-no (length docstrings) (length options)) 1)))))

;; Create a string which is a procedure prototype.  The necessary
;; information for constructing the prototype is taken from the line
;; @var{def-line}, which is a line starting with @code{(define...}.
(define (make-prototype def-line)
  (call-with-input-string
   def-line
   (lambda (s-p)
     (let* ((paren (read-char s-p))
	    (keyword (read s-p))
	    (tmp (read s-p)))
       (cond
	((pair? tmp)
	 (join-symbols tmp))
	((symbol? tmp)
	 (symbol->string tmp))
	(else
	 ""))))))

(define (get-symbol def-line)
  (call-with-input-string
   def-line
   (lambda (s-p)
     (let* ((paren (read-char s-p))
	    (keyword (read s-p))
	    (tmp (read s-p)))
       (cond
	((pair? tmp)
	 (car tmp))
	((symbol? tmp)
	 tmp)
	(else
	 'foo))))))

;; Append the symbols in the string list @var{s}, separated with a
;; space character.
(define (join-symbols s)
  (cond ((null? s)
	 "")
	((symbol? s)
	 (string-append ". " (symbol->string s)))
	((null? (cdr s))
	 (symbol->string (car s)))
	(else
	 (string-append (symbol->string (car s)) " " (join-symbols (cdr s))))))

;; Write @var{entries} to @var{output-file} using @var{writer}.
;; @var{writer} is a proc that takes one entry.
;; If @var{output-file} is #f, write to stdout.
;;-ttn-mod: new proc
(define (write-output entries output-file writer)
  (with-output-to-port (cond (output-file (open-output-file output-file))
                             (else (current-output-port)))
    (lambda () (for-each writer entries))))

;; Write an @var{entry} using texinfo format.
;;-ttn-mod: renamed from `texinfo-output', distilled
(define (format-texinfo entry)
  (display "\n\f")
  (display (entry-symbol entry))
  (newline)
  (display "@c snarfed from ")
  (display (entry-filename entry))
  (display ":")
  (display (entry-line entry))
  (newline)
  (display "@deffn procedure ")
  (display (entry-signature entry))
  (newline)
  (for-each (lambda (s) (write-line s))
            (entry-docstrings entry))
  (for-each (lambda (s) (display "@c ") (write-line s))
            (entry-options entry))
  (write-line "@end deffn"))

;; Write an @var{entry} using plain format.
;;-ttn-mod: renamed from `texinfo-output', distilled
(define (format-plain entry)
  (display "Procedure: ")
  (display (entry-signature entry))
  (newline)
  (for-each (lambda (s) (write-line s))
            (entry-docstrings entry))
  (for-each (lambda (s) (display ";; ") (write-line s))
            (entry-options entry))
  (display "Snarfed from ")
  (display (entry-filename entry))
  (display ":")
  (display (entry-line entry))
  (newline)
  (write-line "\f"))

;;; doc-snarf ends here

path: scripts/doc-snarf