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

Text File | 1989-09-23 | 56.9 KB | 1,855 lines

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

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

[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 4 (of 14)."
# Contents:  src/list.c src/proc.c src/char.c src/symbol.c src/macros.h
#   src/prim.c src/stack.s.vax scm
# Wrapped by net@tub on Sun Sep 17 17:32:22 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f src/list.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/list.c\"
else
echo shar: Extracting \"src/list.c\" \(6515 characters\)
sed "s/^X//" >src/list.c <<'END_OF_src/list.c'
X/* Lists
X */
X
X#include "scheme.h"
X
XObject P_Cons (car, cdr) Object car, cdr; {
X    register char *p;
X    register f = 0;
X    Object cell;
X    GC_Node2;
X
X    p = Hp;
X    ALIGN(p);
X    if (p + sizeof (struct S_Pair) <= Heap_End) {
X    Hp = p + sizeof (struct S_Pair);
X    } else {
X    GC_Link2 (car, cdr);
X    p = Get_Bytes (sizeof (struct S_Pair));
X    f++;
X    }
X    SET(cell, T_Pair, (struct S_Pair *)p);
X    Car (cell) = car;
X    Cdr (cell) = cdr;
X    if (f)
X    GC_Unlink;
X    return cell;
X}
X
XObject P_Car (x) Object x; {
X    Check_List (x);
X    return Nullp (x) ? Null : Car (x);
X}
X
XObject P_Cdr (x) Object x; {
X    Check_List (x);
X    return Nullp (x) ? Null : Cdr (x);
X}
X
XObject Cxr (x, pat, len) Object x; register char *pat; register len; {
X    Object ret;
X
X    for (ret = x, pat += len; !Nullp (ret) && len > 0; len--)
X    switch (*--pat) {
X    case 'a': ret = P_Car (ret); break;
X    case 'd': ret = P_Cdr (ret); break;
X    default: Primitive_Error ("invalid pattern");
X    }
X    return ret;
X}
X
XObject P_Cddr  (x) Object x; { return Cxr (x,  "dd", 2); }
XObject P_Cdar  (x) Object x; { return Cxr (x,  "da", 2); }
XObject P_Cadr  (x) Object x; { return Cxr (x,  "ad", 2); }
XObject P_Caar  (x) Object x; { return Cxr (x,  "aa", 2); }
XObject P_Cdddr (x) Object x; { return Cxr (x, "ddd", 3); }
XObject P_Cddar (x) Object x; { return Cxr (x, "dda", 3); }
XObject P_Cdadr (x) Object x; { return Cxr (x, "dad", 3); }
XObject P_Cdaar (x) Object x; { return Cxr (x, "daa", 3); }
XObject P_Caddr (x) Object x; { return Cxr (x, "add", 3); }
XObject P_Cadar (x) Object x; { return Cxr (x, "ada", 3); }
XObject P_Caadr (x) Object x; { return Cxr (x, "aad", 3); }
XObject P_Caaar (x) Object x; { return Cxr (x, "aaa", 3); }
X
XObject P_Cxr (x, pat) Object x, pat; {
X    Check_List (x);
X    if (TYPE(pat) == T_Symbol)
X    pat = SYMBOL(pat)->name;
X    else if (TYPE(pat) != T_String)
X    Wrong_Type_Combination (pat, "string or symbol");
X    return Cxr (x, STRING(pat)->data, STRING(pat)->size);
X}
X
XObject P_Nullp (x) Object x; {
X    return Nullp (x) ? True : False;
X}
X
XObject P_Pairp (x) Object x; {
X    return TYPE(x) == T_Pair ? True : False;
X}
X
XObject P_Setcar (x, new) Object x, new; {
X    Check_Type (x, T_Pair);
X    return Car (x) = new;
X}
X
XObject P_Setcdr (x, new) Object x, new; {
X    Check_Type (x, T_Pair);
X    return Cdr (x) = new;
X}
X
XObject General_Member (key, list, comp) Object key, list; register comp; {
X    register r;
X
X    for ( ; !Nullp (list); list = Cdr (list)) {
X    Check_List (list);
X    if (comp == 0)
X        r = EQ(Car (list), key);
X    else if (comp == 1)
X        r = Eqv (Car (list), key);
X    else
X        r = Equal (Car (list), key);
X    if (r) return list;
X    }
X    return False;
X}
X
XObject P_Memq (key, list) Object key, list; {
X    return General_Member (key, list, 0);
X}
X
XObject P_Memv (key, list) Object key, list; {
X    return General_Member (key, list, 1);
X}
X
XObject P_Member (key, list) Object key, list; {
X    return General_Member (key, list, 2);
X}
X
XObject General_Assoc (key, alist, comp) Object key, alist; register comp; {
X    Object elem;
X    register r;
X
X    for ( ; !Nullp (alist); alist = Cdr (alist)) {
X    Check_List (alist);
X    elem = Car (alist);
X    if (TYPE(elem) != T_Pair)
X        continue;
X    if (comp == 0)
X        r = EQ(Car (elem), key);
X    else if (comp == 1)
X        r = Eqv (Car (elem), key);
X    else
X        r = Equal (Car (elem), key);
X    if (r) return elem;
X    }
X    return False;
X}
X
XObject P_Assq (key, alist) Object key, alist; {
X    return General_Assoc (key, alist, 0);
X}
X
XObject P_Assv (key, alist) Object key, alist; {
X    return General_Assoc (key, alist, 1);
X}
X
XObject P_Assoc (key, alist) Object key, alist; {
X    return General_Assoc (key, alist, 2);
X}
X
XInternal_Length (list) Object list; {
X    Object tail;
X    register i;
X
X    for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
X    ;
X    return i;
X}
X
XObject P_Length (list) Object list; {
X    Object tail;
X    register i;
X
X    for (i = 0, tail = list; !Nullp (tail); tail = Cdr (tail), i++)
X    Check_List (tail);
X    return Make_Integer (i);
X}
X
XObject P_Make_List (n, init) Object n, init; {
X    register len;
X    Object list;
X    GC_Node;
X
X    if ((len = Get_Integer (n)) < 0)
X    Range_Error (n);
X    list = Null;
X    GC_Link (init);
X    while (len-- > 0)
X    list = Cons (init, list);
X    GC_Unlink;
X    return list;
X}
X
XObject P_List (argc, argv) Object *argv; {
X    Object list, tail, cell;
X    GC_Node2;
X
X    GC_Link2 (list, tail);
X    for (list = tail = Null; argc-- > 0; tail = cell) {
X    cell = Cons (*argv++, Null);
X    if (Nullp (list))
X        list = cell;
X    else
X        P_Setcdr (tail, cell);
X    }
X    GC_Unlink;
X    return list;
X}
X
XObject P_Last_Pair (x) Object x; {
X    Check_Type (x, T_Pair);
X    for ( ; TYPE(Cdr (x)) == T_Pair; x = Cdr (x)) ;
X    return x;
X}
X
XObject P_Append (argc, argv) Object *argv; {
X    Object list, last, tail, cell;
X    register i;
X    GC_Node3;
X
X    list = last = Null;
X    GC_Link3 (list, last, tail);
X    for (i = 0; i < argc-1; i++) {
X    for (tail = argv[i]; !Nullp (tail); tail = Cdr (tail)) {
X        Check_List (tail);
X        cell = Cons (Car (tail), Null);
X        if (Nullp (list))
X        list = cell;
X        else
X        P_Setcdr (last, cell);
X        last = cell;
X    }
X    }
X    if (argc)
X    if (Nullp (list))
X        list = argv[i];
X    else
X        P_Setcdr (last, argv[i]);
X    GC_Unlink;
X    return list;
X}
X
XObject P_Append_Set (argc, argv) Object *argv; {
X    register i, j;
X
X    for (i = j = 0; i < argc; i++)
X    if (!Nullp (argv[i]))
X        argv[j++] = argv[i];
X    if (j == 0)
X    return Null;
X    for (i = 0; i < j-1; i++)
X    P_Setcdr (P_Last_Pair (argv[i]), argv[i+1]);
X    return *argv;
X}
X
XObject P_Reverse (x) Object x; {
X    Object ret;
X    GC_Node;
X
X    GC_Link (x);
X    for (ret = Null; !Nullp (x); x = Cdr (x)) {
X    Check_List (x);
X    ret = Cons (Car (x), ret);
X    }
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Reverse_Set (x) Object x; {
X    Object prev, tail;
X
X    for (prev = Null; !Nullp (x); prev = x, x = tail) {
X    Check_List (x);
X    tail = Cdr (x);
X    P_Setcdr (x, prev);
X    }
X    return prev;
X}
X
XObject P_List_Tail (x, num) Object x, num; {
X    register n;
X
X    for (n = Get_Integer (num); n > 0 && !Nullp (x); n--, x = P_Cdr (x)) ;
X    return x;
X}
X
XObject P_List_Ref (x, num) Object x, num; {
X    return P_Car (P_List_Tail (x, num));
X}
X
XObject Copy_List (x) Object x; {
X    Object car, cdr;
X    GC_Node3;
X
X    if (TYPE(x) == T_Pair) {
X    if (stksize () > maxstack)
X        Uncatchable_Error ("Out of stack space");
X    car = cdr = Null;
X    GC_Link3 (x, car, cdr);
X    car = Copy_List (Car (x));
X    cdr = Copy_List (Cdr (x));
X    x = Cons (car, cdr);
X    GC_Unlink;
X    }
X    return x;
X}
END_OF_src/list.c
if test 6515 -ne `wc -c <src/list.c`; then
    echo shar: \"src/list.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/proc.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/proc.c\"
else
echo shar: Extracting \"src/proc.c\" \(13760 characters\)
sed "s/^X//" >src/proc.c <<'END_OF_src/proc.c'
X/* Eval, apply, etc.
X */
X
X#include "scheme.h"
X
Xchar *Error_Tag;
X
X/* "Tail_Call" indicates whether we are executing the last form in a
X * sequence of forms.  If it is true and we are about to call a compound
X * procedure, we are allowed to check whether a tail-call can be
X * performed instead.
X */
Xint Tail_Call = 0;
X
XObject Sym_Lambda,
X       Sym_Macro;
X
XObject Macro_Expand();
X
XInit_Proc () {
X    Define_Symbol (&Sym_Lambda, "lambda");
X    Define_Symbol (&Sym_Macro, "macro");
X}
X
XCheck_Procedure (x) Object x; {
X    register t = TYPE(x);
X
X    if (t != T_Primitive && t != T_Compound)
X    Wrong_Type_Combination (x, "procedure");
X    if (t == T_Primitive && PRIM(x)->disc == NOEVAL)
X    Primitive_Error ("invalid procedure: ~s", x);
X}
X
XObject P_Procedurep (x) Object x; {
X    register t = TYPE(x);
X    return t == T_Primitive || t == T_Compound || t == T_Control_Point
X     ? True : False;
X}
X
XObject P_Primitivep (x) Object x; {
X    return TYPE(x) == T_Primitive ? True : False;
X}
X
XObject P_Compoundp (x) Object x; {
X    return TYPE(x) == T_Compound ? True : False;
X}
X
XObject P_Macrop (x) Object x; {
X    return TYPE(x) == T_Macro ? True : False;
X}
X
XObject Make_Compound () {
X    Object proc;
X    register char *p;
X
X    p = Get_Bytes (sizeof (struct S_Compound));
X    SET(proc, T_Compound, (struct S_Compound *)p);
X    COMPOUND(proc)->closure = COMPOUND(proc)->env = COMPOUND(proc)->name = Null;
X    return proc;
X}
X
XObject Make_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name;
X    enum discipline disc; {
X    Object prim;
X    register char *p;
X    register struct S_Primitive *pr;
X
X    p = Get_Bytes (sizeof (struct S_Primitive));
X    SET(prim, T_Primitive, (struct S_Primitive *)p);
X    pr = PRIM(prim);
X    pr->tag = Null;
X    pr->fun = fun;
X    pr->name = name;
X    pr->minargs = min;
X    pr->maxargs = max;
X    pr->disc = disc;
X    return prim;
X}
X
XObject P_Begin (forms) Object forms; {
X    GC_Node;
X    TC_Prolog;
X
X    if (Nullp (forms))
X    return Null;
X    GC_Link (forms);
X    TC_Disable;
X    for ( ; !Nullp (Cdr (forms)); forms = Cdr (forms))
X    (void)Eval (Car (forms));
X    GC_Unlink;
X    TC_Enable;
X    return Eval (Car (forms));
X}
X
XObject P_Begin1 (forms) Object forms; {
X    register n;
X    Object r, ret;
X    GC_Node;
X    TC_Prolog;
X
X    GC_Link (forms);
X    TC_Disable;
X    for (n = 1; !Nullp (Cdr (forms)); n = 0, forms = Cdr (forms)) {
X    r = Eval (Car (forms));
X    if (n)
X        ret = r;
X    }
X    GC_Unlink;
X    TC_Enable;
X    r = Eval (Car (forms));
X    return n ? r : ret;
X}
X
XObject Eval (form) Object form; {
X    register t;
X    register struct S_Symbol *sym;
X    Object fun, binding, args, ret;
X    GC_Node;
X
Xagain:
X    t = TYPE(form);
X    if (t == T_Symbol) {
X    sym = SYMBOL(form);
X    if (EQ(sym->value,Unbound)) {
X        binding = Lookup_Symbol (form, 1);
X        sym->value = Cdr (binding);
X    }
X    ret = sym->value;
X    if (TYPE(ret) == T_Autoload)
X        ret = Do_Autoload (form, ret);
X    return ret;
X    }
X    if (t != T_Pair)
X    return form;
X    if (stksize () > maxstack)
X    Uncatchable_Error ("Out of stack space");
X    GC_Link (form);
X    fun = Eval (Car (form));
X    args = Cdr (form);
X    Check_List (args);
X    if (TYPE(fun) == T_Macro) {
X    form = Macro_Expand (fun, args);
X    GC_Unlink;
X    goto again;
X    }
X    ret = Funcall (fun, args, 1);
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Eval (argc, argv) Object *argv; {
X    Object ret, oldenv;
X    GC_Node;
X
X    if (argc == 1)
X    return Eval (argv[0]);
X    Check_Type (argv[1], T_Environment);
X    oldenv = The_Environment;
X    GC_Link (oldenv);
X    Switch_Environment (argv[1]);
X    ret = Eval (argv[0]);
X    Switch_Environment (oldenv);
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Apply (argc, argv) Object *argv; {
X    Object ret, list, tail, cell, last;
X    register i;
X    GC_Node3;
X
X    Check_Procedure (argv[0]);
X    /* Make a list of all args but the last, then append the
X     * last arg (which must be a proper list) to this list.
X     */
X    list = tail = last = Null;
X    GC_Link3 (list, tail, last);
X    for (i = 1; i < argc-1; i++, tail = cell) {
X    cell = Cons (argv[i], Null);
X    if (Nullp (list))
X        list = cell;
X    else
X        P_Setcdr (tail, cell);
X    }
X    for (last = argv[argc-1]; !Nullp (last); last = Cdr (last), tail = cell) {
X    cell = Cons (P_Car (last), Null);
X    if (Nullp (list))
X        list = cell;
X    else
X        P_Setcdr (tail, cell);
X    }
X    ret = Funcall (argv[0], list, 0);
X    GC_Unlink;
X    return ret;
X}
X
XArglist_Length (list) Object list; {
X    Object tail;
X    register i;
X
X    for (i = 0, tail = list; TYPE(tail) == T_Pair; tail = Cdr (tail), i++)
X    ;
X    if (Nullp (tail))
X    return i;
X    Primitive_Error ("argument list is improper");
X    /*NOTREACHED*/
X}
X
XObject Funcall_Primitive (fun, argl, eval) Object fun, argl; {
X    register struct S_Primitive *prim;
X    register argc, i;
X    char *last;
X    register Object *argv;
X    Object abuf[8], ret;
X    GC_Node2; GCNODE gcv;
X    TC_Prolog;
X
X    prim = PRIM(fun);
X    last = Error_Tag;
X    Error_Tag = prim->name;
X    argc = Arglist_Length (argl);
X    if (argc < prim->minargs
X        || (prim->maxargs != MANY && argc > prim->maxargs))
X    Primitive_Error ("wrong number of arguments");
X    if (prim->disc == NOEVAL) {
X    ret = (prim->fun)(argl);
X    } else {
X    /* Tail recursion is not possible while evaluating the arguments
X     * of a primitive procedure.
X     */
X    TC_Disable;
X    if (argc <= 8)
X        argv = abuf;
X    else
X        argv = (Object *)alloca (argc * sizeof (Object));
X    GC_Link2 (argl, fun);
X    gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc2; GC_List = &gcv;
X    for (i = 0; i < argc; i++, argl = Cdr (argl)) {
X        argv[i] = eval ? Eval (Car (argl)) : Car (argl);
X        gcv.gclen++;
X    }
X    TC_Enable;
X    prim = PRIM(fun);   /* fun has possibly been moved during gc */
X    if (prim->disc == VARARGS) {
X        ret = (prim->fun)(argc, argv);
X    } else {
X        switch (argc) {
X        case 0:
X        ret = (prim->fun)(); break;
X        case 1:
X        ret = (prim->fun)(argv[0]); break;
X        case 2:
X        ret = (prim->fun)(argv[0], argv[1]); break;
X        case 3:
X        ret = (prim->fun)(argv[0], argv[1], argv[2]); break;
X        case 4:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3]); break;
X        case 5:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4]);
X        break;
X        case 6:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
X                          argv[5]); break;
X        case 7:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
X                          argv[5], argv[6]); break;
X        case 8:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
X                          argv[5], argv[6], argv[7]); break;
X        case 9:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
X                          argv[5], argv[6], argv[7], argv[8]); break;
X        case 10:
X        ret = (prim->fun)(argv[0], argv[1], argv[2], argv[3], argv[4],
X                          argv[5], argv[6], argv[7], argv[8], argv[9]);
X        break;
X        default:
X        Panic ("too many args for primitive");
X        }
X    }
X    GC_Unlink;
X    }
X    Error_Tag = last;
X    return ret;
X}
X
X/* If we are in a tail recursion, we are reusing the old procedure
X * frame; we just assign new values to the formal parameters:
X */
X#define Lambda_Bind(var,val)\
Xif (tail_calling) {\
X    frame = Lookup_Symbol (var, 1);\
X    Cdr (frame) = val;\
X    SYMBOL(var)->value = val;\
X} else {\
X    frame = Add_Binding (frame, var, val);\
X}
X
XObject Funcall_Compound (fun, argl, eval) Object fun, argl; {
X    register argc, i, tail_calling = 0;
X    Object oldenv;
X    Object *argv, abuf[4], rest, ret, frame, tail, tail_call_env;
X    GC_Node5; GCNODE gcv;
X    TC_Prolog;
X
X#ifdef lint
X    tail_call_env = Null;
X#endif
X    frame = oldenv = tail = Null;
X    GC_Link5 (argl, oldenv, frame, tail, fun);
Xagain:
X    argc = Arglist_Length (argl);
X    if (tail_calling) {
X    tail = The_Environment;
X    Switch_Environment (tail_call_env);
X    } else {
X    if (argc <= 4)
X        argv = abuf;
X    else
X        argv = (Object *)alloca (argc * sizeof (Object));
X    }
X    TC_Disable;
X    gcv.gclen = 1; gcv.gcobj = argv; gcv.next = &gc5; GC_List = &gcv;
X    for (i = 0; i < argc; i++, argl = Cdr (argl)) {
X    argv[i] = eval ? Eval (Car (argl)) : Car (argl);
X    gcv.gclen++;
X    }
X    TC_Enable;
X    if (tail_calling)
X    Switch_Environment (tail);
X    tail = Car (Cdr (COMPOUND(fun)->closure));
X    if (TYPE(tail) == T_Symbol) {
X    rest = P_List (argc, argv);
X    Lambda_Bind (tail, rest);
X    } else {
X    for (i = 0; TYPE(tail) == T_Pair; tail = Cdr (tail), i++) {
X        Check_Type (Car (tail), T_Symbol);
X        if (i == argc)
X        Primitive_Error ("too few arguments for ~s", fun);
X        Lambda_Bind (Car (tail), argv[i]);
X    }
X    if (Nullp (tail)) {
X        if (i < argc)
X        Primitive_Error ("too many arguments for ~s", fun);
X    } else {
X        Check_Type (tail, T_Symbol);
X        rest = P_List (argc-i, argv+i);
X        Lambda_Bind (tail, rest);
X    }
X    }
X    if (!tail_calling) {
X    oldenv = The_Environment;
X    Switch_Environment (COMPOUND(fun)->env);
X    Push_Frame (frame);
X    }
X    Tail_Call = 1;
X    ret = Begin (Cdr (Cdr (COMPOUND(fun)->closure)));
X    if (TYPE(ret) == T_Special) {
X    argl = Car (ret);
X    tail_call_env = Cdr (ret);
X    tail_calling = 1;
X    eval = 1;
X    goto again;
X    }
X    Tail_Call = 0;
X    Pop_Frame ();
X    Switch_Environment (oldenv);
X    GC_Unlink;
X    return ret;
X}
X
XObject Funcall (fun, argl, eval) Object fun, argl; {
X    register t;
X    static struct S_Pair tail_call_info;
X    Object ret, env;
X    Tag_Node;
X
X    t = TYPE(fun);
X    if (Tail_Call && eval && t == T_Compound) {
X    register GCNODE *p;
X    Object f;
X
X    for (p = GC_List; p; p = p->next) {
X        f = *(p->gcobj);
X        if (p->gclen == TAG_FUN && TYPE(f) == T_Compound) {
X        if (EQ(f,fun)) {
X            SET(ret, T_Special, &tail_call_info);
X            Car (ret) = argl;
X            Cdr (ret) = The_Environment;
X            return ret;
X        }
X        break;
X        }
X    }
X    }
X    env = The_Environment;
X    Tag_Link (argl, fun, env);
X    if (t == T_Primitive) {
X    ret = Funcall_Primitive (fun, argl, eval);
X    } else if (t == T_Compound) {
X    ret = Funcall_Compound (fun, argl, eval);
X    } else if (t == T_Control_Point) {
X    Funcall_Control_Point (fun, argl, eval);
X    /*NOTREACHED*/
X    } else Primitive_Error ("application of non-procedure (~s)", fun);
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Lambda (argl) Object argl; {
X    Object proc, args, closure;
X    GC_Node2;
X
X    proc = Null;
X    args = Car (argl);
X    if (TYPE(args) != T_Symbol && TYPE(args) != T_Pair && !Nullp (args))
X    Wrong_Type_Combination (args, "list or symbol");
X    GC_Link2 (argl, proc);
X    proc = Make_Compound ();
X    closure = Cons (Sym_Lambda, argl);
X    COMPOUND(proc)->closure = closure;
X    COMPOUND(proc)->env = The_Environment;
X    GC_Unlink;
X    return proc;
X}
X
XObject P_Procedure_Lambda (p) Object p; {
X    Check_Type (p, T_Compound);
X    return Copy_List (COMPOUND(p)->closure);
X}
X
XObject P_Procedure_Env (p) Object p; {
X    Check_Type (p, T_Compound);
X    return COMPOUND(p)->env;
X}
X
XObject General_Map (argc, argv, accum) Object *argv; register accum; {
X    register i;
X    Object *args;
X    Object head, list, tail, cell, arglist, val;
X    GC_Node2; GCNODE gcv;
X
X    Check_Procedure (argv[0]);
X    args = (Object *)alloca ((argc-1) * sizeof (Object));
X    list = tail = Null;
X    GC_Link2 (list, tail);
X    gcv.gclen = argc; gcv.gcobj = args; gcv.next = &gc2; GC_List = &gcv;
X    while (1) {
X    for (i = 1; i < argc; i++) {
X        head = argv[i];
X        if (Nullp (head)) {
X        GC_Unlink;
X        return list;
X        }
X        Check_Type (head, T_Pair);
X        args[i-1] = Car (head);
X        argv[i] = Cdr (head);
X    }
X    arglist = P_List (argc-1, args);
X    val = Funcall (argv[0], arglist, 0);
X    if (!accum)
X        continue;
X    cell = Cons (val, Null);
X    if (Nullp (list))
X        list = cell;
X    else
X        P_Setcdr (tail, cell);
X    tail = cell;
X    }
X    /*NOTREACHED*/
X}
X
XObject P_Map (argc, argv) Object *argv; {
X    return General_Map (argc, argv, 1);
X}
X
XObject P_For_Each (argc, argv) Object *argv; {
X    return General_Map (argc, argv, 0);
X}
X
XObject Make_Macro () {
X    Object mac;
X    register char *p;
X
X    p = Get_Bytes (sizeof (struct S_Macro));
X    SET(mac, T_Macro, (struct S_Macro *)p);
X    MACRO(mac)->body = MACRO(mac)->name = Null;
X    return mac;
X}
X
XObject P_Macro (argl) Object argl; {
X    Object mac, args, body;
X    GC_Node2;
X
X    mac = Null;
X    args = Car (argl);
X    if (TYPE(args) != T_Symbol && TYPE(args) != T_Pair && !Nullp (args))
X    Wrong_Type_Combination (args, "list or symbol");
X    GC_Link2 (argl, mac);
X    mac = Make_Macro ();
X    body = Cons (Sym_Macro, argl);
X    MACRO(mac)->body = body;
X    GC_Unlink;
X    return mac;
X}
X
XObject P_Macro_Body (m) Object m; {
X    Check_Type (m, T_Macro);
X    return Copy_List (MACRO(m)->body);
X}
X
XObject Macro_Expand (mac, argl) Object mac, argl; {
X    register argc, i, tail_calling = 0;
X    Object frame, ret, tail;
X    GC_Node4;
X    TC_Prolog;
X
X    frame = tail = Null;
X    GC_Link4 (argl, frame, tail, mac);
X    argc = Arglist_Length (argl);
X    tail = Car (Cdr (MACRO(mac)->body));
X    if (TYPE(tail) == T_Symbol) {
X    Lambda_Bind (tail, argl);
X    } else {
X    for (i = 0; TYPE(tail) == T_Pair; tail = Cdr (tail), i++) {
X        Check_Type (Car (tail), T_Symbol);
X        if (i == argc)
X        Primitive_Error ("too few arguments for ~s", mac);
X        Lambda_Bind (Car (tail), Car (argl));
X        argl = Cdr (argl);
X    }
X    if (Nullp (tail)) {
X        if (i < argc)
X        Primitive_Error ("too many arguments for ~s", mac);
X    } else {
X        Check_Type (tail, T_Symbol);
X        Lambda_Bind (tail, argl);
X    }
X    }
X    Push_Frame (frame);
X    TC_Disable;
X    ret = Begin (Cdr (Cdr (MACRO(mac)->body)));
X    TC_Enable;
X    Pop_Frame ();
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Macro_Expand (form) Object form; {
X    Object ret, mac;
X    GC_Node;
X
X    Check_Type (form, T_Pair);
X    GC_Link (form);
X    mac = Eval (Car (form));
X    if (TYPE(mac) != T_Macro)
X    ret = form;
X    else
X    ret = Macro_Expand (mac, Cdr (form));
X    GC_Unlink;
X    return ret;
X}
END_OF_src/proc.c
if test 13760 -ne `wc -c <src/proc.c`; then
    echo shar: \"src/proc.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/char.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/char.c\"
else
echo shar: Extracting \"src/char.c\" \(2740 characters\)
sed "s/^X//" >src/char.c <<'END_OF_src/char.c'
X/* Characters
X */
X
X#include <ctype.h>
X
X#include "scheme.h"
X
XObject Make_Char (c) register c; {
X    Object ch;
X
X    SET(ch, T_Character, (unsigned char)c);
X    return ch;
X}
X
XObject P_Charp (c) Object c; {
X    return TYPE(c) == T_Character ? True : False;
X}
X
XObject P_Char_To_Integer (c) Object c; {
X    Check_Type (c, T_Character);
X    return Make_Integer (CHAR(c));
X}
X
XObject P_Integer_To_Char (n) Object n; {
X    register i;
X
X    if ((i = Get_Integer (n)) < 0 || i > 255)
X    Range_Error (n);
X    return Make_Char (i);
X}
X
XObject P_Char_Upper_Case (c) Object c; {
X    Check_Type (c, T_Character);
X    return isupper (CHAR(c)) ? True : False;
X}
X
XObject P_Char_Lower_Case (c) Object c; {
X    Check_Type (c, T_Character);
X    return islower (CHAR(c)) ? True : False;
X}
X
XObject P_Char_Alphabetic (c) Object c; {
X    Check_Type (c, T_Character);
X    return isalpha (CHAR(c)) ? True : False;
X}
X
XObject P_Char_Numeric (c) Object c; {
X    Check_Type (c, T_Character);
X    return isdigit (CHAR(c)) ? True : False;
X}
X
XObject P_Char_Whitespace (c) Object c; {
X    register x;
X
X    Check_Type (c, T_Character);
X    x = CHAR(c);
X    return Whitespace (x) ? True : False;
X}
X
XObject P_Char_Upcase (c) Object c; {
X    Check_Type (c, T_Character);
X    return islower (CHAR(c)) ? Make_Char (toupper (CHAR(c))) : c;
X}
X
XObject P_Char_Downcase (c) Object c; {
X    Check_Type (c, T_Character);
X    return isupper (CHAR(c)) ? Make_Char (tolower (CHAR(c))) : c;
X}
X
XGeneral_Chrcmp (c1, c2, ci) Object c1, c2; register ci; {
X    Check_Type (c1, T_Character);
X    Check_Type (c2, T_Character);
X    if (ci)
X    return Char_Map[CHAR(c1)] - Char_Map[CHAR(c2)];
X    return CHAR(c1) - CHAR(c2);
X}
X
XObject P_Chr_Eq (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 0) ? False : True;
X}
X
XObject P_Chr_Less (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 0) < 0 ? True : False;
X}
X
XObject P_Chr_Greater (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 0) > 0 ? True : False;
X}
X
XObject P_Chr_Eq_Less (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 0) <= 0 ? True : False;
X}
X
XObject P_Chr_Eq_Greater (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 0) >= 0 ? True : False;
X}
X
XObject P_Chr_CI_Eq (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 1) ? False : True;
X}
X
XObject P_Chr_CI_Less (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 1) < 0 ? True : False;
X}
X
XObject P_Chr_CI_Greater (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 1) > 0 ? True : False;
X}
X
XObject P_Chr_CI_Eq_Less (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 1) <= 0 ? True : False;
X}
X
XObject P_Chr_CI_Eq_Greater (c1, c2) Object c1, c2; {
X    return General_Chrcmp (c1, c2, 1) >= 0 ? True : False;
X}
END_OF_src/char.c
if test 2740 -ne `wc -c <src/char.c`; then
    echo shar: \"src/char.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/symbol.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/symbol.c\"
else
echo shar: Extracting \"src/symbol.c\" \(4650 characters\)
sed "s/^X//" >src/symbol.c <<'END_OF_src/symbol.c'
X/* Symbol handling and the obarray
X */
X
X#include "scheme.h"
X
XObject Obarray;
X
XObject Null,
X       True,
X       False,
X       Unbound,
X       Special,
X       Void,
X       Newline,
X       Eof,
X       Zero,
X       One;
X
XInit_Symbol () {
X    SETTYPE(Null, T_Null);
X    SETTYPE(True, T_Boolean); SETFIXNUM(True, 1);
X    SETTYPE(False, T_Boolean); SETFIXNUM(False, 0);
X    SETTYPE(Unbound, T_Unbound);
X    SETTYPE(Special, T_Special);
X    SETTYPE(Void, T_Void);
X    SETTYPE(Eof, T_End_Of_File);
X    Newline = Make_Char ('\n');
X    Zero = Make_Fixnum (0);
X    One = Make_Fixnum (1);
X    Obarray = Make_Vector (OBARRAY_SIZE, Null);
X    Global_GC_Link (Obarray);
X}
X
XObject Make_Symbol (name) Object name; {
X    Object sym;
X    register char *p;
X    register struct S_Symbol *sp;
X    GC_Node;
X
X    GC_Link (name);
X    p = Get_Bytes (sizeof (struct S_Symbol));
X    SET(sym, T_Symbol, (struct S_Symbol *)p);
X    sp = SYMBOL(sym);
X    sp->name = name;
X    sp->value = Unbound;
X    sp->plist = Null;
X    GC_Unlink;
X    return sym;
X}
X
XObject P_Symbolp (x) Object x; {
X    return TYPE(x) == T_Symbol ? True : False;
X}
X
XObject P_Symbol_To_String (x) Object x; {
X    Check_Type (x, T_Symbol);
X    return SYMBOL(x)->name;
X}
X
XObject Obarray_Lookup (str, len) register char *str; register len; {
X    register h;
X    register struct S_String *s;
X    register struct S_Symbol *sym;
X    Object p;
X
X    h = Hash (str, len) % OBARRAY_SIZE;
X    for (p = VECTOR(Obarray)->data[h]; !Nullp (p); p = sym->next) {
X    sym = SYMBOL(p);
X    s = STRING(sym->name);
X    if (s->size == len && bcmp (s->data, str, len) == 0)
X        return p;
X    }
X    return Make_Fixnum (h);
X}
X
XObject Intern (str) char *str; {
X    Object s, *p, sym, ostr;
X    register len;
X
X    len = strlen (str);
X    s = Obarray_Lookup (str, len);
X    if (TYPE(s) != T_Fixnum)
X    return s;
X    ostr = Make_String (str, len);
X    sym = Make_Symbol (ostr);
X    p = &VECTOR(Obarray)->data[FIXNUM(s)];
X    SYMBOL(sym)->next = (TYPE(*p) == T_Fixnum) ? Null : *p;
X    *p = sym;
X    return sym;
X}
X
XObject P_String_To_Symbol (str) Object str; {
X    Object s, *p, sym;
X
X    Check_Type (str, T_String);
X    s = Obarray_Lookup (STRING(str)->data, STRING(str)->size);
X    if (TYPE(s) != T_Fixnum)
X    return s;
X    sym = Make_Symbol (str);
X    p = &VECTOR(Obarray)->data[FIXNUM(s)];
X    SYMBOL(sym)->next = (TYPE(*p) == T_Fixnum) ? Null : *p;
X    return *p = sym;
X}
X
XObject P_Oblist () {
X    register i;
X    Object p, list, bucket;
X    GC_Node2;
X
X    p = list = Null;
X    GC_Link2 (p, list);
X    for (i = 0; i < OBARRAY_SIZE; i++) {
X    bucket = Null;
X    for (p = VECTOR(Obarray)->data[i]; !Nullp (p); p = SYMBOL(p)->next)
X        bucket = Cons (p, bucket);
X    if (!Nullp (bucket))
X        list = Cons (bucket, list);
X    }
X    GC_Unlink;
X    return list;
X}
X
XObject P_Put (argc, argv) Object *argv; {
X    Object sym, key, last, tail, prop;
X    GC_Node3;
X
X    sym = argv[0];
X    key = argv[1];
X    Check_Type (sym, T_Symbol);
X    Check_Type (key, T_Symbol);
X    last = Null;
X    for (tail = SYMBOL(sym)->plist; !Nullp (tail); tail = Cdr (tail)) {
X    prop = Car (tail);
X    if (EQ(Car (prop), key)) {
X        if (argc == 3)
X        Cdr (prop) = argv[2];
X        else if (Nullp (last))
X        SYMBOL(sym)->plist = Cdr (tail);
X        else
X        Cdr (last) = Cdr (tail);
X        return key;
X    }
X    last = tail;
X    }
X    if (argc == 2)
X    return False;
X    GC_Link3 (sym, last, key);
X    tail = Cons (key, argv[2]);
X    tail = Cons (tail, Null);
X    if (Nullp (last))
X    SYMBOL(sym)->plist = tail;
X    else
X    Cdr (last) = tail;
X    GC_Unlink;
X    return key;
X}
X
XObject P_Get (sym, key) Object sym, key; {
X    Object prop;
X
X    Check_Type (sym, T_Symbol);
X    Check_Type (key, T_Symbol);
X    prop = Assq (key, SYMBOL(sym)->plist);
X    if (!Truep (prop))
X    return False;
X    /*
X     * Do we want to signal an error or return #f?
X     *
X     * Primitive_Error ("~s has no such property: ~s", sym, key);
X     */
X    return Cdr (prop);
X}
X
XObject P_Symbol_Plist (sym) Object sym; {
X    Check_Type (sym, T_Symbol);
X    return Copy_List (SYMBOL(sym)->plist);
X}
X
XHash (str, len) char *str; {
X    register h;
X    register char *p, *ep;
X
X    h = 5 * len;
X    if (len > 5)
X    len = 5;
X    for (p = str, ep = p+len; p < ep; ++p)
X    h = (h << 2) ^ *p;
X    return h & 017777777777;
X}
X
XDefine_Symbol (sym, name) Object *sym; char *name; {
X    *sym = Intern (name);
X    _Global_GC_Link (sym);
X}
X
XDefine_Variable (var, name, init) Object *var, init; char *name; {
X    Object frame, sym;
X    GC_Node;
X
X    GC_Link (init);
X    sym = Intern (name);
X    SYMBOL(sym)->value = init;
X    frame = Add_Binding (Car (The_Environment), sym, init);
X    *var = Car (frame);
X    Car (The_Environment) = frame;
X    _Global_GC_Link (var);
X    GC_Unlink;
X}
END_OF_src/symbol.c
if test 4650 -ne `wc -c <src/symbol.c`; then
    echo shar: \"src/symbol.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/macros.h -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/macros.h\"
else
echo shar: Extracting \"src/macros.h\" \(3835 characters\)
sed "s/^X//" >src/macros.h <<'END_OF_src/macros.h'
X#ifndef MACROS_H
X#define MACROS_H
X
X/* Miscellaneous #define's
X */
X
X#ifndef sigmask
X#define sigmask(n)  (1 << ((n)-1))
X#endif
X
X#define Nullp(x)    ((TYPE(x) == T_Null))
X#define Truep(x)    (!EQ(x,False) && !Nullp(x))
X#define Car(x)      PAIR(x)->car
X#define Cdr(x)      PAIR(x)->cdr
X#define Val(x)      Cdr(x)
X#define Cons        P_Cons
X#define Begin       P_Begin
X#define Assq(x,y)   General_Assoc(x,y,0)
X#define Print(x)    General_Print_Object (x, Curr_Output_Port, 0)
X#define Numeric(t)  (t == T_Fixnum || t == T_Flonum || t == T_Bignum)
X
X#define Whitespace(c) (c == ' ' || c == '\t' || c == '\014' || c == '\n')
X#define Delimiter(c) (c == ';' || c == ')' || c == '(' || c == '#')
X
X#ifdef USE_SIGNAL
X#  define Disable_Interrupts (void)signal (SIGINT, SIG_IGN);
X#  define Enable_Interrupts  (void)signal (SIGINT, Intr_Handler)
X#else
X#  define Disable_Interrupts (void)sigblock (sigmask (SIGINT))
X#  define Enable_Interrupts  (void)sigsetmask (0)
X#endif
X
X/* Align heap addresses */
X#define ALIGN(ptr) ((ptr) = (char *)(((int)(ptr) + 3) & ~3))
X
X/* Normalize stack addresses */
X#define NORM(addr)  ((int)(addr) + delta)
X
X/* Used in special forms: */
X#define TC_Prolog   register _t = Tail_Call
X#define TC_Disable  Tail_Call = 0
X#define TC_Enable   Tail_Call = _t
X
X#define TAG_FUN    -1
X#define TAG_ARGS   -2
X#define TAG_ENV    -3
X
X#define GC_Node     GCNODE gc1
X#define GC_Node2    GCNODE gc1, gc2
X#define GC_Node3    GCNODE gc1, gc2, gc3
X#define GC_Node4    GCNODE gc1, gc2, gc3, gc4
X#define GC_Node5    GCNODE gc1, gc2, gc3, gc4, gc5
X#define GC_Node6    GCNODE gc1, gc2, gc3, gc4, gc5, gc6
X
X#define Tag_Node    GC_Node3
X
X#define Tag_Link(args,fun,env) {\
X    gc1.gclen = TAG_ARGS; gc1.gcobj = &args; gc1.next = GC_List;\
X    gc2.gclen = TAG_FUN;  gc2.gcobj = &fun;  gc2.next = &gc1;\
X    gc3.gclen = TAG_ENV;  gc3.gcobj = &env;  gc3.next = &gc2; GC_List = &gc3;\
X}
X
X#define GC_Link(x) {\
X    gc1.gclen = 0; gc1.gcobj = &x; gc1.next = GC_List; GC_List = &gc1;\
X}
X
X#define GC_Link2(x1,x2) {\
X    gc1.gclen = 0; gc1.gcobj = &x1; gc1.next = GC_List;\
X    gc2.gclen = 0; gc2.gcobj = &x2; gc2.next = &gc1; GC_List = &gc2;\
X}
X
X#define GC_Link3(x1,x2,x3) {\
X    gc1.gclen = 0; gc1.gcobj = &x1; gc1.next = GC_List;\
X    gc2.gclen = 0; gc2.gcobj = &x2; gc2.next = &gc1;\
X    gc3.gclen = 0; gc3.gcobj = &x3; gc3.next = &gc2; GC_List = &gc3;\
X}
X
X#define GC_Link4(x1,x2,x3,x4) {\
X    gc1.gclen = 0; gc1.gcobj = &x1; gc1.next = GC_List;\
X    gc2.gclen = 0; gc2.gcobj = &x2; gc2.next = &gc1;\
X    gc3.gclen = 0; gc3.gcobj = &x3; gc3.next = &gc2;\
X    gc4.gclen = 0; gc4.gcobj = &x4; gc4.next = &gc3; GC_List = &gc4;\
X}
X
X#define GC_Link5(x1,x2,x3,x4,x5) {\
X    gc1.gclen = 0; gc1.gcobj = &x1; gc1.next = GC_List;\
X    gc2.gclen = 0; gc2.gcobj = &x2; gc2.next = &gc1;\
X    gc3.gclen = 0; gc3.gcobj = &x3; gc3.next = &gc2;\
X    gc4.gclen = 0; gc4.gcobj = &x4; gc4.next = &gc3;\
X    gc5.gclen = 0; gc5.gcobj = &x5; gc5.next = &gc4; GC_List = &gc5;\
X}
X
X#define GC_Link6(x1,x2,x3,x4,x5,x6) {\
X    gc1.gclen = 0; gc1.gcobj = &x1; gc1.next = GC_List;\
X    gc2.gclen = 0; gc2.gcobj = &x2; gc2.next = &gc1;\
X    gc3.gclen = 0; gc3.gcobj = &x3; gc3.next = &gc2;\
X    gc4.gclen = 0; gc4.gcobj = &x4; gc4.next = &gc3;\
X    gc5.gclen = 0; gc5.gcobj = &x5; gc5.next = &gc4;\
X    gc6.gclen = 0; gc6.gcobj = &x6; gc6.next = &gc5; GC_List = &gc6;\
X}
X
X#define GC_Unlink (GC_List = gc1.next)
X
X#define Global_GC_Link(x) _Global_GC_Link(&x)
X
X
X#define Check_Type(x,t) {\
X    if (TYPE(x) != t) Wrong_Type (x, t);\
X}
X
X#define Check_List(x) {\
X    if (TYPE(x) != T_Pair && !Nullp (x)) Wrong_Type_Combination (x, "list");\
X}
X
X#define Check_Number(x) {\
X    register t = TYPE(x);\
X    if (!Numeric (t)) Wrong_Type_Combination (x, "number");\
X}
X
X#define Check_Integer(x) {\
X    register t = TYPE(x);\
X    if (t != T_Fixnum && t != T_Bignum) Wrong_Type (x, T_Fixnum);\
X}
X
X#endif
END_OF_src/macros.h
if test 3835 -ne `wc -c <src/macros.h`; then
    echo shar: \"src/macros.h\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/prim.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/prim.c\"
else
echo shar: Extracting \"src/prim.c\" \(19818 characters\)
sed "s/^X//" >src/prim.c <<'END_OF_src/prim.c'
X/* Table of primitives
X */
X
X#include "scheme.h"
X
Xstruct Prim_Init {
X    Object (*fun)();
X    char *name;
X    int minargs, maxargs;
X    enum discipline disc;
X} Primitives[] = {
X
X    /* auto.c:
X     */
X    P_Autoload,          "autoload",                       2, 2,    EVAL,
X
X    /* bool.c:
X     */
X    P_Booleanp,          "boolean?",                       1, 1,    EVAL,
X    P_Not,               "not",                            1, 1,    EVAL,
X    P_Eq,                "eq?",                            2, 2,    EVAL,
X    P_Eqv,               "eqv?",                           2, 2,    EVAL,
X    P_Equal,             "equal?",                         2, 2,    EVAL,
X
X    /* char.c:
X     */
X    P_Charp,             "char?",                          1, 1,    EVAL,
X    P_Char_To_Integer,   "char->integer",                  1, 1,    EVAL,
X    P_Integer_To_Char,   "integer->char",                  1, 1,    EVAL,
X    P_Char_Upper_Case,   "char-upper-case?",               1, 1,    EVAL,
X    P_Char_Lower_Case,   "char-lower-case?",               1, 1,    EVAL,
X    P_Char_Alphabetic,   "char-alphabetic?",               1, 1,    EVAL,
X    P_Char_Numeric,      "char-numeric?",                  1, 1,    EVAL,
X    P_Char_Whitespace,   "char-whitespace?",               1, 1,    EVAL,
X    P_Char_Upcase,       "char-upcase",                    1, 1,    EVAL,
X    P_Char_Downcase,     "char-downcase",                  1, 1,    EVAL,
X    P_Chr_Eq,            "char=?",                         2, 2,    EVAL,
X    P_Chr_Less,          "char<?",                         2, 2,    EVAL,
X    P_Chr_Greater,       "char>?",                         2, 2,    EVAL,
X    P_Chr_Eq_Less,       "char<=?",                        2, 2,    EVAL,
X    P_Chr_Eq_Greater,    "char>=?",                        2, 2,    EVAL,
X    P_Chr_CI_Eq,         "char-ci=?",                      2, 2,    EVAL,
X    P_Chr_CI_Less,       "char-ci<?",                      2, 2,    EVAL,
X    P_Chr_CI_Greater,    "char-ci>?",                      2, 2,    EVAL,
X    P_Chr_CI_Eq_Less,    "char-ci<=?",                     2, 2,    EVAL,
X    P_Chr_CI_Eq_Greater, "char-ci>=?",                     2, 2,    EVAL,
X
X    /* cont.c:
X     */
X    P_Control_Pointp,    "control-point?",                 1, 1,    EVAL,
X    P_Call_CC,           "call-with-current-continuation", 1, 1,    EVAL,
X    P_Dynamic_Wind,      "dynamic-wind",                   3, 3,    EVAL,
X    P_Control_Point_Env, "control-point-environment",      1, 1,    EVAL,
X
X    /* debug.c:
X     */
X    P_Backtrace_List,    "backtrace-list",                 0, 1,    VARARGS,
X
X    /* dump.c:
X     */
X#ifdef CAN_DUMP
X    P_Dump,              "dump",                           1, 1,    EVAL,
X#endif
X
X    /* env.c:
X     */
X    P_Environmentp,      "environment?",                   1, 1,    EVAL,
X    P_The_Environment,   "the-environment",                0, 0,    EVAL,
X    P_Global_Environment,"global-environment",             0, 0,    EVAL,
X    P_Define,            "define",                         1, MANY, NOEVAL,
X    P_Define_Macro,      "define-macro",                   1, MANY, NOEVAL,
X    P_Set,               "set!",                           2, 2,    NOEVAL,
X    P_Env_List,          "environment->list",              1, 1,    EVAL,
X    P_Boundp,            "bound?",                         1, 1,    EVAL,
X
X    /* error.c:
X     */
X    P_Error,             "error",                          2, MANY, VARARGS,
X    P_Reset,             "reset",                          0, 0,    EVAL,
X
X    /* features.c:
X     */
X    P_Featurep,          "feature?",                       1, 1,    EVAL,
X    P_Provide,           "provide",                        1, 1,    EVAL,
X    P_Require,           "require",                        1, 3,    VARARGS,
X
X    /* heap.c:
X     */
X    P_Collect,           "collect",                        0, 0,    EVAL,
X
X    /* io.c:
X     */
X    P_Port_File_Name,    "port-file-name",                 1, 1,    EVAL,
X    P_Eof_Objectp,       "eof-object?",                    1, 1,    EVAL,
X    P_Curr_Input_Port,   "current-input-port",             0, 0,    EVAL,
X    P_Curr_Output_Port,  "current-output-port",            0, 0,    EVAL,
X    P_Input_Portp,       "input-port?",                    1, 1,    EVAL,
X    P_Output_Portp,      "output-port?",                   1, 1,    EVAL,
X    P_Open_Input_File,   "open-input-file",                1, 1,    EVAL,
X    P_Open_Output_File,  "open-output-file",               1, 1,    EVAL,
X    P_Close_Port,        "close-port",                     1, 1,    EVAL,
X    P_With_Input,        "with-input-from-file",           2, 2,    EVAL,
X    P_With_Output,       "with-output-to-file",            2, 2,    EVAL,
X    P_Call_With_Input,   "call-with-input-file",           2, 2,    EVAL,
X    P_Call_With_Output,  "call-with-output-file",          2, 2,    EVAL,
X    P_Open_Input_String, "open-input-string",              1, 1,    EVAL,
X    P_Open_Output_String,"open-output-string",             0, 0,    EVAL,
X    P_Tilde_Expand,      "tilde-expand",                   1, 1,    EVAL,
X    P_File_Existsp,      "file-exists?",                   1, 1,    EVAL,
X
X    /* load.c:
X     */
X    P_Load,              "load",                           1, 2,    VARARGS,
X
X    /* list.c:
X     */
X    P_Cons,              "cons",                           2, 2,    EVAL,
X    P_Car,               "car",                            1, 1,    EVAL,
X    P_Cdr,               "cdr",                            1, 1,    EVAL,
X    P_Cddr,              "cddr",                           1, 1,    EVAL,
X    P_Cdar,              "cdar",                           1, 1,    EVAL,
X    P_Cadr,              "cadr",                           1, 1,    EVAL,
X    P_Caar,              "caar",                           1, 1,    EVAL,
X    P_Cdddr,             "cdddr",                          1, 1,    EVAL,
X    P_Cddar,             "cddar",                          1, 1,    EVAL,
X    P_Cdadr,             "cdadr",                          1, 1,    EVAL,
X    P_Cdaar,             "cdaar",                          1, 1,    EVAL,
X    P_Caddr,             "caddr",                          1, 1,    EVAL,
X    P_Cadar,             "cadar",                          1, 1,    EVAL,
X    P_Caadr,             "caadr",                          1, 1,    EVAL,
X    P_Caaar,             "caaar",                          1, 1,    EVAL,
X    P_Cxr,               "cxr",                            2, 2,    EVAL,
X    P_Nullp,             "null?",                          1, 1,    EVAL,
X    P_Pairp,             "pair?",                          1, 1,    EVAL,
X    P_Setcar,            "set-car!",                       2, 2,    EVAL,
X    P_Setcdr,            "set-cdr!",                       2, 2,    EVAL,
X    P_Assq,              "assq",                           2, 2,    EVAL,
X    P_Assv,              "assv",                           2, 2,    EVAL,
X    P_Assoc,             "assoc",                          2, 2,    EVAL,
X    P_Memq,              "memq",                           2, 2,    EVAL,
X    P_Memv,              "memv",                           2, 2,    EVAL,
X    P_Member,            "member",                         2, 2,    EVAL,
X    P_Make_List,         "make-list",                      2, 2,    EVAL,
X    P_List,              "list",                           0, MANY, VARARGS,
X    P_Length,            "length",                         1, 1,    EVAL,
X    P_Append,            "append",                         0, MANY, VARARGS,
X    P_Append_Set,        "append!",                        0, MANY, VARARGS,
X    P_Last_Pair,         "last-pair",                      1, 1,    EVAL,
X    P_Reverse,           "reverse",                        1, 1,    EVAL,
X    P_Reverse_Set,       "reverse!",                       1, 1,    EVAL,
X    P_List_Tail,         "list-tail",                      2, 2,    EVAL,
X    P_List_Ref,          "list-ref",                       2, 2,    EVAL,
X
X    /* main.c:
X     */
X    P_Command_Line_Args, "command-line-args",              0, 0,    EVAL,
X
X    /* math.c:
X     */
X    P_Numberp,           "number?",                        1, 1,    EVAL,
X    P_Complexp,          "complex?",                       1, 1,    EVAL,
X    P_Realp,             "real?",                          1, 1,    EVAL,
X    P_Rationalp,         "rational?",                      1, 1,    EVAL,
X    P_Integerp,          "integer?",                       1, 1,    EVAL,
X    P_Zerop,             "zero?",                          1, 1,    EVAL,
X    P_Positivep,         "positive?",                      1, 1,    EVAL,
X    P_Negativep,         "negative?",                      1, 1,    EVAL,
X    P_Oddp,              "odd?",                           1, 1,    EVAL,
X    P_Evenp,             "even?",                          1, 1,    EVAL,
X    P_Exactp,            "exact?",                         1, 1,    EVAL,
X    P_Inexactp,          "inexact?",                       1, 1,    EVAL,
X    P_Generic_Equal,     "=",                              1, MANY, VARARGS,
X    P_Generic_Less,      "<",                              1, MANY, VARARGS,
X    P_Generic_Greater,   ">",                              1, MANY, VARARGS,
X    P_Generic_Eq_Less,   "<=",                             1, MANY, VARARGS,
X    P_Generic_Eq_Greater,">=",                             1, MANY, VARARGS,
X    P_Inc,               "1+",                             1, 1,    EVAL,
X    P_Dec,               "1-",                             1, 1,    EVAL,
X    P_Generic_Plus,      "+",                              0, MANY, VARARGS,
X    P_Generic_Minus,     "-",                              1, MANY, VARARGS,
X    P_Generic_Multiply,  "*",                              0, MANY, VARARGS,
X    P_Generic_Divide,    "/",                              1, MANY, VARARGS,
X    P_Abs,               "abs",                            1, 1,    EVAL,
X    P_Quotient,          "quotient",                       2, 2,    EVAL,
X    P_Remainder,         "remainder",                      2, 2,    EVAL,
X    P_Modulo,            "modulo",                         2, 2,    EVAL,
X    P_Gcd,               "gcd",                            0, MANY, VARARGS,
X    P_Lcm,               "lcm",                            0, MANY, VARARGS,
X    P_Floor,             "floor",                          1, 1,    EVAL,
X    P_Ceiling,           "ceiling",                        1, 1,    EVAL,
X    P_Truncate,          "truncate",                       1, 1,    EVAL,
X    P_Round,             "round",                          1, 1,    EVAL,
X    P_Sqrt,              "sqrt",                           1, 1,    EVAL,
X    P_Exp,               "exp",                            1, 1,    EVAL,
X    P_Log,               "log",                            1, 1,    EVAL,
X    P_Sin,               "sin",                            1, 1,    EVAL,
X    P_Cos,               "cos",                            1, 1,    EVAL,
X    P_Tan,               "tan",                            1, 1,    EVAL,
X    P_Asin,              "asin",                           1, 1,    EVAL,
X    P_Acos,              "acos",                           1, 1,    EVAL,
X    P_Atan,              "atan",                           1, 2,    VARARGS,
X    P_Min,               "min",                            1, MANY, VARARGS,
X    P_Max,               "max",                            1, MANY, VARARGS,
X    P_Random,            "random",                         0, 0,    EVAL,
X    P_Srandom,           "srandom",                        1, 1,    EVAL,
X
X    /* prim.c:
X     */
X
X    /* print.c:
X     */
X    P_Write,             "write",                          1, 2,    VARARGS,
X    P_Display,           "display",                        1, 2,    VARARGS,
X    P_Write_Char,        "write-char",                     1, 2,    VARARGS,
X    P_Newline,           "newline",                        0, 1,    VARARGS,
X    P_Print,             "print",                          1, 2,    VARARGS,
X    P_Clear_Output_Port, "clear-output-port",              0, 1,    VARARGS,
X    P_Flush_Output_Port, "flush-output-port",              0, 1,    VARARGS,
X    P_Get_Output_String, "get-output-string",              1, 1,    EVAL,
X    P_Format,            "format",                         2, MANY, VARARGS,
X
X    /* proc.c:
X     */
X    P_Procedurep,        "procedure?",                     1, 1,    EVAL,
X    P_Primitivep,        "primitive?",                     1, 1,    EVAL,
X    P_Compoundp,         "compound?",                      1, 1,    EVAL,
X    P_Macrop,            "macro?",                         1, 1,    EVAL,
X    P_Eval,              "eval",                           1, 2,    VARARGS,
X    P_Apply,             "apply",                          2, MANY, VARARGS,
X    P_Lambda,            "lambda",                         2, MANY, NOEVAL,
X    P_Procedure_Env,     "procedure-environment",          1, 1,    EVAL,
X    P_Procedure_Lambda,  "procedure-lambda",               1, 1,    EVAL,
X    P_Begin,             "begin",                          1, MANY, NOEVAL,
X    P_Begin1,            "begin1",                         1, MANY, NOEVAL,
X    P_Map,               "map",                            2, MANY, VARARGS,
X    P_For_Each,          "for-each",                       2, MANY, VARARGS,
X    P_Macro,             "macro",                          2, MANY, NOEVAL,
X    P_Macro_Body,        "macro-body",                     1, 1,    EVAL,
X    P_Macro_Expand,      "macro-expand",                   1, 1,    EVAL,
X
X    /* promise.c:
X     */
X    P_Delay,             "delay",                          1, 1,    NOEVAL,
X    P_Force,             "force",                          1, 1,    EVAL,
X    P_Promisep,          "promise?",                       1, 1,    EVAL,
X    P_Promise_Env,       "promise-environment",            1, 1,    EVAL,
X
X    /* read.c:
X     */
X    P_Exit,              "exit",                           0, 1,    VARARGS,
X    P_Clear_Input_Port,  "clear-input-port",               0, 1,    EVAL,
X    P_Read,              "read",                           0, 1,    VARARGS,
X    P_Read_Char,         "read-char",                      0, 1,    VARARGS,
X    P_Read_String,       "read-string",                    0, 1,    VARARGS,
X    P_Unread_Char,       "unread-char",                    1, 2,    VARARGS,
X
X    /* special.c:
X     */
X    P_Quote,             "quote",                          1, 1,    NOEVAL,
X    P_Quasiquote,        "quasiquote",                     1, 1,    NOEVAL,
X    P_If,                "if",                             2, MANY, NOEVAL,
X    P_Case,              "case",                           1, MANY, NOEVAL,
X    P_Cond,              "cond",                           1, MANY, NOEVAL,
X    P_Do,                "do",                             2, MANY, NOEVAL,
X    P_Let,               "let",                            2, MANY, NOEVAL,
X    P_Letseq,            "let*",                           2, MANY, NOEVAL,
X    P_Letrec,            "letrec",                         2, MANY, NOEVAL,
X    P_Fluid_Let,         "fluid-let",                      2, MANY, NOEVAL,
X    P_And,               "and",                            0, MANY, NOEVAL,
X    P_Or,                "or",                             0, MANY, NOEVAL,
X
X    /* string.c:
X     */
X    P_String,            "string",                         0, MANY, VARARGS,
X    P_Stringp,           "string?",                        1, 1,    EVAL,
X    P_Make_String,       "make-string",                    1, 2,    VARARGS,
X    P_String_Length,     "string-length",                  1, 1,    EVAL,
X    P_String_To_Number,  "string->number",                 1, 1,    EVAL,
X    P_String_Ref,        "string-ref",                     2, 2,    EVAL,
X    P_String_Set,        "string-set!",                    3, 3,    EVAL,
X    P_Substring,         "substring",                      3, 3,    EVAL,
X    P_String_Copy,       "string-copy",                    1, 1,    EVAL,
X    P_String_Append,     "string-append",                  0, MANY, VARARGS,
X    P_List_To_String,    "list->string",                   1, 1,    EVAL,
X    P_String_To_List,    "string->list",                   1, 1,    EVAL,
X    P_String_Fill,       "string-fill!",                   2, 2,    EVAL,
X    P_Substring_Fill,    "substring-fill!",                4, 4,    EVAL,
X    P_Str_Eq,            "string=?",                       2, 2,    EVAL,
X    P_Str_Less,          "string<?",                       2, 2,    EVAL,
X    P_Str_Greater,       "string>?",                       2, 2,    EVAL,
X    P_Str_Eq_Less,       "string<=?",                      2, 2,    EVAL,
X    P_Str_Eq_Greater,    "string>=?",                      2, 2,    EVAL,
X    P_Str_CI_Eq,         "string-ci=?",                    2, 2,    EVAL,
X    P_Str_CI_Less,       "string-ci<?",                    2, 2,    EVAL,
X    P_Str_CI_Greater,    "string-ci>?",                    2, 2,    EVAL,
X    P_Str_CI_Eq_Less,    "string-ci<=?",                   2, 2,    EVAL,
X    P_Str_CI_Eq_Greater, "string-ci>=?",                   2, 2,    EVAL,
X    P_Substringp,        "substring?",                     2, 2,    EVAL,
X    P_CI_Substringp,     "substring-ci?",                  2, 2,    EVAL,
X
X    /* symbol.c:
X     */
X    P_String_To_Symbol,  "string->symbol",                 1, 1,    EVAL,
X    P_Oblist,            "oblist",                         0, 0,    EVAL,
X    P_Symbolp,           "symbol?",                        1, 1,    EVAL,
X    P_Symbol_To_String,  "symbol->string",                 1, 1,    EVAL,
X    P_Put,               "put",                            2, 3,    VARARGS,
X    P_Get,               "get",                            2, 2,    EVAL,
X    P_Symbol_Plist,      "symbol-plist",                   1, 1,    EVAL,
X
X    /* type.c:
X     */
X    P_Type,              "type",                           1, 1,    EVAL,
X    P_Voidp,             "void?",                          1, 1,    EVAL,
X
X    /* vector.c:
X     */
X    P_Vectorp,           "vector?",                        1, 1,    EVAL,
X    P_Make_Vector,       "make-vector",                    1, 2,    VARARGS,
X    P_Vector,            "vector",                         0, MANY, VARARGS,
X    P_Vector_Length,     "vector-length",                  1, 1,    EVAL,
X    P_Vector_Ref,        "vector-ref",                     2, 2,    EVAL,
X    P_Vector_Set,        "vector-set!",                    3, 3,    EVAL,
X    P_Vector_To_List,    "vector->list",                   1, 1,    EVAL,
X    P_List_To_Vector,    "list->vector",                   1, 1,    EVAL,
X    P_Vector_Fill,       "vector-fill!",                   2, 2,    EVAL,
X    P_Vector_Copy,       "vector-copy",                    1, 1,    EVAL,
X
X    0
X};
X
X/* The C-compiler can't initialize unions, thus the primitive procedures
X * must be created during run-time (the problem actually is that one can't
X * provide an intializer for the "tag" component of an S_Primitive).
X */
X
XInit_Prim () {
X    register struct Prim_Init *p;
X    Object frame, prim, sym;
X
X    for (frame = Car (The_Environment), p = Primitives; p->fun; p++) {
X    prim = Make_Primitive (p->fun, p->name, p->minargs, p->maxargs,
X        p->disc);
X    sym = Intern (p->name);
X    frame = Add_Binding (frame, sym, prim);
X    }
X    Car (The_Environment) = frame;
X    Memoize_Frame (frame);
X}
X
XDefine_Primitive (fun, name, min, max, disc) Object (*fun)(); char *name;
X    enum discipline disc; {
X    Object prim, sym, frame;
X    GC_Node2;
X
X    Error_Tag = "define-primitive";
X    prim = Make_Primitive (fun, name, min, max, disc);
X    sym = Null;
X    GC_Link2 (prim, sym);
X    sym = Intern (name);
X    if (disc == EVAL && min != max)
X    Primitive_Error ("~s: number of arguments must be fixed", sym);
X    frame = Add_Binding (Car (The_Environment), sym, prim);
X    SYMBOL(sym)->value = prim;
X    Car (The_Environment) = frame;
X    GC_Unlink;
X}
END_OF_src/prim.c
if test 19818 -ne `wc -c <src/prim.c`; then
    echo shar: \"src/prim.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/stack.s.vax -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/stack.s.vax\"
else
echo shar: Extracting \"src/stack.s.vax\" \(954 characters\)
sed "s/^X//" >src/stack.s.vax <<'END_OF_src/stack.s.vax'
X    .text
X
X    .globl    _stkbase
X    .globl    _Special
X
X    .globl    _stksize
X    .align    2
X_stksize:
X    .word    0x0000
X    movl    _stkbase,r0
X    subl2    sp,r0
X    addl2    $120,r0
X    ret
X
X    .globl    _saveenv
X    .align    2
X_saveenv:
X    .word    0x0000        # don't save any regs
X    movl    4(ap),r0    # buffer        -> r0
X    movl    fp,4(r0)    # frame pointer -> r0[1]
X    movl    16(fp),8(r0)    # pc of caller  -> r0[2]
X    movl    sp,12(r0)    # sp            -> r0[3]
X
X    movl    sp,r2        # set up loop
X    movl    _stkbase,r3
X    movl    r0,r4
X    addl2    $110,r4
Xrep1:
X    movl    (r2)+,(r4)+    # should use movc3
X    cmpl    r2,r3
X    blss    rep1
X
X    movl    r4,r3        # new-old -> r0[0]  (``relocation'')
X    subl2    r2,r3
X    movl    r3,(r0)
X
X    movl    _Special,r0
X    ret
X
X    .globl    _jmpenv
X    .align    2
X_jmpenv:
X    .word    0x0000
X    movl    8(ap),r0    # return value
X    movl    4(ap),r1    # buffer
X
X    movl    12(r1),sp    # restore sp
X    movl    sp,r2        # set up loop
X    movl    _stkbase,r3
X    movl    r1,r4
X    addl2    $110,r4
Xrep2:
X    movl    (r4)+,(r2)+    # should use movc3
X    cmpl    r2,r3
X    blss    rep2
X
X    movl    4(r1),fp    # restore fp
X    ret            # return from _saveenv
END_OF_src/stack.s.vax
if test 954 -ne `wc -c <src/stack.s.vax`; then
    echo shar: \"src/stack.s.vax\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d scm ; then
    echo shar: Creating directory \"scm\"
    mkdir scm
fi
echo shar: End of archive 4 \(of 14\).
cp /dev/null ark4isdone
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