v08i055: Elk (Extension Language Toolkit) part 07 of 14
Brandon S. Allbery - comp.sources.misc
allbery at uunet.UU.NET
Sun Sep 24 07:41:07 AEST 1989
Posting-number: Volume 8, Issue 55
Submitted-by: net at tub.UUCP (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 at 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 at +,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 at +,a4 at +
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 at +,a2 at +
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 at +,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 at +,a4 at +
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 at +,a2 at +
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 () , at unwind-forms)))
X
X(define-macro (while test . body)
X `(let loop ()
X (cond (,test , at body (loop)))))
X
X(define-macro (when test . body)
X `(and ,test , at body))
X
X(define-macro (unless test . body)
X `(when (not ,test) , at body))
X
X(define-macro (multiple-value-bind vars form . body)
X `(apply (lambda ,vars , at 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 , at 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 , at 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 () , at 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
More information about the Comp.sources.misc
mailing list