Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (04/15/90)
Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock)
Posting-number: Volume 90, Issue 141
Archive-name: applications/xscheme-0.20/part03
#!/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 3 (of 7)."
# Contents: Src/xscheme.h Src/xsdmem.c Src/xsftab.c Src/xsmath.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:24 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/xscheme.h' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xscheme.h'\"
else
echo shar: Extracting \"'Src/xscheme.h'\" \(13100 characters\)
sed "s/^X//" >'Src/xscheme.h' <<'END_OF_FILE'
X/* xscheme.h - xscheme definitions */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X/* system specific definitions */
X#define AZTEC_AMIGA
X
X#include <stdio.h>
X#include <ctype.h>
X#include <setjmp.h>
X
X/* FORWARD type of a forward declaration () */
X/* LOCAL type of a local function (static) */
X/* AFMT printf format for addresses ("%x") */
X/* OFFTYPE number the size of an address (int) */
X/* FIXTYPE data type for fixed point numbers (long) */
X/* ITYPE fixed point input conversion routine type (long atol()) */
X/* ICNV fixed point input conversion routine (atol) */
X/* IFMT printf format for fixed point numbers ("%ld") */
X/* FLOTYPE data type for floating point numbers (float) */
X/* FFMT printf format for floating point numbers (%.15g) */
X
X/* for the Lightspeed C compiler - Macintosh */
X#ifdef LSC
X#define AFMT "%lx"
X#define OFFTYPE long
X#define NIL (void *)0
X#define MACINTOSH
X#endif
X
X/* for the UNIX System V C compiler */
X#ifdef UNIX
X#endif
X
X/* for the Aztec C compiler - Amiga */
X#ifdef AZTEC_AMIGA
X#define AFMT "%lx"
X#define OFFTYPE long
X#define FLOTYPE double
X#endif
X
X/* for the Mark Williams C compiler - Atari ST */
X#ifdef MWC
X#define AFMT "%lx"
X#define OFFTYPE long
X#endif
X
X/* for the Microsoft C 5.0 compiler */
X#ifdef MSC
X#define AFMT "%lx"
X#define OFFTYPE long
X#define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16))
X#define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) < (LVAL huge *)(t))
X/* #define MSDOS -- MSC 5.0 defines this automatically */
X#endif
X
X/* for the Turbo C compiler */
X#ifdef _TURBOC_
X#define AFMT "%lx"
X#define OFFTYPE long
X#define INSEGMENT(n,s) (((OFFTYPE)(n) >> 16) == ((OFFTYPE)(s) >> 16))
X#define VCOMPARE(f,s,t) ((LVAL huge *)(f) + (s) < (LVAL huge *)(t))
X#define MSDOS
X#endif
X
X/* size of each type of memory segment */
X#ifndef NSSIZE
X#define NSSIZE 4000 /* number of nodes per node segment */
X#endif
X#ifndef VSSIZE
X#define VSSIZE 10000 /* number of LVAL's per vector segment */
X#endif
X
X/* default important definitions */
X#ifndef FORWARD
X#define FORWARD
X#endif
X#ifndef LOCAL
X#define LOCAL static
X#endif
X#ifndef AFMT
X#define AFMT "%x"
X#endif
X#ifndef OFFTYPE
X#define OFFTYPE int
X#endif
X#ifndef FIXTYPE
X#define FIXTYPE long
X#endif
X#ifndef ITYPE
X#define ITYPE long atol()
X#endif
X#ifndef ICNV
X#define ICNV(n) atol(n)
X#endif
X#ifndef IFMT
X#define IFMT "%ld"
X#endif
X#ifndef FLOTYPE
X#define FLOTYPE double
X#endif
X#ifndef FFMT
X#define FFMT "%.15g"
X#endif
X#ifndef SFIXMIN
X#define SFIXMIN -1048576
X#define SFIXMAX 1048575
X#endif
X#ifndef INSEGMENT
X#define INSEGMENT(n,s) ((n) >= &(s)->ns_data[0] \
X && (n) < &(s)->ns_data[0] + (s)->ns_size)
X#endif
X#ifndef VCOMPARE
X#define VCOMPARE(f,s,t) ((f) + (s) < (t))
X#endif
X
X/* useful definitions */
X#define TRUE 1
X#define FALSE 0
X#ifndef NIL
X#define NIL (LVAL)0
X#endif
X
X/* program limits */
X#define STRMAX 100 /* maximum length of a string constant */
X#define HSIZE 199 /* symbol hash table size */
X#define SAMPLE 100 /* control character sample rate */
X
X/* stack manipulation macros */
X#define check(n) { if (xlsp - (n) < xlstkbase) xlstkover(); }
X#define cpush(v) { if (xlsp > xlstkbase) push(v); else xlstkover(); }
X#define push(v) (*--xlsp = (v))
X#define pop() (*xlsp++)
X#define top() (*xlsp)
X#define settop(v) (*xlsp = (v))
X#define drop(n) (xlsp += (n))
X
X/* argument list parsing macros */
X#define xlgetarg() (testarg(nextarg()))
X#define xllastarg() {if (xlargc != 0) xltoomany();}
X#define xlpoprest() {xlsp += xlargc;}
X#define testarg(e) (moreargs() ? (e) : xltoofew())
X#define typearg(tp) (tp(*xlsp) ? nextarg() : xlbadtype(*xlsp))
X#define nextarg() (--xlargc, *xlsp++)
X#define moreargs() (xlargc > 0)
X
X/* macros to get arguments of a particular type */
X#define xlgacons() (testarg(typearg(consp)))
X#define xlgalist() (testarg(typearg(listp)))
X#define xlgasymbol() (testarg(typearg(symbolp)))
X#define xlgastring() (testarg(typearg(stringp)))
X#define xlgaobject() (testarg(typearg(objectp)))
X#define xlgafixnum() (testarg(typearg(fixp)))
X#define xlganumber() (testarg(typearg(numberp)))
X#define xlgachar() (testarg(typearg(charp)))
X#define xlgavector() (testarg(typearg(vectorp)))
X#define xlgaport() (testarg(typearg(portp)))
X#define xlgaiport() (testarg(typearg(iportp)))
X#define xlgaoport() (testarg(typearg(oportp)))
X#define xlgaclosure() (testarg(typearg(closurep)))
X#define xlgaenv() (testarg(typearg(envp)))
X
X/* node types */
X#define FREE 0
X#define CONS 1
X#define SYMBOL 2
X#define FIXNUM 3
X#define FLONUM 4
X#define STRING 5
X#define OBJECT 6
X#define PORT 7
X#define VECTOR 8
X#define CLOSURE 9
X#define METHOD 10
X#define CODE 11
X#define SUBR 12
X#define XSUBR 13
X#define CSUBR 14
X#define CONTINUATION 15
X#define CHAR 16
X#define PROMISE 17
X#define ENV 18
X
X/* node flags */
X#define MARK 1
X#define LEFT 2
X
X/* port flags */
X#define PF_INPUT 1
X#define PF_OUTPUT 2
X#define PF_BINARY 4
X
X/* new node access macros */
X#define ntype(x) ((OFFTYPE)(x) & 1 ? FIXNUM : (x)->n_type)
X
X/* macro to determine if a non-nil value is a pointer */
X#define ispointer(x) (((OFFTYPE)(x) & 1) == 0)
X
X/* type predicates */
X#define atom(x) ((x) == NIL || ntype(x) != CONS)
X#define null(x) ((x) == NIL)
X#define listp(x) ((x) == NIL || ntype(x) == CONS)
X#define numberp(x) ((x) && ntype(x) == FIXNUM || ntype(x) == FLONUM)
X#define boundp(x) (getvalue(x) != s_unbound)
X#define iportp(x) (portp(x) && (getpflags(x) & PF_INPUT) != 0)
X#define oportp(x) (portp(x) && (getpflags(x) & PF_OUTPUT) != 0)
X
X/* basic type predicates */
X#define consp(x) ((x) && ntype(x) == CONS)
X#define stringp(x) ((x) && ntype(x) == STRING)
X#define symbolp(x) ((x) && ntype(x) == SYMBOL)
X#define portp(x) ((x) && ntype(x) == PORT)
X#define objectp(x) ((x) && ntype(x) == OBJECT)
X#define fixp(x) ((x) && ntype(x) == FIXNUM)
X#define floatp(x) ((x) && ntype(x) == FLONUM)
X#define vectorp(x) ((x) && ntype(x) == VECTOR)
X#define closurep(x) ((x) && ntype(x) == CLOSURE)
X#define codep(x) ((x) && ntype(x) == CODE)
X#define methodp(x) ((x) && ntype(x) == METHOD)
X#define subrp(x) ((x) && ntype(x) == SUBR)
X#define xsubrp(x) ((x) && ntype(x) == XSUBR)
X#define charp(x) ((x) && ntype(x) == CHAR)
X#define promisep(x) ((x) && ntype(x) == PROMISE)
X#define envp(x) ((x) && ntype(x) == ENV)
X#define booleanp(x) ((x) == NIL || ntype(x) == BOOLEAN)
X
X/* cons access macros */
X#define car(x) ((x)->n_car)
X#define cdr(x) ((x)->n_cdr)
X#define rplaca(x,y) ((x)->n_car = (y))
X#define rplacd(x,y) ((x)->n_cdr = (y))
X
X/* symbol access macros */
X#define getvalue(x) ((x)->n_vdata[0])
X#define setvalue(x,v) ((x)->n_vdata[0] = (v))
X#define getpname(x) ((x)->n_vdata[1])
X#define setpname(x,v) ((x)->n_vdata[1] = (v))
X#define getplist(x) ((x)->n_vdata[2])
X#define setplist(x,v) ((x)->n_vdata[2] = (v))
X#define SYMSIZE 3
X
X/* vector access macros */
X#define getsize(x) ((x)->n_vsize)
X#define getelement(x,i) ((x)->n_vdata[i])
X#define setelement(x,i,v) ((x)->n_vdata[i] = (v))
X
X/* object access macros */
X#define getclass(x) ((x)->n_vdata[1])
X#define setclass(x,v) ((x)->n_vdata[1] = (v))
X#define getivar(x,i) ((x)->n_vdata[i])
X#define setivar(x,i,v) ((x)->n_vdata[i] = (v))
X
X/* promise access macros */
X#define getpproc(x) ((x)->n_car)
X#define setpproc(x,v) ((x)->n_car = (v))
X#define getpvalue(x) ((x)->n_cdr)
X#define setpvalue(x,v) ((x)->n_cdr = (v))
X
X/* closure access macros */
X#define getcode(x) ((x)->n_car)
X#define getenv(x) ((x)->n_cdr)
X
X/* code access macros */
X#define getbcode(x) ((x)->n_vdata[0])
X#define setbcode(x,v) ((x)->n_vdata[0] = (v))
X#define getcname(x) ((x)->n_vdata[1])
X#define setcname(x,v) ((x)->n_vdata[1] = (v))
X#define getvnames(x) ((x)->n_vdata[2])
X#define setvnames(x,v) ((x)->n_vdata[2] = (v))
X#define FIRSTLIT 3
X
X/* fixnum/flonum/character access macros */
X#define getfixnum(x) ((OFFTYPE)(x) & 1 ? getsfixnum(x) : (x)->n_int)
X#define getflonum(x) ((x)->n_flonum)
X#define getchcode(x) ((x)->n_chcode)
X
X/* small fixnum access macros */
X#define cvsfixnum(x) ((LVAL)(((OFFTYPE)x << 1) | 1))
X#define getsfixnum(x) ((FIXTYPE)((OFFTYPE)(x) >> 1))
X
X/* string access macros */
X#define getstring(x) ((unsigned char *)(x)->n_vdata)
X#define getslength(x) ((x)->n_vsize)
X
X/* iport/oport access macros */
X#define getfile(x) ((x)->n_fp)
X#define setfile(x,v) ((x)->n_fp = (v))
X#define getsavech(x) ((x)->n_savech)
X#define setsavech(x,v) ((x)->n_savech = (v))
X#define getpflags(x) ((x)->n_pflags)
X#define setpflags(x,v) ((x)->n_pflags = (v))
X
X/* subr access macros */
X#define getsubr(x) ((x)->n_subr)
X#define getoffset(x) ((x)->n_offset)
X
X/* list node */
X#define n_car n_info.n_xlist.xl_car
X#define n_cdr n_info.n_xlist.xl_cdr
X
X/* integer node */
X#define n_int n_info.n_xint.xi_int
X
X/* flonum node */
X#define n_flonum n_info.n_xflonum.xf_flonum
X
X/* character node */
X#define n_chcode n_info.n_xchar.xc_chcode
X
X/* string node */
X#define n_str n_info.n_xstr.xst_str
X#define n_strlen n_info.n_xstr.xst_length
X
X/* file pointer node */
X#define n_fp n_info.n_xfptr.xf_fp
X#define n_savech n_info.n_xfptr.xf_savech
X#define n_pflags n_info.n_xfptr.xf_pflags
X
X/* vector/object node */
X#define n_vsize n_info.n_xvect.xv_size
X#define n_vdata n_info.n_xvect.xv_data
X
X/* subr node */
X#define n_subr n_info.n_xsubr.xs_subr
X#define n_offset n_info.n_xsubr.xs_offset
X
X/* node structure */
Xtypedef struct node {
X char n_type; /* type of node */
X char n_flags; /* flag bits */
X union ninfo { /* value */
X struct xlist { /* list node (cons) */
X struct node *xl_car; /* the car pointer */
X struct node *xl_cdr; /* the cdr pointer */
X } n_xlist;
X struct xint { /* integer node */
X FIXTYPE xi_int; /* integer value */
X } n_xint;
X struct xflonum { /* flonum node */
X FLOTYPE xf_flonum; /* flonum value */
X } n_xflonum;
X struct xchar { /* character node */
X int xc_chcode; /* character code */
X } n_xchar;
X struct xstr { /* string node */
X int xst_length; /* string length */
X unsigned char *xst_str; /* string pointer */
X } n_xstr;
X struct xfptr { /* file pointer node */
X FILE *xf_fp; /* the file pointer */
X short xf_savech; /* lookahead character for input files */
X short xf_pflags; /* port flags */
X } n_xfptr;
X struct xvect { /* vector node */
X int xv_size; /* vector size */
X struct node **xv_data; /* vector data */
X } n_xvect;
X struct xsubr { /* subr/fsubr node */
X struct node *(*xs_subr)(); /* function pointer */
X int xs_offset; /* offset into funtab */
X } n_xsubr;
X } n_info;
X} NODE,*LVAL;
X
X/* memory allocator definitions */
X
X/* macros to compute the size of a segment */
X#define nsegsize(n) (sizeof(NSEGMENT)+((n)-1)*sizeof(struct node))
X#define vsegsize(n) (sizeof(VSEGMENT)+((n)-1)*sizeof(LVAL))
X
X/* macro to convert a byte size to a word size */
X#define btow_size(n) (((n) + sizeof(LVAL) - 1) / sizeof(LVAL))
X
X/* node segment structure */
Xtypedef struct nsegment {
X struct nsegment *ns_next; /* next node segment */
X unsigned int ns_size; /* number of nodes in this segment */
X struct node ns_data[1]; /* segment data */
X} NSEGMENT;
X
X/* vector segment structure */
Xtypedef struct vsegment {
X struct vsegment *vs_next; /* next vector segment */
X LVAL *vs_free; /* next free location in this segment */
X LVAL *vs_top; /* top of segment (plus one) */
X LVAL vs_data[1]; /* segment data */
X} VSEGMENT;
X
X/* function definition structure */
Xtypedef struct {
X char *fd_name; /* function name */
X LVAL (*fd_subr)(); /* function entry point */
X} FUNDEF;
X
X/* external variables */
Xextern LVAL *xlstkbase; /* base of value stack */
Xextern LVAL *xlstktop; /* top of value stack */
Xextern LVAL *xlsp; /* value stack pointer */
Xextern int xlargc; /* argument count for current call */
X
X/* external routine declarations */
Xextern LVAL cons(); /* (cons x y) */
Xextern LVAL xlenter(); /* enter a symbol */
Xextern LVAL xlgetprop(); /* get the value of a property */
Xextern LVAL cvsymbol(); /* convert a string to a symbol */
Xextern LVAL cvstring(); /* convert a string */
Xextern LVAL cvfixnum(); /* convert a fixnum */
Xextern LVAL cvflonum(); /* convert a flonum */
Xextern LVAL cvchar(); /* convert a character */
Xextern LVAL cvclosure(); /* convert code and an env to a closure */
Xextern LVAL cvmethod(); /* convert code and an env to a method */
Xextern LVAL cvsubr(); /* convert a function into a subr */
Xextern LVAL cvport(); /* convert a file pointer to an input port */
Xextern LVAL cvpromise(); /* convert a procedure to a promise */
Xextern LVAL newstring(); /* create a new string */
Xextern LVAL newobject(); /* create a new object */
Xextern LVAL newvector(); /* create a new vector */
Xextern LVAL newcode(); /* create a new code object */
Xextern LVAL newcontinuation(); /* create a new continuation object */
Xextern LVAL newframe(); /* create a new environment frame */
Xextern LVAL newnode(); /* create a new node */
Xextern LVAL xltoofew(); /* report "too few arguments" */
Xextern LVAL xlbadtype(); /* report "wrong argument type" */
Xextern LVAL curinput(); /* get the current input port */
Xextern LVAL curoutput(); /* get the current output port */
END_OF_FILE
if test 13100 -ne `wc -c <'Src/xscheme.h'`; then
echo shar: \"'Src/xscheme.h'\" unpacked with wrong size!
fi
# end of 'Src/xscheme.h'
fi
if test -f 'Src/xsdmem.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsdmem.c'\"
else
echo shar: Extracting \"'Src/xsdmem.c'\" \(15137 characters\)
sed "s/^X//" >'Src/xsdmem.c' <<'END_OF_FILE'
X/* xsdmem.c - xscheme dynamic memory management routines */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* virtual machine registers */
XLVAL xlfun=NIL; /* current function */
XLVAL xlenv=NIL; /* current environment */
XLVAL xlval=NIL; /* value of most recent instruction */
XLVAL *xlsp=NULL; /* value stack pointer */
X
X/* stack limits */
XLVAL *xlstkbase=NULL; /* base of value stack */
XLVAL *xlstktop=NULL; /* top of value stack (actually, one beyond) */
X
X/* variables shared with xsimage.c */
XFIXTYPE total=0; /* total number of bytes of memory in use */
XFIXTYPE gccalls=0; /* number of calls to the garbage collector */
X
X/* node space */
XNSEGMENT *nsegments=NULL; /* list of node segments */
XNSEGMENT *nslast=NULL; /* last node segment */
Xint nscount=0; /* number of node segments */
XFIXTYPE nnodes=0; /* total number of nodes */
XFIXTYPE nfree=0; /* number of nodes in free list */
XLVAL fnodes=NIL; /* list of free nodes */
X
X/* vector (and string) space */
XVSEGMENT *vsegments=NULL; /* list of vector segments */
XVSEGMENT *vscurrent=NULL; /* current vector segment */
Xint vscount=0; /* number of vector segments */
XLVAL *vfree=NULL; /* next free location in vector space */
XLVAL *vtop=NULL; /* top of vector space */
X
X/* external variables */
Xextern LVAL s_unbound; /* *UNBOUND* symbol */
Xextern LVAL obarray; /* *OBARRAY* symbol */
Xextern LVAL default_object; /* default object */
Xextern LVAL eof_object; /* eof object */
Xextern LVAL true; /* truth value */
X
X/* external routines */
Xextern unsigned char *calloc();
X
X/* forward declarations */
XFORWARD LVAL allocnode();
XFORWARD LVAL allocvector();
X
X/* cons - construct a new cons node */
XLVAL cons(x,y)
X LVAL x,y;
X{
X LVAL nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X check(2);
X push(x);
X push(y);
X findmemory();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X drop(2);
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X --nfree;
X
X /* initialize the new node */
X nnode->n_type = CONS;
X rplaca(nnode,x);
X rplacd(nnode,y);
X
X /* return the new node */
X return (nnode);
X}
X
X/* newframe - create a new environment frame */
XLVAL newframe(parent,size)
X LVAL parent; int size;
X{
X LVAL frame;
X frame = cons(newvector(size),parent);
X frame->n_type = ENV;
X return (frame);
X}
X
X/* cvstring - convert a string to a string node */
XLVAL cvstring(str)
X unsigned char *str;
X{
X LVAL val;
X val = newstring(strlen(str)+1);
X strcpy(getstring(val),str);
X return (val);
X}
X
X/* cvsymbol - convert a string to a symbol */
XLVAL cvsymbol(pname)
X unsigned char *pname;
X{
X LVAL val;
X val = allocvector(SYMBOL,SYMSIZE);
X cpush(val);
X setvalue(val,s_unbound);
X setpname(val,cvstring(pname));
X setplist(val,NIL);
X return (pop());
X}
X
X/* cvfixnum - convert an integer to a fixnum node */
XLVAL cvfixnum(n)
X FIXTYPE n;
X{
X LVAL val;
X if (n >= SFIXMIN && n <= SFIXMAX)
X return (cvsfixnum(n));
X val = allocnode(FIXNUM);
X val->n_int = n;
X return (val);
X}
X
X/* cvflonum - convert a floating point number to a flonum node */
XLVAL cvflonum(n)
X FLOTYPE n;
X{
X LVAL val;
X val = allocnode(FLONUM);
X val->n_flonum = n;
X return (val);
X}
X
X/* cvchar - convert an integer to a character node */
XLVAL cvchar(ch)
X int ch;
X{
X LVAL val;
X val = allocnode(CHAR);
X val->n_chcode = ch;
X return (val);
X}
X
X/* cvclosure - convert code and an environment to a closure */
XLVAL cvclosure(code,env)
X LVAL code,env;
X{
X LVAL val;
X val = cons(code,env);
X val->n_type = CLOSURE;
X return (val);
X}
X
X/* cvpromise - convert a procedure to a promise */
XLVAL cvpromise(code,env)
X LVAL code,env;
X{
X LVAL val;
X val = cons(cvclosure(code,env),NIL);
X val->n_type = PROMISE;
X return (val);
X}
X
X/* cvmethod - convert code and an environment to a method */
XLVAL cvmethod(code,class)
X LVAL code,class;
X{
X LVAL val;
X val = cons(code,class);
X val->n_type = METHOD;
X return (val);
X}
X
X/* cvsubr - convert a function to a subr/xsubr */
XLVAL cvsubr(type,fcn,offset)
X int type; LVAL (*fcn)(); int offset;
X{
X LVAL val;
X val = allocnode(type);
X val->n_subr = fcn;
X val->n_offset = offset;
X return (val);
X}
X
X/* cvport - convert a file pointer to an port */
XLVAL cvport(fp,flags)
X FILE *fp; int flags;
X{
X LVAL val;
X val = allocnode(PORT);
X setfile(val,fp);
X setsavech(val,'\0');
X setpflags(val,flags);
X return (val);
X}
X
X/* newvector - allocate and initialize a new vector */
XLVAL newvector(size)
X int size;
X{
X return (allocvector(VECTOR,size));
X}
X
X/* newstring - allocate and initialize a new string */
XLVAL newstring(size)
X int size;
X{
X LVAL val;
X val = allocvector(STRING,btow_size(size));
X val->n_vsize = size;
X return (val);
X}
X
X/* newcode - create a new code object */
XLVAL newcode(nlits)
X int nlits;
X{
X return (allocvector(CODE,nlits));
X}
X
X/* newcontinuation - create a new continuation object */
XLVAL newcontinuation(size)
X int size;
X{
X return (allocvector(CONTINUATION,size));
X}
X
X/* newobject - allocate and initialize a new object */
XLVAL newobject(cls,size)
X LVAL cls; int size;
X{
X LVAL val;
X val = allocvector(OBJECT,size+2); /* class, ivars */
X setclass(val,cls);
X return (val);
X}
X
X/* allocnode - allocate a new node */
XLOCAL LVAL allocnode(type)
X int type;
X{
X LVAL nnode;
X
X /* get a free node */
X if ((nnode = fnodes) == NIL) {
X findmemory();
X if ((nnode = fnodes) == NIL)
X xlabort("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(nnode);
X --nfree;
X
X /* initialize the new node */
X nnode->n_type = type;
X rplacd(nnode,NIL);
X
X /* return the new node */
X return (nnode);
X}
X
X/* findmemory - garbage collect, then add more node space if necessary */
XLOCAL findmemory()
X{
X /* first try garbage collecting */
X gc();
X
X /* expand memory only if less than one segment is free */
X if (nfree < (long)NSSIZE)
X nexpand(1);
X}
X
X/* nexpand - expand node space */
Xnexpand(n)
X int n;
X{
X NSEGMENT *newnsegment(),*newseg;
X LVAL p;
X int i;
X
X /* try to add n segments */
X while (--n >= 0) {
X
X /* allocate the new segment */
X if ((newseg = newnsegment(NSSIZE)) == NULL)
X return;
X
X /* add each new node to the free list */
X p = &newseg->ns_data[0];
X for (i = NSSIZE; --i >= 0; ++p) {
X p->n_type = FREE;
X p->n_flags = 0;
X rplacd(p,fnodes);
X fnodes = p;
X }
X }
X}
X
X/* allocvector - allocate and initialize a new vector node */
XLOCAL LVAL allocvector(type,size)
X int type,size;
X{
X register LVAL val,*p;
X register int i;
X
X /* get a free node */
X if ((val = fnodes) == NIL) {
X findmemory();
X if ((val = fnodes) == NIL)
X xlabort("insufficient node space");
X }
X
X /* unlink the node from the free list */
X fnodes = cdr(fnodes);
X --nfree;
X
X /* initialize the vector node */
X val->n_type = type;
X val->n_vsize = size;
X val->n_vdata = NULL;
X cpush(val);
X
X /* add space for the backpointer */
X ++size;
X
X /* make sure there's enough space */
X if (!VCOMPARE(vfree,size,vtop)) {
X findvmemory(size);
X if (!VCOMPARE(vfree,size,vtop))
X xlabort("insufficient vector space");
X }
X
X /* allocate the next available block */
X p = vfree;
X vfree += size;
X
X /* store the backpointer */
X *p++ = top();
X val->n_vdata = p;
X
X /* set all the elements to NIL */
X for (i = size; i > 1; --i)
X *p++ = NIL;
X
X /* return the new vector */
X return (pop());
X}
X
X/* findvmemory - find vector memory */
Xfindvmemory(size)
X int size;
X{
X gc();
X makevmemory(size);
X}
X
X/* makevmemory - make vector memory (used by 'xsimage.c') */
Xmakevmemory(size)
X int size;
X{
X VSEGMENT *vseg;
X
X /* look for a vector segment with enough space */
X for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
X if (VCOMPARE(vseg->vs_free,size,vseg->vs_top)) {
X if (vscurrent != NULL)
X vscurrent->vs_free = vfree;
X vfree = vseg->vs_free;
X vtop = vseg->vs_top;
X vscurrent = vseg;
X return;
X }
X
X /* allocate a new vector segment and make it current */
X vexpand(1);
X}
X
X/* vexpand - expand vector space */
Xvexpand(n)
X int n;
X{
X VSEGMENT *newvsegment(),*vseg;
X
X /* try to add n segments */
X while (--n >= 0) {
X if ((vseg = newvsegment(VSSIZE)) == NULL)
X return;
X if (vscurrent != NULL)
X vscurrent->vs_free = vfree;
X vfree = vseg->vs_free;
X vtop = vseg->vs_top;
X vscurrent = vseg;
X }
X}
X
X/* newnsegment - create a new node segment */
XNSEGMENT *newnsegment(n)
X unsigned int n;
X{
X NSEGMENT *newseg;
X
X /* allocate the new segment */
X if ((newseg = (NSEGMENT *)calloc(1,nsegsize(n))) == NULL)
X return (NULL);
X
X /* initialize the new segment */
X newseg->ns_size = n;
X newseg->ns_next = NULL;
X if (nsegments)
X nslast->ns_next = newseg;
X else
X nsegments = newseg;
X nslast = newseg;
X
X /* update the statistics */
X total += (long)nsegsize(n);
X nnodes += (long)n;
X nfree += (long)n;
X ++nscount;
X
X /* return the new segment */
X return (newseg);
X}
X
X/* newvsegment - create a new vector segment */
XVSEGMENT *newvsegment(n)
X unsigned int n;
X{
X VSEGMENT *newseg;
X
X /* allocate the new segment */
X if ((newseg = (VSEGMENT *)calloc(1,vsegsize(n))) == NULL)
X return (NULL);
X
X /* initialize the new segment */
X newseg->vs_free = &newseg->vs_data[0];
X newseg->vs_top = newseg->vs_free + n;
X newseg->vs_next = vsegments;
X vsegments = newseg;
X
X /* update the statistics */
X total += (long)vsegsize(n);
X ++vscount;
X
X /* return the new segment */
X return (newseg);
X}
X
X/* gc - garbage collect */
Xgc()
X{
X register LVAL *p,tmp;
X int compact();
X
X /* mark the obarray and the current environment */
X if (obarray && ispointer(obarray))
X mark(obarray);
X if (xlfun && ispointer(xlfun))
X mark(xlfun);
X if (xlenv && ispointer(xlenv))
X mark(xlenv);
X if (xlval && ispointer(xlval))
X mark(xlval);
X if (default_object && ispointer(default_object))
X mark(default_object);
X if (eof_object && ispointer(eof_object))
X mark(eof_object);
X if (true && ispointer(true))
X mark(true);
X
X /* mark the stack */
X for (p = xlsp; p < xlstktop; ++p)
X if ((tmp = *p) && ispointer(tmp))
X mark(tmp);
X
X /* compact vector space */
X gc_protect(compact);
X
X /* sweep memory collecting all unmarked nodes */
X sweep();
X
X /* count the gc call */
X ++gccalls;
X}
X
X/* mark - mark all accessible nodes */
XLOCAL mark(ptr)
X LVAL ptr;
X{
X register LVAL this,prev,tmp;
X
X /* initialize */
X prev = NIL;
X this = ptr;
X
X /* mark this node */
X for (;;) {
X
X /* descend as far as we can */
X while (!(this->n_flags & MARK))
X
X /* mark this node and trace its children */
X switch (this->n_type) {
X case CONS: /* mark cons-like nodes */
X case CLOSURE:
X case METHOD:
X case PROMISE:
X case ENV:
X this->n_flags |= MARK;
X if ((tmp = car(this)) && ispointer(tmp)) {
X this->n_flags |= LEFT;
X rplaca(this,prev);
X prev = this;
X this = tmp;
X }
X else if ((tmp = cdr(this)) && ispointer(tmp)) {
X rplacd(this,prev);
X prev = this;
X this = tmp;
X }
X break;
X case SYMBOL: /* mark vector-like nodes */
X case OBJECT:
X case VECTOR:
X case CODE:
X case CONTINUATION:
X this->n_flags |= MARK;
X markvector(this);
X break;
X default: /* mark all other types of nodes */
X this->n_flags |= MARK;
X break;
X }
X
X /* backup to a point where we can continue descending */
X for (;;)
X
X /* make sure there is a previous node */
X if (prev) {
X if (prev->n_flags & LEFT) { /* came from left side */
X prev->n_flags &= ~LEFT;
X tmp = car(prev);
X rplaca(prev,this);
X if ((this = cdr(prev)) && ispointer(this)) {
X rplacd(prev,tmp);
X break;
X }
X }
X else { /* came from right side */
X tmp = cdr(prev);
X rplacd(prev,this);
X }
X this = prev; /* step back up the branch */
X prev = tmp;
X }
X
X /* no previous node, must be done */
X else
X return;
X }
X}
X
X/* markvector - mark a vector-like node */
XLOCAL markvector(vect)
X LVAL vect;
X{
X register LVAL tmp,*p;
X register int n;
X if (p = vect->n_vdata) {
X n = getsize(vect);
X while (--n >= 0)
X if ((tmp = *p++) != NULL && ispointer(tmp))
X mark(tmp);
X }
X}
X
X/* compact - compact vector space */
XLOCAL compact()
X{
X VSEGMENT *vseg;
X
X /* store the current segment information */
X if (vscurrent)
X vscurrent->vs_free = vfree;
X
X /* compact each vector segment */
X for (vseg = vsegments; vseg != NULL; vseg = vseg->vs_next)
X compact_vector(vseg);
X
X /* make the first vector segment current */
X if (vscurrent = vsegments) {
X vfree = vscurrent->vs_free;
X vtop = vscurrent->vs_top;
X }
X}
X
X/* compact_vector - compact a vector segment */
XLOCAL compact_vector(vseg)
X VSEGMENT *vseg;
X{
X register LVAL *vdata,*vnext,*vfree,vector;
X register int vsize;
X
X vdata = vnext = &vseg->vs_data[0];
X vfree = vseg->vs_free;
X while (vdata < vfree) {
X vector = *vdata;
X if (vector->n_type == STRING)
X vsize = btow_size(vector->n_vsize) + 1;
X else
X vsize = vector->n_vsize + 1;
X if (vector->n_flags & MARK) {
X if (vdata == vnext) {
X vdata += vsize;
X vnext += vsize;
X }
X else {
X vector->n_vdata = vnext + 1;
X while (vsize > 0) {
X *vnext++ = *vdata++;
X --vsize;
X }
X }
X }
X else
X vdata += vsize;
X }
X vseg->vs_free = vnext;
X}
X
X/* sweep - sweep all unmarked nodes and add them to the free list */
XLOCAL sweep()
X{
X NSEGMENT *nseg;
X
X /* empty the free list */
X fnodes = NIL;
X nfree = 0L;
X
X /* sweep each node segment */
X for (nseg = nsegments; nseg != NULL; nseg = nseg->ns_next)
X sweep_segment(nseg);
X}
X
X/* sweep_segment - sweep a node segment */
XLOCAL sweep_segment(nseg)
X NSEGMENT *nseg;
X{
X register FIXTYPE n;
X register LVAL p;
X
X /* add all unmarked nodes */
X for (p = &nseg->ns_data[0], n = nseg->ns_size; --n >= 0L; ++p)
X if (!(p->n_flags & MARK)) {
X switch (p->n_type) {
X case PORT:
X if (getfile(p))
X osclose(getfile(p));
X break;
X }
X p->n_type = FREE;
X rplacd(p,fnodes);
X fnodes = p;
X ++nfree;
X }
X else
X p->n_flags &= ~MARK;
X}
X
X/* xlminit - initialize the dynamic memory module */
Xxlminit(ssize)
X unsigned int ssize;
X{
X unsigned int n;
X
X /* initialize our internal variables */
X gccalls = 0;
X total = 0L;
X
X /* initialize node space */
X nsegments = nslast = NULL;
X nscount = 0;
X nnodes = nfree = 0L;
X fnodes = NIL;
X
X /* initialize vector space */
X vsegments = vscurrent = NULL;
X vscount = 0;
X vfree = vtop = NULL;
X
X /* allocate the value stack */
X n = ssize * sizeof(LVAL);
X if ((xlstkbase = (LVAL *)calloc(1,n)) == NULL)
X xlfatal("insufficient memory");
X total += (long)n;
X
X /* initialize structures that are marked by the collector */
X obarray = default_object = eof_object = true = NIL;
X xlfun = xlenv = xlval = NIL;
X
X /* initialize the stack */
X xlsp = xlstktop = xlstkbase + ssize;
X}
END_OF_FILE
if test 15137 -ne `wc -c <'Src/xsdmem.c'`; then
echo shar: \"'Src/xsdmem.c'\" unpacked with wrong size!
fi
# end of 'Src/xsdmem.c'
fi
if test -f 'Src/xsftab.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsftab.c'\"
else
echo shar: Extracting \"'Src/xsftab.c'\" \(14063 characters\)
sed "s/^X//" >'Src/xsftab.c' <<'END_OF_FILE'
X/* xsftab.c - built-in function table */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X
X/* external variables */
Xextern LVAL s_stdin,s_stdout;
X
X/* external functions */
Xextern LVAL
X xapply(),xcallcc(),xmap(),xmap1(),xforeach(),xforeach1(),
X xforce(),xforce1(),xcallwi(),xcallwo(),xwithfile1(),
X xload(),xloadnoisily(),xload1(),
X xsendsuper(),clnew(),clisnew(),clanswer(),
X obisnew(),obclass(),obshow(),
X xcons(),xcar(),xcdr(),
X xcaar(),xcadr(),xcdar(),xcddr(),
X xcaaar(),xcaadr(),xcadar(),xcaddr(),
X xcdaar(),xcdadr(),xcddar(),xcdddr(),
X xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
X xcadaar(),xcadadr(),xcaddar(),xcadddr(),
X xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
X xcddaar(),xcddadr(),xcdddar(),xcddddr(),
X xsetcar(),xsetcdr(),xlist(),
X xappend(),xreverse(),xlastpair(),xlength(),xlistref(),xlisttail(),
X xmember(),xmemv(),xmemq(),xassoc(),xassv(),xassq(),
X xsymvalue(),xsetsymvalue(),xsymplist(),xsetsymplist(),xgensym(),
X xboundp(),xget(),xput(),
X xtheenvironment(),xprocenvironment(),xenvp(),xenvbindings(),xenvparent(),
X xvector(),xmakevector(),xvlength(),xvref(),xvset(),
X xvectlist(),xlistvect(),
X xmakearray(),xaref(),xaset(),
X xsymstr(),xstrsym(),
X xnull(),xatom(),xlistp(),xnumberp(),xbooleanp(),
X xpairp(),xsymbolp(),xintegerp(),xrealp(),xcharp(),xstringp(),xvectorp(),
X xprocedurep(),xobjectp(),xdefaultobjectp(),
X xinputportp(),xoutputportp(),xportp(),
X xeq(),xeqv(),xequal(),
X xzerop(),xpositivep(),xnegativep(),xoddp(),xevenp(),
X xexactp(),xinexactp(),
X xadd1(),xsub1(),xabs(),xgcd(),xrandom(),
X xadd(),xsub(),xmul(),xdiv(),xquo(),xrem(),xmin(),xmax(),
X xsin(),xcos(),xtan(),xasin(),xacos(),xatan(),
X xxexp(),xsqrt(),xexpt(),xxlog(),xtruncate(),xfloor(),xceiling(),xround(),
X xlogand(),xlogior(),xlogxor(),xlognot(),
X xlss(),xleq(),xeql(),xgeq(),xgtr(),
X xstrlen(),xstrnullp(),xstrappend(),xstrref(),xsubstring(),
X xstrlist(),xliststring(),
X xstrlss(),xstrleq(),xstreql(),xstrgeq(),xstrgtr(),
X xstrilss(),xstrileq(),xstrieql(),xstrigeq(),xstrigtr(),
X xcharint(),xintchar(),
X xchrlss(),xchrleq(),xchreql(),xchrgeq(),xchrgtr(),
X xchrilss(),xchrileq(),xchrieql(),xchrigeq(),xchrigtr(),
X xread(),xrdchar(),xrdbyte(),xrdshort(),xrdlong(),xeofobjectp(),
X xwrite(),xwrchar(),xwrbyte(),xwrshort(),xwrlong(),
X xdisplay(),xnewline(),xprint(),xprbreadth(),xprdepth(),
X xopeni(),xopeno(),xopena(),xopenu(),xclosei(),xcloseo(),xclose(),
X xgetfposition(),xsetfposition(),xcurinput(),xcuroutput(),
X xtranson(),xtransoff(),xgetarg(),xexit(),xcompile(),xdecompile(),xgc(),
X xsave(),xrestore(),xtraceon(),xtraceoff(),xreset(),xerror(),
X xicar(),xicdr(),xisetcar(),xisetcdr(),xivlength(),xivref(),xivset();
X#ifdef MACINTOSH
Xextern LVAL xhidepen(),xshowpen(),xgetpen(),xpensize(),xpenmode();
Xextern LVAL xpenpat(),xpennormal(),xmoveto(),xmove(),xlineto(),xline();
Xextern LVAL xshowgraphics(),xhidegraphics(),xcleargraphics();
X#endif
X#ifdef MSDOS
Xextern LVAL xint86(),xinbyte(),xoutbyte(),xsystem(),xgetkey();
X#endif
X#ifdef UNIX
Xextern LVAL xsystem();
X#endif
X#ifdef AZTEC_AMIGA
Xextern LVAL xsystem();
X#endif
X
Xint xsubrcnt = 12; /* number of XSUBR functions */
Xint csubrcnt = 17; /* number of CSUBR functions + xsubrcnt */
X
X/* built-in functions */
XFUNDEF funtab[] = {
X
X /* functions that call eval or apply (# must match xsubrcnt) */
X{ "APPLY", xapply },
X{ "CALL-WITH-CURRENT-CONTINUATION", xcallcc },
X{ "CALL/CC", xcallcc },
X{ "MAP", xmap },
X{ "FOR-EACH", xforeach },
X{ "CALL-WITH-INPUT-FILE", xcallwi },
X{ "CALL-WITH-OUTPUT-FILE", xcallwo },
X{ "LOAD", xload },
X{ "LOAD-NOISILY", xloadnoisily },
X{ "SEND-SUPER", xsendsuper },
X{ "%CLASS-NEW", clnew },
X{ "FORCE", xforce },
X
X /* continuations for xsubrs (# must match csubrcnt) */
X{ "%MAP1", xmap1 },
X{ "%FOR-EACH1", xforeach1 },
X{ "%WITH-FILE1", xwithfile1 },
X{ "%LOAD1", xload1 },
X{ "%FORCE1", xforce1 },
X
X /* methods */
X{ "%CLASS-ISNEW", clisnew },
X{ "%CLASS-ANSWER", clanswer },
X{ "%OBJECT-ISNEW", obisnew },
X{ "%OBJECT-CLASS", obclass },
X{ "%OBJECT-SHOW", obshow },
X
X /* list functions */
X{ "CONS", xcons },
X{ "CAR", xcar },
X{ "CDR", xcdr },
X{ "CAAR", xcaar },
X{ "CADR", xcadr },
X{ "CDAR", xcdar },
X{ "CDDR", xcddr },
X{ "CAAAR", xcaaar },
X{ "CAADR", xcaadr },
X{ "CADAR", xcadar },
X{ "CADDR", xcaddr },
X{ "CDAAR", xcdaar },
X{ "CDADR", xcdadr },
X{ "CDDAR", xcddar },
X{ "CDDDR", xcdddr },
X{ "CAAAAR", xcaaaar },
X{ "CAAADR", xcaaadr },
X{ "CAADAR", xcaadar },
X{ "CAADDR", xcaaddr },
X{ "CADAAR", xcadaar },
X{ "CADADR", xcadadr },
X{ "CADDAR", xcaddar },
X{ "CADDDR", xcadddr },
X{ "CDAAAR", xcdaaar },
X{ "CDAADR", xcdaadr },
X{ "CDADAR", xcdadar },
X{ "CDADDR", xcdaddr },
X{ "CDDAAR", xcddaar },
X{ "CDDADR", xcddadr },
X{ "CDDDAR", xcdddar },
X{ "CDDDDR", xcddddr },
X{ "LIST", xlist },
X{ "APPEND", xappend },
X{ "REVERSE", xreverse },
X{ "LAST-PAIR", xlastpair },
X{ "LENGTH", xlength },
X{ "MEMBER", xmember },
X{ "MEMV", xmemv },
X{ "MEMQ", xmemq },
X{ "ASSOC", xassoc },
X{ "ASSV", xassv },
X{ "ASSQ", xassq },
X{ "LIST-REF", xlistref },
X{ "LIST-TAIL", xlisttail },
X
X /* destructive list functions */
X{ "SET-CAR!", xsetcar },
X{ "SET-CDR!", xsetcdr },
X
X
X /* symbol functions */
X{ "BOUND?", xboundp },
X{ "SYMBOL-VALUE", xsymvalue },
X{ "SET-SYMBOL-VALUE!", xsetsymvalue },
X{ "SYMBOL-PLIST", xsymplist },
X{ "SET-SYMBOL-PLIST!", xsetsymplist },
X{ "GENSYM", xgensym },
X{ "GET", xget },
X{ "PUT", xput },
X
X /* environment functions */
X{ "THE-ENVIRONMENT", xtheenvironment },
X{ "PROCEDURE-ENVIRONMENT", xprocenvironment},
X{ "ENVIRONMENT?", xenvp },
X{ "ENVIRONMENT-BINDINGS", xenvbindings },
X{ "ENVIRONMENT-PARENT", xenvparent },
X
X /* vector functions */
X{ "VECTOR", xvector },
X{ "MAKE-VECTOR", xmakevector },
X{ "VECTOR-LENGTH", xvlength },
X{ "VECTOR-REF", xvref },
X{ "VECTOR-SET!", xvset },
X
X /* array functions */
X{ "MAKE-ARRAY", xmakearray },
X{ "ARRAY-REF", xaref },
X{ "ARRAY-SET!", xaset },
X
X /* conversion functions */
X{ "SYMBOL->STRING", xsymstr },
X{ "STRING->SYMBOL", xstrsym },
X{ "VECTOR->LIST", xvectlist },
X{ "LIST->VECTOR", xlistvect },
X{ "STRING->LIST", xstrlist },
X{ "LIST->STRING", xliststring },
X{ "CHAR->INTEGER", xcharint },
X{ "INTEGER->CHAR", xintchar },
X
X /* predicate functions */
X{ "NULL?", xnull },
X{ "ATOM?", xatom },
X{ "LIST?", xlistp },
X{ "NUMBER?", xnumberp },
X{ "BOOLEAN?", xbooleanp },
X{ "PAIR?", xpairp },
X{ "SYMBOL?", xsymbolp },
X{ "COMPLEX?", xrealp }, /*(1)*/
X{ "REAL?", xrealp },
X{ "RATIONAL?", xintegerp }, /*(1)*/
X{ "INTEGER?", xintegerp },
X{ "CHAR?", xcharp },
X{ "STRING?", xstringp },
X{ "VECTOR?", xvectorp },
X{ "PROCEDURE?", xprocedurep },
X{ "PORT?", xportp },
X{ "INPUT-PORT?", xinputportp },
X{ "OUTPUT-PORT?", xoutputportp },
X{ "OBJECT?", xobjectp },
X{ "EOF-OBJECT?", xeofobjectp },
X{ "DEFAULT-OBJECT?", xdefaultobjectp },
X{ "EQ?", xeq },
X{ "EQV?", xeqv },
X{ "EQUAL?", xequal },
X
X /* arithmetic functions */
X{ "ZERO?", xzerop },
X{ "POSITIVE?", xpositivep },
X{ "NEGATIVE?", xnegativep },
X{ "ODD?", xoddp },
X{ "EVEN?", xevenp },
X{ "EXACT?", xexactp },
X{ "INEXACT?", xinexactp },
X{ "TRUNCATE", xtruncate },
X{ "FLOOR", xfloor },
X{ "CEILING", xceiling },
X{ "ROUND", xround },
X{ "1+", xadd1 },
X{ "-1+", xsub1 },
X{ "ABS", xabs },
X{ "GCD", xgcd },
X{ "RANDOM", xrandom },
X{ "+", xadd },
X{ "-", xsub },
X{ "*", xmul },
X{ "/", xdiv },
X{ "QUOTIENT", xquo },
X{ "REMAINDER", xrem },
X{ "MIN", xmin },
X{ "MAX", xmax },
X{ "SIN", xsin },
X{ "COS", xcos },
X{ "TAN", xtan },
X{ "ASIN", xasin },
X{ "ACOS", xacos },
X{ "ATAN", xatan },
X{ "EXP", xxexp },
X{ "SQRT", xsqrt },
X{ "EXPT", xexpt },
X{ "LOG", xxlog },
X
X /* bitwise logical functions */
X{ "LOGAND", xlogand },
X{ "LOGIOR", xlogior },
X{ "LOGXOR", xlogxor },
X{ "LOGNOT", xlognot },
X
X /* numeric comparison functions */
X{ "<", xlss },
X{ "<=", xleq },
X{ "=", xeql },
X{ ">=", xgeq },
X{ ">", xgtr },
X
X /* string functions */
X{ "STRING-LENGTH", xstrlen },
X{ "STRING-NULL?", xstrnullp },
X{ "STRING-APPEND", xstrappend },
X{ "STRING-REF", xstrref },
X{ "SUBSTRING", xsubstring },
X{ "STRING<?", xstrlss },
X{ "STRING<=?", xstrleq },
X{ "STRING=?", xstreql },
X{ "STRING>=?", xstrgeq },
X{ "STRING>?", xstrgtr },
X{ "STRING-CI<?", xstrilss },
X{ "STRING-CI<=?", xstrileq },
X{ "STRING-CI=?", xstrieql },
X{ "STRING-CI>=?", xstrigeq },
X{ "STRING-CI>?", xstrigtr },
X
X /* character functions */
X{ "CHAR<?", xchrlss },
X{ "CHAR<=?", xchrleq },
X{ "CHAR=?", xchreql },
X{ "CHAR>=?", xchrgeq },
X{ "CHAR>?", xchrgtr },
X{ "CHAR-CI<?", xchrilss },
X{ "CHAR-CI<=?", xchrileq },
X{ "CHAR-CI=?", xchrieql },
X{ "CHAR-CI>=?", xchrigeq },
X{ "CHAR-CI>?", xchrigtr },
X
X /* I/O functions */
X{ "READ", xread },
X{ "READ-CHAR", xrdchar },
X{ "READ-BYTE", xrdbyte },
X{ "READ-SHORT", xrdshort },
X{ "READ-LONG", xrdlong },
X{ "WRITE", xwrite },
X{ "WRITE-CHAR", xwrchar },
X{ "WRITE-BYTE", xwrbyte },
X{ "WRITE-SHORT", xwrshort },
X{ "WRITE-LONG", xwrlong },
X{ "DISPLAY", xdisplay },
X{ "PRINT", xprint },
X{ "NEWLINE", xnewline },
X
X /* print control functions */
X{ "PRINT-BREADTH", xprbreadth },
X{ "PRINT-DEPTH", xprdepth },
X
X /* file I/O functions */
X{ "OPEN-INPUT-FILE", xopeni },
X{ "OPEN-OUTPUT-FILE", xopeno },
X{ "OPEN-APPEND-FILE", xopena },
X{ "OPEN-UPDATE-FILE", xopenu },
X{ "CLOSE-PORT", xclose },
X{ "CLOSE-INPUT-PORT", xclosei },
X{ "CLOSE-OUTPUT-PORT", xcloseo },
X{ "GET-FILE-POSITION", xgetfposition },
X{ "SET-FILE-POSITION!", xsetfposition },
X{ "CURRENT-INPUT-PORT", xcurinput },
X{ "CURRENT-OUTPUT-PORT", xcuroutput },
X
X /* utility functions */
X{ "TRANSCRIPT-ON", xtranson },
X{ "TRANSCRIPT-OFF", xtransoff },
X{ "GETARG", xgetarg },
X{ "EXIT", xexit },
X{ "COMPILE", xcompile },
X{ "DECOMPILE", xdecompile },
X{ "GC", xgc },
X{ "SAVE", xsave },
X{ "RESTORE", xrestore },
X{ "RESET", xreset },
X{ "ERROR", xerror },
X
X /* debugging functions */
X{ "TRACE-ON", xtraceon },
X{ "TRACE-OFF", xtraceoff },
X
X /* internal functions */
X{ "%CAR", xicar },
X{ "%CDR", xicdr },
X{ "%SET-CAR!", xisetcar },
X{ "%SET-CDR!", xisetcdr },
X{ "%VECTOR-LENGTH", xivlength },
X{ "%VECTOR-REF", xivref },
X{ "%VECTOR-SET!", xivset },
X
X#ifdef MACINTOSH
X{ "HIDEPEN", xhidepen },
X{ "SHOWPEN", xshowpen },
X{ "GETPEN", xgetpen },
X{ "PENSIZE", xpensize },
X{ "PENMODE", xpenmode },
X{ "PENPAT", xpenpat },
X{ "PENNORMAL", xpennormal },
X{ "MOVETO", xmoveto },
X{ "MOVE", xmove },
X{ "LINETO", xlineto },
X{ "LINE", xline },
X{ "SHOW-GRAPHICS", xshowgraphics },
X{ "HIDE-GRAPHICS", xhidegraphics },
X{ "CLEAR-GRAPHICS", xcleargraphics },
X#endif
X
X#ifdef MSDOS
X{ "INT86", xint86 },
X{ "INBYTE", xinbyte },
X{ "OUTBYTE", xoutbyte },
X{ "SYSTEM", xsystem },
X{ "GET-KEY", xgetkey },
X#endif
X
X#ifdef UNIX
X{ "SYSTEM", xsystem },
X#endif
X
X#ifdef AZTEC_AMIGA
X{ "SYSTEM", xsystem },
X#endif
X
X{0,0} /* end of table marker */
X
X};
X
X/* Notes:
X
X (1) This version only supports integers and reals.
X
X*/
X
X/* curinput - get the current input port */
XLVAL curinput()
X{
X return (getvalue(s_stdin));
X}
X
X/* curoutput - get the current output port */
XLVAL curoutput()
X{
X return (getvalue(s_stdout));
X}
X
X/* eq - internal 'eq?' function */
Xint eq(arg1,arg2)
X LVAL arg1,arg2;
X{
X return (arg1 == arg2);
X}
X
X/* eqv - internal 'eqv?' function */
Xint eqv(arg1,arg2)
X LVAL arg1,arg2;
X{
X /* try the eq test first */
X if (arg1 == arg2)
X return (TRUE);
X
X /* compare fixnums, flonums and characters */
X if (!null(arg1)) {
X switch (ntype(arg1)) {
X case FIXNUM:
X return (fixp(arg2)
X && getfixnum(arg1) == getfixnum(arg2));
X case FLONUM:
X return (floatp(arg2)
X && getflonum(arg1) == getflonum(arg2));
X case CHAR:
X return (charp(arg2)
X && getchcode(arg1) == getchcode(arg2));
X }
X }
X return (FALSE);
X}
X
X/* equal - internal 'equal?' function */
Xint equal(arg1,arg2)
X LVAL arg1,arg2;
X{
X /* try the eq test first */
X if (arg1 == arg2)
X return (TRUE);
X
X /* compare fixnums, flonums, characters, strings, vectors and conses */
X if (!null(arg1)) {
X switch (ntype(arg1)) {
X case FIXNUM:
X return (fixp(arg2)
X && getfixnum(arg1) == getfixnum(arg2));
X case FLONUM:
X return (floatp(arg2)
X && getflonum(arg1) == getflonum(arg2));
X case CHAR:
X return (charp(arg2)
X && getchcode(arg1) == getchcode(arg2));
X case STRING:
X return (stringp(arg2)
X && strcmp(getstring(arg1),getstring(arg2)) == 0);
X case VECTOR:
X return (vectorp(arg2)
X && vectorequal(arg1,arg2));
X case CONS:
X return (consp(arg2)
X && equal(car(arg1),car(arg2))
X && equal(cdr(arg1),cdr(arg2)));
X }
X }
X return (FALSE);
X}
X
X/* vectorequal - compare two vectors */
Xint vectorequal(v1,v2)
X LVAL v1,v2;
X{
X int len,i;
X
X /* compare the vector lengths */
X if ((len = getsize(v1)) != getsize(v2))
X return (FALSE);
X
X /* compare the vector elements */
X for (i = 0; i < len; ++i)
X if (!equal(getelement(v1,i),getelement(v2,i)))
X return (FALSE);
X return (TRUE);
X}
X
X/* xltoofew - too few arguments to this function */
XLVAL xltoofew()
X{
X xlfail("too few arguments");
X}
X
X/* xltoomany - too many arguments to this function */
Xxltoomany()
X{
X xlfail("too many arguments");
X}
X
X/* xlbadtype - incorrect argument type */
XLVAL xlbadtype(val)
X LVAL val;
X{
X xlerror("incorrect type",val);
X}
END_OF_FILE
if test 14063 -ne `wc -c <'Src/xsftab.c'`; then
echo shar: \"'Src/xsftab.c'\" unpacked with wrong size!
fi
# end of 'Src/xsftab.c'
fi
if test -f 'Src/xsmath.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsmath.c'\"
else
echo shar: Extracting \"'Src/xsmath.c'\" \(13437 characters\)
sed "s/^X//" >'Src/xsmath.c' <<'END_OF_FILE'
X/* xsmath.c - xscheme built-in arithmetic functions */
X/* Copyright (c) 1988, by David Michael Betz
X All Rights Reserved
X Permission is granted for unrestricted non-commercial use */
X
X#include "xscheme.h"
X#include <math.h>
X
X/* external variables */
Xextern LVAL true;
X
X/* forward declarations */
XFORWARD LVAL unary();
XFORWARD LVAL binary();
XFORWARD LVAL predicate();
XFORWARD LVAL compare();
XFORWARD FLOTYPE toflotype();
X
X/* xexactp - built-in function 'exact?' */
X/**** THIS IS REALLY JUST A STUB FOR NOW ****/
XLVAL xexactp()
X{
X LVAL arg;
X arg = xlganumber();
X xllastarg();
X return (NIL);
X}
X
X/* xinexactp - built-in function 'inexact?' */
X/**** THIS IS REALLY JUST A STUB FOR NOW ****/
XLVAL xinexactp()
X{
X LVAL arg;
X arg = xlganumber();
X xllastarg();
X return (true);
X}
X
X/* xatan - built-in function 'atan' */
XLVAL xatan()
X{
X LVAL arg,arg2;
X FLOTYPE val;
X
X /* get the first argument */
X arg = xlganumber();
X
X /* handle two argument (atan y x) */
X if (moreargs()) {
X arg2 = xlganumber();
X xllastarg();
X val = atan2(toflotype(arg),toflotype(arg2));
X }
X
X /* handle one argument (atan x) */
X else
X val = atan(toflotype(arg));
X
X /* return the resulting flonum */
X return (cvflonum(val));
X}
X
X/* xfloor - built-in function 'floor' */
XLVAL xfloor()
X{
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg))
X return (arg);
X else if (floatp(arg))
X return (cvfixnum((FIXTYPE)floor(getflonum(arg))));
X else
X xlbadtype(arg);
X}
X
X/* xceiling - built-in function 'ceiling' */
XLVAL xceiling()
X{
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg))
X return (arg);
X else if (floatp(arg))
X return (cvfixnum((FIXTYPE)ceil(getflonum(arg))));
X else
X xlbadtype(arg);
X}
X
X/* xround - built-in function 'round' */
XLVAL xround()
X{
X FLOTYPE x,y,z;
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg))
X return (arg);
X else if (floatp(arg)) {
X x = getflonum(arg);
X y = floor(x);
X z = x - y;
X if (z == 0.5) {
X if (((FIXTYPE)y & 1) == 1)
X y += 1.0;
X return (cvfixnum((FIXTYPE)y));
X }
X else if (z < 0.5)
X return (cvfixnum((FIXTYPE)y));
X else
X return (cvfixnum((FIXTYPE)(y + 1.0)));
X }
X else
X xlbadtype(arg);
X}
X
X/* xtruncate - built-in function 'truncate' */
XLVAL xtruncate()
X{
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg))
X return (arg);
X else if (floatp(arg))
X return (cvfixnum((FIXTYPE)(getflonum(arg))));
X else
X xlbadtype(arg);
X}
X
X/* binary functions */
XLVAL xadd() /* + */
X{
X if (!moreargs())
X return (cvfixnum((FIXTYPE)0));
X return (binary('+'));
X}
XLVAL xmul() /* * */
X{
X if (!moreargs())
X return (cvfixnum((FIXTYPE)1));
X return (binary('*'));
X}
XLVAL xsub() { return (binary('-')); } /* - */
XLVAL xdiv() { return (binary('/')); } /* / */
XLVAL xquo() { return (binary('Q')); } /* quotient */
XLVAL xrem() { return (binary('R')); } /* remainder */
XLVAL xmin() { return (binary('m')); } /* min */
XLVAL xmax() { return (binary('M')); } /* max */
XLVAL xexpt() { return (binary('E')); } /* expt */
XLVAL xlogand() { return (binary('&')); } /* logand */
XLVAL xlogior() { return (binary('|')); } /* logior */
XLVAL xlogxor() { return (binary('^')); } /* logxor */
X
X/* binary - handle binary operations */
XLOCAL LVAL binary(fcn)
X int fcn;
X{
X FIXTYPE ival,iarg;
X FLOTYPE fval,farg;
X LVAL arg;
X int mode;
X
X /* get the first argument */
X arg = xlgetarg();
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X mode = 'I';
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X mode = 'F';
X }
X else
X xlbadtype(arg);
X
X /* treat a single argument as a special case */
X if (!moreargs()) {
X switch (fcn) {
X case '-':
X switch (mode) {
X case 'I':
X ival = -ival;
X break;
X case 'F':
X fval = -fval;
X break;
X }
X break;
X case '/':
X switch (mode) {
X case 'I':
X checkizero(ival);
X if (ival != 1) {
X fval = 1.0 / (FLOTYPE)ival;
X mode = 'F';
X }
X break;
X case 'F':
X checkfzero(fval);
X fval = 1.0 / fval;
X break;
X }
X }
X }
X
X /* handle each remaining argument */
X while (moreargs()) {
X
X /* get the next argument */
X arg = xlgetarg();
X
X /* check its type */
X if (fixp(arg)) {
X switch (mode) {
X case 'I':
X iarg = getfixnum(arg);
X break;
X case 'F':
X farg = (FLOTYPE)getfixnum(arg);
X break;
X }
X }
X else if (floatp(arg)) {
X switch (mode) {
X case 'I':
X fval = (FLOTYPE)ival;
X farg = getflonum(arg);
X mode = 'F';
X break;
X case 'F':
X farg = getflonum(arg);
X break;
X }
X }
X else
X xlbadtype(arg);
X
X /* accumulate the result value */
X switch (mode) {
X case 'I':
X switch (fcn) {
X case '+': ival += iarg; break;
X case '-': ival -= iarg; break;
X case '*': ival *= iarg; break;
X case '/': checkizero(iarg);
X if ((ival % iarg) == 0)
X ival /= iarg;
X else {
X fval = (FLOTYPE)ival;
X farg = (FLOTYPE)iarg;
X fval /= farg;
X mode = 'F';
X }
X break;
X case 'Q': checkizero(iarg); ival /= iarg; break;
X case 'R': checkizero(iarg); ival %= iarg; break;
X case 'M': if (iarg > ival) ival = iarg; break;
X case 'm': if (iarg < ival) ival = iarg; break;
X case 'E': return (cvflonum((FLOTYPE)pow((FLOTYPE)ival,(FLOTYPE)iarg)));
X case '&': ival &= iarg; break;
X case '|': ival |= iarg; break;
X case '^': ival ^= iarg; break;
X default: badiop();
X }
X break;
X case 'F':
X switch (fcn) {
X case '+': fval += farg; break;
X case '-': fval -= farg; break;
X case '*': fval *= farg; break;
X case '/': checkfzero(farg); fval /= farg; break;
X case 'M': if (farg > fval) fval = farg; break;
X case 'm': if (farg < fval) fval = farg; break;
X case 'E': fval = pow(fval,farg); break;
X default: badfop();
X }
X break;
X }
X }
X
X /* return the result */
X switch (mode) {
X case 'I': return (cvfixnum(ival));
X case 'F': return (cvflonum(fval));
X }
X}
X
X/* unary functions */
XLVAL xlognot() { return (unary('~')); } /* lognot */
XLVAL xabs() { return (unary('A')); } /* abs */
XLVAL xadd1() { return (unary('+')); } /* 1+ */
XLVAL xsub1() { return (unary('-')); } /* -1+ */
XLVAL xsin() { return (unary('S')); } /* sin */
XLVAL xcos() { return (unary('C')); } /* cos */
XLVAL xtan() { return (unary('T')); } /* tan */
XLVAL xasin() { return (unary('s')); } /* asin */
XLVAL xacos() { return (unary('c')); } /* acos */
XLVAL xxexp() { return (unary('E')); } /* exp */
XLVAL xsqrt() { return (unary('R')); } /* sqrt */
XLVAL xxlog() { return (unary('L')); } /* log */
XLVAL xrandom() { return (unary('?')); } /* random */
X
X/* unary - handle unary operations */
XLOCAL LVAL unary(fcn)
X int fcn;
X{
X FLOTYPE fval;
X FIXTYPE ival;
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check its type */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X switch (fcn) {
X case '~': ival = ~ival; break;
X case 'A': ival = (ival < 0 ? -ival : ival); break;
X case '+': ival++; break;
X case '-': ival--; break;
X case 'S': return (cvflonum((FLOTYPE)sin((FLOTYPE)ival)));
X case 'C': return (cvflonum((FLOTYPE)cos((FLOTYPE)ival)));
X case 'T': return (cvflonum((FLOTYPE)tan((FLOTYPE)ival)));
X case 's': return (cvflonum((FLOTYPE)asin((FLOTYPE)ival)));
X case 'c': return (cvflonum((FLOTYPE)acos((FLOTYPE)ival)));
X case 't': return (cvflonum((FLOTYPE)atan((FLOTYPE)ival)));
X case 'E': return (cvflonum((FLOTYPE)exp((FLOTYPE)ival)));
X case 'L': return (cvflonum((FLOTYPE)log((FLOTYPE)ival)));
X case 'R': checkineg(ival);
X return (cvflonum((FLOTYPE)sqrt((FLOTYPE)ival)));
X case '?': ival = (FIXTYPE)osrand((int)ival); break;
X default: badiop();
X }
X return (cvfixnum(ival));
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X switch (fcn) {
X case 'A': fval = (fval < 0.0 ? -fval : fval); break;
X case '+': fval += 1.0; break;
X case '-': fval -= 1.0; break;
X case 'S': fval = sin(fval); break;
X case 'C': fval = cos(fval); break;
X case 'T': fval = tan(fval); break;
X case 's': fval = asin(fval); break;
X case 'c': fval = acos(fval); break;
X case 't': fval = atan(fval); break;
X case 'E': fval = exp(fval); break;
X case 'L': fval = log(fval); break;
X case 'R': checkfneg(fval);
X fval = sqrt(fval); break;
X default: badfop();
X }
X return (cvflonum(fval));
X }
X else
X xlbadtype(arg);
X}
X
X/* xgcd - greatest common divisor */
XLVAL xgcd()
X{
X FIXTYPE m,n,r;
X LVAL arg;
X
X if (!moreargs()) /* check for identity case */
X return (cvfixnum((FIXTYPE)0));
X arg = xlgafixnum();
X n = getfixnum(arg);
X if (n < (FIXTYPE)0) n = -n; /* absolute value */
X while (moreargs()) {
X arg = xlgafixnum();
X m = getfixnum(arg);
X if (m < (FIXTYPE)0) m = -m; /* absolute value */
X for (;;) { /* euclid's algorithm */
X r = m % n;
X if (r == (FIXTYPE)0)
X break;
X m = n;
X n = r;
X }
X }
X return (cvfixnum(n));
X}
X
X/* unary predicates */
XLVAL xnegativep() { return (predicate('-')); } /* negative? */
XLVAL xzerop() { return (predicate('Z')); } /* zero? */
XLVAL xpositivep() { return (predicate('+')); } /* positive? */
XLVAL xevenp() { return (predicate('E')); } /* even? */
XLVAL xoddp() { return (predicate('O')); } /* odd? */
X
X/* predicate - handle a predicate function */
XLOCAL LVAL predicate(fcn)
X int fcn;
X{
X FLOTYPE fval;
X FIXTYPE ival;
X LVAL arg;
X
X /* get the argument */
X arg = xlgetarg();
X xllastarg();
X
X /* check the argument type */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X switch (fcn) {
X case '-': ival = (ival < 0); break;
X case 'Z': ival = (ival == 0); break;
X case '+': ival = (ival > 0); break;
X case 'E': ival = ((ival & 1) == 0); break;
X case 'O': ival = ((ival & 1) != 0); break;
X default: badiop();
X }
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X switch (fcn) {
X case '-': ival = (fval < 0); break;
X case 'Z': ival = (fval == 0); break;
X case '+': ival = (fval > 0); break;
X default: badfop();
X }
X }
X else
X xlbadtype(arg);
X
X /* return the result value */
X return (ival ? true : NIL);
X}
X
X/* comparison functions */
XLVAL xlss() { return (compare('<')); } /* < */
XLVAL xleq() { return (compare('L')); } /* <= */
XLVAL xeql() { return (compare('=')); } /* = */
XLVAL xgeq() { return (compare('G')); } /* >= */
XLVAL xgtr() { return (compare('>')); } /* > */
X
X/* compare - common compare function */
XLOCAL LVAL compare(fcn)
X int fcn;
X{
X FIXTYPE icmp,ival,iarg;
X FLOTYPE fcmp,fval,farg;
X LVAL arg;
X int mode;
X
X /* get the first argument */
X arg = xlgetarg();
X
X /* set the type of the first argument */
X if (fixp(arg)) {
X ival = getfixnum(arg);
X mode = 'I';
X }
X else if (floatp(arg)) {
X fval = getflonum(arg);
X mode = 'F';
X }
X else
X xlbadtype(arg);
X
X /* handle each remaining argument */
X for (icmp = TRUE; icmp && moreargs(); ival = iarg, fval = farg) {
X
X /* get the next argument */
X arg = xlgetarg();
X
X /* check its type */
X if (fixp(arg)) {
X switch (mode) {
X case 'I':
X iarg = getfixnum(arg);
X break;
X case 'F':
X farg = (FLOTYPE)getfixnum(arg);
X break;
X }
X }
X else if (floatp(arg)) {
X switch (mode) {
X case 'I':
X fval = (FLOTYPE)ival;
X farg = getflonum(arg);
X mode = 'F';
X break;
X case 'F':
X farg = getflonum(arg);
X break;
X }
X }
X else
X xlbadtype(arg);
X
X /* compute result of the compare */
X switch (mode) {
X case 'I':
X icmp = ival - iarg;
X switch (fcn) {
X case '<': icmp = (icmp < 0); break;
X case 'L': icmp = (icmp <= 0); break;
X case '=': icmp = (icmp == 0); break;
X case 'G': icmp = (icmp >= 0); break;
X case '>': icmp = (icmp > 0); break;
X }
X break;
X case 'F':
X fcmp = fval - farg;
X switch (fcn) {
X case '<': icmp = (fcmp < 0.0); break;
X case 'L': icmp = (fcmp <= 0.0); break;
X case '=': icmp = (fcmp == 0.0); break;
X case 'G': icmp = (fcmp >= 0.0); break;
X case '>': icmp = (fcmp > 0.0); break;
X }
X break;
X }
X }
X
X /* return the result */
X return (icmp ? true : NIL);
X}
X
X/* toflotype - convert a lisp value to a floating point number */
XFLOTYPE toflotype(val)
X LVAL val;
X{
X /* must be a number for this to work */
X switch (ntype(val)) {
X case FIXNUM: return ((FLOTYPE)getfixnum(val));
X case FLONUM: return (getflonum(val));
X }
X}
X
X/* checkizero - check for integer division by zero */
Xcheckizero(iarg)
X FIXTYPE iarg;
X{
X if (iarg == 0)
X xlfail("division by zero");
X}
X
X/* checkineg - check for square root of a negative number */
Xcheckineg(iarg)
X FIXTYPE iarg;
X{
X if (iarg < 0)
X xlfail("square root of a negative number");
X}
X
X/* checkfzero - check for floating point division by zero */
Xcheckfzero(farg)
X FLOTYPE farg;
X{
X if (farg == 0.0)
X xlfail("division by zero");
X}
X
X/* checkfneg - check for square root of a negative number */
Xcheckfneg(farg)
X FLOTYPE farg;
X{
X if (farg < 0.0)
X xlfail("square root of a negative number");
X}
X
X/* badiop - bad integer operation */
XLOCAL badiop()
X{
X xlfail("bad integer operation");
X}
X
X/* badfop - bad floating point operation */
XLOCAL badfop()
X{
X xlfail("bad floating point operation");
X}
END_OF_FILE
if test 13437 -ne `wc -c <'Src/xsmath.c'`; then
echo shar: \"'Src/xsmath.c'\" unpacked with wrong size!
fi
# end of 'Src/xsmath.c'
fi
echo shar: End of archive 3 \(of 7\).
cp /dev/null ark3isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
if test ! -f ark${I}isdone ; then
MISSING="${MISSING} ${I}"
fi
done
if test "${MISSING}" = "" ; then
echo You have unpacked all 7 archives.
rm -f ark[1-9]isdone
else
echo You still need to unpack the following archives:
echo " " ${MISSING}
fi
## End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <amiga@cs.odu.edu>.
Mail comments to the moderator at <amiga-request@cs.odu.edu>.
Post requests for sources, and general discussion to comp.sys.amiga.