allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc) (09/24/89)
Posting-number: Volume 8, Issue 54
Submitted-by: net@tub.UUCP (Oliver Laumann)
Archive-name: elk/part06
[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 6 (of 14)."
# Contents: src/math.c src/special.c src/dump.c src/type.c src/bool.c
# src/bignum.c src/alloca.s.386 tst
# Wrapped by net@tub on Sun Sep 17 17:32:26 1989
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f src/math.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/math.c\"
else
echo shar: Extracting \"src/math.c\" \(14868 characters\)
sed "s/^X//" >src/math.c <<'END_OF_src/math.c'
X/* Numbers
X */
X
X#include <math.h>
X#include <errno.h>
X
X#include "scheme.h"
X
XObject Generic_Multiply(), Generic_Divide();
X
XInit_Math () {
X (void)srandom (getpid ());
X}
X
XObject Make_Fixnum (n) {
X Object num;
X
X SET(num, T_Fixnum, n);
X return num;
X}
X
XObject Make_Integer (n) register n; {
X if (FIXNUM_FITS(n))
X return Make_Fixnum (n);
X else
X return Integer_To_Bignum (n);
X}
X
XObject Make_Unsigned (n) register unsigned n; {
X if (FIXNUM_FITS_UNSIGNED(n))
X return Make_Fixnum (n);
X else
X return Unsigned_To_Bignum (n);
X}
X
XGet_Integer (x) Object x; {
X switch (TYPE(x)) {
X case T_Fixnum:
X return FIXNUM(x);
X case T_Bignum:
X return Bignum_To_Integer (x);
X default:
X Wrong_Type (x, T_Fixnum);
X }
X /*NOTREACHED*/
X}
X
XGet_Index (n, obj) Object n, obj; {
X register size, i;
X
X i = Get_Integer (n);
X size = TYPE(obj) == T_Vector ? VECTOR(obj)->size : STRING(obj)->size;
X if (i < 0 || i >= size)
X Range_Error (n);
X return i;
X}
X
XObject Make_Reduced_Flonum (d) double d; {
X Object num;
X register char *p;
X int expo;
X
X if (floor (d) == d) {
X if (d == 0)
X return Zero;
X (void)frexp (d, &expo);
X if (expo <= VALBITS-1)
X return Make_Fixnum ((int)d);
X }
X p = Get_Bytes (sizeof (struct S_Flonum));
X SET(num, T_Flonum, (struct S_Flonum *)p);
X FLONUM(num)->tag = Null;
X FLONUM(num)->val = d;
X return num;
X}
X
XObject P_Integerp (x) Object x; {
X return TYPE(x) == T_Fixnum || TYPE(x) == T_Bignum ? True : False;
X}
X
XObject P_Rationalp (x) Object x; {
X return P_Integerp (x);
X}
X
XObject P_Realp (x) Object x; {
X register t = TYPE(x);
X return t == T_Flonum || t == T_Fixnum || t == T_Bignum ? True : False;
X}
X
XObject P_Complexp (x) Object x; {
X return P_Realp (x);
X}
X
XObject P_Numberp (x) Object x; {
X return P_Complexp (x);
X}
X
X#define General_Generic_Predicate(prim,op,bigop) Object prim (x) Object x; {\
X register ret;\
X Check_Number (x);\
X switch (TYPE(x)) {\
X case T_Flonum:\
X ret = FLONUM(x)->val op 0; break;\
X case T_Fixnum:\
X ret = FIXNUM(x) op 0; break;\
X case T_Bignum:\
X ret = bigop (x); break;\
X }\
X return ret ? True : False;\
X}
X
XGeneral_Generic_Predicate (P_Zerop, ==, Bignum_Zero)
XGeneral_Generic_Predicate (P_Negativep, <, Bignum_Negative)
XGeneral_Generic_Predicate (P_Positivep, >, Bignum_Positive)
X
XObject P_Evenp (x) Object x; {
X register ret;
X
X Check_Integer (x);
X switch (TYPE(x)) {
X case T_Fixnum:
X ret = !(FIXNUM(x) & 1); break;
X case T_Bignum:
X ret = Bignum_Even (x); break;
X }
X return ret ? True : False;
X}
X
XObject P_Oddp (x) Object x; {
X Object tmp;
X tmp = P_Evenp (x);
X return EQ(tmp,True) ? False : True;
X}
X
XObject P_Exactp (x) Object x; {
X Check_Number (x);
X return False;
X}
X
XObject P_Inexactp (x) Object x; {
X Check_Number (x);
X return True;
X}
X
X#define General_Generic_Compare(name,op,bigop) name (x, y) Object x, y; {\
X Object b; register ret;\
X GC_Node;\
X \
X switch (TYPE(x)) {\
X case T_Fixnum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X return FIXNUM(x) op FIXNUM(y);\
X case T_Flonum:\
X return FIXNUM(x) op FLONUM(y)->val;\
X case T_Bignum:\
X GC_Link (y);\
X b = Integer_To_Bignum (FIXNUM(x));\
X ret = bigop (b, y);\
X GC_Unlink;\
X return ret;\
X }\
X case T_Flonum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X return FLONUM(x)->val op FIXNUM(y);\
X case T_Flonum:\
X return FLONUM(x)->val op FLONUM(y)->val;\
X case T_Bignum:\
X return FLONUM(x)->val op Bignum_To_Double (y);\
X }\
X case T_Bignum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X GC_Link (x);\
X b = Integer_To_Bignum (FIXNUM(y));\
X ret = bigop (x, b);\
X GC_Unlink;\
X return ret;\
X case T_Flonum:\
X return Bignum_To_Double (x) op FLONUM(y)->val;\
X case T_Bignum:\
X return bigop (x, y);\
X }\
X }\
X /*NOTREACHED*/\
X}
X
XGeneral_Generic_Compare (Generic_Equal, ==, Bignum_Equal)
XGeneral_Generic_Compare (Generic_Less, <, Bignum_Less)
XGeneral_Generic_Compare (Generic_Greater, >, Bignum_Greater)
XGeneral_Generic_Compare (Generic_Eq_Less, <=, Bignum_Eq_Less)
XGeneral_Generic_Compare (Generic_Eq_Greater, >=, Bignum_Eq_Greater)
X
XObject General_Compare (argc, argv, op) Object *argv; register (*op)(); {
X register i;
X
X Check_Number (argv[0]);
X for (i = 1; i < argc; i++) {
X Check_Number (argv[i]);
X if (!(*op) (argv[i-1], argv[i]))
X return False;
X }
X return True;
X}
X
XObject P_Generic_Equal (argc, argv) Object *argv; {
X return General_Compare (argc, argv, Generic_Equal);
X}
X
XObject P_Generic_Less (argc, argv) Object *argv; {
X return General_Compare (argc, argv, Generic_Less);
X}
X
XObject P_Generic_Greater (argc, argv) Object *argv; {
X return General_Compare (argc, argv, Generic_Greater);
X}
X
XObject P_Generic_Eq_Less (argc, argv) Object *argv; {
X return General_Compare (argc, argv, Generic_Eq_Less);
X}
X
XObject P_Generic_Eq_Greater (argc, argv) Object *argv; {
X return General_Compare (argc, argv, Generic_Eq_Greater);
X}
X
X#define General_Generic_Operator(name,op,bigop) Object name (x, y)\
X Object x, y; {\
X Object b1, b2, ret; register i;\
X GC_Node2;\
X \
X switch (TYPE(x)) {\
X case T_Fixnum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X i = FIXNUM(x) op FIXNUM(y);\
X if (FIXNUM_FITS(i))\
X return Make_Fixnum (i);\
X b1 = b2 = Null;\
X GC_Link2 (b1, b2);\
X b1 = Integer_To_Bignum (FIXNUM(x));\
X b2 = Integer_To_Bignum (FIXNUM(y));\
X ret = bigop (b1, b2);\
X GC_Unlink;\
X return ret;\
X case T_Flonum:\
X return Make_Reduced_Flonum (FIXNUM(x) op FLONUM(y)->val);\
X case T_Bignum:\
X return bigop (Integer_To_Bignum (FIXNUM(x)), y);\
X }\
X case T_Flonum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X return Make_Reduced_Flonum (FLONUM(x)->val op FIXNUM(y));\
X case T_Flonum:\
X return Make_Reduced_Flonum (FLONUM(x)->val op FLONUM(y)->val);\
X case T_Bignum:\
X return Make_Reduced_Flonum (FLONUM(x)->val op\
X Bignum_To_Double (y));\
X }\
X case T_Bignum:\
X switch (TYPE(y)) {\
X case T_Fixnum:\
X return bigop (x, Integer_To_Bignum (FIXNUM(y)));\
X case T_Flonum:\
X return Make_Reduced_Flonum (Bignum_To_Double (x) op\
X FLONUM(y)->val);\
X case T_Bignum:\
X return bigop (x, y);\
X }\
X }\
X /*NOTREACHED*/\
X}
X
XGeneral_Generic_Operator (Generic_Plus, +, Bignum_Plus)
XGeneral_Generic_Operator (Generic_Minus, -, Bignum_Minus)
X
XObject P_Inc (x) Object x; {
X Check_Number (x);
X return Generic_Plus (x, One);
X}
X
XObject P_Dec (x) Object x; {
X Check_Number (x);
X return Generic_Minus (x, One);
X}
X
XObject General_Operator (argc, argv, start, op) Object *argv, start;
X register Object (*op)(); {
X register i;
X Object accum;
X
X if (argc > 0)
X Check_Number (argv[0]);
X accum = start;
X switch (argc) {
X case 0:
X break;
X case 1:
X accum = (*op) (accum, argv[0]); break;
X default:
X for (accum = argv[0], i = 1; i < argc; i++) {
X Check_Number (argv[i]);
X accum = (*op) (accum, argv[i]);
X }
X }
X return accum;
X}
X
XObject P_Generic_Plus (argc, argv) Object *argv; {
X return General_Operator (argc, argv, Zero, Generic_Plus);
X}
X
XObject P_Generic_Minus (argc, argv) Object *argv; {
X return General_Operator (argc, argv, Zero, Generic_Minus);
X}
X
XObject P_Generic_Multiply (argc, argv) Object *argv; {
X return General_Operator (argc, argv, One, Generic_Multiply);
X}
X
XObject P_Generic_Divide (argc, argv) Object *argv; {
X return General_Operator (argc, argv, One, Generic_Divide);
X}
X
XObject Generic_Multiply (x, y) Object x, y; {
X Object b, ret;
X
X switch (TYPE(x)) {
X case T_Fixnum:
X switch (TYPE(y)) {
X case T_Fixnum:
X ret = Fixnum_Multiply (FIXNUM(x), FIXNUM(y));
X if (Nullp (ret)) {
X b = Integer_To_Bignum (FIXNUM(x));
X return Bignum_Fixnum_Multiply (b, y);
X }
X return ret;
X case T_Flonum:
X return Make_Reduced_Flonum (FIXNUM(x) * FLONUM(y)->val);
X case T_Bignum:
X return Bignum_Fixnum_Multiply (y, x);
X }
X case T_Flonum:
X switch (TYPE(y)) {
X case T_Fixnum:
X return Make_Reduced_Flonum (FLONUM(x)->val * FIXNUM(y));
X case T_Flonum:
X return Make_Reduced_Flonum (FLONUM(x)->val * FLONUM(y)->val);
X case T_Bignum:
X return Make_Reduced_Flonum (FLONUM(x)->val * Bignum_To_Double (y));
X }
X case T_Bignum:
X switch (TYPE(y)) {
X case T_Fixnum:
X return Bignum_Fixnum_Multiply (x, y);
X case T_Flonum:
X return Make_Reduced_Flonum (Bignum_To_Double (x) * FLONUM(y)->val);
X case T_Bignum:
X return Bignum_Multiply (x, y);
X }
X }
X /*NOTREACHED*/
X}
X
XObject Generic_Divide (x, y) Object x, y; {
X register t = TYPE(y);
X Object b, ret;
X GC_Node2;
X
X if (t == T_Fixnum ? FIXNUM(y) == 0 :
X (t == T_Flonum ? FLONUM(y) == 0 : Bignum_Zero (y)))
X Range_Error (y);
X switch (TYPE(x)) {
X case T_Fixnum:
X switch (t) {
X case T_Fixnum:
X return Make_Reduced_Flonum ((double)FIXNUM(x) / (double)FIXNUM(y));
X case T_Flonum:
X return Make_Reduced_Flonum ((double)FIXNUM(x) / FLONUM(y)->val);
X case T_Bignum:
X GC_Link (y);
X b = Integer_To_Bignum (FIXNUM(x));
X ret = Bignum_Divide (b, y);
X GC_Unlink;
X if (EQ(Cdr (ret),Zero))
X return Car (ret);
X return Make_Reduced_Flonum ((double)FIXNUM(x) /
X Bignum_To_Double (y));
X }
X case T_Flonum:
X switch (t) {
X case T_Fixnum:
X return Make_Reduced_Flonum (FLONUM(x)->val / (double)FIXNUM(y));
X case T_Flonum:
X return Make_Reduced_Flonum (FLONUM(x)->val / FLONUM(y)->val);
X case T_Bignum:
X return Make_Reduced_Flonum (FLONUM(x)->val / Bignum_To_Double (y));
X }
X case T_Bignum:
X switch (t) {
X case T_Fixnum:
X GC_Link (x);
X ret = Bignum_Fixnum_Divide (x, y);
X GC_Unlink;
X if (EQ(Cdr (ret),Zero))
X return Car (ret);
X return Make_Reduced_Flonum (Bignum_To_Double (x) /
X (double)FIXNUM(y));
X case T_Flonum:
X return Make_Reduced_Flonum (Bignum_To_Double (x) / FLONUM(y)->val);
X case T_Bignum:
X GC_Link2 (x, y);
X ret = Bignum_Divide (x, y);
X GC_Unlink;
X if (EQ(Cdr (ret),Zero))
X return Car (ret);
X return Make_Reduced_Flonum (Bignum_To_Double (x) /
X Bignum_To_Double (y));
X }
X }
X /*NOTREACHED*/
X}
X
XObject P_Abs (x) Object x; {
X register i;
X
X Check_Number (x);
X switch (TYPE(x)) {
X case T_Fixnum:
X i = FIXNUM(x);
X return i < 0 ? Make_Integer (-i) : x;
X case T_Flonum:
X return Make_Reduced_Flonum (fabs (FLONUM(x)->val));
X case T_Bignum:
X return Bignum_Abs (x);
X }
X /*NOTREACHED*/
X}
X
XObject General_Integer_Divide (x, y, rem) Object x, y; {
X register fx = FIXNUM(x), fy = FIXNUM(y);
X Object b, ret;
X GC_Node;
X
X Check_Integer (x);
X Check_Integer (y);
X if (TYPE(y) == T_Fixnum ? FIXNUM(y) == 0 : Bignum_Zero (y))
X Range_Error (y);
X switch (TYPE(x)) {
X case T_Fixnum:
X switch (TYPE(y)) {
X case T_Fixnum:
X return Make_Fixnum (rem ? (fx % fy) : (fx / fy));
X case T_Bignum:
X GC_Link (y);
X b = Integer_To_Bignum (fx);
X GC_Unlink;
X ret = Bignum_Divide (b, y);
Xdone:
X return rem ? Cdr (ret) : Car (ret);
X }
X case T_Bignum:
X switch (TYPE(y)) {
X case T_Fixnum:
X ret = Bignum_Fixnum_Divide (x, y);
X goto done;
X case T_Bignum:
X ret = Bignum_Divide (x, y);
X goto done;
X }
X }
X /*NOTREACHED*/
X}
X
XObject P_Quotient (x, y) Object x, y; {
X return General_Integer_Divide (x, y, 0);
X}
X
XObject P_Remainder (x, y) Object x, y; {
X return General_Integer_Divide (x, y, 1);
X}
X
XObject P_Modulo (x, y) Object x, y; {
X Object rem, xneg, yneg;
X GC_Node2;
X
X GC_Link2 (x, y);
X rem = General_Integer_Divide (x, y, 1);
X xneg = P_Negativep (x);
X yneg = P_Negativep (y);
X if (!EQ(xneg,yneg))
X rem = Generic_Plus (rem, y);
X GC_Unlink;
X return rem;
X}
X
XObject gcd (x, y) Object x, y; {
X Object r, z;
X GC_Node2;
X
X Check_Integer (x);
X Check_Integer (y);
X GC_Link2 (x, y);
X while (1) {
X z = P_Zerop (x);
X if (EQ(z,True)) {
X r = y;
X break;
X }
X z = P_Zerop (y);
X if (EQ(z,True)) {
X r = x;
X break;
X }
X r = General_Integer_Divide (x, y, 1);
X x = y;
X y = r;
X }
X GC_Unlink;
X return r;
X}
X
XObject P_Gcd (argc, argv) Object *argv; {
X return P_Abs (General_Operator (argc, argv, Zero, gcd));
X}
X
XObject lcm (x, y) Object x, y; {
X Object ret, p, z;
X GC_Node3;
X
X ret = Null;
X GC_Link3 (x, y, ret);
X ret = gcd (x, y);
X z = P_Zerop (ret);
X if (!EQ(z,True)) {
X p = Generic_Multiply (x, y);
X ret = General_Integer_Divide (p, ret, 0);
X }
X GC_Unlink;
X return ret;
X}
X
XObject P_Lcm (argc, argv) Object *argv; {
X return P_Abs (General_Operator (argc, argv, One, lcm));
X}
X
X#define General_Conversion(name,op) Object name (x) Object x; {\
X double d; int expo;\
X \
X Check_Number (x);\
X if (TYPE(x) != T_Flonum)\
X return x;\
X d = op (FLONUM(x)->val);\
X (void)frexp (d, &expo);\
X return (expo <= VALBITS-1) ? Make_Fixnum ((int)d) : Double_To_Bignum (d);\
X}
X
X#define trunc(x) (x)
X#define round(x) ((x) >= 0 ? (x) + 0.5 : (x) - 0.5)
X
XGeneral_Conversion (P_Floor, floor)
XGeneral_Conversion (P_Ceiling, ceil)
XGeneral_Conversion (P_Truncate, trunc)
XGeneral_Conversion (P_Round, round)
X
Xdouble Get_Double (x) Object x; {
X Check_Number (x);
X switch (TYPE(x)) {
X case T_Fixnum:
X return (double)FIXNUM(x);
X case T_Flonum:
X return FLONUM(x)->val;
X case T_Bignum:
X return Bignum_To_Double (x);
X }
X /*NOTREACHED*/
X}
X
XObject General_Function (x, y, fun) Object x, y; double (*fun)(); {
X double d, ret;
X
X d = Get_Double (x);
X errno = 0;
X if (Nullp (y))
X ret = (*fun) (d);
X else
X ret = (*fun) (d, Get_Double (y));
X if (errno == ERANGE || errno == EDOM)
X Range_Error (x);
X return Make_Reduced_Flonum (ret);
X}
X
XObject P_Sqrt (x) Object x; { return General_Function (x, Null, sqrt); }
X
XObject P_Exp (x) Object x; { return General_Function (x, Null, exp); }
X
XObject P_Log (x) Object x; { return General_Function (x, Null, log); }
X
XObject P_Sin (x) Object x; { return General_Function (x, Null, sin); }
X
XObject P_Cos (x) Object x; { return General_Function (x, Null, cos); }
X
XObject P_Tan (x) Object x; { return General_Function (x, Null, tan); }
X
XObject P_Asin (x) Object x; { return General_Function (x, Null, asin); }
X
XObject P_Acos (x) Object x; { return General_Function (x, Null, acos); }
X
XObject P_Atan (argc, argv) Object *argv; {
X register a2 = argc == 2;
X return General_Function (argv[0], a2 ? argv[1] : Null, a2 ? atan2 : atan);
X}
X
XObject Min (x, y) Object x, y; {
X return Generic_Less (x, y) ? x : y;
X}
X
XObject Max (x, y) Object x, y; {
X return Generic_Less (x, y) ? y : x;
X}
X
XObject P_Min (argc, argv) Object *argv; {
X return General_Operator (argc, argv, argv[0], Min);
X}
X
XObject P_Max (argc, argv) Object *argv; {
X return General_Operator (argc, argv, argv[0], Max);
X}
X
XObject P_Random () {
X extern long random();
X return Make_Fixnum ((int)random () & ~SIGNMASK);
X}
X
XObject P_Srandom (x) Object x; {
X Check_Integer (x);
X (void)srandom (Get_Integer (x));
X return x;
X}
END_OF_src/math.c
if test 14868 -ne `wc -c <src/math.c`; then
echo shar: \"src/math.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/special.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/special.c\"
else
echo shar: Extracting \"src/special.c\" \(9557 characters\)
sed "s/^X//" >src/special.c <<'END_OF_src/special.c'
X/* Miscellaneous special forms
X */
X
X#include "scheme.h"
X
Xstatic Object Sym_Else;
X
XInit_Special () {
X Define_Symbol (&Sym_Else, "else");
X}
X
XObject P_Quote (argl) Object argl; {
X return Car (argl);
X}
X
XObject Quasiquote (x, level) Object x; {
X Object form, list, tail, cell, qcar, qcdr, ret;
X TC_Prolog;
X
X if (TYPE(x) != T_Pair)
X return x;
X if (EQ(Car (x), Sym_Unquote)) {
X x = Cdr (x);
X if (TYPE(x) != T_Pair)
X Primitive_Error ("bad unquote form: ~s", x);
X if (level) {
X ret = Cons (Car (x), Null);
X ret = Quasiquote(ret, level-1);
X ret = Cons (Sym_Unquote, ret);
X } else {
X TC_Disable;
X ret = Eval (Car (x));
X TC_Enable;
X }
X return ret;
X } else if (TYPE(Car (x)) == T_Pair
X && EQ(Car (Car (x)), Sym_Unquote_Splicing)) {
X GC_Node6;
X
X qcdr = Cdr (x);
X form = list = tail = cell = Null;
X x = Car (x);
X if (TYPE(Cdr (x)) != T_Pair)
X Primitive_Error ("bad unquote-splicing form: ~s", x);
X if (level) {
X GC_Link2 (list, qcdr);
X list = Quasiquote(Cdr (x), level-1);
X list = Cons (Sym_Unquote_Splicing, list);
X qcdr = Quasiquote(qcdr, level);
X list = Cons (list, qcdr);
X GC_Unlink;
X return list;
X }
X GC_Link6 (x, qcdr, form, list, tail, cell);
X TC_Disable;
X form = Eval (Car (Cdr (x)));
X TC_Enable;
X for ( ; TYPE(form) == T_Pair; tail = cell, form = Cdr (form)) {
X cell = Cons (Car (form), Null);
X if (Nullp (list))
X list = cell;
X else
X P_Setcdr (tail, cell);
X }
X qcdr = Quasiquote (qcdr, level);
X GC_Unlink;
X if (Nullp (list))
X return qcdr;
X P_Setcdr (tail, qcdr);
X return list;
X } else {
X GC_Node3;
X
X qcar = qcdr = Null;
X GC_Link3 (x, qcar, qcdr);
X if (EQ(Car (x), Sym_Quasiquote)) /* hack! */
X ++level;
X qcar = Quasiquote (Car (x), level);
X qcdr = Quasiquote (Cdr (x), level);
X list = Cons (qcar, qcdr);
X GC_Unlink;
X return list;
X }
X}
X
XObject P_Quasiquote (argl) Object argl; {
X return Quasiquote (Car (argl), 0);
X}
X
XObject P_If (argl) Object argl; {
X Object cond, ret;
X GC_Node;
X TC_Prolog;
X
X GC_Link (argl);
X TC_Disable;
X cond = Eval (Car (argl));
X TC_Enable;
X if (Truep(cond))
X ret = Eval (Car (Cdr (argl)));
X else
X ret = Begin (Cdr (Cdr (argl)));
X GC_Unlink;
X return ret;
X}
X
XObject P_Case (argl) Object argl; {
X Object ret, key, clause, select;
X GC_Node;
X TC_Prolog;
X
X GC_Link (argl);
X ret = False;
X TC_Disable;
X key = Eval (Car (argl));
X for (argl = Cdr (argl); !Nullp (argl); argl = Cdr (argl)) {
X clause = Car (argl);
X Check_List (clause);
X if (Nullp (clause))
X Primitive_Error ("empty clause");
X select = Car (clause);
X if (EQ(select, Sym_Else)) {
X if (!Nullp (Cdr (argl)))
X Primitive_Error ("`else' not in last clause");
X if (Nullp (Cdr (clause)))
X Primitive_Error ("no forms in `else' clause");
X } else if (TYPE(select) == T_Pair) {
X select = P_Memv (key, select);
X } else
X select = P_Eqv (key, select);
X if (Truep (select)) {
X clause = Cdr (clause);
X TC_Enable;
X ret = Nullp (clause) ? True : Begin (clause);
X break;
X }
X }
X TC_Enable;
X GC_Unlink;
X return ret;
X}
X
XObject P_Cond (argl) Object argl; {
X Object ret, clause, guard;
X GC_Node3;
X TC_Prolog;
X
X ret = False;
X clause = guard = Null;
X GC_Link3 (argl, clause, guard);
X TC_Disable;
X for ( ; !Nullp (argl); argl = Cdr (argl)) {
X clause = Car (argl);
X Check_List (clause);
X if (Nullp (clause))
X Primitive_Error ("empty clause");
X guard = Car (clause);
X if (EQ(guard, Sym_Else)) {
X if (!Nullp (Cdr (argl)))
X Primitive_Error ("`else' not in last clause");
X if (Nullp (Cdr (clause)))
X Primitive_Error ("no forms in `else' clause");
X } else
X guard = Eval (Car (clause));
X if (Truep (guard)) {
X clause = Cdr (clause);
X TC_Enable;
X ret = Nullp (clause) ? guard : Begin (clause);
X break;
X }
X }
X TC_Enable;
X GC_Unlink;
X return ret;
X}
X
XObject General_Junction (argl, and) Object argl; register and; {
X Object ret;
X GC_Node;
X TC_Prolog;
X
X ret = and ? True : False;
X if (Nullp (argl))
X return ret;
X GC_Link (argl);
X TC_Disable;
X for ( ; !Nullp (Cdr (argl)); argl = Cdr (argl)) {
X ret = Eval (Car (argl));
X if (and != Truep (ret))
X break;
X }
X TC_Enable;
X if (Nullp (Cdr (argl)))
X ret = Eval (Car (argl));
X GC_Unlink;
X return ret;
X}
X
XObject P_And (argl) Object argl; {
X return General_Junction (argl, 1);
X}
X
XObject P_Or (argl) Object argl; {
X return General_Junction (argl, 0);
X}
X
XObject P_Do (argl) Object argl; {
X Object tail, b, val, test, frame, newframe, len, ret;
X register local_vars;
X GC_Node6;
X TC_Prolog;
X
X b = test = frame = newframe = Null;
X GC_Link6 (argl, tail, b, test, frame, newframe);
X TC_Disable;
X for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
X Check_List (tail);
X b = Car (tail);
X if (Nullp (b))
X Primitive_Error ("bad initialization form");
X val = P_Cdr (b);
X Check_List (val);
X Check_Type (Car (b), T_Symbol);
X if (!Nullp (val))
X val = Eval (Car (val));
X frame = Add_Binding (frame, Car (b), val);
X }
X if (local_vars = !Nullp (frame))
X Push_Frame (frame);
X test = Car (Cdr (argl));
X Check_Type (test, T_Pair);
X while (1) {
X b = Eval (Car (test));
X if (Truep (b))
X break;
X (void)Begin (Cdr (Cdr (argl)));
X if (!local_vars)
X continue;
X newframe = Null;
X for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
X b = Car (tail);
X /* Gosh! This could be done much more
X * efficiently, but I'm too lazy...
X */
X val = Cdr (b);
X len = P_Length (val);
X val = FIXNUM(len) > 1 ? Car (Cdr (val)) : Car (b);
X newframe = Add_Binding (newframe, Car (b), Eval (val));
X }
X Pop_Frame ();
X Push_Frame (newframe);
X }
X Check_List (Cdr (test));
X TC_Enable;
X ret = Begin (Cdr (test));
X if (local_vars)
X Pop_Frame ();
X GC_Unlink;
X return ret;
X}
X
XObject General_Let (argl, disc) Object argl; {
X Object frame, b, val, tail, ret;
X GC_Node5;
X TC_Prolog;
X
X frame = b = val = Null;
X GC_Link5 (argl, frame, b, val, tail);
X TC_Disable;
X for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
X Check_List (tail);
X b = Car (tail);
X if (Nullp (b))
X Primitive_Error ("bad binding form");
X val = P_Cdr (b);
X Check_List (val);
X Check_Type (Car (b), T_Symbol);
X if (!Nullp (val))
X val = Car (val);
X if (disc == 0) {
X val = Eval (val);
X } else if (disc == 1) {
X Push_Frame (frame);
X val = Eval (val);
X Pop_Frame ();
X } else if (disc == 2)
X val = Null;
X frame = Add_Binding (frame, Car (b), val);
X }
X Push_Frame (frame);
X if (disc == 2) {
X for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
X b = Car (tail);
X val = Cdr (b);
X if (Nullp (val)) continue;
X val = Car (val);
X b = Lookup_Symbol (Car (b), 1);
X val = Eval (val);
X Cdr (b) = val;
X SYMBOL(Car (b))->value = val;
X }
X }
X TC_Enable;
X ret = Begin (Cdr (argl));
X Pop_Frame ();
X GC_Unlink;
X return ret;
X}
X
XObject Named_Let (argl) Object argl; {
X Object b, val, tail, vlist, vtail, flist, ftail, cell;
X GC_Node6;
X TC_Prolog;
X
X tail = vlist = vtail = flist = ftail = Null;
X GC_Link6 (argl, tail, vlist, vtail, flist, ftail);
X TC_Disable;
X for (tail = Car (Cdr (argl)); !Nullp (tail); tail = Cdr (tail)) {
X Check_List (tail);
X b = Car (tail);
X if (Nullp (b))
X Primitive_Error ("bad binding form");
X val = P_Cdr (b);
X Check_List (val);
X Check_Type (Car (b), T_Symbol);
X if (!Nullp (val))
X val = Car (val);
X cell = Cons (val, Null);
X if (Nullp (flist))
X flist = cell;
X else
X P_Setcdr (ftail, cell);
X ftail = cell;
X cell = Cons (Car (Car (tail)), Null);
X if (Nullp (vlist))
X vlist = cell;
X else
X P_Setcdr (vtail, cell);
X vtail = cell;
X }
X Push_Frame (Add_Binding (Null, Car (argl), Null));
X tail = Cons (vlist, Cdr (Cdr (argl)));
X tail = P_Lambda (tail);
X COMPOUND(tail)->name = Car (argl);
X b = Lookup_Symbol (Car (argl), 1);
X Cdr (b) = tail;
X SYMBOL(Car (argl))->value = tail;
X TC_Enable;
X tail = Funcall_Compound (tail, flist, 1);
X Pop_Frame ();
X GC_Unlink;
X return tail;
X}
X
XObject P_Let (argl) Object argl; {
X if (TYPE(Car (argl)) == T_Symbol)
X return Named_Let (argl);
X else
X return General_Let (argl, 0);
X}
X
XObject P_Letseq (argl) Object argl; {
X return General_Let (argl, 1);
X}
X
XObject P_Letrec (argl) Object argl; {
X return General_Let (argl, 2);
X}
X
XObject P_Fluid_Let (argl) Object argl; {
X Object b, sym, val, tail, ret;
X register WIND *w, *first = First_Wind, *last = Last_Wind;
X GC_Node5;
X TC_Prolog;
X
X sym = b = val = Null;
X GC_Link5 (argl, sym, b, val, tail);
X TC_Disable;
X for (tail = Car (argl); !Nullp (tail); tail = Cdr (tail)) {
X Check_List (tail);
X b = Car (tail);
X if (Nullp (b))
X Primitive_Error ("bad binding form");
X sym = Car (b);
X val = P_Cdr (b);
X Check_List (val);
X Check_Type (sym, T_Symbol);
X if (!Nullp (val))
X val = Car (val);
X val = Eval (val);
X b = Lookup_Symbol (sym, 1);
X w = (WIND *)alloca (sizeof (WIND));
X Add_Wind (w, Null, Null);
X w->in = Cons (sym, val);
X w->out = Cons (sym, Cdr (b));
X Cdr (b) = val;
X SYMBOL(sym)->value = val;
X }
X ret = Begin (Cdr (argl));
X for (w = Last_Wind; w != last; w = w->prev) {
X sym = Car (w->out); val = Cdr (w->out);
X b = Lookup_Symbol (sym, 0);
X if (Nullp (b))
X Panic ("fluid-let1");
X Cdr (b) = val;
X SYMBOL(sym)->value = val;
X }
X if (Last_Wind = last)
X last->next = 0;
X First_Wind = first;
X GC_Unlink;
X TC_Enable;
X return ret;
X}
END_OF_src/special.c
if test 9557 -ne `wc -c <src/special.c`; then
echo shar: \"src/special.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/dump.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/dump.c\"
else
echo shar: Extracting \"src/dump.c\" \(6831 characters\)
sed "s/^X//" >src/dump.c <<'END_OF_src/dump.c'
X/* Create a.out from running interpreter
X *
X * COFF doesn't work together with dynamic loading.
X * Some of the COFF code has been taken from GNU Emacs's unexec.c
X * (in a modified form).
X */
X
X#include <signal.h>
X
X#include "scheme.h"
X
X#ifdef CAN_DUMP
X
X#include <sys/types.h>
X#include <sys/stat.h>
X
X#ifdef COFF
X# include <filehdr.h>
X# include <aouthdr.h>
X# include <scnhdr.h>
X# include <syms.h>
X# ifndef N_BADMAG
X# define N_BADMAG(x) (0)
X# endif
X#else
X# include <a.out.h>
X#endif
X
XObject Dump_Control_Point;
X
XInit_Dump () {
X Global_GC_Link (Dump_Control_Point);
X}
X
XObject P_Dump (ofile) Object ofile; {
X#ifdef COFF
X static struct scnhdr thdr, dhdr, bhdr, scn;
X static struct filehdr hdr;
X static struct aouthdr ohdr;
X unsigned bias;
X unsigned lnno_start, syms_start;
X unsigned text_scn_start, data_scn_start;
X unsigned data_end;
X int pagemask = PAGESIZE-1;
X#else
X struct exec hdr, shdr;
X unsigned data_start, data_end;
X int pagemask = getpagesize () - 1;
X#endif
X char *afn;
X register n;
X char buf[BUFSIZ];
X Object ret, port;
X int ofd, afd;
X struct stat st;
X GC_Node;
X
X if (!EQ (Curr_Input_Port, Standard_Input_Port) ||
X !EQ (Curr_Output_Port, Standard_Output_Port))
X Primitive_Error ("cannot dump with current ports redirected");
X Flush_Output (Curr_Output_Port);
X Close_All_Files ();
X
X GC_Link (ofile);
X n = stksize ();
X Dump_Control_Point = Make_Control_Point (n);
X SETFAST(ret,saveenv (CONTROL(Dump_Control_Point)->stack));
X if (TYPE(ret) != T_Special) {
X Enable_Interrupts;
X return ret;
X }
X GC_Unlink;
X
X Disable_Interrupts;
X port = General_Open_File (ofile, 0, Null);
X ofd = dup (fileno (PORT(port)->file));
X P_Close_Port (port);
X if (ofd < 0)
X Primitive_Error ("out of file descriptors");
X
X if ((afd = open (myname, 0)) == -1) {
X Saved_Errno = errno;
X close (ofd);
X Primitive_Error ("cannot open a.out file: ~E");
X }
X if (read (afd, (char *)&hdr, sizeof (hdr)) != sizeof (hdr)
X || N_BADMAG(hdr)) {
Xbadaout:
X close (ofd);
X close (afd);
X Primitive_Error ("corrupt a.out file");
X }
X#ifdef COFF
X data_end = ((unsigned)sbrk (0) + pagemask) & ~pagemask;
X syms_start = sizeof (hdr);
X if (hdr.f_opthdr > 0) {
X if (read (afd, (char *)&ohdr, sizeof (ohdr)) != sizeof (ohdr))
X goto badaout;
X }
X for (n = 0; n < hdr.f_nscns; n++) {
X if (read (afd, (char *)&scn, sizeof (scn)) != sizeof (scn))
X goto badaout;
X if (scn.s_scnptr > 0 && syms_start < scn.s_scnptr + scn.s_size)
X syms_start = scn.s_scnptr + scn.s_size;
X if (strcmp (scn.s_name, ".text") == 0)
X thdr = scn;
X else if (strcmp (scn.s_name, ".data") == 0)
X dhdr = scn;
X else if (strcmp (scn.s_name, ".bss") == 0)
X bhdr = scn;
X }
X hdr.f_flags |= (F_RELFLG|F_EXEC);
X ohdr.dsize = data_end - ohdr.data_start;
X ohdr.bsize = 0;
X thdr.s_size = ohdr.tsize;
X thdr.s_scnptr = sizeof (hdr) + sizeof (ohdr)
X + hdr.f_nscns * sizeof (thdr);
X lnno_start = thdr.s_lnnoptr;
X text_scn_start = thdr.s_scnptr;
X dhdr.s_paddr = dhdr.s_vaddr = ohdr.data_start;
X dhdr.s_size = ohdr.dsize;
X dhdr.s_scnptr = thdr.s_scnptr + thdr.s_size;
X data_scn_start = dhdr.s_scnptr;
X bhdr.s_paddr = bhdr.s_vaddr = ohdr.data_start + ohdr.dsize;
X bhdr.s_size = ohdr.bsize;
X bhdr.s_scnptr = 0;
X
X bias = dhdr.s_scnptr + dhdr.s_size - syms_start;
X if (hdr.f_symptr > 0)
X hdr.f_symptr += bias;
X if (thdr.s_lnnoptr > 0)
X thdr.s_lnnoptr += bias;
X
X if (write (ofd, (char *)&hdr, sizeof (hdr)) != sizeof (hdr)) {
Xbadwrite:
X Saved_Errno = errno;
X close (ofd);
X close (afd);
X Primitive_Error ("error writing dump file: ~E");
X }
X if (write (ofd, (char *)&ohdr, sizeof (ohdr)) != sizeof (ohdr))
X goto badwrite;
X if (write (ofd, (char *)&thdr, sizeof (thdr)) != sizeof (thdr))
X goto badwrite;
X if (write (ofd, (char *)&dhdr, sizeof (dhdr)) != sizeof (dhdr))
X goto badwrite;
X if (write (ofd, (char *)&bhdr, sizeof (bhdr)) != sizeof (bhdr))
X goto badwrite;
X lseek (ofd, (long)text_scn_start, 0);
X if (write (ofd, (char *)ohdr.text_start, ohdr.tsize) != ohdr.tsize)
X goto badwrite;
X dumped = 1;
X lseek (ofd, (long)data_scn_start, 0);
X if (write (ofd, (char *)ohdr.data_start, ohdr.dsize) != ohdr.dsize)
X goto badwrite;
X lseek (afd, lnno_start ? (long)lnno_start : (long)syms_start, 0);
X#else
X close (afd);
X data_start = hdr.a_text;
X data_start = (data_start + SEGMENT_SIZE-1) & ~(SEGMENT_SIZE-1);
X data_end = (unsigned)sbrk (0);
X data_end = (data_end + pagemask) & ~pagemask;
X hdr.a_data = data_end - data_start;
X hdr.a_bss = 0;
X hdr.a_trsize = hdr.a_drsize = 0;
X
X afn = Loader_Input;
X if (afn[0] == 0)
X afn = myname;
X if ((afd = open (afn, 0)) == -1) {
X Saved_Errno = errno;
X close (ofd);
X Primitive_Error ("cannot open symbol table file: ~E");
X }
X if (read (afd, (char *)&shdr, sizeof (shdr)) != sizeof (shdr)
X || N_BADMAG(shdr)) {
X close (ofd);
X close (afd);
X Primitive_Error ("corrupt symbol table file");
X }
X hdr.a_syms = shdr.a_syms;
X
X if (write (ofd, (char *)&hdr, sizeof (hdr)) != sizeof(hdr)) {
Xbadwrite:
X Saved_Errno = errno;
X close (ofd);
X close (afd);
X Primitive_Error ("error writing dump file: ~E");
X }
X
X (void)lseek (ofd, (long)FILE_TEXT_START, 0);
X n = hdr.a_text - TEXT_LENGTH_ADJ;
X if (write (ofd, (char *)MEM_TEXT_START, n) != n)
X goto badwrite;
X dumped = 1;
X if (Heap_Start > Free_Start) {
X n = (unsigned)Free_Start - data_start;
X if (write (ofd, (char *)data_start, n) != n)
X goto badwrite;
X (void)lseek (ofd, (long)(Free_End - Free_Start), 1);
X n = Hp - Heap_Start;
X if (write (ofd, Heap_Start, n) != n)
X goto badwrite;
X (void)lseek (ofd, (long)(Heap_End - Hp), 1);
X n = data_end - (unsigned)Heap_End;
X if (write (ofd, Heap_End, n) != n)
X goto badwrite;
X } else {
X n = (unsigned)Hp - data_start;
X if (write (ofd, (char *)data_start, n) != n)
X goto badwrite;
X (void)lseek (ofd, (long)(Free_End - Hp), 1);
X n = data_end - (unsigned)Free_End;
X if (write (ofd, Free_End, n) != n)
X goto badwrite;
X }
X
X (void)lseek (afd, (long)N_SYMOFF(shdr), 0);
X#endif
X while ((n = read (afd, buf, BUFSIZ)) > 0) {
X if (write (ofd, buf, n) != n)
X goto badwrite;
X }
X if (n < 0) {
X Saved_Errno = errno;
X close (ofd);
X close (afd);
X Primitive_Error ("error reading symbol table: ~E");
X }
X close (afd);
X if (fstat (ofd, &st) != -1) {
X int omask = umask (0);
X (void)umask (omask);
X#ifdef FCHMOD_BROKEN
X {
X Object f = PORT(port)->name;
X register n = STRING(f)->size;
X register char *s = alloca (n+1);
X bcopy (STRING(f)->data, s, n);
X s[n] = '\0';
X (void)chmod (s, st.st_mode & 0777 | 0111 & ~omask);
X }
X#else
X (void)fchmod (ofd, st.st_mode & 0777 | 0111 & ~omask);
X#endif
X }
X close (ofd);
X Enable_Interrupts;
X return False;
X}
X#endif
END_OF_src/dump.c
if test 6831 -ne `wc -c <src/dump.c`; then
echo shar: \"src/dump.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/type.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/type.c\"
else
echo shar: Extracting \"src/type.c\" \(2756 characters\)
sed "s/^X//" >src/type.c <<'END_OF_src/type.c'
X/* Types
X */
X
X#include "scheme.h"
X
X/*ARGSUSED*/
XDummy_Visit (p, fp) Object *p, (*fp)(); {
X Panic ("Dummy_Visit");
X}
X
X/* User-defined types must be greater than T_Last and less than MAX_TYPE.
X */
XTYPEDESCR Types[MAX_TYPE] = {
X { 0, "integer", 0, 0, 0, 0, 0, 0, },
X { 1, "integer", /*bignum*/ 0, 0, 0, 0, 0, 0, },
X { 1, "real", 0, 0, 0, 0, 0, 0, },
X { 0, "null", 0, 0, 0, 0, 0, 0, },
X { 0, "boolean", 0, 0, 0, 0, 0, 0, },
X { 0, "void", 0, 0, 0, 0, 0, 0, },
X { 0, "unbound", 0, 0, 0, 0, 0, 0, },
X { 0, "special", 0, 0, 0, 0, 0, 0, },
X { 0, "character", 0, 0, 0, 0, 0, 0, },
X { 1, "symbol", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "pair", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "environment", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "string", 0, 0, 0, 0, 0, 0, },
X { 1, "vector", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "primitive", 0, 0, 0, 0, 0, 0, },
X { 1, "compound", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "control-point", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "promise", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "port", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 0, "end-of-file", 0, 0, 0, 0, 0, 0, },
X { 1, "autoload", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "macro", 0, 0, 0, 0, 0, Dummy_Visit, },
X { 1, "!!broken-heart!!", 0, 0, 0, 0, 0, 0, },
X};
X
XWrong_Type (x, t) Object x; register t; {
X Wrong_Type_Combination (x, Types[t].name);
X}
X
XWrong_Type_Combination (x, name) Object x; register char *name; {
X register t = TYPE(x);
X register char *p;
X char buf[100];
X
X if (t < 0 || t >= MAX_TYPE || !(p = Types[t].name))
X Panic ("bad type");
X sprintf (buf, "wrong argument type %s (expected %s)", p, name);
X Primitive_Error (buf);
X}
X
XObject P_Type (x) Object x; {
X register t = TYPE(x);
X register char *p;
X
X if (t < 0 || t >= MAX_TYPE || !(p = Types[t].name))
X Panic ("bad type");
X return Intern (p);
X}
X
XDefine_Type (t, name, size, const_size, eqv, equal, print, visit) register t;
X char *name;
X int (*size)(), (*eqv)(), (*equal)(), (*print)(), (*visit)(); {
X register TYPEDESCR *p;
X
X Error_Tag = "define-type";
X if (t == 0) {
X for (t = T_Last+1; t < MAX_TYPE && Types[t].name; t++)
X ;
X if (t == MAX_TYPE)
X Primitive_Error ("out of types");
X } else {
X if (t < 0 || t >= MAX_TYPE)
X Primitive_Error ("bad type");
X if (Types[t].name)
X Primitive_Error ("type already in use");
X }
X p = &Types[t];
X p->haspointer = 1; /* Assumption */
X p->name = name;
X p->size = size;
X p->const_size = const_size;
X p->eqv = eqv;
X p->equal = equal;
X p->print = print;
X p->visit = visit;
X return t;
X}
X
XObject P_Voidp (x) Object x; { /* Don't know a better place for this. */
X return TYPE(x) == T_Void ? True : False;
X}
END_OF_src/type.c
if test 2756 -ne `wc -c <src/type.c`; then
echo shar: \"src/type.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/bool.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/bool.c\"
else
echo shar: Extracting \"src/bool.c\" \(2385 characters\)
sed "s/^X//" >src/bool.c <<'END_OF_src/bool.c'
X/* Booleans, Equality/Equivalence
X */
X
X#include "scheme.h"
X
XObject P_Booleanp (x) Object x; {
X return TYPE(x) == T_Boolean ? True : False;
X}
X
XObject P_Not (x) Object x; {
X return Truep (x) ? False : True;
X}
X
XObject P_Eq (x1, x2) Object x1, x2; {
X return EQ(x1, x2) ? True : False;
X}
X
XObject P_Eqv (x1, x2) Object x1, x2; {
X return Eqv (x1, x2) ? True : False;
X}
X
XObject P_Equal (x1, x2) Object x1, x2; {
X return Equal (x1, x2) ? True : False;
X}
X
XEqv (x1, x2) Object x1, x2; {
X register t1, t2;
X if (EQ(x1, x2))
X return 1;
X t1 = TYPE(x1);
X t2 = TYPE(x2);
X if (Numeric (t1) && Numeric (t2))
X return Generic_Equal (x1, x2);
X if (t1 != t2)
X return 0;
X switch (t1) {
X case T_String:
X return STRING(x1)->size == 0 && STRING(x2)->size == 0;
X case T_Vector:
X return VECTOR(x1)->size == 0 && VECTOR(x2)->size == 0;
X case T_Primitive:
X return strcmp (PRIM(x1)->name, PRIM(x2)->name) == 0;
X default:
X if (t1 < 0 || t1 >= MAX_TYPE || !Types[t1].name)
X Panic ("bad type in eqv");
X if (Types[t1].eqv == NOFUNC)
X return 0;
X return (*Types[t1].eqv)(x1, x2);
X }
X /*NOTREACHED*/
X}
X
XEqual (x1, x2) Object x1, x2; {
X register t1, t2, i;
X
Xagain:
X if (EQ(x1, x2))
X return 1;
X t1 = TYPE(x1);
X t2 = TYPE(x2);
X if (Numeric (t1) && Numeric (t2))
X return Generic_Equal (x1, x2);
X if (t1 != t2)
X return 0;
X switch (t1) {
X case T_Boolean:
X case T_Character:
X case T_Compound:
X case T_Control_Point:
X case T_Promise:
X case T_Port:
X case T_Macro:
X return 0;
X case T_Primitive:
X return Eqv (x1, x2);
X case T_Symbol:
X return Equal (SYMBOL(x1)->name, SYMBOL(x2)->name) &&
X Equal (SYMBOL(x1)->plist, SYMBOL(x2)->plist);
X case T_Environment:
X case T_Pair:
X if (!Equal (Car (x1), Car (x2)))
X return 0;
X x1 = Cdr (x1); x2 = Cdr (x2);
X goto again;
X case T_String:
X return STRING(x1)->size == STRING(x2)->size &&
X bcmp (STRING(x1)->data, STRING(x2)->data, STRING(x1)->size) == 0;
X case T_Vector:
X if (VECTOR(x1)->size != VECTOR(x2)->size)
X return 0;
X for (i = 0; i < VECTOR(x1)->size; i++)
X if (!Equal (VECTOR(x1)->data[i], VECTOR(x2)->data[i]))
X return 0;
X return 1;
X default:
X if (t1 < 0 || t1 >= MAX_TYPE || !Types[t1].name)
X Panic ("bad type in equal");
X if (Types[t1].equal == NOFUNC)
X return 0;
X return (*Types[t1].equal)(x1, x2);
X }
X /*NOTREACHED*/
X}
END_OF_src/bool.c
if test 2385 -ne `wc -c <src/bool.c`; then
echo shar: \"src/bool.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/bignum.c -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/bignum.c\"
else
echo shar: Extracting \"src/bignum.c\" \(15711 characters\)
sed "s/^X//" >src/bignum.c <<'END_OF_src/bignum.c'
X/* Bignum arithmetic
X */
X
X#include <math.h>
X#include <ctype.h>
X
X#include "scheme.h"
X
XObject Make_Uninitialized_Bignum (size) {
X register char *p;
X Object big;
X
X p = Get_Bytes ((sizeof (struct S_Bignum) - sizeof (gran_t)) +
X (size * sizeof (gran_t)));
X SET(big, T_Bignum, (struct S_Bignum *)p);
X BIGNUM(big)->minusp = False;
X BIGNUM(big)->size = size;
X BIGNUM(big)->usize = 0;
X return big;
X}
X
XObject Copy_Bignum (x) Object x; {
X Object big;
X register size;
X GC_Node;
X
X GC_Link (x);
X big = Make_Uninitialized_Bignum (size = BIGNUM(x)->usize);
X BIGNUM(big)->minusp = BIGNUM(x)->minusp;
X BIGNUM(big)->usize = size;
X bcopy ((char *)BIGNUM(x)->data, (char *)BIGNUM(big)->data,
X size * sizeof (gran_t));
X GC_Unlink;
X return big;
X}
X
XObject Copy_S_Bignum (s) struct S_Bignum *s; {
X Object big;
X register size;
X
X big = Make_Uninitialized_Bignum (size = s->usize);
X BIGNUM(big)->minusp = s->minusp;
X BIGNUM(big)->usize = size;
X bcopy ((char *)s->data, (char *)BIGNUM(big)->data,
X size * sizeof (gran_t));
X return big;
X}
X
XObject Make_Bignum (buf, neg, base) char *buf; {
X Object big;
X register char *p;
X register c;
X register size = (strlen (buf) + 4) / 4;
X
X big = Make_Uninitialized_Bignum (size);
X BIGNUM(big)->minusp = neg ? True : False;
X p = buf;
X while (c = *p++) {
X Bignum_Mult_In_Place (BIGNUM(big), base);
X if (base == 16) {
X if (isupper (c))
X c = tolower (c);
X if (c >= 'a')
X c = '9' + c - 'a' + 1;
X }
X Bignum_Add_In_Place (BIGNUM(big), c - '0');
X }
X Bignum_Normalize_In_Place (BIGNUM(big)); /* to avoid -0 */
X return big;
X}
X
XObject Reduce_Bignum (x) Object x; {
X register i;
X register struct S_Bignum *p = BIGNUM(x);
X
X if (p->usize > 2 || (p->usize == 2 && p->data[1] >= 32768))
X return x;
X i = Bignum_To_Integer (x);
X if (!FIXNUM_FITS(i))
X return x;
X return Make_Fixnum (i);
X}
X
XBignum_Mult_In_Place (x, n) register struct S_Bignum *x; {
X register i = x->usize;
X register gran_t *p = x->data;
X register j;
X register unsigned k = 0;
X
X for (j = 0; j < i; ++j) {
X k += n * *p;
X *p++ = k;
X k >>= 16;
X }
X if (k) {
X if (i >= x->size)
X Panic ("Bignum_Mult_In_Place");
X *p++ = k;
X x->usize++;
X }
X}
X
XBignum_Add_In_Place (x, n) register struct S_Bignum *x; {
X register i = x->usize;
X register gran_t *p = x->data;
X register j = 0;
X register unsigned k = n;
X
X if (i == 0) goto extend;
X k += *p;
X *p++ = k;
X while (k >>= 16) {
X if (++j >= i) {
X extend:
X if (i >= x->size)
X Panic ("Bignum_Add_In_Place");
X *p++ = k;
X x->usize++;
X return;
X }
X k += *p;
X *p++ = k;
X }
X}
X
XBignum_Div_In_Place (x, n) register struct S_Bignum *x; {
X register i = x->usize;
X register gran_t *p = x->data + i;
X register unsigned k = 0;
X for ( ; i; --i) {
X k <<= 16;
X k += *--p;
X *p = k / n;
X k %= n;
X }
X Bignum_Normalize_In_Place (x);
X return k;
X}
X
XBignum_Normalize_In_Place (x) register struct S_Bignum *x; {
X register i = x->usize;
X register gran_t *p = x->data + i;
X while (i && !*--p)
X --i;
X x->usize = i;
X if (!i)
X x->minusp = False;
X}
X
XPrint_Bignum (port, x) Object port, x; {
X register char *buf, *p;
X register size;
X register struct S_Bignum *big;
X
X if (Bignum_Zero (x)) {
X Printf (port, "0");
X return;
X }
X
X size = BIGNUM(x)->usize * 5 + 3;
X buf = alloca (size + 1);
X p = buf + size;
X *p = 0;
X
X size = (sizeof (struct S_Bignum) - sizeof (gran_t))
X + BIGNUM(x)->usize * sizeof (gran_t);
X big = (struct S_Bignum *)alloca (size);
X bcopy ((char *)POINTER(x), (char *)big, size);
X big->size = BIGNUM(x)->usize;
X
X while (big->usize) {
X register unsigned bigdig = Bignum_Div_In_Place (big, 10000);
X *--p = '0' + bigdig % 10;
X bigdig /= 10;
X *--p = '0' + bigdig % 10;
X bigdig /= 10;
X *--p = '0' + bigdig % 10;
X bigdig /= 10;
X *--p = '0' + bigdig;
X }
X while (*p == '0')
X ++p;
X if (Truep (BIGNUM(x)->minusp))
X Printf (port, "-");
X Format (port, p, strlen (p), 0, (Object *)0);
X}
X
XBignum_To_Integer (x) Object x; {
X unsigned n = 0;
X int s = BIGNUM(x)->usize;
X
X if (s) {
X n = BIGNUM(x)->data[0];
X if (s > 1) {
X n |= BIGNUM(x)->data[1] << 16;
X if (s > 2)
Xerr:
X Primitive_Error ("integer out of range: ~s", x);
X }
X }
X if (Truep (BIGNUM(x)->minusp)) {
X if (n > (~(unsigned)0 >> 1) + 1)
X goto err;
X return -n;
X } else {
X if (n > ~(unsigned)0 >> 1)
X goto err;
X return n;
X }
X}
X
XObject Integer_To_Bignum (i) {
X Object big = Make_Uninitialized_Bignum (2);
X unsigned n = i;
X
X if (i < 0) {
X BIGNUM(big)->minusp = True;
X n = -i;
X }
X BIGNUM(big)->data[0] = n;
X BIGNUM(big)->data[1] = n >> 16;
X BIGNUM(big)->usize = 2;
X Bignum_Normalize_In_Place (BIGNUM(big));
X return big;
X}
X
XObject Unsigned_To_Bignum (i) unsigned i; {
X Object big = Make_Uninitialized_Bignum (2);
X
X BIGNUM(big)->data[0] = i;
X BIGNUM(big)->data[1] = i >> 16;
X BIGNUM(big)->usize = 2;
X Bignum_Normalize_In_Place (BIGNUM(big));
X return big;
X}
X
XObject Double_To_Bignum (d) double d; { /* Truncates the double */
X Object big;
X int expo, size;
X double mantissa = frexp (d, &expo);
X register gran_t *p;
X
X if (expo <= 0 || mantissa == 0.0)
X return Make_Uninitialized_Bignum (0);
X size = (expo + (16-1)) / 16;
X big = Make_Uninitialized_Bignum (size);
X BIGNUM(big)->usize = size;
X if (mantissa < 0.0) {
X BIGNUM(big)->minusp = True;
X mantissa = -mantissa;
X }
X p = BIGNUM(big)->data;
X bzero ((char *)p, size * sizeof (gran_t));
X p += size;
X if (expo &= (16-1))
X mantissa = ldexp (mantissa, expo - 16);
X while (mantissa != 0.0) {
X if (--size < 0)
X break; /* inexact */
X mantissa *= 65536.0;
X *--p = (int)mantissa;
X mantissa -= *p;
X }
X Bignum_Normalize_In_Place (BIGNUM(big)); /* Probably not needed */
X return Reduce_Bignum (big);
X}
X
Xdouble Bignum_To_Double (x) Object x; { /* error if it ain't fit */
X double rx = 0.0;
X register i = BIGNUM(x)->usize;
X register gran_t *p = BIGNUM(x)->data + i;
X
X for (i = BIGNUM(x)->usize; --i >= 0; ) {
X if (rx >= HUGE / 65536.0)
X Primitive_Error ("cannot coerce to real: ~s", x);
X rx *= 65536.0;
X rx += *--p;
X }
X if (Truep (BIGNUM(x)->minusp))
X rx = -rx;
X return rx;
X}
X
XBignum_Zero (x) Object x; {
X return BIGNUM(x)->usize == 0;
X}
X
XBignum_Negative (x) Object x; {
X return Truep (BIGNUM(x)->minusp);
X}
X
XBignum_Positive (x) Object x; {
X return !Truep (BIGNUM(x)->minusp) && BIGNUM(x)->usize != 0;
X}
X
XBignum_Even (x) Object x; {
X return BIGNUM(x)->usize == 0 || (BIGNUM(x)->data[0] & 1) == 0;
X}
X
XObject Bignum_Abs (x) Object x; {
X Object big;
X
X big = Copy_Bignum (x);
X BIGNUM(big)->minusp = False;
X return big;
X}
X
XBignum_Mantissa_Cmp (x, y) register struct S_Bignum *x, *y; {
X register i = x->usize;
X if (i < y->usize)
X return -1;
X else if (i > y->usize)
X return 1;
X else {
X register gran_t *xbuf = x->data + i;
X register gran_t *ybuf = y->data + i;
X for ( ; i; --i) {
X register n;
X if (n = (int)*--xbuf - (int)*--ybuf)
X return n;
X }
X return 0;
X }
X}
X
XBignum_Cmp (x, y) register struct S_Bignum *x, *y; {
X register xm = Truep (x->minusp);
X register ym = Truep (y->minusp);
X if (xm) {
X if (ym)
X return -Bignum_Mantissa_Cmp (x, y);
X else return -1;
X } else {
X if (ym)
X return 1;
X else return Bignum_Mantissa_Cmp (x, y);
X }
X}
X
XBignum_Equal (x, y) Object x, y; {
X return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) == 0;
X}
X
XBignum_Less (x, y) Object x, y; {
X return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) < 0;
X}
X
XBignum_Greater (x, y) Object x, y; {
X return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) > 0;
X}
X
XBignum_Eq_Less (x, y) Object x, y; {
X return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) <= 0;
X}
X
XBignum_Eq_Greater (x, y) Object x, y; {
X return Bignum_Cmp (BIGNUM(x), BIGNUM(y)) >= 0;
X}
X
XObject General_Bignum_Plus_Minus (x, y, neg) Object x, y; {
X Object big;
X int size, xsize, ysize, xminusp, yminusp;
X GC_Node2;
X
X GC_Link2 (x,y);
X xsize = BIGNUM(x)->usize;
X ysize = BIGNUM(y)->usize;
X xminusp = Truep (BIGNUM(x)->minusp);
X yminusp = Truep (BIGNUM(y)->minusp);
X if (neg)
X yminusp = !yminusp;
X size = xsize > ysize ? xsize : ysize;
X if (xminusp == yminusp)
X size++;
X big = Make_Uninitialized_Bignum (size);
X BIGNUM(big)->usize = size;
X GC_Unlink;
X
X if (xminusp == yminusp) {
X /* Add x and y */
X register unsigned k = 0;
X register i;
X register gran_t *xbuf = BIGNUM(x)->data;
X register gran_t *ybuf = BIGNUM(y)->data;
X register gran_t *zbuf = BIGNUM(big)->data;
X for (i = 0; i < size; ++i) {
X if (i < xsize)
X k += *xbuf++;
X if (i < ysize)
X k += *ybuf++;
X *zbuf++ = k;
X k >>= 16;
X }
X } else {
X if (Bignum_Mantissa_Cmp (BIGNUM(x), BIGNUM(y)) < 0) {
X Object temp = x;
X x = y; y = temp;
X xsize = ysize;
X ysize = BIGNUM(y)->usize;
X xminusp = yminusp;
X }
X /* Subtract y from x */
X {
X register unsigned k = 1;
X register i;
X register gran_t *xbuf = BIGNUM(x)->data;
X register gran_t *ybuf = BIGNUM(y)->data;
X register gran_t *zbuf = BIGNUM(big)->data;
X for (i = 0; i < size; ++i) {
X if (i < xsize)
X k += *xbuf++;
X else Panic ("General_Bignum_Plus_Minus");
X if (i < ysize)
X k += ~*ybuf++ & 0xFFFF;
X else k += 0xFFFF;
X *zbuf++ = k;
X k >>= 16;
X }
X }
X }
X BIGNUM(big)->minusp = xminusp ? True : False;
X Bignum_Normalize_In_Place (BIGNUM(big));
X return Reduce_Bignum (big);
X}
X
XObject Bignum_Plus (x, y) Object x, y; { /* bignum + bignum */
X return General_Bignum_Plus_Minus (x, y, 0);
X}
X
XObject Bignum_Minus (x, y) Object x, y; { /* bignum - bignum */
X return General_Bignum_Plus_Minus (x, y, 1);
X}
X
XObject Bignum_Fixnum_Multiply (x, y) Object x, y; { /* bignum * fixnum */
X Object big;
X register size, xsize, i;
X register gran_t *xbuf, *zbuf;
X int yn = FIXNUM(y);
X register unsigned yl, yh;
X GC_Node;
X
X GC_Link (x);
X xsize = BIGNUM(x)->usize;
X size = xsize + 2;
X big = Make_Uninitialized_Bignum (size);
X BIGNUM(big)->usize = size;
X if (Truep (BIGNUM(x)->minusp) != (yn < 0))
X BIGNUM(big)->minusp = True;
X bzero ((char *)BIGNUM(big)->data, size * sizeof (gran_t));
X xbuf = BIGNUM(x)->data;
X if (yn < 0)
X yn = -yn;
X yl = yn & 0xFFFF;
X yh = yn >> 16;
X zbuf = BIGNUM(big)->data;
X for (i = 0; i < xsize; ++i) {
X register unsigned xf = xbuf[i];
X register unsigned k = 0;
X register gran_t *r = zbuf + i;
X k += xf * yl + *r;
X *r++ = k;
X k >>= 16;
X k += xf * yh + *r;
X *r++ = k;
X k >>= 16;
X *r = k;
X }
X GC_Unlink;
X Bignum_Normalize_In_Place (BIGNUM(big));
X return Reduce_Bignum (big);
X}
X
XObject Bignum_Multiply (x, y) Object x, y; { /* bignum * bignum */
X Object big;
X register size, xsize, ysize, i, j;
X register gran_t *xbuf, *ybuf, *zbuf;
X GC_Node2;
X
X GC_Link2 (x, y);
X xsize = BIGNUM(x)->usize;
X ysize = BIGNUM(y)->usize;
X size = xsize + ysize;
X big = Make_Uninitialized_Bignum (size);
X BIGNUM(big)->usize = size;
X if (!EQ(BIGNUM(x)->minusp, BIGNUM(y)->minusp))
X BIGNUM(big)->minusp = True;
X bzero ((char *)BIGNUM(big)->data, size * sizeof (gran_t));
X xbuf = BIGNUM(x)->data;
X ybuf = BIGNUM(y)->data;
X zbuf = BIGNUM(big)->data;
X for (i = 0; i < xsize; ++i) {
X register unsigned xf = xbuf[i];
X register unsigned k = 0;
X register gran_t *p = ybuf;
X register gran_t *r = zbuf + i;
X for (j = 0; j < ysize; ++j) {
X k += xf * *p++ + *r;
X *r++ = k;
X k >>= 16;
X }
X *r = k;
X }
X GC_Unlink;
X Bignum_Normalize_In_Place (BIGNUM(big));
X return Reduce_Bignum (big);
X}
X
X/* Returns cons cell (quotient . remainder); cdr is a fixnum
X */
XObject Bignum_Fixnum_Divide (x, y) Object x, y; { /* bignum / fixnum */
X Object big;
X register xsize, i;
X register gran_t *xbuf, *zbuf;
X int yn = FIXNUM(y);
X int xminusp, yminusp = 0;
X register unsigned rem;
X GC_Node;
X
X GC_Link (x);
X if (yn < 0) {
X yn = -yn;
X yminusp = 1;
X }
X if (yn > 0xFFFF) {
X big = Integer_To_Bignum (FIXNUM(y));
X GC_Unlink;
X return Bignum_Divide (x, big);
X }
X xsize = BIGNUM(x)->usize;
X big = Make_Uninitialized_Bignum (xsize);
X BIGNUM(big)->usize = xsize;
X xminusp = Truep (BIGNUM(x)->minusp);
X if (xminusp != yminusp)
X BIGNUM(big)->minusp = True;
X xbuf = BIGNUM(x)->data;
X zbuf = BIGNUM(big)->data;
X rem = 0;
X for (i = xsize; --i >= 0; ) {
X rem <<= 16;
X rem += xbuf[i];
X zbuf[i] = rem / yn;
X rem %= yn;
X }
X GC_Unlink;
X Bignum_Normalize_In_Place (BIGNUM(big));
X if (xminusp)
X rem = -(int)rem;
X return Cons (Reduce_Bignum (big), Make_Fixnum ((int)rem));
X}
X
X/* Returns cons cell (quotient . remainder); cdr is a fixnum
X */
XObject Bignum_Divide (x, y) Object x, y; { /* bignum / bignum */
X struct S_Bignum *dend, *dor;
X int quotsize, dendsize, dorsize, scale;
X unsigned dor1, dor2;
X Object quot, rem;
X register gran_t *qp, *dendp;
X GC_Node2;
X
X if (BIGNUM(y)->usize < 2)
X return Bignum_Fixnum_Divide (x, Make_Fixnum (Bignum_To_Integer (y)));
X
X GC_Link2 (x, y);
X quotsize = BIGNUM(x)->usize - BIGNUM(y)->usize + 1;
X if (quotsize < 0)
X quotsize = 0;
X quot = Make_Uninitialized_Bignum (quotsize);
X GC_Unlink;
X
X dendsize = (sizeof (struct S_Bignum) - sizeof (gran_t))
X + (BIGNUM(x)->usize + 1) * sizeof (gran_t);
X dend = (struct S_Bignum *)alloca (dendsize);
X bcopy ((char *)POINTER(x), (char *)dend, dendsize);
X dend->size = BIGNUM(x)->usize + 1;
X
X if (quotsize == 0 || Bignum_Mantissa_Cmp (dend, BIGNUM(y)) < 0)
X goto zero;
X
X dorsize = (sizeof (struct S_Bignum) - sizeof (gran_t))
X + BIGNUM (y)->usize * sizeof (gran_t);
X dor = (struct S_Bignum *)alloca (dorsize);
X bcopy ((char *)POINTER(y), (char *)dor, dorsize);
X dor->size = dorsize = BIGNUM(y)->usize;
X
X scale = 65536 / (dor->data[dor->usize - 1] + 1);
X Bignum_Mult_In_Place (dend, scale);
X if (dend->usize < dend->size)
X dend->data[dend->usize++] = 0;
X Bignum_Mult_In_Place (dor, scale);
X
X BIGNUM(quot)->usize = BIGNUM(quot)->size;
X qp = BIGNUM(quot)->data + BIGNUM(quot)->size;
X dendp = dend->data + dend->usize;
X dor1 = dor->data[dor->usize - 1];
X dor2 = dor->data[dor->usize - 2];
X
X while (qp > BIGNUM(quot)->data) {
X unsigned msw, guess;
X int k;
X register gran_t *dep, *dop, *edop;
X
X msw = dendp[-1] << 16 | dendp[-2];
X guess = msw / dor1;
X if (guess >= 65536) /* [65535, 0, 0] / [65535, 65535] */
X guess = 65535;
X for (;;) {
X unsigned d1, d2, d3;
X d3 = dor2 * guess;
X d2 = dor1 * guess + (d3 >> 16);
X d3 &= 0xFFFF;
X d1 = d2 >> 16;
X d2 &= 0xFFFF;
X if (d1 < dendp[-1] || (d1 == dendp[-1] &&
X (d2 < dendp[-2] || (d2 == dendp[-2] &&
X d3 <= dendp[-3]))))
X break;
X --guess;
X }
X --dendp;
X k = 0;
X dep = dendp - dorsize;
X for (dop = dor->data, edop = dop + dor->usize; dop < edop; ) {
X register unsigned prod = *dop++ * guess;
X k += *dep;
X k -= prod & 0xFFFF;
X *dep++ = k;
X k >>= 16;
X k -= prod >> 16;
X }
X k += *dep;
X *dep = k;
X if (k < 0) {
X k = 0;
X dep = dendp - dorsize;
X for (dop = dor->data, edop = dop + dor->usize; dop < edop; ) {
X k += *dep + *dop++;
X *dep++ = k;
X k >>= 16;
X }
X k += *dep;
X *dep = k;
X --guess;
X }
X *--qp = guess;
X }
X
X if (Bignum_Div_In_Place (dend, scale))
X Panic ("Bignum_Div scale");
X zero:
X if (Truep (dend->minusp = BIGNUM(x)->minusp) != Truep (BIGNUM(y)->minusp))
X BIGNUM(quot)->minusp = True;
X Bignum_Normalize_In_Place (BIGNUM(quot));
X Bignum_Normalize_In_Place (dend);
X GC_Link (quot);
X rem = Reduce_Bignum (Copy_S_Bignum (dend));
X GC_Unlink;
X return Cons (Reduce_Bignum (quot), rem);
X}
END_OF_src/bignum.c
if test 15711 -ne `wc -c <src/bignum.c`; then
echo shar: \"src/bignum.c\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test -f src/alloca.s.386 -a "${1}" != "-c" ; then
echo shar: Will not over-write existing file \"src/alloca.s.386\"
else
echo shar: Extracting \"src/alloca.s.386\" \(125 characters\)
sed "s/^X//" >src/alloca.s.386 <<'END_OF_src/alloca.s.386'
X .file "alloca.s"
X .globl alloca
X
Xalloca:
X popl %edx
X subl 0(%esp),%esp
X andl $0xfffffffc,%esp
X leal 4(%esp),%eax
X jmp *%edx
END_OF_src/alloca.s.386
if test 125 -ne `wc -c <src/alloca.s.386`; then
echo shar: \"src/alloca.s.386\" unpacked with wrong size!
fi
# end of overwriting check
fi
if test ! -d tst ; then
echo shar: Creating directory \"tst\"
mkdir tst
fi
echo shar: End of archive 6 \(of 14\).
cp /dev/null ark6isdone
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