Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume8/elk/part07

Text File | 1989-09-23 | 62KB | 2,225 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Brandon S. Allbery - comp.sources.misc)
Subject: v08i055: Elk (Extension Language Toolkit) part 07 of 14
Reply-To: [e-mail] (Oliver Laumann)

Posting-number: Volume 8, Issue 55
Submitted-by: [e-mail] (Oliver Laumann)
Archive-name: elk/part07

[Let this be a lesson to submitters:  this was submitted as uuencoded,
compressed files.  I lost the source information while unpacking it; this
is the best approximation I could come up with.  ++bsa]

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 7 (of 14)."
# Contents:  src/debug.c src/stack.s src/promise.c src/stack.s.68k
#   src/stack.s.386 src/scheme.h src/stab.c scm/toplevel scm/pp
#   scm/debug scm/apropos scm/flame scm/macros scm/qsort
#   scm/toplevel.simple scm/qsort.mit scm/struct scm/describe scm/oda
#   scm/cscheme scm/xlib scm/setf scm/gray scm/xlib.more scm/parse
#   scm/xt scm/expt scm/xwidgets tst/gcd
# Wrapped by net@tub on Sun Sep 17 17:32:28 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f src/debug.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/debug.c\"
else
echo shar: Extracting \"src/debug.c\" \(929 characters\)
sed "s/^X//" >src/debug.c <<'END_OF_src/debug.c'
X/* Backtrace, etc.
X */
X
X#include "scheme.h"
X
XObject P_Backtrace_List (argc, argv) Object *argv; {
X    register GCNODE *p, *gp = GC_List;
X    register delta = 0;
X    Object cp, list, tail, cell, vec;
X    GC_Node3;
X
X    if (argc > 0) {
X    cp = argv[0];
X    Check_Type (cp, T_Control_Point);
X    delta = *(int *)(CONTROL(cp)->stack);
X    gp = CONTROL(cp)->gclist;
X    }
X    vec = list = tail = Null;
X    GC_Link3 (vec, list, tail);
X    for ( ; gp; gp = p->next) {
X    p = (GCNODE *)NORM(gp);
X    switch (p->gclen) {
X    case TAG_ENV:
X        vec = Make_Vector (3, Null);
X        VECTOR(vec)->data[2] = *(Object *)NORM(p->gcobj);
X        break;
X    case TAG_FUN:
X        VECTOR(vec)->data[0] = *(Object *)NORM(p->gcobj);
X        break;
X    case TAG_ARGS:
X        VECTOR(vec)->data[1] = *(Object *)NORM(p->gcobj);
X        cell = Cons (vec, Null);
X        if (Nullp (list))
X        list = cell;
X        else
X        P_Setcdr (tail, cell);
X        tail = cell;
X    }
X    }
X    GC_Unlink;
X    return list;
X}
END_OF_src/debug.c
if test 929 -ne `wc -c <src/debug.c`; then
    echo shar: \"src/debug.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/stack.s -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/stack.s\"
else
echo shar: Extracting \"src/stack.s\" \(1112 characters\)
sed "s/^X//" >src/stack.s <<'END_OF_src/stack.s'
X/* int stksize();
X * int saveenv(char* envbuf);
X * dead jmpenv(const char* envbuf, int retcode);
X */
X    .globl    _stksize
X    .globl    _Special
X_stksize:
X    movl    _stkbase,d0
X    subl    sp,d0
X    addl    #120,d0
X    rts
X
X    .globl    _saveenv
X_saveenv:
X    movl    sp@(4),a0
X    movl    a6,a0@(12)        /* save frame pointer of caller */
X    movl    sp@+,a1            /* pop return address */
X    movl    a1,a0@(4)        /* save pc of caller */
X    movl    sp,a0@(8)
X    moveml    #0xBCFC,a0@(40)        /* XXX (shouldn't need this) XXX */
X    movl    sp,a2
X    movl    _stkbase,a3
X    movl    a0,a4
X    addl    #110,a4
Xrep1:    movl    a2@+,a4@+
X    cmpl    a2,a3
X    jcc    rep1
X    movl    a4,d0            /* New pointer */
X    subl    a2,d0            /* Minus old pointer */
X    movl    d0,a0@            /* is the relocation offset */
X    moveml    a0@(40),#0xBCFC        /* XXX (shouldn't need this) XXX */
X    movl    _Special,d0
X    jmp    a1@
X
X    .globl    _jmpenv
X_jmpenv:
X    movl    sp@(8),d0        /* return value */
X    movl    sp@(4),a0        /* fetch buffer */
X
X    movl    a0@(8),sp
X    movl    sp,a2
X    movl    _stkbase,a3
X    movl    a0,a4
X    addl    #110,a4
Xrep2:    movl    a4@+,a2@+
X    cmpl    a2,a3
X    jcc    rep2
X    moveml    a0@(40),#0xBCFC        /* XXX (shouldn't need this) XXX */
X    movl    a0@(12),a6        /* restore frame pointer */
X    movl    a0@(4),a1        /* pc */
X    jmp    a1@
END_OF_src/stack.s
if test 1112 -ne `wc -c <src/stack.s`; then
    echo shar: \"src/stack.s\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/promise.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/promise.c\"
else
echo shar: Extracting \"src/promise.c\" \(888 characters\)
sed "s/^X//" >src/promise.c <<'END_OF_src/promise.c'
X/* Delay and force
X */
X
X#include "scheme.h"
X
XObject P_Promisep (x) Object x; {
X    return TYPE(x) == T_Promise ? True : False;
X}
X
XObject P_Delay (argl) Object argl; {
X    Object d;
X    register char *p;
X    GC_Node;
X
X    GC_Link (argl);
X    p = Get_Bytes (sizeof (struct S_Promise));
X    GC_Unlink;
X    SET(d, T_Promise, (struct S_Promise *)p);
X    PROMISE(d)->done = 0;
X    PROMISE(d)->env = The_Environment;
X    PROMISE(d)->thunk = Car (argl);
X    return d;
X}
X
XObject P_Force (d) Object d; {
X    Object ret, a[2];
X    GC_Node;
X
X    Check_Type (d, T_Promise);
X    if (PROMISE(d)->done)
X    return PROMISE(d)->thunk;
X    GC_Link (d);
X    a[0] = PROMISE(d)->thunk; a[1] = PROMISE(d)->env;
X    ret = P_Eval (2, a);
X    GC_Unlink;
X    PROMISE(d)->done = 1;
X    return PROMISE(d)->thunk = ret;
X}
X
XObject P_Promise_Env (p) Object p; {
X    Check_Type (p, T_Promise);
X    return PROMISE(p)->env;
X}
END_OF_src/promise.c
if test 888 -ne `wc -c <src/promise.c`; then
    echo shar: \"src/promise.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/stack.s.68k -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/stack.s.68k\"
else
echo shar: Extracting \"src/stack.s.68k\" \(1112 characters\)
sed "s/^X//" >src/stack.s.68k <<'END_OF_src/stack.s.68k'
X/* int stksize();
X * int saveenv(char* envbuf);
X * dead jmpenv(const char* envbuf, int retcode);
X */
X    .globl    _stksize
X    .globl    _Special
X_stksize:
X    movl    _stkbase,d0
X    subl    sp,d0
X    addl    #120,d0
X    rts
X
X    .globl    _saveenv
X_saveenv:
X    movl    sp@(4),a0
X    movl    a6,a0@(12)        /* save frame pointer of caller */
X    movl    sp@+,a1            /* pop return address */
X    movl    a1,a0@(4)        /* save pc of caller */
X    movl    sp,a0@(8)
X    moveml    #0xBCFC,a0@(40)        /* XXX (shouldn't need this) XXX */
X    movl    sp,a2
X    movl    _stkbase,a3
X    movl    a0,a4
X    addl    #110,a4
Xrep1:    movl    a2@+,a4@+
X    cmpl    a2,a3
X    jcc    rep1
X    movl    a4,d0            /* New pointer */
X    subl    a2,d0            /* Minus old pointer */
X    movl    d0,a0@            /* is the relocation offset */
X    moveml    a0@(40),#0xBCFC        /* XXX (shouldn't need this) XXX */
X    movl    _Special,d0
X    jmp    a1@
X
X    .globl    _jmpenv
X_jmpenv:
X    movl    sp@(8),d0        /* return value */
X    movl    sp@(4),a0        /* fetch buffer */
X
X    movl    a0@(8),sp
X    movl    sp,a2
X    movl    _stkbase,a3
X    movl    a0,a4
X    addl    #110,a4
Xrep2:    movl    a4@+,a2@+
X    cmpl    a2,a3
X    jcc    rep2
X    moveml    a0@(40),#0xBCFC        /* XXX (shouldn't need this) XXX */
X    movl    a0@(12),a6        /* restore frame pointer */
X    movl    a0@(4),a1        /* pc */
X    jmp    a1@
END_OF_src/stack.s.68k
if test 1112 -ne `wc -c <src/stack.s.68k`; then
    echo shar: \"src/stack.s.68k\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/stack.s.386 -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/stack.s.386\"
else
echo shar: Extracting \"src/stack.s.386\" \(1052 characters\)
sed "s/^X//" >src/stack.s.386 <<'END_OF_src/stack.s.386'
X    .file "stack.s"
X
X    .globl    stksize
X    .globl saveenv
X    .globl jmpenv
X    .globl    Special
X
Xstksize:
X    movl    stkbase,%eax
X    subl    %esp,%eax
X    addl    $120,%eax
X    ret
X
Xsaveenv:
X    movl    4(%esp),%eax
X    movl    %ebp,12(%eax)
X    movl   %ebx,40(%eax)
X    movl    (%esp),%ebx
X    movl    %ebx,4(%eax)
X    addl    $4,%esp
X    movl    %esp,8(%eax)
X    movl   %esi,44(%eax)
X    movl   %edi,48(%eax)
X    movl   %ebp,52(%eax)
X    movl   %edx,56(%eax)
X
X    movl    %esp,%esi
X    movl    %eax,%edi
X    addl    $80,%edi
X
X    movl    stkbase,%ecx
X    subl    %esi,%ecx
X    shr    $2,%ecx
X    repz
X     movsl
X    subl    %esi,%edi
X    movl    %edi,(%eax)
X    movl    40(%eax),%ebx
X    movl    44(%eax),%esi
X    movl    48(%eax),%edi
X    movl    52(%eax),%ebp
X    movl    56(%eax),%edx
X    movl    %eax,%ecx
X    movl    Special,%eax
X    jmp    *4(%ecx)
X
Xjmpenv:
X    movl    8(%esp),%ecx
X    movl    4(%esp),%eax
X    movl    8(%eax),%esp
X    movl    %esp,%edi
X    movl    %eax,%esi
X    addl    $80,%esi
X    movl    %ecx,%ebx
X    movl    stkbase,%ecx
X    subl    %edi,%ecx
X    shr    $2,%ecx
X    repz
X    movsl
X    movl    %ebx,%ecx
X    movl    40(%eax),%ebx
X    movl    44(%eax),%esi
X    movl    48(%eax),%edi
X    movl    52(%eax),%ebp
X    movl    56(%eax),%edx
X    movl    12(%eax),%ebp
X    xchg    %eax,%ecx
X    jmp    *4(%ecx)
X
END_OF_src/stack.s.386
if test 1052 -ne `wc -c <src/stack.s.386`; then
    echo shar: \"src/stack.s.386\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/scheme.h -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/scheme.h\"
else
echo shar: Extracting \"src/scheme.h\" \(100 characters\)
sed "s/^X//" >src/scheme.h <<'END_OF_src/scheme.h'
X#include <stdio.h>
X
X#include "config.h"
X#include "object.h"
X#include "extern.h"
X#include "macros.h"
END_OF_src/scheme.h
if test 100 -ne `wc -c <src/scheme.h`; then
    echo shar: \"src/scheme.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/stab.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/stab.c\"
else
echo shar: Extracting \"src/stab.c\" \(3985 characters\)
sed "s/^X//" >src/stab.c <<'END_OF_src/stab.c'
X/* Read and manage symbol tables from object modules
X */
X
X#include "scheme.h"
X
X#if defined(CAN_LOAD_OBJ) || defined (INIT_OBJECTS)
X
X#ifdef COFF
X#  include <filehdr.h>
X#  include <syms.h>
X#  undef TYPE         /* ldfnc.h defines a TYPE macro. */
X#  include <ldfcn.h>
X#  undef TYPE
X#  ifdef USE_BITFIELDS
X#    define TYPE(x) ((int)(x).s.type)
X#  else
X#    define TYPE(x) ((int)((x) >> VALBITS))
X#  endif
X#else
X#  include <a.out.h>
X#  include <sys/types.h>
X#endif
X
Xchar *Safe_Malloc (size) {
X    char *ret;
X
X    if ((ret = malloc (size)) == 0)
X    Primitive_Error ("not enough memory to allocate ~s bytes",
X        Make_Fixnum (size));
X    return ret;
X}
X
X#ifdef COFF
X
XSYMTAB *Snarf_Symbols (lf, ep) LDFILE *lf; {
X    SYMTAB *tab;
X    register SYM *sp, **nextp;
X    SYMENT sym;
X    long inx;
X    char *p;
X    extern char *ldgetname();
X
X    if (ldtbseek (lf) == FAILURE) {
X    ldclose (lf, NULL);
X    Primitive_Error ("can't ldtbseek");
X    }
X    tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
X    tab->first = 0;
X    tab->strings = 0;
X    nextp = &tab->first;
X    while (1) {
X    inx = ldtbindex (lf);
X    if (ldtbread (lf, inx, &sym) == FAILURE)
X        break;
X    if (sym.n_scnum == N_UNDEF || sym.n_scnum == N_DEBUG
X        || sym.n_scnum > HEADER(lf).f_nscns)
X        continue;
X    if ((p = ldgetname (lf, &sym)) == NULL)
X        continue;
X    sp = (SYM *)Safe_Malloc (sizeof (SYM));
X    sp->name = Safe_Malloc (strlen (p) + 1);
X    strcpy (sp->name, p);
X    sp->type = sym.n_type;
X    sp->value = sym.n_value;
X    *nextp = sp;
X    nextp = &sp->next;
X    *nextp = 0;
X    }
X    return tab;
X}
X
XSYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
X    LDFILE *f;
X    SYMTAB *tab;
X
X    if ((f = ldopen (name, NULL)) == FAILURE)
X    Primitive_Error ("can't ldopen a.out file");
X    tab = Snarf_Symbols (f);
X    ldclose (f);
X    return tab;
X}
X
X#else
X
XSYMTAB *Snarf_Symbols (f, ep) FILE *f; struct exec *ep; {
X    SYMTAB *tab;
X    register SYM *sp, **nextp;
X    int nsyms, strsiz;
X    struct nlist nl;
X
X    tab = (SYMTAB *)Safe_Malloc (sizeof (SYMTAB));
X    tab->first = 0;
X    tab->strings = 0;
X    nextp = &tab->first;
X    (void)fseek (f, (long)N_SYMOFF(*ep), 0);
X    for (nsyms = ep->a_syms / sizeof (nl); nsyms > 0; nsyms--) {
X    if (fread ((char *)&nl, sizeof (nl), 1, f) != 1) {
X        Free_Symbols (tab);
X        fclose (f);
X        Primitive_Error ("corrupt symbol table in object file");
X    }
X    if (nl.n_un.n_strx == 0 || nl.n_type & N_STAB)
X        continue;
X    sp = (SYM *)Safe_Malloc (sizeof (SYM));
X    sp->name = (char *)nl.n_un.n_strx;
X    sp->type = nl.n_type;
X    sp->value = nl.n_value;
X    *nextp = sp;
X    nextp = &sp->next;
X    *nextp = 0;
X    }
X    if (fread ((char *)&strsiz, sizeof (strsiz), 1, f) != 1) {
Xstrerr:
X    Free_Symbols (tab);
X    fclose (f);
X    Primitive_Error ("corrupt string table in object file");
X    }
X    if (strsiz <= 4)
X    goto strerr;
X    tab->strings = Safe_Malloc (strsiz);
X    strsiz -= 4;
X    if (fread (tab->strings+4, 1, strsiz, f) != strsiz)
X    goto strerr;
X    for (sp = tab->first; sp; sp = sp->next)
X    sp->name = tab->strings + (long)sp->name;
X    return tab;
X}
X
XSYMTAB *Open_File_And_Snarf_Symbols (name) char *name; {
X    struct exec hdr;
X    FILE *f;
X    SYMTAB *tab;
X
X    if ((f = fopen (name, "r")) == NULL)
X    Primitive_Error ("can't open a.out file");
X    if (fread ((char *)&hdr, sizeof hdr, 1, f) != 1) {
X    fclose (f);
X    Primitive_Error ("can't read a.out header");
X    }
X    tab = Snarf_Symbols (f, &hdr);
X    fclose (f);
X    return tab;
X}
X
X#endif
X
XFree_Symbols (tab) SYMTAB *tab; {
X    register SYM *sp;
X
X    for (sp = tab->first; sp; sp = sp->next) {
X#ifdef COFF
X    free (sp->name);
X#endif
X    free ((char *)sp);
X    }
X    if (tab->strings)
X    free (tab->strings);
X}
X
XCall_Initializers (tab, addr) SYMTAB *tab; char *addr; {
X    register SYM *sp;
X
X    for (sp = tab->first; sp; sp = sp->next) {
X#ifndef COFF
X    if ((sp->type & N_TYPE) != N_TEXT)
X        continue;
X#endif
X    if (sp->name[0] == '_' && (char *)sp->value >= addr
X        && (bcmp (sp->name, "__STI", 5) == 0
X        || bcmp (sp->name, "_init_", 6) == 0))
X        ((int (*)())sp->value)();
X    }
X}
X
X#endif
END_OF_src/stab.c
if test 3985 -ne `wc -c <src/stab.c`; then
    echo shar: \"src/stab.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/toplevel -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/toplevel\"
else
echo shar: Extracting \"scm/toplevel\" \(2687 characters\)
sed "s/^X//" >scm/toplevel <<'END_OF_scm/toplevel'
X;;; -*-Scheme-*-
X;;;
X;;; Read-eval-print loop and error handler
X
X(define (directory-filename s)
X  (substring s 0
X         (1+
X          (do ((i (1- (string-length s)) (1- i)))
X          ((or (zero? i) (char=? (string-ref s i) #\/)) i)))))
X
X(define top-dir (directory-filename (cadr load-path)))
X
X(append! load-path (list (string-append top-dir "lib")
X             (string-append top-dir "tst")))
X
X(define call/cc call-with-current-continuation)
X
X(fluid-let ((autoload-notify? #f))
X  (require 'macros))
X
X(autoload 'pp 'pp)
X(autoload 'apropos 'apropos)
X(autoload 'flame 'flame)
X(autoload 'sort 'qsort)
X(autoload 'define-structure 'struct)
X(autoload 'describe 'describe)
X(autoload 'backtrace 'debug)
X(autoload 'inspect 'debug)
X(autoload 'expt 'expt)
X
X(define ?)
X(define ??)
X(define ???)
X(define !)
X(define !!)
X(define !!!)
X(define &)
X
X(define (rep-loop env)
X  (define input)
X  (define value)
X  (let loop ()
X    (set! ??? ??)
X    (set! ?? ?)
X    (set! ? &)
X    ;;; X Windows hack
X    (if (and (bound? 'display-flush-output) (bound? 'dpy) (display? dpy))
X    (display-flush-output dpy))
X    (if (> rep-level 0)
X    (display rep-level))
X    (display "> ")
X    (set! input (read))
X    (set! & input)
X    (if (not (eof-object? input))
X    (begin
X      (set! value (eval input env))
X      (set! !!! !!)
X      (set! !! !)
X      (set! ! value)
X      (write value)
X      (newline)
X      (loop)))))
X
X(define rep-frames)
X(define rep-level)
X
X(set! interrupt-handler
X  (lambda ()
X    (format #t "~%\7Interrupt!~%")
X    (let ((next-frame (car rep-frames)))
X      (next-frame #t))))
X
X(define-macro (push-frame control-point)
X  `(begin
X     (set! rep-frames (cons ,control-point rep-frames))
X     (set! rep-level (1+ rep-level))))
X
X(define-macro (pop-frame)
X  '(begin
X     (set! rep-frames (cdr rep-frames))
X     (set! rep-level (1- rep-level))))
X
X(define (error-print error-msg)
X  (format #t "~s: " (car error-msg))
X  (apply format `(#t ,@(cdr error-msg)))
X  (newline))
X
X(set! error-handler
X  (lambda error-msg
X    (error-print error-msg)
X    (let loop ((just-called #t))
X      (if (call-with-current-continuation
X       (lambda (control-point)
X         (if just-called
X         (push-frame control-point))
X         (rep-loop (the-environment))
X         #f))
X      (loop #f)))
X    (newline)
X    (pop-frame)
X    (let ((next-frame (car rep-frames)))
X      (next-frame #t))))
X
X(define top-level-environment (the-environment))
X
X(define (top-level)
X  (let loop ()
X    (if (call-with-current-continuation
X     (lambda (control-point)
X       (set! rep-frames (list control-point))
X       (set! top-level-control-point control-point)
X       (set! rep-level 0)
X       (rep-loop top-level-environment)
X       #f))
X    (loop))))
X
X(define (the-top-level)
X  (top-level)
X  (newline)
X  (exit))
X
X(the-top-level)
X
X
END_OF_scm/toplevel
if test 2687 -ne `wc -c <scm/toplevel`; then
    echo shar: \"scm/toplevel\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/pp -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/pp\"
else
echo shar: Extracting \"scm/pp\" \(2757 characters\)
sed "s/^X//" >scm/pp <<'END_OF_scm/pp'
X;;; -*-Scheme-*-
X;;;
X;;; Trivial pretty-printer
X
X(provide 'pp)
X
X(define pp)
X
X(let ((max-pos 55) (pos 0) (tab-stop 8))
X
X  (put 'lambda  'special #t)
X  (put 'macro   'special #t)
X  (put 'define  'special #t)
X  (put 'define-macro     'special #t)
X  (put 'define-structure 'special #t)
X  (put 'fluid-let        'special #t)
X  (put 'let     'special #t)
X  (put 'let*    'special #t)
X  (put 'letrec  'special #t)
X  (put 'case    'special #t)
X
X  (put 'call-with-current-continuation 'long #t)
X
X  (put 'quote            'abbr "'")
X  (put 'quasiquote       'abbr "`")
X  (put 'unquote          'abbr ",")
X  (put 'unquote-splicing 'abbr ",@")
X
X(set! pp (lambda (x)
X  (set! pos 0)
X  (cond ((eq? (type x) 'compound)
X         (set! x (procedure-lambda x)))
X    ((eq? (type x) 'macro)
X     (set! x (macro-body x))))
X  (fluid-let ((garbage-collect-notify? #f))
X    (pp-object x))
X  #v))
X
X(define (flat-size s)
X  (fluid-let ((print-length 1000) (print-depth 100))
X    (string-length (format #f "~a" s))))
X
X(define (pp-object x)
X  (if (or (null? x) (pair? x))
X      (pp-list x)
X      (if (void? x)
X      (display "#v")
X          (write x))
X      (set! pos (+ pos (flat-size x)))))
X
X(define (pp-list x)
X  (if (and (pair? x)
X       (symbol? (car x))
X       (string? (get (car x) 'abbr))
X       (= 2 (length x)))
X      (let ((abbr (get (car x) 'abbr)))
X    (display abbr)
X    (set! pos (+ pos (flat-size abbr)))
X    (pp-object (cadr x)))
X      (if (> (flat-size x) (- max-pos pos))
X      (pp-list-vertically x)
X      (pp-list-horizontally x))))
X
X(define (pp-list-vertically x)
X  (maybe-pp-list-vertically #t x))
X
X(define (pp-list-horizontally x)
X  (maybe-pp-list-vertically #f x))
X
X(define (maybe-pp-list-vertically vertical? list)
X  (display "(")
X  (set! pos (1+ pos))
X  (if (null? list)
X      (begin
X    (display ")")
X    (set! pos (1+ pos)))
X      (let ((pos1 pos))
X    (pp-object (car list))
X    (if (and vertical?
X         (or
X          (and (pair? (car list))
X               (not (null? (cdr list))))
X          (and (symbol? (car list))
X               (get (car list) 'long))))
X        (indent-newline (1- pos1)))
X    (let ((pos2 (1+ pos)) (key (car list)))
X      (let tail ((flag #f) (l (cdr list)))
X        (cond ((pair? l)
X           (if flag
X               (indent-newline
X            (if (and (symbol? key) (get key 'special))
X                (1+ pos1)
X                pos2))
X               (display " ")
X               (set! pos (1+ pos)))
X           (pp-object (car l))
X           (tail vertical? (cdr l)))
X          (else
X           (cond ((not (null? l))
X              (display " . ")
X              (set! pos (+ pos 3))
X              (if flag (indent-newline pos2))
X              (pp-object l)))
X           (display ")")
X           (set! pos (1+ pos)))))))))
X
X (define (indent-newline x)
X   (newline)
X   (set! pos x)
X   (let loop ((i x))
X     (cond ((>= i tab-stop)
X        (display "\t")
X        (loop (- i tab-stop)))
X       ((> i 0)
X        (display " ")
X        (loop (1- i)))))))
X
END_OF_scm/pp
if test 2757 -ne `wc -c <scm/pp`; then
    echo shar: \"scm/pp\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/debug -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/debug\"
else
echo shar: Extracting \"scm/debug\" \(4452 characters\)
sed "s/^X//" >scm/debug <<'END_OF_scm/debug'
X;;; -*-Scheme-*-
X;;;
X;;; A simple debugger (needs much work)
X
X(define (backtrace . args)
X  (if (> (length args) 1)
X      (error 'backtrace "too many arguments"))
X  (if (not (null? args))
X      (if (not (eq? (type (car args)) 'control-point))
X      (error 'backtrace "argument must be a control point")))
X  (let ((trace
X     (apply backtrace-list args))
X    (maxlen 28))
X    (if (null? args)
X    (set! trace (cdddr trace)))
X    (for-each
X     (lambda (frame)
X       (let* ((func
X          (format #f "~s" (vector-ref frame 0)))
X         (indent
X          (- maxlen (string-length func))))
X     (display func)
X     (if (negative? indent)
X         (begin
X           (newline)
X           (set! indent maxlen)))
X     (do ((i indent (1- i)))
X         ((> 0 i))
X       (display " ")))
X       (fluid-let
X       ((print-depth 2)
X        (print-length 3))
X     (display (vector-ref frame 1)))
X       (newline))
X     trace))
X  #v)
X
X(define (show env)
X  (fluid-let
X      ((print-length 2)
X       (print-depth 2))
X    (do ((f (environment->list env) (cdr f)))
X    ((null? f))
X      (do ((b (car f) (cdr b)))
X      ((null? b))
X    (format #t "~s\t~s~%" (caar b) (cdar b)))
X      (print '-------)))
X  #v)
X
X(define inspect)
X
X(let ((frame)
X      (trace)
X      (help-text
X       '("q   -- quit inspector"
X     "f   -- print current frame"
X     "u   -- go up one frame"
X     "d   -- go down one frame"
X     "^   -- go to top frame"
X     "$   -- go to bottom frame"
X     "e   -- eval expressions in environment"
X     "p   -- pretty-print procedure"
X     "v   -- show environment"
X     "<n> -- pretty-print n-th argument"
X         "o   -- obarray information")))
X
X  (define (inspect-command-loop)
X    (let ((input) (done #f))
X      (display "inspect> ")
X      (set! input (read))
X      (case input
X    (q
X     (set! done #t))
X    (?
X     (for-each
X      (lambda (msg)
X        (display msg)
X        (newline))
X      help-text))
X    (f
X     (print-frame))
X    (^
X     (set! frame 0)
X     (print-frame))
X    ($
X     (set! frame (1- (length trace)))
X     (print-frame))
X    (u
X     (if (zero? frame)
X         (format #t "Already on top frame.~%")
X         (set! frame (1- frame))
X       (print-frame)))
X    (d
X     (if (= frame (1- (length trace)))
X         (format #t "Already on bottom frame.~%")
X         (set! frame (1+ frame))
X       (print-frame)))
X    (v
X     (show (vector-ref (list-ref trace frame) 2)))
X    (e
X     (format #t "Type ^D to return to Inspector.~%")
X     (let loop ()
X       (display "eval> ")
X       (set! input (read))
X       (if (not (eof-object? input))
X           (begin
X         (write (eval input
X                  (vector-ref (list-ref trace frame) 2)))
X         (newline)
X         (loop))))
X     (newline))
X    (p
X     (pp (vector-ref (list-ref trace frame) 0))
X     (newline))
X    (o
X     (let ((l (map length (oblist))))
X       (let ((n 0))
X         (for-each (lambda (x) (set! n (+ x n))) l)
X         (format #t "~s symbols " n)
X         (format #t "(maximum bucket: ~s).~%" (apply max l)))))
X    (else
X     (cond
X      ((integer? input)
X       (let ((args (vector-ref (list-ref trace frame) 1)))
X         (if (or (< input 1) (> input (length args)))
X         (format #t "No such argument.~%")
X         (pp (list-ref args (1- input)))
X           (newline))))
X      ((eof-object? input)
X       (set! done #t))
X      (else
X       (format #t "Invalid command.  Type ? for help.~%")))))
X      (if (not done)
X      (inspect-command-loop))))
X
X  (define (print-frame)
X    (format #t "~%Frame ~s of ~s:~%~%" (1+ frame) (length trace))
X    (let* ((f (list-ref trace frame)) (args (vector-ref f 1)))
X      (format #t "Procedure:    ~s~%" (vector-ref f 0))
X      (format #t "Environment:  ~s~%" (vector-ref f 2))
X      (if (null? args)
X      (format #t "No arguments.~%")
X      (fluid-let
X          ((print-depth 2)
X           (print-length 3))
X        (do ((i 1 (1+ i)) (args args (cdr args))) ((null? args))
X          (format #t "Argument ~s:   ~s~%" i (car args))))))
X    (newline))
X
X  (set! inspect
X    (lambda ()
X      (set! frame 0)
X      (set! trace (backtrace-list))
X      (set! trace (cddr trace))
X      (do ((t trace (cdr t)) (f 1 (1+ f))) ((null? t))
X        (if (not (null? (vector-ref (car t) 1)))
X        (let ((last (last-pair (vector-ref (car t) 1))))
X          (if (not (null? (cdr last)))
X              (begin
X            (format #t
X "[inspector: fixing improper arglist in frame ~s]~%" f)
X            (set-cdr! last (cons (cdr last) ())))))))
X      (format #t "Inspector (type ? for help):~%")
X      (let loop ((just-called #t))
X        (if (call-with-current-continuation
X         (lambda (control-point)
X           (if just-called
X               (push-frame control-point))
X           (inspect-command-loop)
X           #f))
X        (loop #f)))
X      (newline)
X      (pop-frame)
X      (let ((next-frame (car rep-frames)))
X        (next-frame #t)))))
X
END_OF_scm/debug
if test 4452 -ne `wc -c <scm/debug`; then
    echo shar: \"scm/debug\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/apropos -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/apropos\"
else
echo shar: Extracting \"scm/apropos\" \(626 characters\)
sed "s/^X//" >scm/apropos <<'END_OF_scm/apropos'
X;;; -*-Scheme-*-
X;;;
X;;; apropos -- print matching symbols
X
X(define apropos)
X
X(let ((found))
X
X(define (got-one sym)
X  (if (bound? sym)
X      (begin
X    (set! found #t)
X    (print sym))))
X
X(set! apropos (lambda (what)
X  (if (symbol? what)
X      (set! what (symbol->string what))
X      (if (not (string? what))
X      (error 'apropos "string or symbol expected")))
X  (set! found #f)
X  (do ((tail (oblist) (cdr tail))) ((null? tail))
X    (do ((l (car tail) (cdr l))) ((null? l))
X      (if (substring? what (symbol->string (car l)))
X      (got-one (car l)))))
X  (if (not found)
X      (format #t "~a: nothing appropriate~%" what))
X  #v)))
X
END_OF_scm/apropos
if test 626 -ne `wc -c <scm/apropos`; then
    echo shar: \"scm/apropos\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/flame -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/flame\"
else
echo shar: Extracting \"scm/flame\" \(8934 characters\)
sed "s/^X//" >scm/flame <<'END_OF_scm/flame'
X;;; -*-Scheme-*-
X;;;
X;;; flame -- print a flame (ported from the Gnu-Emacs flame.el)
X
X(define flame)
X
X(let ((pos) (end-margin 55) (margin 65))
X
X(set! flame (lambda n
X    (cond ((null? n)
X       (set! n '(1)))
X      ((or (not (integer? (car n))) (negative? (car n)))
X       (error 'flame "positive integer argument expected")))
X    (set! pos 0)
X    (fluid-let ((garbage-collect-notify? #f))
X      (do ((i (car n) (1- i))) ((zero? i))
X    (if (> pos end-margin)
X        (begin
X          (set! pos 0) (newline)))
X    (flame-print #t (flatten (flame-expand '(sentence))))
X    (display "  "))
X      (newline))
X    #v))
X
X(define (flame-expand x)
X  (if (pair? x)
X      (map flame-expand ((eval (car x))))
X      x))
X
X(define (flatten x)
X  (if (pair? x)
X      (apply append (map flatten x))
X      (list x)))
X
X(define (capitalize w)
X  (display (char-upcase (string-ref w 0)))
X  (if (> (string-length w) 1)
X      (display (substring w 1 (string-length w)))))
X
X(define (flame-print first x)
X  (if (not (null? x))
X      (begin
X    (let* ((w (symbol->string (car x))) (len (string-length w)))
X      ((if first capitalize display) w)
X      (set! pos (+ 1 pos len))
X      (if (not (null? (cdr x)))
X          (begin
X        (if (not (memq (cadr x) '(? \. \, s! ! s \'s -loving)))
X            (if (< pos margin)
X            (display " ")
X            (set! pos 0) (newline)))
X        (flame-print #f (cdr x))))))))
X
X(define (choose class)
X  (list-ref class (modulo (random) (length class))))
X
X(define (sentence) (choose sentences))
X
X(define sentences
X  '((how can you say that (statement) ?)
X    (I can't believe how (adjective) you are.)
X    (only a (der-term) like you would say that (statement) \.)
X    ((statement) \, huh?) (so, (statement) ?)
X    ((statement) \, right?) (I mean, (sentence))
X    (don't you realise that (statement) ?)
X    (I firmly believe that (statement) \.)
X    (let me tell you something, you (der-term) \, (statement) \.)
X    (furthermore, you (der-term) \, (statement) \.)
X    (I couldn't care less about your (thing) \.)
X    (How can you be so (adjective) ?)
X    (you make me sick.)
X    (it's well known that (statement) \.)
X    ((statement) \.)
X    (it takes a (group-adj) (der-term) like you to say that (statement) \.)
X    (I don't want to hear about your (thing) \.)
X    (you're always totally wrong.)
X    (I've never heard anything as ridiculous as the idea that (statement) \.)
X    (you must be a real (der-term) to think that (statement) \.)
X    (you (adjective) (group-adj) (der-term) !)
X    (you're probably (group-adj) yourself.)
X    (you sound like a real (der-term) \.)
X    (why, (statement) !)
X    (I have many (group-adj) friends.)
X    (save the (thing) s!) (no nukes!) (ban (thing) s!)
X    (I'll bet you think that (thing) s are (adjective) \.)
X    (you know, (statement) \.)
X    (your (quality) reminds me of a (thing) \.)
X    (you have the (quality) of a (der-term) \.)
X    ((der-term) !)
X    ((adjective) (group-adj) (der-term) !)
X    (you're a typical (group-adj) person, totally (adjective) \.)
X    (man, (sentence))))
X
X(define (quality) (choose qualities))
X
X(define qualities
X  '((ignorance) (stupidity) (worthlessness)
X    (prejudice) (lack of intelligence) (lousiness)
X    (bad grammar) (lousy spelling)
X    (lack of common decency) (ugliness) (nastiness)
X    (subtlety) (dishonesty) ((adjective) (quality))))
X
X(define (adjective) (choose adjectives))
X
X(define adjectives
X  '((ignorant) (crass) (pathetic) (sick)
X    (bloated) (malignant) (perverted) (sadistic)
X    (stupid) (unpleasant) (lousy) (abusive) (bad)
X    (braindamaged) (selfish) (improper) (nasty)
X    (disgusting) (foul) (intolerable) (primitive)
X    (depressing) (dumb) (phoney)
X    ((adjective) and (adjective))
X    (as (adjective) as a (thing))))
X
X(define (der-term) (choose der-terms))
X
X(define der-terms
X  '(((adjective) (der-term)) (sexist) (fascist)
X    (weakling) (coward) (beast) (peasant) (racist)
X    (cretin) (fool) (jerk) (ignoramus) (idiot)
X    (wanker) (rat) (slimebag) (DAF driver)
X    (Neanderthal) (sadist) (drunk) (capitalist)
X    (wimp) (dogmatist) (wally) (maniac)
X    (whimpering scumbag) (pea brain) (arsehole)
X    (moron) (goof) (incompetant) (lunkhead) (Nazi)
X    (SysThug) ((der-term) (der-term))))
X
X(define (thing) (choose things))
X
X(define things
X  '(((adjective) (thing)) (computer)
X    (Honeywell DPS8) (whale) (operation)
X    (sexist joke) (ten-incher) (dog) (MicroVAX II)
X    (source license) (real-time clock)
X    (mental problem) (sexual fantasy)
X    (venereal disease) (Jewish grandmother)
X    (cardboard cut-out) (punk haircut) (surfboard)
X    (system call) (wood-burning stove)
X    (graphics editor) (right wing death squad)
X    (disease) (vegetable) (religion)
X    (cruise missile) (bug fix) (lawyer) (copyright)
X    (PAD)))
X
X(define (group-adj) (choose group-adjs))
X
X(define group-adjs
X  '((gay) (old) (lesbian) (young) (black)
X    (Polish) ((adjective)) (white)
X    (mentally retarded) (Nicaraguan) (homosexual)
X    (dead) (underpriviledged) (religious)
X    ((thing) -loving) (feminist) (foreign)
X    (intellectual) (crazy) (working) (unborn)
X    (Chinese) (short) ((adjective)) (poor) (rich)
X    (funny-looking) (Puerto Rican) (Mexican)
X    (Italian) (communist) (fascist) (Iranian)
X    (Moonie)))
X
X(define (statement) (choose statements))
X
X(define statements
X  '((your (thing) is great) ((thing) s are fun)
X    ((person) is a (der-term))
X    ((group-adj) people are (adjective))
X    (every (group-adj) person is a (der-term))
X    (most (group-adj) people have (thing) s)
X    (all (group-adj) dudes should get (thing) s)
X    ((person) is (group-adj)) (trees are (adjective))
X    (if you've seen one (thing) \, you've seen them all)
X    (you're (group-adj)) (you have a (thing))
X    (my (thing) is pretty good)
X    (the Martians are coming)
X    (the (paper) is always right)
X    (just because you read it in the (paper) that doesn't mean it's true)
X    ((person) was (group-adj))
X    ((person) \'s ghost is living in your (thing))
X    (you look like a (thing))
X    (the oceans are full of dirty fish)
X    (people are dying every day)
X    (a (group-adj) man ain't got nothing in the world these days)
X    (women are inherently superior to men)
X    (the system staff is fascist)
X    (there is life after death)
X    (the world is full of (der-term) s)
X    (you remind me of (person)) (technology is evil)
X    ((person) killed (person))
X    (the Russians are tapping your phone)
X    (the Earth is flat)
X    (it's OK to run down (group-adj) people)
X    (Multics is a really (adjective) operating system)
X    (the CIA killed (person))
X    (the sexual revolution is over)
X    (Lassie was (group-adj))
X    (the (group-adj) s have really got it all together)
X    (I was (person) in a previous life)
X    (breathing causes cancer)
X    (it's fun to be really (adjective))
X    ((quality) is pretty fun) (you're a (der-term))
X    (the (group-adj) culture is fascinating)
X    (when ya gotta go ya gotta go)
X    ((person) is (adjective))
X    ((person) \'s (quality) is (adjective))
X    (it's a wonderful day)
X    (everything is really a (thing))
X    (there's a (thing) in (person) \'s brain)
X    ((person) is a cool dude)
X    ((person) is just a figment of your imagination)
X    (the more (thing) s you have, the better)
X    (life is a (thing)) (life is (quality))
X    ((person) is (adjective))
X    ((group-adj) people are all (adjective) (der-term) s)
X    ((statement) \, and (statement))
X    ((statement) \, but (statement))
X    (I wish I had a (thing))
X    (you should have a (thing))
X    (you hope that (statement))
X    ((person) is secretly (group-adj))
X    (you wish you were (group-adj))
X    (you wish you were a (thing))
X    (I wish I were a (thing))
X    (you think that (statement))
X    ((statement) \, because (statement))
X    ((group-adj) people don't get married to (group-adj) people because (reason))
X    ((group-adj) people are all (adjective) because (reason))
X    ((group-adj) people are (adjective) \, and (reason))
X    (you must be a (adjective) (der-term) to think that (person) said (statement))
X    ((group-adj) people are inherently superior to (group-adj) people)
X    (God is Dead)))
X
X(define (paper) (choose papers))
X
X(define papers
X  '((Daily Mail) (Daily Express)
X    (Centre Bulletin) (Sun) (Daily Mirror)
X    (Daily Telegraph) (Beano) (Multics Manual)))
X
X(define (person) (choose persons))
X
X(define persons
X  '((Reagan) (Ken Thompson) (Dennis Ritchie)
X    (JFK) (the Pope) (Gadaffi) (Napoleon)
X    (Karl Marx) (Groucho) (Michael Jackson)
X    (Caesar) (Nietzsche) (Heidegger)
X    (Henry Kissinger) (Nixon) (Castro) (Thatcher)
X    (Attilla the Hun) (Alaric the Visigoth) (Hitler)))
X
X(define (reason) (choose reasons))
X
X(define reasons
X  '((they don't want their children to grow up to be too lazy to steal)
X    (they can't tell them apart from (group-adj) dudes)
X    (they're too (adjective))
X    ((person) wouldn't have done it)
X    (they can't spray paint that small)
X    (they don't have (thing) s) (they don't know how)
X    (they can't afford (thing) s)))
X)
END_OF_scm/flame
if test 8934 -ne `wc -c <scm/flame`; then
    echo shar: \"scm/flame\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/macros -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/macros\"
else
echo shar: Extracting \"scm/macros\" \(894 characters\)
sed "s/^X//" >scm/macros <<'END_OF_scm/macros'
X;;; -*-Scheme-*-
X;;;
X;;; Useful macros (loaded by the standard toplevel)
X
X(provide 'macros)
X
X(define (expand form)
X  (if (or (not (pair? form)) (null? form))
X      form
X      (let ((head (expand (car form))) (args (expand (cdr form))) (result))
X    (if (and (symbol? head) (bound? head))
X        (begin
X          (set! result (macro-expand (cons head args)))
X          (if (not (equal? result form))
X          (expand result)
X          result))
X        (cons head args)))))
X
X(define-macro (unwind-protect body . unwind-forms)
X  `(dynamic-wind
X    (lambda () #f)
X    (lambda () ,body)
X    (lambda () ,@unwind-forms)))
X
X(define-macro (while test . body)
X  `(let loop ()
X     (cond (,test ,@body (loop)))))
X
X(define-macro (when test . body)
X  `(and ,test ,@body))
X
X(define-macro (unless test . body)
X  `(when (not ,test) ,@body))
X
X(define-macro (multiple-value-bind vars form . body)
X  `(apply (lambda ,vars ,@body) ,form))
END_OF_scm/macros
if test 894 -ne `wc -c <scm/macros`; then
    echo shar: \"scm/macros\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/qsort -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/qsort\"
else
echo shar: Extracting \"scm/qsort\" \(845 characters\)
sed "s/^X//" >scm/qsort <<'END_OF_scm/qsort'
X;;; -*-Scheme-*-
X;;;
X;;; Quicksort (straight from Wirth, Algorithmen & Datenstrukturen, p. 117)
X
X(provide 'sort)
X
X(define (sort obj pred)
X  (if (vector? obj)
X      (sort! (vector-copy obj) pred)
X      (vector->list (sort! (list->vector obj) pred))))
X
X(define (sort! v pred)
X  (define (internal-sort l r)
X    (let ((i l) (j r) (x (vector-ref v (quotient (1- (+ l r)) 2))))
X      (let loop ()
X    (do () ((not (pred (vector-ref v i) x))) (set! i (1+ i)))
X    (do () ((not (pred x (vector-ref v j)))) (set! j (1- j)))
X    (if (<= i j)
X        (begin
X          (vector-set! v j (vector-set! v i (vector-ref v j)))
X          (set! i (1+ i))
X          (set! j (1- j))))
X    (if (<= i j)
X        (loop)))
X      (if (< l j)
X      (internal-sort l j))
X      (if (< i r)
X      (internal-sort i r))))
X  (let ((len (vector-length v)))
X    (if (> len 1)
X    (internal-sort 0 (1- len)))
X    v))
END_OF_scm/qsort
if test 845 -ne `wc -c <scm/qsort`; then
    echo shar: \"scm/qsort\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/toplevel.simple -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/toplevel.simple\"
else
echo shar: Extracting \"scm/toplevel.simple\" \(643 characters\)
sed "s/^X//" >scm/toplevel.simple <<'END_OF_scm/toplevel.simple'
X;;; -*-Scheme-*-
X;;;
X;;; Simple and stupid read-eval-print loop (for testing purposes)
X
X(define (top-level)
X  (letrec ((top-level-input)
X       (top-level-prompt "> ")
X       (top-level-environment (the-environment)))
X
X    (do () ((eof-object? top-level-input))
X      (call-with-current-continuation
X       (lambda (control-point)
X     (set! top-level-control-point control-point)
X     (do () ((eof-object? top-level-input))
X       (display top-level-prompt)
X       (set! top-level-input (read))
X       (if (eof-object? top-level-input)
X           (begin
X         (newline) (exit)))
X       (write (eval top-level-input top-level-environment))
X       (newline)))))))
X
X(top-level)
END_OF_scm/toplevel.simple
if test 643 -ne `wc -c <scm/toplevel.simple`; then
    echo shar: \"scm/toplevel.simple\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/qsort.mit -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/qsort.mit\"
else
echo shar: Extracting \"scm/qsort.mit\" \(1377 characters\)
sed "s/^X//" >scm/qsort.mit <<'END_OF_scm/qsort.mit'
X;;; -*-Scheme-*-
X;;;
X;;; Another quicksort (stolen from C-Scheme)
X
X(define (sort obj pred)
X  (if (vector? obj)
X      (sort! (vector-copy obj) pred)
X      (vector->list (sort! (list->vector obj) pred))))
X
X(define sort!
X  (let ()
X
X    (define (exchange! vec i j)
X      ;; Speedup hack uses value of vector-set!.
X      (vector-set! vec j (vector-set! vec i (vector-ref vec j))))
X
X    (lambda (obj pred)
X      (define (sort-internal! vec l r)
X    (cond
X     ((<= r l)
X      vec)
X     ((= r (1+ l))
X      (if (pred (vector-ref vec r)
X            (vector-ref vec l))
X          (exchange! vec l r)
X          vec))
X     (else
X      (quick-merge vec l r))))
X
X      (define (quick-merge vec l r)
X    (let ((first (vector-ref vec l)))
X      (define (increase-i i)
X        (if (or (> i r)
X            (pred first (vector-ref vec i)))
X        i
X        (increase-i (1+ i))))
X      (define (decrease-j j)
X        (if (or (<= j l)
X            (not (pred first (vector-ref vec j))))
X        j
X        (decrease-j (1- j))))
X      (define (loop i j)
X        (if (< i j)
X        (begin (exchange! vec i j)
X               (loop (increase-i (1+ i)) (decrease-j (1- j))))
X        (begin
X          (cond ((> j l)
X             (exchange! vec j l)))
X          (sort-internal! vec (1+ j) r)
X          (sort-internal! vec l (1- j)))))
X      (loop (increase-i (1+ l))
X        (decrease-j r))))
X
X      (if (vector? obj)
X      (begin (sort-internal! obj 0 (1- (vector-length obj))) obj)
X      (error 'sort! "works on vectors only")))))
END_OF_scm/qsort.mit
if test 1377 -ne `wc -c <scm/qsort.mit`; then
    echo shar: \"scm/qsort.mit\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/struct -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/struct\"
else
echo shar: Extracting \"scm/struct\" \(3423 characters\)
sed "s/^X//" >scm/struct <<'END_OF_scm/struct'
X;;; -*-Scheme-*-
X;;;
X;;; The Scheme part of the structures implementation
X;;;
X;;; (define-structure name slot slot ...)
X;;;
X;;; slot  =  slot-name  or  (slot-name initial-value)
X
X(require 'structures 'struct.o)
X
X(define-macro (define-structure name . slot-descr)
X  (if (not (symbol? name))
X      (error 'define-structure "structure name must be a symbol"))
X  (if (null? slot-descr)
X      (error 'define-structure "structure has no slots"))
X  (let* ((s (symbol->string name))
X     (constructor
X      (string->symbol (string-append "make-" s)))
X     (predicator
X      (string->symbol (string-append s "?")))
X     (copier
X      (string->symbol (string-append "copy-" s)))
X     (slots ()) (arg-slots ()))
X    (for-each
X     (lambda (slot)
X       (cond ((symbol? slot)
X          (set! slots (cons slot slots))
X          (set! arg-slots (cons slot arg-slots)))
X         ((pair? slot)
X          (if (or (not (pair? (cdr slot)))
X              (not (null? (cddr slot))))
X          (error 'define-structure "invalid slot specification")
X          (if (not (symbol? (car slot)))
X              (error 'define-structure "slot name must be a symbol"))
X          (set! slots (cons (car slot) slots))))
X         (else
X          (error 'define-structure "slot must be symbol or list"))))
X     slot-descr)
X    (set! slots (reverse slots))
X    `(begin
X       (make-constructor ,constructor ,name ,slots
X             ,(reverse arg-slots) ,slot-descr)
X       (make-predicator ,predicator ',name)
X       (make-copier ,copier)
X       ,@(let ((offset -1))
X       (map
X        (lambda (slot)
X          (let ((f
X             (string->symbol (format #f "~s-~s" name slot))))
X            (set! offset (1+ offset))
X            `(make-accessor ,f ',name ,offset)))
X        slots))
X       ,@(let ((offset -1))
X       (map
X        (lambda (slot)
X          (let ((f
X             (string->symbol (format #f "set-~s-~s!" name slot))))
X        (set! offset (1+ offset))
X        `(make-mutator ,f ',name ,offset)))
X        slots))
X       ',name)))
X
X(define-macro (make-constructor constructor name slots arg-slots descr)
X  `(define (,constructor ,@arg-slots)
X     (let ((,name (make-structure ',name ',slots)))
X       ,@(let ((offset -1))
X       (map
X        (lambda (slot)
X          (set! offset (1+ offset))
X          `(structure-set! ,name ',name ,offset
X                   ,(if (symbol? slot)
X                    slot
X                    (cadr slot))))
X        descr))
X       ,name)))
X
X(define-macro (make-predicator predicator name)
X  `(define (,predicator x)
X     (and (structure? x) (eq? (structure-name x) ,name))))
X
X(define-macro (make-copier copier)
X  `(define (,copier x)
X     (copy-structure x)))
X
X(define-macro (make-accessor accessor name offset)
X  `(define (,accessor x)
X     (structure-ref x ,name ,offset)))
X
X(define-macro (make-mutator mutator name offset)
X  `(define (,mutator x val)
X     (structure-set! x ,name ,offset val)))
X
X(define (copy-structure s)
X  (let* ((slots (structure-slots s))
X     (name (structure-name s))
X     (new (make-structure name slots))
X     (size (length slots)))
X    (do ((offset 0 (1+ offset))) ((= offset size) new)
X      (structure-set! new name offset (structure-ref s name offset)))))
X
X(define (describe-structure s)
X  (format #t "a structure of type ~s.~%" (structure-name s))
X  (if (null? (structure-slots s))
X      (format #t "It has no slots.~%")
X      (format #t "Its slots are: ")
X      (let loop ((slots (structure-slots s))
X         (values (structure-values s)))
X    (if (null? slots)
X        (format #t ".~%")
X        (format #t " (~s ~s)" (car slots) (car values))
X        (loop (cdr slots) (cdr values))))))
END_OF_scm/struct
if test 3423 -ne `wc -c <scm/struct`; then
    echo shar: \"scm/struct\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/describe -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/describe\"
else
echo shar: Extracting \"scm/describe\" \(2209 characters\)
sed "s/^X//" >scm/describe <<'END_OF_scm/describe'
X;;; -*-Scheme-*-
X;;;
X;;; describe -- print information about a Scheme object
X
X(define (describe x)
X  (fluid-let
X      ((print-depth 2)
X       (print-length 3))
X    (format #t "~s is " (if (void? x) '\#v x)))
X  (case (type x)
X    (integer
X     (format #t "an integer.~%"))
X    (real
X     (format #t "a real.~%"))
X    (null
X     (format #t "an empty list.~%"))
X    (boolean
X     (format #t "a boolean value (~s).~%" (if x 'true 'false)))
X    (void
X     (format #t "void (the non-printing object).~%"))
X    (character
X     (format #t "a character, ascii value is ~s~%" (char->integer x)))
X    (symbol
X     (format #t "a symbol.")
X     (let ((l (symbol-plist x)))
X       (if (null? l)
X       (format #t "  It has no property list.~%")
X       (format #t "~%Its property list is: ~s.~%" l))))
X    (pair
X     (if (pair? (cdr x))
X     (let ((p (last-pair x)))
X       (if (null? (cdr p))
X           (format #t "a list of length ~s.~%" (length x))
X           (format #t "an improper list.~%")))
X     (format #t "a pair (cons cell).~%")))
X    (environment
X     (format #t "an environment.~%"))
X    (string
X     (if (eqv? x "")
X     (format #t "an empty string.~%")
X     (format #t "a string of length ~s.~%" (string-length x))))
X    (vector
X     (if (eqv? x #())
X     (format #t "an empty vector.~%")
X     (if (and (feature? 'oops) (memq (vector-ref x 0)
X                     '(class instance)))
X         (if (eq? (vector-ref x 0) 'class)
X         (begin
X           (format #t "a class.~%~%")
X           (describe-class x))
X         (format #t "an instance.~%~%")
X         (describe-instance x))
X         (format #t "a vector of length ~s.~%" (vector-length x)))))
X    (primitive
X     (format #t "a primitive procedure.~%"))
X    (compound
X     (format #t "a compound procedure (type ~s).~%"
X         (car (procedure-lambda x))))
X    (control-point
X     (format #t "a control point (continuation).~%"))
X    (promise
X     (format #t "a promise.~%"))
X    (port
X     (format #t "a port.~%"))
X    (end-of-file
X     (format #t "the end-of-file object.~%"))
X    (macro
X      (format #t "a macro.~%"))
X    (else
X     (let ((descr-func (string->symbol
X            (format #f "describe-~s" (type x)))))
X       (if (bound? descr-func)
X       ((eval descr-func) x)
X       (format #t "an object of unknown type (~s)~%" (type x)))))))
X
END_OF_scm/describe
if test 2209 -ne `wc -c <scm/describe`; then
    echo shar: \"scm/describe\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/oda -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/oda\"
else
echo shar: Extracting \"scm/oda\" \(903 characters\)
sed "s/^X//" >scm/oda <<'END_OF_scm/oda'
X;;; -*-Scheme-*-
X;;;
X;;; Useful hacks for the ISOTEXT project
X
X(define-macro (load* first . rest)
X  (let loop ((s "") (r rest))
X    (if (pair? r)
X    (loop
X     (string-append s (find-object-file (eval (car r))) " ") (cdr r))
X    `(fluid-let
X        ((load-libraries
X          (string-append ,s "-lC " load-libraries)))
X       (load ,first)))))
X
X(define-macro (stringify s)
X  `(if (symbol? ,s) (symbol->string ,s) ,s))
X
X(define (find-object-file f)
X  (if (not (or (symbol? f) (string? f)))
X      (error 'load* "file name must be string or symbol"))
X  (set! f (stringify f))
X  (if (eqv? f "")
X      (error 'load* "invalid filename"))
X  (set! f (tilde-expand f))
X  (if (eq? #\/ (string-ref f 0))
X      f
X      (let loop ((p load-path))
X    (if (null? p)
X        (error 'load* "no such load file: ~s" f))
X    (let ((ret (format #f "~a/~a" (stringify (car p)) f)))
X      (if (file-exists? ret)
X          ret
X          (loop (cdr p)))))))
X
END_OF_scm/oda
if test 903 -ne `wc -c <scm/oda`; then
    echo shar: \"scm/oda\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/cscheme -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/cscheme\"
else
echo shar: Extracting \"scm/cscheme\" \(2920 characters\)
sed "s/^X//" >scm/cscheme <<'END_OF_scm/cscheme'
X;;; -*-Scheme-*-
X;;;
X;;; Some C-Scheme compatibility hacks
X
X(provide 'cscheme)
X
X(define-macro (syntax-table-define table name mac)
X  `(define ,(eval name) ,mac))
X
X(define mapcar map)
X
X(define user-initial-environment (global-environment))
X
X(define (rep-environment) (global-environment))
X
X(define (atom? x)
X  (not (pair? x)))
X
X(define nil ())
X
X(define *the-non-printing-object* #v)
X
X(define (integer->string i)
X  (format #f "~s" i))
X
X(define (get* sym prop)
X  (let ((ret (get sym prop)))
X    (if ret ret ())))
X
X(define-macro (access sym env)
X  `(eval ',sym ,env))
X
X(define-macro (in-package env . body)
X  `(eval '(begin ,@body) ,env))
X
X(define-macro (without-interrupts thunk)
X  `(,thunk))
X
X(define-macro (rec var exp)
X  `(letrec ((,var ,exp)) ,exp))
X
X(define (caaaar x) (car (caaar x)))
X(define (caaadr x) (car (caadr x)))
X(define (caadar x) (car (cadar x)))
X(define (caaddr x) (car (caddr x)))
X(define (cadaar x) (car (cdaar x)))
X(define (cadadr x) (car (cdadr x)))
X(define (caddar x) (car (cddar x)))
X(define (cadddr x) (car (cdddr x)))
X(define (cdaaar x) (cdr (caaar x)))
X(define (cdaadr x) (cdr (caadr x)))
X(define (cdadar x) (cdr (cadar x)))
X(define (cdaddr x) (cdr (caddr x)))
X(define (cddaar x) (cdr (cdaar x)))
X(define (cddadr x) (cdr (cdadr x)))
X(define (cdddar x) (cdr (cddar x)))
X(define (cddddr x) (cdr (cdddr x)))
X
X(define (cons* first . rest)
X  (let loop ((curr first) (rest rest))
X    (if (null? rest)
X    curr
X    (cons curr (loop (car rest) (cdr rest))))))
X
X(define sequence begin)
X
X(define -1+ 1-)
X
X(define close-input-port close-port)
X(define close-output-port close-port)
X
X(define (remq x y)
X  (cond ((null? y) y)
X    ((eq? x (car y)) (remq x (cdr y)))
X    (else (cons (car y) (remq x (cdr y))))))
X
X(define (remv x y)
X  (cond ((null? y) y)
X    ((eqv? x (car y)) (remv x (cdr y)))
X    (else (cons (car y) (remv x (cdr y))))))
X
X(define (remove x y)
X  (cond ((null? y) y)
X    ((equal? x (car y)) (remove x (cdr y)))
X    (else (cons (car y) (remove x (cdr y))))))
X
X(define (remq! x y)
X  (cond ((null? y) y)
X    ((eq? x (car y)) (remq! x (cdr y)))
X    (else (let loop ((prev y))
X        (cond ((null? (cdr prev))
X               y)
X              ((eq? (cadr prev) x)
X               (set-cdr! prev (cddr prev))
X               (loop prev))
X              (else (loop (cdr prev))))))))
X
X(define (remv! x y)
X  (cond ((null? y) y)
X    ((eqv? x (car y)) (remv! x (cdr y)))
X    (else (let loop ((prev y))
X        (cond ((null? (cdr prev))
X               y)
X              ((eqv? (cadr prev) x)
X               (set-cdr! prev (cddr prev))
X               (loop prev))
X              (else (loop (cdr prev))))))))
X
X(define (remove! x y)
X  (cond ((null? y) y)
X    ((equal? x (car y)) (remove! x (cdr y)))
X    (else (let loop ((prev y))
X        (cond ((null? (cdr prev))
X               y)
X              ((equal? (cadr prev) x)
X               (set-cdr! prev (cddr prev))
X               (loop prev))
X              (else (loop (cdr prev))))))))
X
X(define delq remq)
X(define delv remv)
X(define delete remove)
X(define delq! remq!)
X(define delv! remv!)
X(define delete! remove!)
END_OF_scm/cscheme
if test 2920 -ne `wc -c <scm/cscheme`; then
    echo shar: \"scm/cscheme\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/xlib -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/xlib\"
else
echo shar: Extracting \"scm/xlib\" \(207 characters\)
sed "s/^X//" >scm/xlib <<'END_OF_scm/xlib'
X;;; -*-Scheme-*-
X;;;
X;;; The Scheme part of the X11 interface
X
X(require 'xlib.o)
X
X(load 'xlib.core)
X(load 'xlib.more)
X
X(append! load-path (list (string-append top-dir "lib/xlib/examples")))
X
X(provide 'xlib)
END_OF_scm/xlib
if test 207 -ne `wc -c <scm/xlib`; then
    echo shar: \"scm/xlib\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/setf -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/setf\"
else
echo shar: Extracting \"scm/setf\" \(593 characters\)
sed "s/^X//" >scm/setf <<'END_OF_scm/setf'
X;;; -*-Scheme-*-
X;;;
X;;; defsetf and setf
X
X(define defsetf)
X(define get-setter)
X
X(let ((setters ()))
X
X  (set! defsetf
X    (lambda (accessor setter)
X      (set! setters (cons (cons accessor setter) setters))
X      #v))
X
X  (set! get-setter
X    (lambda (accessor)
X      (let ((a (assoc accessor setters)))
X        (if a
X        (cdr a)
X        (error 'get-setter "no setter for ~s" accessor))))))
X
X(define-macro (setf var val)
X  (cond
X   ((symbol? var) `(set! ,var ,val))
X   ((pair? var)
X    (let ((setter (get-setter (eval (car var)))))
X      `(,setter ,@(cdr var) ,val)))
X   (else (error 'setf "symbol or form expected"))))
END_OF_scm/setf
if test 593 -ne `wc -c <scm/setf`; then
    echo shar: \"scm/setf\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/gray -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/gray\"
else
echo shar: Extracting \"scm/gray\" \(72 characters\)
sed "s/^X//" >scm/gray <<'END_OF_scm/gray'
X;;; -*-Scheme-*-
X
X(define gray-bits "\125\125\252\252\125\125\252\252")
END_OF_scm/gray
if test 72 -ne `wc -c <scm/gray`; then
    echo shar: \"scm/gray\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/xlib.more -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/xlib.more\"
else
echo shar: Extracting \"scm/xlib.more\" \(2166 characters\)
sed "s/^X//" >scm/xlib.more <<'END_OF_scm/xlib.more'
X;;; -*-Scheme-*-
X;;;
X;;; X11 interface
X
X(require 'xlib.o)
X
X(define (translate-text string)
X  (list->vector (map char->integer (string->list string))))
X
X(define (drawable? d)
X  (or (window? d) (pixmap? d)))
X
X(define (clear-window w)
X  (clear-area w 0 0 0 0 #f))
X
X(define (define-cursor w c)
X  (set-window-cursor! w c))
X
X(define (undefine-cursor w)
X  (set-window-cursor! w 'none))
X
X(define (create-font-cursor dpy which)
X  (let ((font (open-font dpy 'cursor)))
X    (unwind-protect
X     (create-glyph-cursor font which font (1+ which)
X              (make-color 0 0 0) (make-color 1 1 1))
X     (close-font font))))
X
X(define (synchronize d)
X  (set-after-function! d (lambda (d) (display-wait-output d #f))))
X
X(define (font-property font prop)
X  (let* ((dpy (font-display font))
X    (atom (intern-atom dpy prop))
X    (properties (vector->list (font-properties font)))
X    (result (assq atom properties)))
X    (if result
X    (cdr result)
X    result)))
X
X(define-macro (with-server-grabbed dpy . body)
X  `(dynamic-wind
X    (lambda () (grab-server ,dpy))
X    (lambda () ,@body)
X    (lambda () (ungrab-server ,dpy))))
X
X(define (warp-pointer dst dst-x dst-y)
X  (general-warp-pointer (window-display dst) dst dst-x dst-y 'none 0 0 0 0))
X
X(define (warp-pointer-relative dpy x-off y-off)
X  (general-warp-pointer dpy 'none x-off y-off 'none 0 0 0 0))
X
X(define (query-best-cursor dpy w h)
X  (query-best-size dpy w h 'cursor))
X
X(define (query-best-tile dpy w h)
X  (query-best-size dpy w h 'tile))
X
X(define (query-best-stipple dpy w h)
X  (query-best-size dpy w h 'stipple))
X
X;; Until Xlib provides an XGetCommand():
X
X(define (wm-command w)
X  (let* ((dpy (window-display w))
X     (string (intern-atom dpy 'STRING))
X     (p (get-property w (intern-atom dpy 'WM_COMMAND) string 0 1000 #f))
X     (s (caddr p))
X     (next-null (lambda (i)
X                      (do ((i i (1+ i)))
X                      ((char=? (string-ref s i) (integer->char 0)) i)))))
X    (if (and (eq? (car p) string) (= (cadr p) 8))
X    (do ((len (string-length s))
X         (end 0)
X         (start 0 (1+ end))
X         (l () (cons (substring s start end) l)))
X        ((>= start len) (reverse! l))
X      (set! end (next-null start)))
X    ())))
X
X
X;;; Describe functions go here:
END_OF_scm/xlib.more
if test 2166 -ne `wc -c <scm/xlib.more`; then
    echo shar: \"scm/xlib.more\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/parse -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/parse\"
else
echo shar: Extracting \"scm/parse\" \(418 characters\)
sed "s/^X//" >scm/parse <<'END_OF_scm/parse'
X;;; -*-Scheme-*-
X;;;
X;;; Parse a string into a list of tokens
X
X(define (parse s)
X  (let ((i 0) (j)
X    (n (string-length s)))
X    (let loop ((args ()))
X      (while (and (< i n) (char-whitespace? (string-ref s i)))
X    (set! i (1+ i)))
X      (if (>= i n)
X    (reverse! args)
X        (set! j i)
X    (while (and (< i n) (not (char-whitespace? (string-ref s i))))
X      (set! i (1+ i)))
X        (loop (cons (substring s j i) args))))))
END_OF_scm/parse
if test 418 -ne `wc -c <scm/parse`; then
    echo shar: \"scm/parse\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/xt -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/xt\"
else
echo shar: Extracting \"scm/xt\" \(583 characters\)
sed "s/^X//" >scm/xt <<'END_OF_scm/xt'
X;;; -*-Scheme-*-
X;;;
X;;; The Scheme part of the Xt interface
X
X(require 'xt.o)
X
X(load 'xlib.core)
X(load 'xlib.more)
X
X(provide 'xlib)
X(provide 'xt)
X
X(define (manage-child w)
X  (manage-children (list w)))
X
X(define (unmanage-child w)
X  (unmanage-children (list w)))
X
X(define (add-callback w name fun)
X  (add-callbacks w name (list fun)))
X
X(define (create-managed-widget . args)
X  (let ((w (apply create-widget args)))
X    (manage-child w)
X    w))
X
X(append! load-path (list (string-append top-dir "lib/xt/examples")
X                         (string-append top-dir "lib/xlib/examples")))
X
END_OF_scm/xt
if test 583 -ne `wc -c <scm/xt`; then
    echo shar: \"scm/xt\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/expt -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/expt\"
else
echo shar: Extracting \"scm/expt\" \(225 characters\)
sed "s/^X//" >scm/expt <<'END_OF_scm/expt'
X;;; -*-Scheme-*-
X;;;
X;;; expt
X
X(define (square x) (* x x))
X
X(define (expt b n)
X  (cond ((= n 0) 1)
X    ((negative? n) (/ 1 (expt b (abs n))))
X        ((even? n) (square (expt b (/ n 2))))
X        (else (* b (expt b (- n 1))))))
END_OF_scm/expt
if test 225 -ne `wc -c <scm/expt`; then
    echo shar: \"scm/expt\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f scm/xwidgets -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"scm/xwidgets\"
else
echo shar: Extracting \"scm/xwidgets\" \(1137 characters\)
sed "s/^X//" >scm/xwidgets <<'END_OF_scm/xwidgets'
X;;; -*-Scheme-*-
X;;;
X;;; The Scheme part of the X11 widget interface
X
X(require 'xt)
X
X(define widget-load-path '(xaw xhp))
X
X(define widgets ())
X
X(define-macro (load-widgets . w)
X  (let ((s "") (l ()))
X    (if (null? w)
X    (error 'load-widgets "no arguments"))
X    (for-each
X     (lambda (w)
X       (if (not (symbol? w))
X       (error 'load-widgets "argument not a symbol"))
X       (if (not (memq w widgets))
X       (set! l (cons w l))))
X     w)
X    (if l
X    (begin
X      (set! widgets (append widgets l))
X      (format #t "[Loading ")
X      (do ((f (cdr l) (cdr f))) ((null? f))
X        (format #t "~a " (car f))
X        (set! s (format #f "~a ~a" s (locate-widget (car f)))))
X      (format #t "~a]~%" (car l))
X      `(fluid-let ((load-libraries
X            (format #f "~a -lXw -lXaw -lXmu -lXt -lX11 -lc" ,s)))
X         (load (locate-widget ',(car l))))))))
X
X(define (locate-widget w)
X  (let loop ((path widget-load-path))
X    (if (null? path)
X    (error 'locate-widget "no such widget: ~s" w)
X    (let ((name (format #f "~alib/~a/~a.o" top-dir (car path) w)))
X      (if (file-exists? name)
X          name
X          (loop (cdr path)))))))
X
X(define load-widget load-widgets)
X
X(provide 'xwidgets)
END_OF_scm/xwidgets
if test 1137 -ne `wc -c <scm/xwidgets`; then
    echo shar: \"scm/xwidgets\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f tst/gcd -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"tst/gcd\"
else
echo shar: Extracting \"tst/gcd\" \(70 characters\)
sed "s/^X//" >tst/gcd <<'END_OF_tst/gcd'
X(define (g x y)
X  (if (zero? y)
X      x
X      (g y (remainder x y))))
END_OF_tst/gcd
if test 70 -ne `wc -c <tst/gcd`; then
    echo shar: \"tst/gcd\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 7 \(of 14\).
cp /dev/null ark7isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 14 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0