allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) (09/24/89)
Posting-number: Volume 8, Issue 52
Submitted-by: net@tub.UUCP (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