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