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

Text File | 1989-09-23 | 57.8 KB | 2,376 lines

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

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

[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 5 (of 14)."
# Contents:  src/string.c src/vector.c src/cont.c src/print.c
#   src/read.c src/io.c src/load.c src/auto.c src/alloca.s.vax
# Wrapped by net@tub on Sun Sep 17 17:32:24 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f src/string.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/string.c\"
else
echo shar: Extracting \"src/string.c\" \(6826 characters\)
sed "s/^X//" >src/string.c <<'END_OF_src/string.c'
X/* Strings
X */
X
X#include <ctype.h>
X
X#include "scheme.h"
X
Xchar Char_Map[256];
X
XInit_String () {
X    register i;
X
X    for (i = 0; i < 256; i++)
X    Char_Map[i] = i;
X    for (i = 'A'; i <= 'Z'; i++)
X    Char_Map[i] = tolower (i);
X}
X
XObject Make_String (s, len) char *s; {
X    Object str;
X    register char *p;
X
X    p = Get_Bytes (len + sizeof (struct S_String) - 1);
X    SET(str, T_String, (struct S_String *)p);
X    STRING(str)->tag = Null;
X    STRING(str)->size = len;
X    if (s)
X    bcopy (s, STRING(str)->data, len);
X    return str;
X}
X
XObject P_Stringp (s) Object s; {
X    return TYPE(s) == T_String ? True : False;
X}
X
XObject P_Make_String (argc, argv) Object *argv; {
X    register len, c = ' ';
X    Object str;
X    register char *p;
X
X    if ((len = Get_Integer (argv[0])) < 0)
X    Range_Error (argv[0]);
X    if (argc == 2) {
X    Check_Type (argv[1], T_Character);
X    c = CHAR(argv[1]);
X    }
X    str = Make_String ((char *)0, len);
X    for (p = STRING(str)->data; len; len--) *p++ = c;
X    return str;
X}
X
XObject P_String (argc, argv) Object *argv; {
X    Object str;
X    register i;
X
X    str = Make_String ((char *)0, argc);
X    for (i = 0; i < argc; i++) {
X    Check_Type (argv[i], T_Character);
X    STRING(str)->data[i] = CHAR(argv[i]);
X    }
X    return str;
X}
X
XObject P_String_To_Number (s) Object s; {
X    Object ret;
X    register char *b;
X    register struct S_String *p;
X
X    Check_Type (s, T_String);
X    p = STRING(s);
X    if (stksize () + p->size > maxstack) goto err;
X    b = alloca (p->size+1);
X    bcopy (p->data, b, p->size);
X    b[p->size] = '\0';
X    ret = Read_Number_Maybe (b);
X    if (Nullp (ret))
Xerr:
X    Primitive_Error ("argument does not represent a number");
X    return ret;
X}
X
XObject P_String_Length (s) Object s; {
X    Check_Type (s, T_String);
X    return Make_Integer (STRING(s)->size);
X}
X
XObject P_String_Ref (s, n) Object s, n; {
X    Check_Type (s, T_String);
X    return Make_Char (STRING(s)->data[Get_Index (n, s)]);
X}
X
XObject P_String_Set (s, n, new) Object s, n, new; {
X    register i, old;
X
X    Check_Type (s, T_String);
X    Check_Type (new, T_Character);
X    old = STRING(s)->data[i = Get_Index (n, s)];
X    STRING(s)->data[i] = CHAR(new);
X    return Make_Char (old);
X}
X
XObject P_Substring (s, a, b) Object s, a, b; {
X    register i, j;
X
X    Check_Type (s, T_String);
X    if ((i = Get_Integer (a)) < 0 || i > STRING(s)->size)
X    Range_Error (a);
X    if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
X    Range_Error (b);
X    if (i > j)
X    Primitive_Error ("`end' less than `start'");
X    return Make_String (&STRING(s)->data[i], j-i);
X}
X
XObject P_String_Copy (s) Object s; {
X    Check_Type (s, T_String);
X    return Make_String (STRING(s)->data, STRING(s)->size);
X}
X
XObject P_String_Append (argc, argv) Object *argv; {
X    register i, len;
X    Object s, str;
X
X    for (len = i = 0; i < argc; i++) {
X    Check_Type (argv[i], T_String);
X    len += STRING(argv[i])->size;
X    }
X    str = Make_String ((char *)0, len);
X    for (len = i = 0; i < argc; i++) {
X    s = argv[i];
X    bcopy (STRING(s)->data, &STRING(str)->data[len], STRING(s)->size);
X    len += STRING(s)->size;
X    }
X    return str;
X}
X
XObject P_List_To_String (list) Object list; {
X    Object str, len;
X    register i;
X    GC_Node;
X
X    GC_Link (list);
X    len = P_Length (list);
X    str = Make_String ((char *)0, FIXNUM(len));
X    for (i = 0; i < FIXNUM(len); i++, list = Cdr (list)) {
X    Check_Type (Car (list), T_Character);
X    STRING(str)->data[i] = CHAR(Car (list));
X    }
X    GC_Unlink;
X    return str;
X}
X
XObject P_String_To_List (s) Object s; {
X    register i;
X    Object list, tail, cell;
X    GC_Node3;
X
X    Check_Type (s, T_String);
X    list = tail = Null;
X    GC_Link3 (s, list, tail);
X    for (i = 0; i < STRING(s)->size; i++, tail = cell) {
X    cell = Cons (Make_Char (STRING(s)->data[i]), 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_Substring_Fill (s, a, b, c) Object s, a, b, c; {
X    register i, j;
X
X    Check_Type (s, T_String);
X    Check_Type (c, T_Character);
X    i = Get_Index (a, s);
X    if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
X    Range_Error (b);
X    if (i > j)
X    Primitive_Error ("`end' less than `start'");
X    while (i < j)
X    STRING(s)->data[i++] = CHAR(c);
X    return s;
X}
X
XObject P_String_Fill (s, c) Object s, c; {
X    Object ret;
X    GC_Node2;
X
X    GC_Link2 (s, c);
X    Check_Type (s, T_String);
X    ret = P_Substring_Fill (s, Make_Integer (0),
X    Make_Integer (STRING(s)->size), c);
X    GC_Unlink;
X    return ret;
X}
X
XObject General_Substringp (s1, s2, ci) Object s1, s2; register ci; {
X    register n, l1, l2;
X    register char *p1, *p2, *p3, *map;
X
X    Check_Type (s1, T_String);
X    Check_Type (s2, T_String);
X    l1 = STRING(s1)->size;
X    l2 = STRING(s2)->size;
X    map = Char_Map;
X    for (p2 = STRING(s2)->data; l2 >= l1; p2++, l2--) {
X    for (p1 = STRING(s1)->data, p3 = p2, n = l1; n; n--, p1++, p3++) {
X        if (ci) {
X        if (map[*p1] != map[*p3]) goto fail;
X        } else
X        if (*p1 != *p3) goto fail;
X    }
X    return Make_Integer (STRING(s2)->size - l2);
Xfail:   ;
X    }
X    return False;
X}
X
XObject P_Substringp (s1, s2) Object s1, s2; {
X    return General_Substringp (s1, s2, 0);
X}
X
XObject P_CI_Substringp (s1, s2) Object s1, s2; {
X    return General_Substringp (s1, s2, 1);
X}
X
XGeneral_Strcmp (s1, s2, ci) Object s1, s2; register ci; {
X    register n, l1, l2;
X    register char *p1, *p2, *map;
X
X    Check_Type (s1, T_String);
X    Check_Type (s2, T_String);
X    l1 = STRING(s1)->size; l2 = STRING(s2)->size;
X    n = l1 > l2 ? l2 : l1;
X    p1 = STRING(s1)->data; p2 = STRING(s2)->data;
X    for (map = Char_Map; --n >= 0; p1++, p2++) {
X    if (ci) {
X        if (map[*p1] != map[*p2]) break;
X    } else
X        if (*p1 != *p2) break;
X    }
X    if (n < 0)
X    return l1 - l2;
X    return *p1 - *p2;
X}
X
XObject P_Str_Eq (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 0) ? False : True;
X}
X
XObject P_Str_Less (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 0) < 0 ? True : False;
X}
X
XObject P_Str_Greater (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 0) > 0 ? True : False;
X}
X
XObject P_Str_Eq_Less (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 0) <= 0 ? True : False;
X}
X
XObject P_Str_Eq_Greater (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 0) >= 0 ? True : False;
X}
X
XObject P_Str_CI_Eq (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 1) ? False : True;
X}
X
XObject P_Str_CI_Less (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 1) < 0 ? True : False;
X}
X
XObject P_Str_CI_Greater (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 1) > 0 ? True : False;
X}
X
XObject P_Str_CI_Eq_Less (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 1) <= 0 ? True : False;
X}
X
XObject P_Str_CI_Eq_Greater (s1, s2) Object s1, s2; {
X    return General_Strcmp (s1, s2, 1) >= 0 ? True : False;
X}
END_OF_src/string.c
if test 6826 -ne `wc -c <src/string.c`; then
    echo shar: \"src/string.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/vector.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/vector.c\"
else
echo shar: Extracting \"src/vector.c\" \(2773 characters\)
sed "s/^X//" >src/vector.c <<'END_OF_src/vector.c'
X/* Vectors
X */
X
X#include "scheme.h"
X
XObject Make_Vector (len, fill) Object fill; {
X    Object vec;
X    register char *p;
X    register Object *op;
X    GC_Node;
X
X    GC_Link (fill);
X    p = Get_Bytes ((len-1) * sizeof (Object) + sizeof (struct S_Vector));
X    SET(vec, T_Vector, (struct S_Vector *)p);
X    VECTOR(vec)->tag = Null;
X    VECTOR(vec)->size = len;
X    for (op = VECTOR(vec)->data; len--; op++)
X    *op = fill;
X    GC_Unlink;
X    return vec;
X}
X
XObject P_Make_Vector (argc, argv) Object *argv; {
X    register len;
X
X    if ((len = Get_Integer (argv[0])) < 0)
X    Range_Error (argv[0]);
X    return Make_Vector (len, argc == 1 ? Null : argv[1]);
X}
X
XObject P_Vector (argc, argv) Object *argv; {
X    Object vec;
X    register i;
X
X    vec = Make_Vector (argc, Null);
X    for (i = 0; i < argc; i++)
X    VECTOR(vec)->data[i] = *argv++;
X    return vec;
X}
X
XObject P_Vectorp (x) Object x; {
X    return TYPE(x) == T_Vector ? True : False;
X}
X
XObject P_Vector_Length (x) Object x; {
X    Check_Type (x, T_Vector);
X    return Make_Integer (VECTOR(x)->size);
X}
X
XObject P_Vector_Ref (vec, n) Object vec, n; {
X    Check_Type (vec, T_Vector);
X    return VECTOR(vec)->data[Get_Index (n, vec)];
X}
X
XObject P_Vector_Set (vec, n, new) Object vec, n, new; {
X    Object old;
X    register i;
X
X    Check_Type (vec, T_Vector);
X    old = VECTOR(vec)->data[i = Get_Index (n, vec)];
X    VECTOR(vec)->data[i] = new;
X    return old;
X}
X
X/* We cannot simply call P_List with vec->size and vec->data here,
X * because the latter can change during GC.  (Bletch!)
X */
XObject P_Vector_To_List (vec) Object vec; {
X    register i;
X    Object list, tail, cell;
X    GC_Node3;
X
X    Check_Type (vec, T_Vector);
X    list = tail = Null;
X    GC_Link3 (vec, list, tail);
X    for (i = 0; i < VECTOR(vec)->size; i++, tail = cell) {
X    cell = Cons (VECTOR(vec)->data[i], 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_List_To_Vector (list) Object list; {
X    Object vec, len;
X    register i;
X    GC_Node;
X
X    GC_Link (list);
X    len = P_Length (list);
X    vec = Make_Vector (FIXNUM(len), Null);
X    for (i = 0; i < FIXNUM(len); i++, list = Cdr (list))
X    VECTOR(vec)->data[i] = Car (list);
X    GC_Unlink;
X    return vec;
X}
X
XObject P_Vector_Fill (vec, fill) Object vec, fill; {
X    register i;
X
X    Check_Type (vec, T_Vector);
X    for (i = 0; i < VECTOR(vec)->size; i++)
X    VECTOR(vec)->data[i] = fill;
X    return vec;
X}
X
XObject P_Vector_Copy (vec) Object vec; {
X    Object new;
X    GC_Node;
X
X    Check_Type (vec, T_Vector);
X    GC_Link (vec);
X    new = Make_Vector (VECTOR(vec)->size, Null);
X    bcopy ((char *)POINTER(vec), (char *)POINTER(new),
X    (VECTOR(vec)->size-1) * sizeof (Object) + sizeof (struct S_Vector));
X    GC_Unlink;
X    return new;
X}
END_OF_src/vector.c
if test 2773 -ne `wc -c <src/vector.c`; then
    echo shar: \"src/vector.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/cont.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/cont.c\"
else
echo shar: Extracting \"src/cont.c\" \(3090 characters\)
sed "s/^X//" >src/cont.c <<'END_OF_src/cont.c'
X/* Control points, call-with-current-continuation, dynamic-wind
X */
X
X#include <signal.h>
X
X#include "scheme.h"
X
XWIND *First_Wind, *Last_Wind;
X
XObject P_Control_Pointp (x) Object x; {
X    return TYPE(x) == T_Control_Point ? True : False;
X}
X
XObject Make_Control_Point (size) {
X    Object control;
X    register struct S_Control *cp;
X    register char *p;
X
X    p = Get_Bytes (size + sizeof (struct S_Control) - 1);
X    cp = (struct S_Control *)p;
X    SET(control, T_Control_Point, cp);
X    cp->env = The_Environment;
X    cp->gclist = GC_List;
X    cp->firstwind = First_Wind;
X    cp->lastwind = Last_Wind;
X    cp->tailcall = Tail_Call;
X    cp->size = size;
X    return control;
X}
X
XObject P_Call_CC (proc) Object proc; {
X    int size;
X    Object control, ret;
X    GC_Node;
X
X    Check_Procedure (proc);
X    GC_Link (proc);
X    size = stksize ();
X    control = Make_Control_Point (size);
X    SETFAST(ret,saveenv (CONTROL(control)->stack));
X    if (TYPE(ret) != T_Special) {
X    Enable_Interrupts;
X    return ret;
X    }
X    control = Cons (control, Null);
X    ret = Funcall (proc, control, 0);
X    GC_Unlink;
X    return ret;
X}
X
XFuncall_Control_Point (control, argl, eval) Object control, argl; {
X    Object val, len;
X    register struct S_Control *cp;
X    register WIND *wp, *p;
X    register delta;
X    GC_Node3;
X
X    val = Null;
X    GC_Link3 (argl, control, val);
X    len = P_Length (argl);
X    if (FIXNUM(len) != 1)
X    Primitive_Error ("control point expects one argument");
X    val = Car (argl);
X    if (eval)
X    val = Eval (val);
X    for (wp = Last_Wind; wp; wp = wp->prev)
X    Do_Wind (wp->out);
X    delta = *(int *)(CONTROL(control)->stack);
X    for (wp = CONTROL(control)->firstwind; wp; wp = p->next) {
X    p = (WIND *)NORM(wp);
X    Do_Wind (p->in);
X    }
X    GC_Unlink;
X    cp = CONTROL(control);
X    Switch_Environment (cp->env);
X    GC_List = cp->gclist;
X    First_Wind = cp->firstwind;
X    Last_Wind = cp->lastwind;
X    Tail_Call = cp->tailcall;
X    jmpenv (cp->stack, val);
X    /*NOTREACHED*/
X}
X
XDo_Wind (w) Object w; {
X    Object b, sym, val;
X
X    if (TYPE(w) == T_Pair) {
X    b = Lookup_Symbol (Car (w), 0);
X    if (Nullp (b))
X        Panic ("fluid-let2");
X    sym = Car (b);
X    val = Cdr (w);
X    Cdr (b) = val;
X    SYMBOL(sym)->value = val;
X    } else {
X    (void)Funcall (w, Null, 0);
X    }
X}
X
XAdd_Wind (w, in, out) register WIND *w; Object in, out; {
X    w->in = in;
X    w->out = out;
X    w->next = 0;
X    if (First_Wind == 0)
X    First_Wind = w;
X    else
X    Last_Wind->next = w;
X    w->prev = Last_Wind;
X    Last_Wind = w;
X}
X
XObject P_Dynamic_Wind (in, body, out) Object in, body, out; {
X    WIND w, *first = First_Wind;
X    Object ret;
X    GC_Node3;
X
X    Check_Procedure (in);
X    Check_Procedure (body);
X    Check_Procedure (out);
X    ret = Null;
X    GC_Link3 (body, out, ret);
X    Add_Wind (&w, in, out);
X    (void)Funcall (in, Null, 0);
X    ret = Funcall (body, Null, 0);
X    (void)Funcall (out, Null, 0);
X    if (Last_Wind = w.prev)
X    Last_Wind->next = 0;
X    First_Wind = first;
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Control_Point_Env (c) Object c; {
X    Check_Type (c, T_Control_Point);
X    return CONTROL(c)->env;
X}
END_OF_src/cont.c
if test 3090 -ne `wc -c <src/cont.c`; then
    echo shar: \"src/cont.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/print.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/print.c\"
else
echo shar: Extracting \"src/print.c\" \(12446 characters\)
sed "s/^X//" >src/print.c <<'END_OF_src/print.c'
X/* Output functions
X */
X
X#include <ctype.h>
X#include <varargs.h>
X#include <sys/ioctl.h>
X
X#include "scheme.h"
X
Xint Saved_Errno;
X
Xstatic Object V_Print_Depth, V_Print_Length;
X
XInit_Print () {
X    Define_Variable (&V_Print_Depth, "print-depth",
X    Make_Fixnum (DEF_PRINT_DEPTH));
X    Define_Variable (&V_Print_Length, "print-length",
X    Make_Fixnum (DEF_PRINT_LEN));
X}
X
XPrint_Length () {
X    Object pl;
X
X    pl = Val (V_Print_Length);
X    return TYPE(pl) == T_Fixnum ? FIXNUM(pl) : DEF_PRINT_LEN;
X}
X
XPrint_Depth () {
X    Object pd;
X
X    pd = Val (V_Print_Depth);
X    return TYPE(pd) == T_Fixnum ? FIXNUM(pd) : DEF_PRINT_DEPTH;
X}
X
XPrint_Char (port, c) Object port; register c; {
X    char buf[1];
X
X    if (PORT(port)->flags & P_STRING) {
X    buf[0] = c;
X    Print_String (port, buf, 1);
X    } else {
X    if (putc (c, PORT(port)->file) == EOF)  {
X        Saved_Errno = errno;   /* errno valid here? */
X        Primitive_Error ("write error on ~s: ~E", port);
X    }
X    }
X}
X
XPrint_String (port, buf, len) Object port; register char *buf; register len; {
X    register n;
X    register struct S_Port *p;
X    Object new;
X    GC_Node;
X
X    p = PORT(port);
X    n = STRING(p->name)->size - p->ptr;
X    if (n < len) {
X    GC_Link (port);
X    n = len - n;
X    if (n < STRING_GROW_SIZE)
X        n = STRING_GROW_SIZE;
X    new = Make_String ((char *)0, STRING(p->name)->size + n);
X    p = PORT(port);
X    GC_Unlink;
X    bcopy (STRING(p->name)->data, STRING(new)->data, p->ptr);
X    p->name = new;
X    }
X    bcopy (buf, STRING(p->name)->data + p->ptr, len);
X    p->ptr += len;
X}
X
X#ifndef VPRINTF
Xvfprintf (f, fmt, ap) register FILE *f; register char *fmt; va_list ap; {
X    _doprnt (fmt, ap, f);
X}
X
Xvsprintf (s, fmt, ap) register char *s, *fmt; va_list ap; {
X    FILE x;
X    x._flag = _IOWRT|_IOSTRG;
X    x._ptr = s;
X    x._cnt = 1024;
X    _doprnt (fmt, ap, &x);
X    putc ('\0', &x);
X}
X#endif
X
X/*VARARGS0*/
XPrintf (va_alist) va_dcl {
X    va_list args;
X    Object port;
X    char *fmt;
X    char buf[1024];
X
X    va_start (args);
X    port = va_arg (args, Object);
X    fmt = va_arg (args, char *);
X    if (PORT(port)->flags & P_STRING) {
X    vsprintf (buf, fmt, args);
X    Print_String (port, buf, strlen (buf));
X    } else {
X    vfprintf (PORT(port)->file, fmt, args);
X    if (ferror (PORT(port)->file)) {
X        Saved_Errno = errno;   /* errno valid here? */
X        Primitive_Error ("write error on ~s: ~E", port);
X    }
X    }
X    va_end (args);
X}
X
XObject General_Print (argc, argv, raw) Object *argv; {
X    General_Print_Object (argv[0], argc == 2 ? argv[1] : Curr_Output_Port, raw);
X    return Void;
X}
X
XObject P_Write (argc, argv) Object *argv; {
X    return General_Print (argc, argv, 0);
X}
X
XObject P_Display (argc, argv) Object *argv; {
X    return General_Print (argc, argv, 1);
X}
X
XObject P_Write_Char (argc, argv) Object *argv; {
X    Check_Type (argv[0], T_Character);
X    return General_Print (argc, argv, 1);
X}
X
X/*VARARGS1*/
XObject P_Newline (argc, argv) Object *argv; {
X    General_Print_Object (Newline, argc == 1 ? argv[0] : Curr_Output_Port, 1);
X    return Void;
X}
X
XObject P_Print (argc, argv) Object *argv; {
X    Object port;
X    GC_Node;
X
X    port = argc == 2 ? argv[1] : Curr_Output_Port;
X    GC_Link (port);
X    General_Print_Object (argv[0], port, 0);
X    Print_Char (port, '\n');
X    Flush_Output (port);
X    GC_Unlink;
X    return Void;
X}
X
XObject P_Clear_Output_Port (argc, argv) Object *argv; {
X    Discard_Output (argc == 1 ? argv[0] : Curr_Output_Port);
X    return Void;
X}
X
XDiscard_Output (port) Object port; {
X    register FILE *f;
X
X    Check_Output_Port (port);
X    if (PORT(port)->flags & P_STRING)
X    return;
X    f = PORT(port)->file;
X    f->_cnt = 0;
X    f->_ptr = f->_base;
X#ifdef TIOCFLUSH
X    (void)ioctl (fileno (f), TIOCFLUSH, (char *)0);
X#endif
X}
X
XObject P_Flush_Output_Port (argc, argv) Object *argv; {
X    Flush_Output (argc == 1 ? argv[0] : Curr_Output_Port);
X    return Void;
X}
X
XFlush_Output (port) Object port; {
X    Check_Output_Port (port);
X    if (PORT(port)->flags & P_STRING)
X    return;
X    if (fflush (PORT(port)->file) == EOF) {
X    Saved_Errno = errno;   /* errno valid here? */
X    Primitive_Error ("write error on ~s: ~E", port);
X    }
X}
X
XObject P_Get_Output_String (port) Object port; {
X    register struct S_Port *p;
X    Object str;
X    GC_Node;
X
X    Check_Output_Port (port);
X    GC_Link (port);
X    str = Make_String ((char *)0, PORT(port)->ptr);
X    p = PORT(port);
X    bcopy (STRING(p->name)->data, STRING(str)->data, p->ptr);
X    p->ptr = 0;
X    GC_Unlink;
X    return str;
X}
X
XCheck_Output_Port (port) Object port; {
X    Check_Type (port, T_Port);
X    if (!(PORT(port)->flags & P_OPEN))
X    Primitive_Error ("port has been closed: ~s", port);
X    if (PORT(port)->flags & P_INPUT)
X    Primitive_Error ("not an output port: ~s", port);
X}
X
XGeneral_Print_Object (x, port, raw) Object x, port; {
X    Check_Output_Port (port);
X    Print_Object (x, port, raw, Print_Depth (), Print_Length ());
X}
X
XPrint_Object (x, port, raw, depth, length) Object x, port;
X    register raw, depth, length; {
X    register t, c, str;
X    GC_Node2;
X
X    GC_Link2 (port, x);
X    t = TYPE(x);
X    switch (t) {
X    case T_Null:
X    Printf (port, "()");
X    break;
X    case T_Fixnum:
X    Printf (port, "%d", FIXNUM(x));
X    break;
X    case T_Bignum:
X    Print_Bignum (port, x);
X    break;
X    case T_Flonum:
X    Printf (port, "%.15g", FLONUM(x)->val);
X    break;
X    case T_Boolean:
X    Printf (port, "#%c", FIXNUM(x) ? 't' : 'f');
X    break;
X    case T_Void:
X    break;
X    case T_Unbound:
X    Printf (port, "#[unbound]");
X    break;
X    case T_Special:
X    Printf (port, "#[special]");
X    break;
X    case T_Character:
X    c = CHAR(x);
X    if (raw)
X        Print_Char (port, c);
X    else
X        Pr_Char (port, c);
X    break;
X    case T_Symbol:
X    Pr_String (port, SYMBOL(x)->name, 1);
X    break;
X    case T_Pair:
X    Pr_List (port, x, raw, depth, length);
X    break;
X    case T_Environment:
X    Printf (port, "#[environment %u]", POINTER(x));
X    break;
X    case T_String:
X    Pr_String (port, x, raw);
X    break;
X    case T_Vector:
X    Pr_Vector (port, x, raw, depth, length);
X    break;
X    case T_Primitive:
X    Printf (port, "#[primitive %s]", PRIM(x)->name);
X    break;
X    case T_Compound:
X    if (Nullp (COMPOUND(x)->name)) {
X        Printf (port, "#[compound %u]", POINTER(x));
X    } else {
X        Printf (port, "#[compound ");
X        Print_Object (COMPOUND(x)->name, port, raw, depth, length);
X        Print_Char (port, ']');
X    }
X    break;
X    case T_Control_Point:
X    Printf (port, "#[control-point %u]", POINTER(x));
X    break;
X    case T_Promise:
X    Printf (port, "#[promise %u]", POINTER(x));
X    break;
X    case T_Port:
X    str = PORT(x)->flags & P_STRING;
X    Printf (port, "#[%s-%sput-port ", str ? "string" : "file",
X        (PORT(x)->flags & P_INPUT) ? "in" : "out");
X    if (str)
X        Printf (port, "%u", POINTER(x));
X    else
X        Pr_String (port, PORT(x)->name, 0);
X    Print_Char (port, ']');
X    break;
X    case T_End_Of_File:
X    Printf (port, "#[end-of-file]");
X    break;
X    case T_Autoload:
X    Printf (port, "#[autoload ");
X    Print_Object (AUTOLOAD(x)->file, port, raw, depth, length);
X    Print_Char (port, ']');
X    break;
X    case T_Macro:
X    if (Nullp (MACRO(x)->name)) {
X        Printf (port, "#[macro %u]", POINTER(x));
X    } else {
X        Printf (port, "#[macro ");
X        Print_Object (MACRO(x)->name, port, raw, depth, length);
X        Print_Char (port, ']');
X    }
X    break;
X    case T_Broken_Heart:
X    Printf (port, "!!broken-heart!!");
X    break;
X    default:
X    if (t < 0 || t >= MAX_TYPE || !Types[t].name)
X        Panic ("bad type in print");
X    (*Types[t].print)(x, port, raw, depth, length);
X    }
X    GC_Unlink;
X}
X
XPr_Char (port, c) Object port; register c; {
X    register char *p = 0;
X
X    switch (c) {
X    case ' ':
X    p = "#\\space";
X    break;
X    case '\t':
X    p = "#\\tab";
X    break;
X    case '\n':
X    p = "#\\newline";
X    break;
X    case '\r':
X    p = "#\\return";
X    break;
X    case '\f':
X    p = "#\\formfeed";
X    break;
X    case '\b':
X    p = "#\\backspace";
X    break;
X    default:
X    if (c > ' ' && c < '\177')
X        Printf (port, "#\\%c", c);
X    else
X        Printf (port, "#\\%03o", (unsigned char)c);
X    }
X    if (p) Printf (port, p);
X}
X
XPr_List (port, list, raw, depth, length) Object port, list;
X    register raw, depth, length; {
X    Object tail;
X    register len;
X    register char *s = 0;
X    GC_Node2;
X
X    if (depth <= 0) {
X    Printf (port, "&");
X    return;
X    }
X    GC_Link2 (port, list);
X    if (!Nullp (list) && ((tail = Cdr (list)), TYPE(tail) == T_Pair)
X              && ((tail = Cdr (tail)), Nullp (tail))) {
X    tail = Car (list);
X    if (EQ(tail, Sym_Quote))
X        s = "'";
X    else if (EQ(tail, Sym_Quasiquote))
X        s = "`";
X    else if (EQ(tail, Sym_Unquote))
X        s = ",";
X    else if (EQ(tail, Sym_Unquote_Splicing))
X        s = ",@";
X    if (s) {
X        Printf (port, s);
X        Print_Object (Car (Cdr (list)), port, raw, depth-1, length);
X        GC_Unlink;
X        return;
X    }
X    }
X    Print_Char (port, '(');
X    for (len = 0; !Nullp (list); len++, list = tail) {
X    if (len >= length) {
X        Printf (port, "...");
X        break;
X    }
X    Print_Object (Car (list), port, raw, depth-1, length);
X    tail = Cdr (list);
X    if (!Nullp (tail)) {
X        if (TYPE(tail) == T_Pair)
X        Print_Char (port, ' ');
X        else {
X        Printf (port, " . ");
X        Print_Object (tail, port, raw, depth-1, length);
X        break;
X        }
X    }
X    }
X    Print_Char (port, ')');
X    GC_Unlink;
X}
X
XPr_Vector (port, vec, raw, depth, length) Object port, vec;
X    register raw, depth, length; {
X    register i, j;
X    GC_Node2;
X
X    if (depth <= 0) {
X    Printf (port, "&");
X    return;
X    }
X    GC_Link2 (port, vec);
X    Printf (port, "#(");
X    for (i = 0, j = VECTOR(vec)->size; i < j; i++) {
X    if (i) Print_Char (port, ' ');
X    if (i >= length) {
X        Printf (port, "...");
X        break;
X    }
X    Print_Object (VECTOR(vec)->data[i], port, raw, depth-1, length);
X    }
X    Print_Char (port, ')');
X    GC_Unlink;
X}
X
XPr_String (port, str, raw) Object port, str; {
X    register char *p = STRING(str)->data;
X    register c, i, len = STRING(str)->size;
X    GC_Node2;
X
X    if (raw) {
X    if (PORT(port)->flags & P_STRING) {
X        Print_String (port, p, len);
X    } else {
X        if (fwrite (p, 1, len, PORT(port)->file) < len) {
X        Saved_Errno = errno;   /* errno valid here? */
X        Primitive_Error ("write error on ~s: ~E", port);
X        }
X    }
X    return;
X    }
X    GC_Link2 (port, str);
X    Print_Char (port, '"');
X    for (i = 0; i < STRING(str)->size; i++) {
X    c = STRING(str)->data[i];
X    if (c == '\\' || c == '"')
X        Print_Char (port, '\\');
X    if (c < ' ' || c >= '\177')
X        Print_Special (port, c);
X    else
X    Print_Char (port, c);
X    }
X    Print_Char (port, '"');
X    GC_Unlink;
X}
X
XPrint_Special (port, c) Object port; register c; {
X    register char *fmt = "\\%c";
X
X    switch (c) {
X    case '\b': c = 'b'; break;
X    case '\t': c = 't'; break;
X    case '\r': c = 'r'; break;
X    case '\n': c = 'n'; break;
X    default:
X    fmt = "\\%03o";
X    }
X    Printf (port, fmt, (unsigned char)c);
X}
X
XObject P_Format (argc, argv) Object *argv; {
X    Object port, str;
X    register stringret = 0;
X    GC_Node;
X
X    port = argv[0];
X    if (TYPE(port) == T_Boolean) {
X    if (Truep (port)) {
X        port = Curr_Output_Port;
X    } else {
X        stringret++;
X        port = P_Open_Output_String ();
X    }
X    } else if (TYPE(port) == T_Port) {
X    Check_Output_Port (port);
X    } else Wrong_Type_Combination (port, "port or #t or #f");
X    str = argv[1];
X    Check_Type (str, T_String);
X    GC_Link (port);
X    Format (port, STRING(str)->data, STRING(str)->size, argc-2, argv+2);
X    GC_Unlink;
X    return stringret ? P_Get_Output_String (port) : Void;
X}
X
XFormat (port, p, len, argc, argv) Object port; register char *p;
X    register len; Object *argv; {
X    register char *s, *ep;
X    register c;
X    char buf[256];
X    extern sys_nerr;
X    extern char *sys_errlist[];
X    GC_Node;
X
X    GC_Link (port);
X    for (ep = p + len; p < ep; p++) {
X    if (*p == '~') {
X        if (++p == ep) break;
X        if ((c = *p) == '~') {
X        Print_Char (port, c);
X        } else if (c == '%') {
X        Print_Char (port, '\n');
X        } else if (c == 'e' || c == 'E') {
X        if (Saved_Errno > 0 && Saved_Errno < sys_nerr) {
X            s = sys_errlist[Saved_Errno];
X            sprintf (buf, "%c%s", isupper (*s) ? tolower (*s) :
X            *s, s+1);
X        } else {
X            sprintf (buf, "error %d", Saved_Errno);
X        }
X        Print_Object (Make_String (buf, strlen (buf)), port,
X            c == 'E', 0, 0);
X        } else {
X        if (--argc < 0)
X            Primitive_Error ("too few arguments");
X        if (c == 's' || c == 'a') {
X            Print_Object (*argv, port, c == 'a', Print_Depth (),
X            Print_Length ());
X            argv++;
X        } else if (c == 'c') {
X            Check_Type (*argv, T_Character);
X            Print_Char (port, CHAR(*argv));
X            argv++;
X        } else Print_Char (port, c);
X        }
X    } else {
X        Print_Char (port, *p);
X    }
X    }
X    GC_Unlink;
X}
END_OF_src/print.c
if test 12446 -ne `wc -c <src/print.c`; then
    echo shar: \"src/print.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/read.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/read.c\"
else
echo shar: Extracting \"src/read.c\" \(12649 characters\)
sed "s/^X//" >src/read.c <<'END_OF_src/read.c'
X/* Input Functions
X */
X
X#include <ctype.h>
X#include <math.h>       /* atof */
X#include <signal.h>
X
X#include "scheme.h"
X
X#ifdef TERMIO
X#  include <termio.h>
X#else
X#  include <sys/ioctl.h>
X#endif
X
Xextern char *index();
X
XObject Sym_Quote,
X       Sym_Quasiquote,
X       Sym_Unquote,
X       Sym_Unquote_Splicing;
X
Xstatic FILE *Last_File;
X
X#define GETC    (str ? String_Getc (port) : getc (f))
X#define UNGETC  {if (str) String_Ungetc (port,c); else (void)ungetc (c,f);}
X
X#define Tweak_Stream(f) {if (!str && (feof (f) || ferror (f))) clearerr (f);}
X
X#define Octal(c) ((c) >= '0' && (c) <= '7')
X
XObject General_Read(), Read_Sequence(), Read_Atom(), Read_Special();
XObject Read_String(), Read_Sharp();
X
XInit_Read () {
X    Define_Symbol (&Sym_Quote, "quote");
X    Define_Symbol (&Sym_Quasiquote, "quasiquote");
X    Define_Symbol (&Sym_Unquote, "unquote");
X    Define_Symbol (&Sym_Unquote_Splicing, "unquote-splicing");
X}
X
XObject P_Exit (argc, argv) Object *argv; {
X    exit (argc == 0 ? 0 : Get_Integer (argv[0]));
X    /*NOTREACHED*/
X}
X
XString_Getc (port) Object port; {
X    register struct S_Port *p;
X    register struct S_String *s;
X
X    p = PORT(port);
X    if (p->flags & P_UNREAD) {
X    p->flags &= ~P_UNREAD;
X    return p->unread;
X    }
X    s = STRING(p->name);
X    return p->ptr >= s->size ? EOF : s->data[p->ptr++];
X}
X
XString_Ungetc (port, c) Object port; register c; {
X    PORT(port)->flags |= P_UNREAD;
X    PORT(port)->unread = c;
X}
X
XCheck_Input_Port (port) Object port; {
X    Check_Type (port, T_Port);
X    if (!(PORT(port)->flags & P_OPEN))
X    Primitive_Error ("port has been closed: ~s", port);
X    if (!(PORT(port)->flags & P_INPUT))
X    Primitive_Error ("not an input port: ~s", port);
X}
X
XObject P_Clear_Input_Port (argc, argv) Object *argv; {
X    Discard_Input (argc == 1 ? argv[0] : Curr_Input_Port);
X    return Void;
X}
X
XDiscard_Input (port) Object port; {
X    register FILE *f;
X
X    Check_Input_Port (port);
X    if (PORT(port)->flags & P_STRING)
X    return;
X    f = PORT(port)->file;
X    f->_cnt = 0;
X    f->_ptr = f->_base;
X}
X
X/* NOTE: dumps core on ISI 4.2BSD when called on an input file port that
X * has not yet been read from.
X */
XObject P_Unread_Char (argc, argv) Object *argv; {
X    Object port, ch;
X    register struct S_Port *p;
X
X    ch = argv[0];
X    Check_Type (ch, T_Character);
X    port = argc == 2 ? argv[1] : Curr_Input_Port;
X    Check_Input_Port (port);
X    p = PORT(port);
X    if (p->flags & P_STRING) {
X    if (p->flags & P_UNREAD)
X        Primitive_Error ("cannot push back more than one char");
X    String_Ungetc (port, CHAR(ch));
X    } else {
X    if (ungetc (CHAR(ch), p->file) == EOF)
X        Primitive_Error ("failed to push back char");
X    }
X    return ch;
X}
X
XTemp_Intr_Handler () {
X    Immediate_Mode (Last_File, 0);
X    (void)signal (SIGINT, Intr_Handler);
X    Intr_Handler ();
X}
X
XObject P_Read_Char (argc, argv) Object *argv; {
X    Object port;
X    register FILE *f;
X    register c, str, flags;
X
X    port = argc == 1 ? argv[0] : Curr_Input_Port;
X    Check_Input_Port (port);
X    f = PORT(port)->file;
X    flags = PORT(port)->flags;
X    str = flags & P_STRING;
X    if (flags & P_TTY) {
X    (void)signal (SIGINT, Temp_Intr_Handler);
X    Last_File = f;
X    Immediate_Mode (f, 1);
X    }
X    c = GETC;
X    if (flags & P_TTY) {
X    Immediate_Mode (f, 0);
X    (void)signal (SIGINT, Intr_Handler);
X    }
X    Tweak_Stream (f);
X    return c == EOF ? Eof : Make_Char (c);
X}
X
XObject P_Read_String (argc, argv) Object *argv; {
X    Object port;
X    register FILE *f;
X    register c, str;
X    register char *p;
X    char buf[MAX_STRING_LEN];
X
X    port = argc == 1 ? argv[0] : Curr_Input_Port;
X    Check_Input_Port (port);
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
X    p = buf;
X    while (1) {
X    c = GETC;
X    if (c == EOF || c == '\n')
X        break;
X    if (p == buf+MAX_STRING_LEN)
X        break;
X    *p++ = c;
X    }
X    Tweak_Stream (f);
X    return c == EOF ? Eof : Make_String (buf, p-buf);
X}
X
XObject P_Read (argc, argv) Object *argv; {
X    return General_Read (argc == 1 ? argv[0] : Curr_Input_Port);
X}
X
XObject General_Read (port) Object port; {
X    register FILE *f;
X    register c, str;
X    Object ret;
X
X    Check_Input_Port (port);
X    Flush_Output (Curr_Output_Port);
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
X    while (1) {
X    c = GETC;
X    if (c == EOF) {
X        ret = Eof;
X        break;
X    }
X    if (Whitespace (c))
X        continue;
X    if (c == ';') {
X        if (Skip_Comment (port) == EOF) {
X        ret = Eof;
X        break;
X        }
X        continue;
X    }
X    if (c == '(') {
X        ret = Read_Sequence (port, 0);
X    } else {
X        UNGETC;
X        ret = Read_Atom (port);
X    }
X    break;
X    }
X    Tweak_Stream (f);
X    return ret;
X}
X
XSkip_Comment (port) Object port; {
X    register FILE *f;
X    register c, str;
X
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
X    do {
X    c = GETC;
X    } while (c != '\n' && c != EOF);
X    return c;
X}
X
XObject Read_Atom (port) Object port; {
X    Object ret;
X
X    ret = Read_Special (port);
X    if (TYPE(ret) == T_Special)
X    Primitive_Error ("syntax error");
X    return ret;
X}
X
XObject Read_Special (port) Object port; {
X    Object ret;
X    register c, str;
X    register FILE *f;
X    char buf[MAX_SYMBOL_LEN+1];
X    register char *p = buf;
X
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
Xagain:
X    c = GETC;
X    switch (c) {
X    case EOF:
Xeof:
X    Tweak_Stream (f);
X    Primitive_Error ("premature end of file");
X    case ';':
X    if (Skip_Comment (port) == EOF)
X        goto eof;
X    goto again;
X    case ')':
X    SET(ret, T_Special, c);
X    return ret;
X    case '(':
X    return Read_Sequence (port, 0);
X    case '\'':
X    ret = Read_Atom (port);
X    ret = Cons (ret, Null);
X    return Cons (Sym_Quote, ret);
X    case '`':
X    ret = Read_Atom (port);
X    ret = Cons (ret, Null);
X    return Cons (Sym_Quasiquote, ret);
X    case ',':
X    c = GETC;
X    if (c == EOF)
X        goto eof;
X    if (c == '@') {
X        ret = Read_Atom (port);
X        ret = Cons (ret, Null);
X        return Cons (Sym_Unquote_Splicing, ret);
X    } else {
X        UNGETC;
X        ret = Read_Atom (port);
X        ret = Cons (ret, Null);
X        return Cons (Sym_Unquote, ret);
X    }
X    case '"':
X    return Read_String (port);
X    case '#':
X    ret = Read_Sharp (port);
X    if (TYPE(ret) == T_Special)
X        goto again;
X    return ret;
X    default:
X    if (Whitespace (c))
X        goto again;
X    if (c == '.') {
X        c = GETC;
X        if (c == EOF)
X        goto eof;
X        if (Whitespace (c)) {
X        SET(ret, T_Special, '.');
X        return ret;
X        }
X        *p++ = '.';
X    }
X    while (!Whitespace (c) && !Delimiter (c) && c != EOF) {
X        if (p == buf+MAX_SYMBOL_LEN)
X        Primitive_Error ("symbol too long");
X        if (c == '\\') {
X        c = GETC;
X        if (c == EOF)
X            break;
X        }
X        *p++ = c;
X        c = GETC;
X    }
X    *p = '\0';
X    if (c != EOF)
X        UNGETC;
X    ret = Read_Number_Maybe (buf);
X    if (Nullp (ret))
X        ret = Intern (buf);
X    return ret;
X    }
X    /*NOTREACHED*/
X}
X
XObject Read_Sequence (port, vec) Object port; {
X    Object ret, e, tail, t;
X    GC_Node3;
X
X    ret = tail = Null;
X    GC_Link3 (ret, tail, port);
X    while (1) {
X    e = Read_Special (port);
X    if (TYPE(e) == T_Special) {
X        if (CHAR(e) == ')') {
X        GC_Unlink;
X        return ret;
X        }
X        if (vec)
X        Primitive_Error ("wrong syntax in vector");
X        if (CHAR(e) == '.') {
X        if (Nullp (tail)) {
X            ret = Read_Atom (port);
X        } else {
X            e = Read_Atom (port);
X            Cdr (tail) = e;
X        }
X        e = Read_Special (port);
X        if (TYPE(e) == T_Special && CHAR(e) == ')') {
X            GC_Unlink;
X            return ret;
X        }
X        Primitive_Error ("dot in wrong context");
X        }
X        Primitive_Error ("syntax error");
X    }
X    t = Cons (e, Null);
X    if (!Nullp (tail))
X        Cdr (tail) = t;
X    else
X        ret = t;
X    tail = t;
X    }
X    /*NOTREACHED*/
X}
X
XObject Read_String (port) Object port; {
X    char buf[MAX_STRING_LEN];
X    register char *p = buf;
X    register FILE *f;
X    register n, c, oc, str;
X
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
X    while (1) {
X    c = GETC;
X    if (c == EOF) {
Xeof:
X        Tweak_Stream (f);
X        Primitive_Error ("end of file in string");
X    }
X    if (c == '\\') {
X        c = GETC;
X        switch (c) {
X        case EOF: goto eof;
X        case 'b': c = '\b'; break;
X        case 't': c = '\t'; break;
X        case 'r': c = '\r'; break;
X        case 'n': c = '\n'; break;
X        case '0': case '1': case '2': case '3':
X        case '4': case '5': case '6': case '7':
X        oc = n = 0;
X        do {
X            oc <<= 3; oc += c - '0';
X            c = GETC;
X            if (c == EOF) goto eof;
X        } while (Octal (c) && ++n <= 2);
X        UNGETC;
X        c = oc;
X        }
X    } else if (c == '"')
X        break;
X    if (p == buf+MAX_STRING_LEN)
X        Primitive_Error ("string too long");
X    *p++ = c;
X    }
X    return Make_String (buf, p-buf);
X}
X
XObject Read_Sharp (port) Object port; {
X    register c, str;
X    register FILE *f;
X    register char *p;
X    char buf[MAX_SYMBOL_LEN+3];
X    Object ret;
X
X    f = PORT(port)->file;
X    str = PORT(port)->flags & P_STRING;
X    c = GETC;
X    if (c == EOF) {
Xeof:
X    Tweak_Stream (f);
X    Primitive_Error ("end of file after `#'");
X    }
X    switch (c) {
X    case '(':
X    return P_List_To_Vector (Read_Sequence (port, 1));
X    case 'b': case 'o': case 'd': case 'x':
X    p = buf; *p++ = '#'; *p++ = c;
X    while (1) {
X        c = GETC;
X        if (c == EOF)
X        goto eof;
X        if (p == buf+MAX_SYMBOL_LEN+2)
X        Primitive_Error ("number too long");
X        if (Whitespace (c) || Delimiter (c))
X        break;
X        *p++ = c;
X    }
X    UNGETC;
X    *p = '\0';
X    ret = Read_Number_Maybe (buf);
X    if (Nullp (ret))
X        Primitive_Error ("radix not followed by a valid number");
X    return ret;
X    case '\\':
X    p = buf;
X    c = GETC;
X    if (c == EOF)
X        goto eof;
X    *p++ = c;
X    while (1) {
X        c = GETC;
X        if (c == EOF)
X        goto eof;
X        if (Whitespace (c) || Delimiter (c))
X        break;
X        if (p == buf+9)
X        goto bad;
X        *p++ = c;
X    }
X    UNGETC;
X    *p = '\0';
X    if (p == buf+1)
X        return Make_Char (*buf);
X    if (p == buf+3) {
X        for (c = 0, p = buf; p < buf+3 && Octal (*p); p++)
X        c = (c << 3) | (*p - '0');
X        if (p == buf+3)
X        return Make_Char (c);
X    }
X    for (p = buf; *p; p++)
X        if (isupper (*p))
X        *p = tolower (*p);
X    if (strcmp (buf, "space") == 0)
X        return Make_Char (' ');
X    if (strcmp (buf, "newline") == 0)
X        return Make_Char ('\n');
X    if (strcmp (buf, "return") == 0)
X        return Make_Char ('\r');
X    if (strcmp (buf, "tab") == 0)
X        return Make_Char ('\t');
X    if (strcmp (buf, "formfeed") == 0)
X        return Make_Char ('\f');
X    if (strcmp (buf, "backspace") == 0)
X        return Make_Char ('\b');
X    goto bad;
X    case 'f': case 'F':
X    return False;
X    case 't': case 'T':
X    return True;
X    case 'v': case 'V':
X    return Void;
X    case '!':                         /* Kludge for interpreter files */
X    if (Skip_Comment (port) == EOF)
X        return Eof;
X    return Special;
X    default:
Xbad:
X    Primitive_Error ("syntax error after `#'");
X    }
X    /*NOTREACHED*/
X}
X
XObject Read_Number_Maybe (buf) char *buf; {
X    register char *p;
X    register c, digit = 0, expo = 0, neg = 0, point = 0, base = 10;
X    register i;
X
X    if (buf[0] == '#') {
X    switch (buf[1]) {
X    case 'b': base = 2; break;
X    case 'o': base = 8; break;
X    case 'd': break;
X    case 'x': base = 16; break;
X    default: return Null;
X    }
X    buf += 2;
X    }
X    p = buf;
X    if (*p == '+' || (neg = *p == '-'))
X    p++;
X    for ( ; c = *p; p++) {
X    if (c == '.') {
X        if (point++)
X        return Null;
X    } else if (base != 16 && (c == 'e' || c == 'E')) {
X        if (expo++)
X        return Null;
X        if (p[1] == '+' || p[1] == '-')
X        p++;
X    } else if (base == 16 && !index ("0123456789abcdefABCDEF", c)) {
X        return Null;
X    } else if (base < 16 && (c < '0' || c > '0' + base-1)) {
X        return Null;
X    } else digit++;
X    }
X    if (!digit)
X    return Null;
X    if (point || expo) {
X    if (base != 10)
X        Primitive_Error ("reals must be given in decimal");
X    return Make_Reduced_Flonum (atof (buf));
X    }
X    for (i = 0, p = buf; c = *p; p++) {
X    if (c == '-' || c == '+') {
X        buf++;
X        continue;
X    }
X    if (base == 16) {
X        if (isupper (c))
X        c = tolower (c);
X        if (c >= 'a')
X        c = '9' + c - 'a' + 1;
X    }
X    i = base * i + c - '0';
X    if (!FIXNUM_FITS(neg ? -i : i))
X        return Make_Bignum (buf, neg, base);
X    }
X    if (neg)
X    i = -i;
X    return Make_Fixnum (i);
X}
X
X#ifdef TERMIO
X
XImmediate_Mode (f, on) FILE *f; {
X    static struct termio b;
X    static oldlflag, oldeof;
X
X    if (on) {
X    (void)ioctl (fileno (f), TCGETA, &b);
X    oldlflag = b.c_lflag;
X    oldeof = b.c_cc[VEOF];
X    b.c_lflag &= ~ICANON;
X    b.c_cc[VEOF] = 1;
X    } else {
X    b.c_lflag = oldlflag;
X    b.c_cc[VEOF] = oldeof;
X    }
X    (void)ioctl (fileno (f), TCSETA, &b);
X}
X
X#else
X
XImmediate_Mode (f, on) FILE *f; {
X    static struct sgttyb b;
X    static oldflags;
X
X    if (on) {
X    if (ioctl (fileno (f), TIOCGETP, &b) == -1)
X        perror("getp");
X    oldflags = b.sg_flags;
X    b.sg_flags |= CBREAK;
X    } else {
X    b.sg_flags = oldflags;
X    }
X    if (ioctl (fileno (f), TIOCSETP, &b) == -1)
X    perror("setp");
X}
X
X#endif
END_OF_src/read.c
if test 12649 -ne `wc -c <src/read.c`; then
    echo shar: \"src/read.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/io.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/io.c\"
else
echo shar: Extracting \"src/io.c\" \(8517 characters\)
sed "s/^X//" >src/io.c <<'END_OF_src/io.c'
X/* Input and output (ports etc.)
X */
X
X#include <errno.h>
X#include <pwd.h>
X#include <sys/types.h>
X#include <sys/param.h>
X#include <sys/stat.h>
X
X#include "scheme.h"
X
Xstatic Max_Open_Files;
Xstatic Object Open_Files[MAX_MAX_OPEN_FILES];
X
XObject Curr_Input_Port, Curr_Output_Port;
XObject Standard_Input_Port, Standard_Output_Port;
X
XObject Make_Port();
Xvoid Close_Lost_Files();
X
XInit_Io () {
X    register Object *p;
X
X#ifdef MAX_OFILES
X    Max_Open_Files = MAX_OFILES;
X#else
X    Max_Open_Files = getdtablesize ();
X#endif
X    if (Max_Open_Files > MAX_MAX_OPEN_FILES)
X    Max_Open_Files = MAX_MAX_OPEN_FILES;
X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++)
X    *p = Null;
X    Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
X    Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
X    Curr_Input_Port = Standard_Input_Port;
X    Curr_Output_Port = Standard_Output_Port;
X    Global_GC_Link (Standard_Input_Port);
X    Global_GC_Link (Standard_Output_Port);
X    Global_GC_Link (Curr_Input_Port);
X    Global_GC_Link (Curr_Output_Port);
X    Register_After_GC (Close_Lost_Files);
X}
X
XReset_IO (destructive) {
X    Discard_Input (Curr_Input_Port);
X    if (destructive)
X    Discard_Output (Curr_Output_Port);
X    else
X    Flush_Output (Curr_Output_Port);
X    Curr_Input_Port = Standard_Input_Port;
X    Curr_Output_Port = Standard_Output_Port;
X}
X
XObject Make_Port (flags, f, name) FILE *f; Object name; {
X    Object port;
X    register char *p;
X    GC_Node;
X
X    if (f && isatty (fileno (f)))
X    flags |= P_TTY;
X    GC_Link (name);
X    p = Get_Bytes (sizeof (struct S_Port));
X    SET(port, T_Port, (struct S_Port *)p);
X    PORT(port)->flags = flags|P_OPEN;
X    PORT(port)->file = f;
X    PORT(port)->name = name;
X    PORT(port)->ptr = 0;
X    GC_Unlink;
X    return port;
X}
X
XObject P_Port_File_Name (p) Object p; {
X    Check_Type (p, T_Port);
X    return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
X}
X
XObject P_Eof_Objectp (x) Object x; {
X    return TYPE(x) == T_End_Of_File ? True : False;
X}
X
XObject P_Curr_Input_Port () { return Curr_Input_Port; }
X
XObject P_Curr_Output_Port () { return Curr_Output_Port; }
X
XObject P_Input_Portp (x) Object x; {
X    return TYPE(x) == T_Port && (PORT(x)->flags & P_INPUT) ? True : False;
X}
X
XObject P_Output_Portp (x) Object x; {
X    return TYPE(x) == T_Port && !(PORT(x)->flags & P_INPUT) ? True : False;
X}
X
Xvoid Close_Lost_Files () {
X    register Object *p, *tag;
X
X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
X    if (Nullp (*p)) continue;
X    if (TYPE(*p) != T_Port)
X        Panic ("bad type in file table");
X    tag = &PORT(*p)->name;
X    if (TYPE(*tag) == T_Broken_Heart) {
X        SETPOINTER(*p, POINTER(*tag));
X    } else {
X        (void)fclose (PORT(*p)->file);
X        *p = Null;
X    }
X    }
X}
X
XClose_All_Files () {
X    register Object *p;
X
X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
X    if (Nullp (*p)) continue;
X    (void)fclose (PORT(*p)->file);
X    PORT(*p)->flags &= ~P_OPEN;
X    *p = Null;
X    }
X}
X
XRegister_File (port) Object port; {
X    register Object *p;
X
X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++)
X    if (Nullp (*p)) break;
X    if (p == Open_Files+Max_Open_Files)
X    Primitive_Error ("no more slots for open files.\n");
X    *p = port;
X}
X
XObject Get_File_Name (name) Object name; {
X    register len;
X
X    if (TYPE(name) == T_Symbol)
X    name = SYMBOL(name)->name;
X    else if (TYPE(name) != T_String)
X    Wrong_Type_Combination (name, "string or symbol");
X    if ((len = STRING(name)->size) > MAXPATHLEN || len == 0)
X    Primitive_Error ("invalid file name");
X    return name;
X}
X
Xchar *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
X    register char *p;
X    struct passwd *pw, *getpwnam();
X
X    if (*s != '~')
X    return 0;
X    for (p = s+1; *p && *p != '/'; p++) ;
X    *p = '\0';
X    if (p == s+1) {
X    if ((*dirp = getenv ("HOME")) == 0)
X        *dirp = "";
X    } else {
X    if ((pw = getpwnam (s+1)) == 0)
X        Primitive_Error ("unknown user: ~a", Make_String (s+1, p-s-1));
X    *dirp = pw->pw_dir;
X    }
X    return p;
X}
X
XObject General_File_Operation (s, op) Object s; register op; {
X    register char *r;
X    register n;
X    Object fn;
X
X    fn = Get_File_Name (s);
X    n = STRING(fn)->size;
X    r = alloca (n+1);
X    bcopy (STRING(fn)->data, r, n);
X    r[n] = '\0';
X    switch (op) {
X    case 0: {
X    char *p, *dir;
X    if ((p = Internal_Tilde_Expand (r, &dir)) == 0)
X        return s;
X    r = alloca (strlen (dir) + 1 + strlen (p));
X    sprintf (r, "%s/%s", dir, p+1);
X    return Make_String (r, strlen (r));
X    }
X    case 1: {
X    struct stat st;
X    return stat (r, &st) == 0 || errno != ENOENT ? True : False;
X    }}
X    /*NOTREACHED*/
X}
X
XObject P_Tilde_Expand (s) Object s; {
X    return General_File_Operation (s, 0);
X}
X
XObject P_File_Existsp (s) Object s; {
X    return General_File_Operation (s, 1);
X}
X
XObject Open_File (name, flags, err) register char *name; {
X    register FILE *f;
X    char *dir, *p;
X    Object fn, port;
X    struct stat st;
X
X    if ((p = Internal_Tilde_Expand (name, &dir))) {
X    name = alloca (strlen (dir) + 1 + strlen (p));
X    sprintf (name, "%s/%s", dir, p+1);
X    }
X    if (!err && stat (name, &st) == -1 && errno == ENOENT)
X    return Null;
X    fn = Make_String (name, strlen (name));
X    if ((f = fopen (name, (flags & P_INPUT) ? "r" : "w")) == NULL) {
X    Saved_Errno = errno;  /* errno valid here? */
X    Primitive_Error ("~s: ~E", fn);
X    }
X    port = Make_Port (flags, f, fn);
X    Register_File (port);
X    return port;
X}
X
XObject General_Open_File (name, flags, path) Object name, path; {
X    Object port, pref;
X    register char *buf, *fn;
X    register plen, len, blen = 0, gotpath = 0;
X
X    name = Get_File_Name (name);
X    len = STRING(name)->size;
X    fn = STRING(name)->data;
X    if (fn[0] != '/' && fn[0] != '~') {
X    for ( ; TYPE(path) == T_Pair; path = Cdr (path)) {
X        pref = Car (path);
X        if (TYPE(pref) == T_Symbol)
X        pref = SYMBOL(pref)->name;
X        if (TYPE(pref) != T_String)
X        continue;
X        gotpath = 1;
X        if ((plen = STRING(pref)->size) > MAXPATHLEN || plen == 0)
X        continue;
X        if (len + plen + 2 > blen)
X        buf = alloca (blen = len + plen + 2);
X        bcopy (STRING(pref)->data, buf, plen);
X        if (buf[plen-1] != '/')
X        buf[plen++] = '/';
X        bcopy (fn, buf+plen, len);
X        buf[len+plen] = '\0';
X        port = Open_File (buf, flags, 0);
X        /* No GC has been taken place in Open_File() if it returns Null.
X         */
X        if (!Nullp (port))
X        return port;
X    }
X    }
X    if (gotpath)
X    Primitive_Error ("file ~s not found", name);
X    if (len + 1 > blen)
X    buf = alloca (len + 1);
X    bcopy (fn, buf, len);
X    buf[len] = '\0';
X    return Open_File (buf, flags, 1);
X}
X
XObject P_Open_Input_File (name) Object name; {
X    return General_Open_File (name, P_INPUT, Null);
X}
X
XObject P_Open_Output_File (name) Object name; {
X    return General_Open_File (name, 0, Null);
X}
X
XObject P_Close_Port (port) Object port; {
X    register Object *p;
X    register flags;
X
X    Check_Type (port, T_Port);
X    flags = PORT(port)->flags;
X    if (!(flags & P_OPEN))
X    return True;
X    if (!(flags & P_STRING))
X    (void)fclose (PORT(port)->file);
X    PORT(port)->flags &= ~P_OPEN;
X    if (!(flags & P_STRING)) {
X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
X        if (EQ(port,*p))
X        *p = Null;
X    }
X    }
X    return Void;
X}
X
X#define General_With(prim,curr,flags) Object prim (name, thunk)\
X    Object name, thunk; {\
X    Object old, ret;\
X    GC_Node2;\
X\
X    Check_Procedure (thunk);\
X    old = curr;\
X    GC_Link2 (thunk, old);\
X    curr = General_Open_File (name, flags, Null);\
X    ret = Funcall (thunk, Null, 0);\
X    P_Close_Port (curr);\
X    GC_Unlink;\
X    curr = old;\
X    return ret;\
X}
X
XGeneral_With (P_With_Input, Curr_Input_Port, P_INPUT)
XGeneral_With (P_With_Output, Curr_Output_Port, 0)
X
XObject General_Call_With (name, flags, proc) Object name, proc; {
X    Object port, ret;
X    GC_Node2;
X
X    Check_Procedure (proc);
X    GC_Link2 (proc, port);
X    port = General_Open_File (name, flags, Null);
X    port = Cons (port, Null);
X    ret = Funcall (proc, port, 0);
X    P_Close_Port (Car (port));
X    GC_Unlink;
X    return ret;
X}
X
XObject P_Call_With_Input (name, proc) Object name, proc; {
X    return General_Call_With (name, P_INPUT, proc);
X}
X
XObject P_Call_With_Output (name, proc) Object name, proc; {
X    return General_Call_With (name, 0, proc);
X}
X
XObject P_Open_Input_String (string) Object string; {
X    Check_Type (string, T_String);
X    return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
X}
X
XObject P_Open_Output_String () {
X    return Make_Port (P_STRING, (FILE *)0, Make_String ((char *)0, 0));
X}
END_OF_src/io.c
if test 8517 -ne `wc -c <src/io.c`; then
    echo shar: \"src/io.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/load.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/load.c\"
else
echo shar: Extracting \"src/load.c\" \(4515 characters\)
sed "s/^X//" >src/load.c <<'END_OF_src/load.c'
X/* Loading of source and object files
X */
X
X#include <signal.h>
X
X#include "scheme.h"
X
X#ifdef COFF
X#  include <filehdr.h>
X#  include <syms.h>
X#  undef TYPE         /* ldfnc.h defines a TYPE macro. */
X#  include <ldfcn.h>
X#  undef TYPE
X#  ifdef USE_BITFIELDS
X#    define TYPE(x) ((int)(x).s.type)
X#  else
X#    define TYPE(x) ((int)((x) >> VALBITS))
X#  endif
X#else
X#  include <a.out.h>
X#  include <sys/types.h>
X#endif
X
Xstatic Object V_Load_Path, V_Load_Noisilyp, V_Load_Libraries;
X
X#ifdef CAN_LOAD_OBJ
X#  ifdef gcc
X#    define Default_Load_Libraries "/usr/new/ghs/lib/libc.a"
X#  else
X#    define Default_Load_Libraries "-lc"
X#  endif
X#else
X#  define Default_Load_Libraries ""
X#endif
X
X#if defined(CAN_DUMP) || defined(CAN_LOAD_OBJ)
Xchar Loader_Input[20];
X#endif
X#ifdef CAN_LOAD_OBJ
Xstatic char Loader_Output[20];
X#endif
X
XInit_Load () {
X    Define_Variable (&V_Load_Path, "load-path",
X    Cons (Make_String (".", 1),
X    Cons (Make_String (DEF_LOAD_DIR, sizeof (DEF_LOAD_DIR) - 1), Null)));
X    Define_Variable (&V_Load_Noisilyp, "load-noisily?", False);
X    Define_Variable (&V_Load_Libraries, "load-libraries",
X    Make_String (Default_Load_Libraries, sizeof Default_Load_Libraries-1));
X}
X
XObject General_Load (name, env) Object name, env; {
X    register char *p;
X    register struct S_String *str;
X    Object oldenv, port;
X    GC_Node2;
X
X    Check_Type (env, T_Environment);
X    oldenv = The_Environment;
X    GC_Link2 (env, oldenv);
X    port = General_Open_File (name, P_INPUT, Val (V_Load_Path));
X    str = STRING(PORT(port)->name);
X    Switch_Environment (env);
X    p = str->data + str->size;
X    if (str->size >= 2 && *--p == 'o' && *--p == '.') {
X#ifdef CAN_LOAD_OBJ
X    Load_Object (port, str);
X#else
X    ;
X#endif
X    } else
X    Load_Source (port);
X    Switch_Environment (oldenv);
X    GC_Unlink;
X    return Void;
X}
X
XObject P_Load (argc, argv) register argc; register Object *argv; {
X    return General_Load (argv[0], argc == 1 ? The_Environment : argv[1]);
X}
X
XLoad_Source (port) Object port; {
X    Object val;
X    GC_Node;
X
X    GC_Link (port);
X    while (1) {
X    val = General_Read (port);
X    if (TYPE(val) == T_End_Of_File)
X        break;
X    val = Eval (val);
X    if (Truep (Val (V_Load_Noisilyp))) {
X        Print (val);
X        P_Newline (0);
X    }
X    }
X    P_Close_Port (port);
X    GC_Unlink;
X}
X
X#ifdef CAN_LOAD_OBJ
XLoad_Object (port, fn) Object port; register struct S_String *fn; {
X    struct exec hdr;
X    register char *brk, *obrk, *buf, *lp, *li;
X    register n, f;
X    Object libs;
X    FILE *fp;
X
X    n = fread ((char *)&hdr, sizeof (hdr), 1, PORT(port)->file);
X    P_Close_Port (port);
X    if (n == 0 || hdr.a_magic != OMAGIC)
X    Primitive_Error ("not a valid object file");
X    strcpy (Loader_Output, "/tmp/ldXXXXXX");
X    mktemp (Loader_Output);
X    buf = alloca (fn->size + strlen (myname) + 500);
X    obrk = brk = sbrk (0);
X    brk = (char *)((int)brk + 7 & ~7);
X    libs = Val (V_Load_Libraries);
X    if (TYPE(libs) == T_String) {
X        if ((n = STRING(libs)->size) > 400)
X        Primitive_Error ("too many load libraries");
X    lp = STRING(libs)->data;
X    } else {
X    lp = "-lc"; n = 3;
X    }
X    li = Loader_Input;
X    if (li[0] == 0)
X    li = myname;
X#ifdef XFLAG_BROKEN
X    sprintf (buf, "/bin/ld -N -A %s -T %x %.*s -o %s %.*s",
X#else
X    sprintf (buf, "/bin/ld -N -x -A %s -T %x %.*s -o %s %.*s",
X#endif
X    li, brk, fn->size, fn->data, Loader_Output, n, lp);
X    if (system (buf) != 0) {
X    (void)unlink (Loader_Output);
X    Primitive_Error ("system linker failed");
X    }
X    Disable_Interrupts;               /* To ensure that f gets closed */
X    if ((f = open (Loader_Output, 0)) == -1) {
X    (void)unlink (Loader_Output);
X    Primitive_Error ("cannot open tempfile");
X    }
X    if (Loader_Input[0])
X    (void)unlink(Loader_Input);
X    strcpy (Loader_Input, Loader_Output);
X    if (read (f, (char *)&hdr, sizeof (hdr)) != sizeof (hdr)) {
Xerr:
X    close (f);
X    Primitive_Error ("corrupt tempfile (/bin/ld is broken)");
X    }
X    n = hdr.a_text + hdr.a_data + hdr.a_bss;
X    n += brk - obrk;
X    if (sbrk (n) == (char *)-1) {
X    close (f);
X    Primitive_Error ("not enough memory to load object file");
X    }
X    bzero (obrk, n);
X    n -= hdr.a_bss;
X    if (read (f, brk, n) != n)
X    goto err;
X    if ((fp = fdopen (f, "r")) == NULL) {
X    close (f);
X    Primitive_Error ("cannot fdopen object file");
X    }
X    if (The_Symbols)
X    Free_Symbols (The_Symbols);
X    The_Symbols = Snarf_Symbols (fp, &hdr);
X    fclose (fp);
X    Call_Initializers (The_Symbols, brk);
X    Enable_Interrupts;
X}
X
XFinit_Load () {
X    if (Loader_Input[0])
X    (void)unlink (Loader_Input);
X}
X#endif
END_OF_src/load.c
if test 4515 -ne `wc -c <src/load.c`; then
    echo shar: \"src/load.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/auto.c -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/auto.c\"
else
echo shar: Extracting \"src/auto.c\" \(1192 characters\)
sed "s/^X//" >src/auto.c <<'END_OF_src/auto.c'
X/* Autoloading
X */
X
X#include "scheme.h"
X
XObject V_Autoload_Notifyp;
X
XInit_Auto () {
X    Define_Variable (&V_Autoload_Notifyp, "autoload-notify?", True);
X}
X
XObject P_Autoload (sym, file) Object sym, file; {
X    Object al, ret;
X    register char *p;
X    GC_Node3;
X
X    al = Null;
X    Check_Type (sym, T_Symbol);
X    if (TYPE(file) != T_Symbol && TYPE(file) != T_String)
X    Wrong_Type_Combination (file, "string or symbol");
X    GC_Link3 (al, sym, file);
X    p = Get_Bytes (sizeof (struct S_Autoload));
X    SET(al, T_Autoload, (struct S_Autoload *)p);
X    AUTOLOAD(al)->file = file;
X    AUTOLOAD(al)->env = The_Environment;
X    al = Cons (al, Null);
X    al = Cons (sym, al);
X    ret = P_Define (al);
X    GC_Unlink;
X    return ret;
X}
X
XObject Do_Autoload (sym, al) Object sym, al; {
X    Object val, a[1];
X    GC_Node;
X
X    if (Truep (Val (V_Autoload_Notifyp))) {
X    a[0] = AUTOLOAD(al)->file;
X    Format (Standard_Output_Port, "[Autoloading ~s]~%", 18, 1, a);
X    }
X    GC_Link (sym);
X    (void)General_Load (AUTOLOAD(al)->file, AUTOLOAD(al)->env);
X    GC_Unlink;
X    val = SYMBOL(sym)->value;
X    if (TYPE(val) == T_Autoload)
X    Primitive_Error ("autoloading failed to define ~s", sym);
X    return val;
X}
END_OF_src/auto.c
if test 1192 -ne `wc -c <src/auto.c`; then
    echo shar: \"src/auto.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/alloca.s.vax -a "${1}" != "-c" ; then
  echo shar: Will not over-write existing file \"src/alloca.s.vax\"
else
echo shar: Extracting \"src/alloca.s.vax\" \(0 character\)
sed "s/^X//" >src/alloca.s.vax <<'END_OF_src/alloca.s.vax'
END_OF_src/alloca.s.vax
if test 0 -ne `wc -c <src/alloca.s.vax`; then
    echo shar: \"src/alloca.s.vax\" unpacked with wrong size!
fi
# end of overwriting check
fi
echo shar: End of archive 5 \(of 14\).
cp /dev/null ark5isdone
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