v08i054: Elk (Extension Language Toolkit) part 06 of 14

Brandon S. Allbery - comp.sources.misc allbery at uunet.UU.NET
Sun Sep 24 07:40:48 AEST 1989


Posting-number: Volume 8, Issue 54
Submitted-by: net at 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 at 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



More information about the Comp.sources.misc mailing list