Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) (04/15/90)
Submitted-by: rusty@fe2o3.UUCP (Rusty Haddock)
Posting-number: Volume 90, Issue 142
Archive-name: applications/xscheme-0.20/part04
#!/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 4 (of 7)."
# Contents: Src/xsfun1.c Src/xsfun2.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:26 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/xsfun1.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsfun1.c'\"
else
echo shar: Extracting \"'Src/xsfun1.c'\" \(19708 characters\)
sed "s/^X//" >'Src/xsfun1.c' <<'END_OF_FILE'
X/* xsfun1.c - xscheme built-in functions - part 1 */
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/* gensym variables */
Xstatic char gsprefix[STRMAX+1] = { 'G',0 }; /* gensym prefix string */
Xstatic int gsnumber = 1; /* gensym number */
X
X/* external variables */
Xextern LVAL xlenv,xlval,default_object,true;
Xextern LVAL s_unbound;
X
X/* external routines */
Xextern int eq(),eqv(),equal();
X
X/* forward declarations */
XFORWARD LVAL cxr();
XFORWARD LVAL member();
XFORWARD LVAL assoc();
XFORWARD LVAL nth();
XFORWARD LVAL eqtest();
X
X/* xcons - construct a new list cell */
XLVAL xcons()
X{
X LVAL carval,cdrval;
X
X /* get the two arguments */
X carval = xlgetarg();
X cdrval = xlgetarg();
X xllastarg();
X
X /* construct a new cons node */
X return (cons(carval,cdrval));
X}
X
X/* xcar - built-in function 'car' */
XLVAL xcar()
X{
X LVAL list;
X list = xlgalist();
X xllastarg();
X return (list ? car(list) : NIL);
X}
X
X/* xicar - built-in function '%car' */
XLVAL xicar()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (car(arg));
X}
X
X/* xcdr - built-in function 'cdr' */
XLVAL xcdr()
X{
X LVAL arg;
X arg = xlgalist();
X xllastarg();
X return (arg ? cdr(arg) : NIL);
X}
X
X/* xicdr - built-in function '%cdr' */
XLVAL xicdr()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (cdr(arg));
X}
X
X/* cxxr functions */
XLVAL xcaar() { return (cxr("aa")); }
XLVAL xcadr() { return (cxr("da")); }
XLVAL xcdar() { return (cxr("ad")); }
XLVAL xcddr() { return (cxr("dd")); }
X
X/* cxxxr functions */
XLVAL xcaaar() { return (cxr("aaa")); }
XLVAL xcaadr() { return (cxr("daa")); }
XLVAL xcadar() { return (cxr("ada")); }
XLVAL xcaddr() { return (cxr("dda")); }
XLVAL xcdaar() { return (cxr("aad")); }
XLVAL xcdadr() { return (cxr("dad")); }
XLVAL xcddar() { return (cxr("add")); }
XLVAL xcdddr() { return (cxr("ddd")); }
X
X/* cxxxxr functions */
XLVAL xcaaaar() { return (cxr("aaaa")); }
XLVAL xcaaadr() { return (cxr("daaa")); }
XLVAL xcaadar() { return (cxr("adaa")); }
XLVAL xcaaddr() { return (cxr("ddaa")); }
XLVAL xcadaar() { return (cxr("aada")); }
XLVAL xcadadr() { return (cxr("dada")); }
XLVAL xcaddar() { return (cxr("adda")); }
XLVAL xcadddr() { return (cxr("ddda")); }
XLVAL xcdaaar() { return (cxr("aaad")); }
XLVAL xcdaadr() { return (cxr("daad")); }
XLVAL xcdadar() { return (cxr("adad")); }
XLVAL xcdaddr() { return (cxr("ddad")); }
XLVAL xcddaar() { return (cxr("aadd")); }
XLVAL xcddadr() { return (cxr("dadd")); }
XLVAL xcdddar() { return (cxr("addd")); }
XLVAL xcddddr() { return (cxr("dddd")); }
X
X/* cxr - common car/cdr routine */
XLOCAL LVAL cxr(adstr)
X char *adstr;
X{
X LVAL list;
X
X /* get the list */
X list = xlgalist();
X xllastarg();
X
X /* perform the car/cdr operations */
X while (*adstr && consp(list))
X list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X /* make sure the operation succeeded */
X if (*adstr && list)
X xlbadtype(list);
X
X /* return the result */
X return (list);
X}
X
X/* xsetcar - built-in function 'set-car!' */
XLVAL xsetcar()
X{
X LVAL arg,newcar;
X
X /* get the cons and the new car */
X arg = xlgacons();
X newcar = xlgetarg();
X xllastarg();
X
X /* replace the car */
X rplaca(arg,newcar);
X return (arg);
X}
X
X/* xisetcar - built-in function '%set-car!' */
XLVAL xisetcar()
X{
X LVAL arg,newcar;
X
X /* get the cons and the new car */
X arg = xlgetarg();
X newcar = xlgetarg();
X xllastarg();
X
X /* replace the car */
X rplaca(arg,newcar);
X return (arg);
X}
X
X/* xsetcdr - built-in function 'set-cdr!' */
XLVAL xsetcdr()
X{
X LVAL arg,newcdr;
X
X /* get the cons and the new cdr */
X arg = xlgacons();
X newcdr = xlgetarg();
X xllastarg();
X
X /* replace the cdr */
X rplacd(arg,newcdr);
X return (arg);
X}
X
X/* xisetcdr - built-in function '%set-cdr!' */
XLVAL xisetcdr()
X{
X LVAL arg,newcdr;
X
X /* get the cons and the new cdr */
X arg = xlgetarg();
X newcdr = xlgetarg();
X xllastarg();
X
X /* replace the cdr */
X rplacd(arg,newcdr);
X return (arg);
X}
X
X/* xlist - built-in function 'list' */
XLVAL xlist()
X{
X LVAL last,next,val;
X
X /* initialize the list */
X val = NIL;
X
X /* add each argument to the list */
X if (moreargs()) {
X val = last = cons(nextarg(),NIL);
X while (moreargs()) {
X next = nextarg();
X push(val);
X next = cons(next,NIL);
X rplacd(last,next);
X last = next;
X val = pop();
X }
X }
X
X /* return the list */
X return (val);
X}
X
X/* xappend - built-in function 'append' */
XLVAL xappend()
X{
X LVAL next,this,last,val;
X
X /* append each argument */
X for (val = last = NIL; xlargc > 1; )
X
X /* append each element of this list to the result list */
X for (next = xlgalist(); consp(next); next = cdr(next)) {
X push(val);
X this = cons(car(next),NIL);
X val = pop();
X if (last == NIL) val = this;
X else rplacd(last,this);
X last = this;
X }
X
X /* tack on the last argument */
X if (moreargs()) {
X if (last == NIL) val = xlgetarg();
X else rplacd(last,xlgetarg());
X }
X
X /* return the list */
X return (val);
X}
X
X/* xreverse - built-in function 'reverse' */
XLVAL xreverse()
X{
X LVAL next,val;
X
X /* get the list to reverse */
X next = xlgalist();
X xllastarg();
X
X /* append each element of this list to the result list */
X for (val = NIL; consp(next); next = cdr(next)) {
X push(val);
X val = cons(car(next),top());
X drop(1);
X }
X
X /* return the list */
X return (val);
X}
X
X/* xlastpair - built-in function 'last-pair' */
XLVAL xlastpair()
X{
X LVAL list;
X
X /* get the list */
X list = xlgalist();
X xllastarg();
X
X /* find the last cons */
X if (consp(list))
X while (consp(cdr(list)))
X list = cdr(list);
X
X /* return the last element */
X return (list);
X}
X
X/* xlength - built-in function 'length' */
XLVAL xlength()
X{
X FIXTYPE n;
X LVAL arg;
X
X /* get the argument */
X arg = xlgalist();
X xllastarg();
X
X /* find the length */
X for (n = (FIXTYPE)0; consp(arg); ++n)
X arg = cdr(arg);
X
X /* return the length */
X return (cvfixnum(n));
X}
X
X/* xmember - built-in function 'member' */
XLVAL xmember()
X{
X return (member(equal));
X}
X
X/* xmemv - built-in function 'memv' */
XLVAL xmemv()
X{
X return (member(eqv));
X}
X
X/* xmemq - built-in function 'memq' */
XLVAL xmemq()
X{
X return (member(eq));
X}
X
X/* member - common routine for member/memv/memq */
XLOCAL LVAL member(fcn)
X int (*fcn)();
X{
X LVAL x,list,val;
X
X /* get the expression to look for and the list */
X x = xlgetarg();
X list = xlgalist();
X xllastarg();
X
X /* look for the expression */
X for (val = NIL; consp(list); list = cdr(list))
X if ((*fcn)(x,car(list))) {
X val = list;
X break;
X }
X
X /* return the result */
X return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XLVAL xassoc()
X{
X return (assoc(equal));
X}
X
X/* xassv - built-in function 'assv' */
XLVAL xassv()
X{
X return (assoc(eqv));
X}
X
X/* xassq - built-in function 'assq' */
XLVAL xassq()
X{
X return (assoc(eq));
X}
X
X/* assoc - common routine for assoc/assv/assq */
XLOCAL LVAL assoc(fcn)
X int (*fcn)();
X{
X LVAL x,alist,pair,val;
X
X /* get the expression to look for and the association list */
X x = xlgetarg();
X alist = xlgalist();
X xllastarg();
X
X /* look for the expression */
X for (val = NIL; consp(alist); alist = cdr(alist))
X if ((pair = car(alist)) && consp(pair))
X if ((*fcn)(x,car(pair),fcn)) {
X val = pair;
X break;
X }
X
X /* return the result */
X return (val);
X}
X
X/* xlistref - built-in function 'list-ref' */
XLVAL xlistref()
X{
X return (nth(TRUE));
X}
X
X/* xlisttail - built-in function 'list-tail' */
XLVAL xlisttail()
X{
X return (nth(FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL LVAL nth(carflag)
X int carflag;
X{
X LVAL list,arg;
X int n;
X
X /* get n and the list */
X list = xlgalist();
X arg = xlgafixnum();
X xllastarg();
X
X /* range check the index */
X if ((n = (int)getfixnum(arg)) < 0)
X xlerror("index out of range",arg);
X
X /* find the nth element */
X for (; consp(list) && n; n--)
X list = cdr(list);
X
X /* make sure the list was long enough */
X if (n)
X xlerror("index out of range",arg);
X
X /* return the list beginning at the nth element */
X return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xboundp - is this a value bound to this symbol? */
XLVAL xboundp()
X{
X LVAL sym;
X sym = xlgasymbol();
X xllastarg();
X return (boundp(sym) ? true : NIL);
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X LVAL sym;
X sym = xlgasymbol();
X xllastarg();
X return (getvalue(sym));
X}
X
X/* xsetsymvalue - set the value of a symbol */
XLVAL xsetsymvalue()
X{
X LVAL sym,val;
X
X /* get the symbol */
X sym = xlgasymbol();
X val = xlgetarg();
X xllastarg();
X
X /* set the global value */
X setvalue(sym,val);
X
X /* return its value */
X return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X LVAL sym;
X
X /* get the symbol */
X sym = xlgasymbol();
X xllastarg();
X
X /* return the property list */
X return (getplist(sym));
X}
X
X/* xsetsymplist - set the property list of a symbol */
XLVAL xsetsymplist()
X{
X LVAL sym,val;
X
X /* get the symbol */
X sym = xlgasymbol();
X val = xlgetarg();
X xllastarg();
X
X /* set the property list */
X setplist(sym,val);
X return (val);
X}
X
X/* xget - get the value of a property */
XLVAL xget()
X{
X LVAL sym,prp;
X
X /* get the symbol and property */
X sym = xlgasymbol();
X prp = xlgasymbol();
X xllastarg();
X
X /* retrieve the property value */
X return (xlgetprop(sym,prp));
X}
X
X/* xput - set the value of a property */
XLVAL xput()
X{
X LVAL sym,val,prp;
X
X /* get the symbol and property */
X sym = xlgasymbol();
X prp = xlgasymbol();
X val = xlgetarg();
X xllastarg();
X
X /* set the property value */
X xlputprop(sym,val,prp);
X
X /* return the value */
X return (val);
X}
X
X/* xtheenvironment - built-in function 'the-environment' */
XLVAL xtheenvironment()
X{
X xllastarg();
X return (xlenv);
X}
X
X/* xprocenvironment - built-in function 'procedure-environment' */
XLVAL xprocenvironment()
X{
X LVAL arg;
X arg = xlgaclosure();
X xllastarg();
X return (getenv(arg));
X}
X
X/* xenvp - built-in function 'environment?' */
XLVAL xenvp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (envp(arg) ? true : NIL);
X}
X
X/* xenvbindings - built-in function 'environment-bindings' */
XLVAL xenvbindings()
X{
X LVAL env,frame,names,val,this,last;
X int len,i;
X
X /* get the environment */
X env = xlgetarg();
X xllastarg();
X
X /* check the argument type */
X if (closurep(env))
X env = getenv(env);
X else if (!envp(env))
X xlbadtype(env);
X
X /* initialize */
X frame = car(env);
X names = getelement(frame,0);
X len = getsize(frame);
X check(1);
X
X /* build a list of dotted pairs */
X for (val = last = NIL, i = 1; i < len; ++i, names = cdr(names)) {
X push(val);
X this = cons(cons(car(names),getelement(frame,i)),NIL);
X val = pop();
X if (last) rplacd(last,this);
X else val = this;
X last = this;
X }
X return (val);
X}
X
X/* xenvparent - built-in function 'environment-parent' */
XLVAL xenvparent()
X{
X LVAL env;
X env = xlgaenv();
X xllastarg();
X return (cdr(env));
X}
X
X/* xvector - built-in function 'vector' */
XLVAL xvector()
X{
X LVAL vect,*p;
X vect = newvector(xlargc);
X for (p = &vect->n_vdata[0]; moreargs(); )
X *p++ = xlgetarg();
X return (vect);
X}
X
X/* xmakevector - built-in function 'make-vector' */
XLVAL xmakevector()
X{
X LVAL arg,val,*p;
X int len;
X
X /* get the vector size */
X arg = xlgafixnum();
X len = (int)getfixnum(arg);
X
X /* check for an initialization value */
X if (moreargs()) {
X arg = xlgetarg(); /* get the initializer */
X xllastarg(); /* make sure that's the last argument */
X cpush(arg); /* save the initializer */
X val = newvector(len); /* create the vector */
X p = &val->n_vdata[0]; /* initialize the vector */
X for (arg = pop(); --len >= 0; )
X *p++ = arg;
X }
X
X /* no initialization value */
X else
X val = newvector(len); /* defaults to initializing to NIL */
X
X /* return the new vector */
X return (val);
X}
X
X/* xvlength - built-in function 'vector-length' */
XLVAL xvlength()
X{
X LVAL arg;
X arg = xlgavector();
X xllastarg();
X return (cvfixnum((FIXTYPE)getsize(arg)));
X}
X
X/* xivlength - built-in function '%vector-length' */
XLVAL xivlength()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (cvfixnum((FIXTYPE)getsize(arg)));
X}
X
X/* xvref - built-in function 'vector-ref' */
XLVAL xvref()
X{
X LVAL vref();
X return (vref(xlgavector()));
X}
X
X/* xivref - built-in function '%vector-ref' */
XLVAL xivref()
X{
X LVAL vref();
X return (vref(xlgetarg()));
X}
X
X/* vref - common code for xvref and xivref */
XLOCAL LVAL vref(vector)
X LVAL vector;
X{
X LVAL index;
X int i;
X
X /* get the index */
X index = xlgafixnum();
X xllastarg();
X
X /* range check the index */
X if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
X xlerror("index out of range",index);
X
X /* return the vector element */
X return (getelement(vector,i));
X}
X
X/* xvset - built-in function 'vector-set!' */
XLVAL xvset()
X{
X LVAL vset();
X return (vset(xlgavector()));
X}
X
X/* xivset - built-in function '%vector-set!' */
XLVAL xivset()
X{
X LVAL vset();
X return (vset(xlgetarg()));
X}
X
X/* vset - common code for xvset and xivset */
XLOCAL LVAL vset(vector)
X LVAL vector;
X{
X LVAL index,val;
X int i;
X
X /* get the index and the new value */
X index = xlgafixnum();
X val = xlgetarg();
X xllastarg();
X
X /* range check the index */
X if ((i = (int)getfixnum(index)) < 0 || i >= getsize(vector))
X xlerror("index out of range",index);
X
X /* set the vector element and return the value */
X setelement(vector,i,val);
X return (val);
X}
X
X/* xvectlist - built-in function 'vector->list' */
XLVAL xvectlist()
X{
X LVAL vect;
X int size;
X
X /* get the vector */
X vect = xlgavector();
X xllastarg();
X
X /* make a list from the vector */
X cpush(vect);
X size = getsize(vect);
X for (xlval = NIL; --size >= 0; )
X xlval = cons(getelement(vect,size),xlval);
X drop(1);
X return (xlval);
X}
X
X/* xlistvect - built-in function 'list->vector' */
XLVAL xlistvect()
X{
X LVAL vect,*p;
X int size;
X
X /* get the list */
X xlval = xlgalist();
X xllastarg();
X
X /* make a vector from the list */
X size = length(xlval);
X vect = newvector(size);
X for (p = &vect->n_vdata[0]; --size >= 0; xlval = cdr(xlval))
X *p++ = car(xlval);
X return (vect);
X}
X
X/* xmakearray - built-in function 'make-array' */
XLVAL xmakearray()
X{
X LVAL makearray1(),val;
X val = makearray1(xlargc,xlsp);
X drop(xlargc);
X return (val);
X}
X
XLVAL makearray1(argc,argv)
X int argc; LVAL *argv;
X{
X int size,i;
X LVAL arg;
X
X /* check for the end of the list of dimensions */
X if (--argc < 0)
X return (NIL);
X
X /* get this dimension */
X arg = *argv++;
X if (!fixp(arg))
X xlbadtype(arg);
X size = (int)getfixnum(arg);
X
X /* make the new array */
X cpush(newvector(size));
X
X /* fill the array and return it */
X for (i = 0; i < size; ++i)
X setelement(top(),i,makearray1(argc,argv));
X return (pop());
X}
X
X/* xaref - built-in function 'array-ref' */
XLVAL xaref()
X{
X LVAL array,index;
X int i;
X
X /* get the array */
X array = xlgavector();
X
X /* get each array index */
X while (xlargc > 1) {
X index = xlgafixnum(); i = (int)getfixnum(index);
X if (i < 0 || i > getsize(array))
X xlerror("index out of range",index);
X array = getelement(array,i);
X if (!vectorp(array))
X xlbadtype(array);
X }
X cpush(array); ++xlargc;
X return (xvref());
X}
X
X/* xaset - built-in function 'array-set!' */
XLVAL xaset()
X{
X LVAL array,index;
X int i;
X
X /* get the array */
X array = xlgavector();
X
X /* get each array index */
X while (xlargc > 2) {
X index = xlgafixnum(); i = (int)getfixnum(index);
X if (i < 0 || i > getsize(array))
X xlerror("index out of range",index);
X array = getelement(array,i);
X if (!vectorp(array))
X xlbadtype(array);
X }
X cpush(array); ++xlargc;
X return (xvset());
X}
X
X/* xnull - built-in function 'null?' */
XLVAL xnull()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (null(arg) ? true : NIL);
X}
X
X/* xatom - built-in function 'atom?' */
XLVAL xatom()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (atom(arg) ? true : NIL);
X}
X
X/* xlistp - built-in function 'list?' */
XLVAL xlistp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (listp(arg) ? true : NIL);
X}
X
X/* xnumberp - built-in function 'number?' */
XLVAL xnumberp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (numberp(arg) ? true : NIL);
X}
X
X/* xbooleanp - built-in function 'boolean?' */
XLVAL xbooleanp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (arg == true || arg == NIL ? true : NIL);
X}
X
X/* xpairp - built-in function 'pair?' */
XLVAL xpairp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (consp(arg) ? true : NIL);
X}
X
X/* xsymbolp - built-in function 'symbol?' */
XLVAL xsymbolp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (symbolp(arg) ? true : NIL);
X}
X
X/* xintegerp - built-in function 'integer?' */
XLVAL xintegerp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (fixp(arg) ? true : NIL);
X}
X
X/* xrealp - built-in function 'real?' */
XLVAL xrealp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (floatp(arg) ? true : NIL);
X}
X
X/* xcharp - built-in function 'char?' */
XLVAL xcharp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (charp(arg) ? true : NIL);
X}
X
X/* xstringp - built-in function 'string?' */
XLVAL xstringp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (stringp(arg) ? true : NIL);
X}
X
X/* xvectorp - built-in function 'vector?' */
XLVAL xvectorp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (vectorp(arg) ? true : NIL);
X}
X
X/* xprocedurep - built-in function 'procedure?' */
XLVAL xprocedurep()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (closurep(arg) ? true : NIL);
X}
X
X/* xobjectp - built-in function 'object?' */
XLVAL xobjectp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (closurep(arg) ? true : NIL);
X}
X
X/* xdefaultobjectp - built-in function 'default-object?' */
XLVAL xdefaultobjectp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (arg == default_object ? true : NIL);
X}
X
X/* xeq - built-in function 'eq?' */
XLVAL xeq()
X{
X return (eqtest(eq));
X}
X
X/* xeqv - built-in function 'eqv?' */
XLVAL xeqv()
X{
X return (eqtest(eqv));
X}
X
X/* xequal - built-in function 'equal?' */
XLVAL xequal()
X{
X return (eqtest(equal));
X}
X
X/* eqtest - common code for eq?/eqv?/equal? */
XLOCAL LVAL eqtest(fcn)
X int (*fcn)();
X{
X LVAL arg1,arg2;
X arg1 = xlgetarg();
X arg2 = xlgetarg();
X xllastarg();
X return ((*fcn)(arg1,arg2) ? true : NIL);
X}
X
X/* xgensym - generate a symbol */
XLVAL xgensym()
X{
X char sym[STRMAX+11]; /* enough space for prefix and number */
X LVAL x;
X
X /* get the prefix or number */
X if (moreargs()) {
X x = xlgetarg();
X switch (ntype(x)) {
X case SYMBOL:
X x = getpname(x);
X case STRING:
X strncpy(gsprefix,getstring(x),STRMAX);
X gsprefix[STRMAX] = '\0';
X break;
X case FIXNUM:
X gsnumber = getfixnum(x);
X break;
X default:
X xlerror("bad argument type",x);
X }
X }
X xllastarg();
X
X /* create the pname of the new symbol */
X sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X /* make a symbol with this print name */
X return (cvsymbol(sym));
X}
END_OF_FILE
if test 19708 -ne `wc -c <'Src/xsfun1.c'`; then
echo shar: \"'Src/xsfun1.c'\" unpacked with wrong size!
fi
# end of 'Src/xsfun1.c'
fi
if test -f 'Src/xsfun2.c' -a "${1}" != "-c" ; then
echo shar: Will not clobber existing file \"'Src/xsfun2.c'\"
else
echo shar: Extracting \"'Src/xsfun2.c'\" \(27271 characters\)
sed "s/^X//" >'Src/xsfun2.c' <<'END_OF_FILE'
X/* xsfun2.c - xscheme built-in functions - part 2 */
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 jmp_buf top_level;
Xextern LVAL eof_object,true;
Xextern LVAL xlfun,xlenv,xlval;
Xextern int prbreadth,prdepth;
Xextern FILE *tfp;
X
X/* external routines */
Xextern xlprin1(),xlprinc();
X
X/* forward declarations */
XFORWARD LVAL setit();
XFORWARD LVAL strcompare();
XFORWARD LVAL chrcompare();
X
X/* xapply - built-in function 'apply' */
XLVAL xapply()
X{
X LVAL args,*p;
X
X /* get the function and argument list */
X xlval = xlgetarg();
X args = xlgalist();
X xllastarg();
X
X /* get the argument count and make space on the stack */
X xlargc = length(args);
X check(xlargc);
X
X /* copy the arguments onto the stack */
X for (xlsp -= xlargc, p = xlsp; consp(args); args = cdr(args))
X *p++ = car(args);
X
X /* apply the function to the arguments */
X xlapply();
X}
X
X/* xcallcc - built-in function 'call-with-current-continuation' */
XLVAL xcallcc()
X{
X LVAL cont,*src,*dst;
X int size;
X
X /* get the function to call */
X xlval = xlgetarg();
X xllastarg();
X
X /* create a continuation object */
X size = (int)(xlstktop - xlsp);
X cont = newcontinuation(size);
X for (src = xlsp, dst = &cont->n_vdata[0]; --size >= 0; )
X *dst++ = *src++;
X
X /* setup the argument list */
X cpush(cont);
X xlargc = 1;
X
X /* apply the function */
X xlapply();
X}
X
X/* xmap - built-in function 'map' */
XLVAL xmap()
X{
X if (xlargc < 2) xltoofew();
X xlval = NIL;
X do_maploop(NIL);
X}
X
X/* do_maploop - setup for the next application */
Xdo_maploop(last)
X LVAL last;
X{
X extern LVAL cs_map1;
X LVAL *oldsp,*p,x;
X int cnt;
X
X /* get a pointer to the end of the argument list */
X p = &xlsp[xlargc];
X oldsp = xlsp;
X
X /* save a continuation */
X if (xlval) { check(5); push(xlval); push(last); }
X else { check(4); push(NIL); }
X push(cvfixnum((FIXTYPE)xlargc));
X push(cs_map1);
X push(xlenv);
X
X /* build the argument list for the next application */
X for (cnt = xlargc; --cnt >= 1; ) {
X x = *--p;
X if (consp(x)) {
X cpush(car(x));
X *p = cdr(x);
X }
X else {
X xlsp = oldsp;
X drop(xlargc);
X xlreturn();
X return;
X }
X }
X xlval = *--p; /* get the function to apply */
X xlargc -= 1; /* count shouldn't include the function itself */
X xlapply(); /* apply the function */
X}
X
X/* xmap1 - continuation for xmap */
XLVAL xmap1()
X{
X LVAL last,tmp;
X
X /* get the argument count */
X tmp = pop();
X
X /* get the tail of the value list */
X if (last = pop()) {
X rplacd(last,cons(xlval,NIL)); /* add the new value to the tail */
X last = cdr(last); /* remember the new tail */
X xlval = pop(); /* restore the head of the list */
X }
X else
X xlval = last = cons(xlval,NIL); /* build the initial value list */
X
X /* convert the argument count and loop */
X xlargc = (int)getfixnum(tmp);
X do_maploop(last);
X}
X
X/* xforeach - built-in function 'for-each' */
XLVAL xforeach()
X{
X if (xlargc < 2) xltoofew();
X do_forloop();
X}
X
X/* do_forloop - setup for the next application */
Xdo_forloop()
X{
X extern LVAL cs_foreach1;
X LVAL *oldsp,*p,x;
X int cnt;
X
X /* get a pointer to the end of the argument list */
X p = &xlsp[xlargc];
X oldsp = xlsp;
X
X /* save a continuation */
X check(3);
X push(cvfixnum((FIXTYPE)xlargc));
X push(cs_foreach1);
X push(xlenv);
X
X /* build the argument list for the next application */
X for (cnt = xlargc; --cnt >= 1; ) {
X x = *--p;
X if (consp(x)) {
X cpush(car(x));
X *p = cdr(x);
X }
X else {
X xlsp = oldsp;
X drop(xlargc);
X xlval = NIL;
X xlreturn();
X return;
X }
X }
X xlval = *--p; /* get the function to apply */
X xlargc -= 1; /* count shouldn't include the function itself */
X xlapply(); /* apply the function */
X}
X
X/* xforeach1 - continuation for xforeach */
XLVAL xforeach1()
X{
X LVAL tmp;
X
X /* get the argument count */
X tmp = pop();
X
X /* convert the argument count and loop */
X xlargc = (int)getfixnum(tmp);
X do_forloop();
X}
X
X/* xcallwi - built-in function 'call-with-input-file' */
XLVAL xcallwi()
X{
X do_withfile(PF_INPUT,"r");
X}
X
X/* xcallwo - built-in function 'call-with-output-file' */
XLVAL xcallwo()
X{
X do_withfile(PF_OUTPUT,"w");
X}
X
X/* do_withfile - handle the 'call-with-xxx-file' functions */
Xdo_withfile(flags,mode)
X int flags; char *mode;
X{
X extern LVAL cs_withfile1;
X extern FILE *osaopen();
X LVAL name,file;
X FILE *fp;
X
X /* get the function to call */
X name = xlgastring();
X xlval = xlgetarg();
X xllastarg();
X
X /* create a file object */
X file = cvport(NULL,flags);
X if ((fp = osaopen(getstring(name),mode)) == NULL)
X xlerror("can't open file",name);
X setfile(file,fp);
X
X /* save a continuation */
X check(3);
X push(file);
X push(cs_withfile1);
X push(xlenv);
X
X /* setup the argument list */
X cpush(file);
X xlargc = 1;
X
X /* apply the function */
X xlapply();
X}
X
X/* xwithfile1 - continuation for xcallwi and xcallwo */
XLVAL xwithfile1()
X{
X osclose(getfile(top()));
X setfile(pop(),NULL);
X xlreturn();
X}
X
X/* xload - built-in function 'load' */
XLVAL xload()
X{
X do_load(NIL);
X}
X
X/* xloadnoisily - built-in function 'load-noisily' */
XLVAL xloadnoisily()
X{
X do_load(true);
X}
X
X/* do_load - open the file and setup the load loop */
Xdo_load(print)
X LVAL print;
X{
X extern FILE *osaopen();
X LVAL file;
X FILE *fp;
X
X /* get the function to call */
X xlval = xlgastring();
X xllastarg();
X
X /* create a file object */
X file = cvport(NULL,PF_INPUT);
X if ((fp = osaopen(getstring(xlval),"r")) == NULL) {
X xlval = NIL;
X xlreturn();
X return;
X }
X setfile(file,fp);
X xlval = file;
X
X /* do the first read */
X do_loadloop(print);
X}
X
X/* do_loadloop - read the next expression and setup to evaluate it */
Xdo_loadloop(print)
X LVAL print;
X{
X extern LVAL cs_load1,s_eval;
X LVAL expr;
X
X /* try to read the next expression from the file */
X if (xlread(xlval,&expr)) {
X
X /* save a continuation */
X check(4);
X push(xlval);
X push(print);
X push(cs_load1);
X push(xlenv);
X
X /* setup the argument list */
X xlval = getvalue(s_eval);
X cpush(expr);
X xlargc = 1;
X
X /* apply the function */
X xlapply();
X }
X else {
X osclose(getfile(xlval));
X setfile(xlval,NULL);
X xlval = true;
X xlreturn();
X }
X}
X
X/* xload1 - continuation for xload */
XLVAL xload1()
X{
X LVAL print;
X
X /* print the value if the print variable is set */
X if (print = pop()) {
X xlprin1(xlval,curoutput());
X xlterpri(curoutput());
X }
X xlval = pop();
X
X /* setup for the next read */
X do_loadloop(print);
X}
X
X/* xforce - built-in function 'force' */
XLVAL xforce()
X{
X extern LVAL cs_force1;
X
X /* get the promise */
X xlval = xlgetarg();
X xllastarg();
X
X /* check for a promise */
X if (promisep(xlval)) {
X
X /* force the promise the first time */
X if ((xlfun = getpproc(xlval)) != NIL) {
X check(3);
X push(xlval);
X push(cs_force1);
X push(xlenv);
X xlval = xlfun;
X xlargc = 0;
X xlapply();
X }
X
X /* return the saved value if the promise has already been forced */
X else {
X xlval = getpvalue(xlval);
X xlreturn();
X }
X
X }
X
X /* otherwise, just return the argument */
X else
X xlreturn();
X}
X
X/* xforce1 - continuation for xforce */
XLVAL xforce1()
X{
X LVAL promise;
X promise = pop();
X setpvalue(promise,xlval);
X setpproc(promise,NIL);
X xlreturn();
X}
X
X/* xsymstr - built-in function 'symbol->string' */
XLVAL xsymstr()
X{
X xlval = xlgasymbol();
X xllastarg();
X return (getpname(xlval));
X}
X
X/* xstrsym - built-in function 'string->symbol' */
XLVAL xstrsym()
X{
X xlval = xlgastring();
X xllastarg();
X return (xlenter(getstring(xlval)));
X}
X
X/* xread - built-in function 'read' */
XLVAL xread()
X{
X LVAL fptr,val;
X
X /* get file pointer and eof value */
X fptr = (moreargs() ? xlgaiport() : curinput());
X xllastarg();
X
X /* read an expression */
X if (!xlread(fptr,&val))
X val = eof_object;
X
X /* return the expression */
X return (val);
X}
X
X/* xrdchar - built-in function 'read-char' */
XLVAL xrdchar()
X{
X LVAL fptr;
X int ch;
X fptr = (moreargs() ? xlgaiport() : curinput());
X xllastarg();
X return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvchar(ch));
X}
X
X/* xrdbyte - built-in function 'read-byte' */
XLVAL xrdbyte()
X{
X LVAL fptr;
X int ch;
X fptr = (moreargs() ? xlgaiport() : curinput());
X xllastarg();
X return ((ch = xlgetc(fptr)) == EOF ? eof_object : cvfixnum((FIXTYPE)ch));
X}
X
X/* xrdshort - built-in function 'read-short' */
XLVAL xrdshort()
X{
X unsigned char *p;
X short int val=0;
X LVAL fptr;
X int ch,n;
X fptr = (moreargs() ? xlgaiport() : curinput());
X xllastarg();
X for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; ) {
X if ((ch = xlgetc(fptr)) == EOF)
X return (eof_object);
X *p++ = ch;
X }
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xrdlong - built-in function 'read-long' */
XLVAL xrdlong()
X{
X unsigned char *p;
X long int val=0;
X LVAL fptr;
X int ch,n;
X fptr = (moreargs() ? xlgaiport() : curinput());
X xllastarg();
X for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; ) {
X if ((ch = xlgetc(fptr)) == EOF)
X return (eof_object);
X *p++ = ch;
X }
X return (cvfixnum((FIXTYPE)val));
X}
X
X/* xeofobjectp - built-in function 'eof-object?' */
XLVAL xeofobjectp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (arg == eof_object ? true : NIL);
X}
X
X/* xwrite - built-in function 'write' */
XLVAL xwrite()
X{
X LVAL fptr,val;
X
X /* get expression to print and file pointer */
X val = xlgetarg();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X
X /* print the value */
X xlprin1(val,fptr);
X return (true);
X}
X
X/* xprint - built-in function 'print' */
XLVAL xprint()
X{
X LVAL fptr,val;
X
X /* get expression to print and file pointer */
X val = xlgetarg();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X
X /* print the value */
X xlprin1(val,fptr);
X xlterpri(fptr);
X return (true);
X}
X
X/* xwrchar - built-in function 'write-char' */
XLVAL xwrchar()
X{
X LVAL fptr,ch;
X ch = xlgachar();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X xlputc(fptr,(int)getchcode(ch));
X return (true);
X}
X
X/* xwrbyte - built-in function 'write-byte' */
XLVAL xwrbyte()
X{
X LVAL fptr,ch;
X ch = xlgafixnum();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X xlputc(fptr,(int)getfixnum(ch));
X return (true);
X}
X
X/* xwrshort - built-in function 'write-short' */
XLVAL xwrshort()
X{
X unsigned char *p;
X short int val;
X LVAL fptr,v;
X int n;
X v = xlgafixnum(); val = (short int)getfixnum(v);
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X for (n = sizeof(short int), p = (unsigned char *)&val; --n >= 0; )
X xlputc(fptr,*p++);
X return (true);
X}
X
X/* xwrlong - built-in function 'write-long' */
XLVAL xwrlong()
X{
X unsigned char *p;
X long int val;
X LVAL fptr,v;
X int n;
X v = xlgafixnum(); val = (long int)getfixnum(v);
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X for (n = sizeof(long int), p = (unsigned char *)&val; --n >= 0; )
X xlputc(fptr,*p++);
X return (true);
X}
X
X/* xdisplay - built-in function 'display' */
XLVAL xdisplay()
X{
X LVAL fptr,val;
X
X /* get expression to print and file pointer */
X val = xlgetarg();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X
X /* print the value */
X xlprinc(val,fptr);
X return (true);
X}
X
X/* xnewline - terminate the current print line */
XLVAL xnewline()
X{
X LVAL fptr;
X
X /* get file pointer */
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X
X /* terminate the print line and return nil */
X xlterpri(fptr);
X return (true);
X}
X
X/* xprbreadth - set the maximum number of elements to be printed */
XLVAL xprbreadth()
X{
X return (setit(&prbreadth));
X}
X
X/* xprdepth - set the maximum depth of nested lists to be printed */
XLVAL xprdepth()
X{
X return (setit(&prdepth));
X}
X
X/* setit - common routine for prbreadth/prdepth */
XLOCAL LVAL setit(pvar)
X int *pvar;
X{
X LVAL arg;
X
X /* get the optional argument */
X if (moreargs()) {
X arg = xlgetarg();
X xllastarg();
X *pvar = (fixp(arg) ? (int)getfixnum(arg) : -1);
X }
X
X /* return the value of the variable */
X return (*pvar >= 0 ? cvfixnum((FIXTYPE)*pvar) : NIL);
X}
X
X/* xopeni - built-in function 'open-input-file' */
XLVAL xopeni()
X{
X LVAL openfile();
X return (openfile(PF_INPUT,"r"));
X}
X
X/* xopeno - built-in function 'open-output-file' */
XLVAL xopeno()
X{
X LVAL openfile();
X return (openfile(PF_OUTPUT,"w"));
X}
X
X/* xopena - built-in function 'open-append-file' */
XLVAL xopena()
X{
X LVAL openfile();
X return (openfile(PF_OUTPUT,"a"));
X}
X
X/* xopenu - built-in function 'open-update-file' */
XLVAL xopenu()
X{
X LVAL openfile();
X return (openfile(PF_INPUT|PF_OUTPUT,"r+"));
X}
X
X/* openfile - open an ascii or binary file */
XLOCAL LVAL openfile(flags,mode)
X int flags; char *mode;
X{
X extern FILE *osaopen(),*osbopen();
X LVAL file,modekey;
X char *name;
X FILE *fp;
X
X /* get the file name and direction */
X name = (char *)getstring(xlgastring());
X modekey = (moreargs() ? xlgasymbol() : NIL);
X xllastarg();
X
X /* check for binary mode */
X if (modekey != NIL) {
X if (modekey == xlenter("BINARY"))
X flags |= PF_BINARY;
X else if (modekey != xlenter("TEXT"))
X xlerror("unrecognized open mode",modekey);
X }
X
X /* try to open the file */
X file = cvport(NULL,flags);
X fp = ((flags & PF_BINARY) == 0 ? osaopen(name,mode) : osbopen(name,mode));
X if (fp == NULL)
X return (NIL);
X setfile(file,fp);
X return (file);
X}
X
X/* xclose - built-in function 'close-port' */
XLVAL xclose()
X{
X LVAL fptr;
X fptr = xlgaport();
X xllastarg();
X if (getfile(fptr))
X osclose(getfile(fptr));
X setfile(fptr,NULL);
X return (NIL);
X}
X
X/* xclosei - built-in function 'close-input-port' */
XLVAL xclosei()
X{
X LVAL fptr;
X fptr = xlgaiport();
X xllastarg();
X if (getfile(fptr))
X osclose(getfile(fptr));
X setfile(fptr,NULL);
X return (NIL);
X}
X
X/* xcloseo - built-in function 'close-output-port' */
XLVAL xcloseo()
X{
X LVAL fptr;
X fptr = xlgaoport();
X xllastarg();
X if (getfile(fptr))
X osclose(getfile(fptr));
X setfile(fptr,NULL);
X return (NIL);
X}
X
X/* xgetfposition - built-in function 'get-file-position' */
XLVAL xgetfposition()
X{
X extern long ostell();
X LVAL fptr;
X fptr = xlgaport();
X xllastarg();
X return (cvfixnum(ostell(getfile(fptr))));
X}
X
X/* xsetfposition - built-in function 'set-file-position!' */
XLVAL xsetfposition()
X{
X LVAL fptr,val;
X long position;
X int whence;
X fptr = xlgaport();
X val = xlgafixnum(); position = getfixnum(val);
X val = xlgafixnum(); whence = (int)getfixnum(val);
X xllastarg();
X return (osseek(getfile(fptr),position,whence) == 0 ? true : NIL);
X}
X
X/* xcurinput - built-in function 'current-input-port' */
XLVAL xcurinput()
X{
X xllastarg();
X return (curinput());
X}
X
X/* xcuroutput - built-in function 'current-output-port' */
XLVAL xcuroutput()
X{
X xllastarg();
X return (curoutput());
X}
X
X/* xportp - built-in function 'port?' */
XLVAL xportp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (portp(arg) ? true : NIL);
X}
X
X/* xinputportp - built-in function 'input-port?' */
XLVAL xinputportp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (iportp(arg) ? true : NIL);
X}
X
X/* xoutputportp - built-in function 'output-port?' */
XLVAL xoutputportp()
X{
X LVAL arg;
X arg = xlgetarg();
X xllastarg();
X return (oportp(arg) ? true : NIL);
X}
X
X/* xtranson - built-in function 'transcript-on' */
XLVAL xtranson()
X{
X extern FILE *osaopen();
X char *name;
X
X /* get the file name and direction */
X name = (char *)getstring(xlgastring());
X xllastarg();
X
X /* close any currently open transcript file */
X if (tfp) { osclose(tfp); tfp = NULL; }
X
X /* try to open the file */
X return ((tfp = osaopen(name,"w")) == NULL ? NIL : true);
X}
X
X/* xtransoff - built-in function 'transcript-off' */
XLVAL xtransoff()
X{
X /* make sure there aren't any arguments */
X xllastarg();
X
X /* make sure the transcript is open */
X if (tfp == NULL)
X return (NIL);
X
X /* close the transcript and return successfully */
X osclose(tfp); tfp = NULL;
X return (true);
X}
X
X/* xstrlen - built-in function 'string-length' */
XLVAL xstrlen()
X{
X LVAL str;
X str = xlgastring();
X xllastarg();
X return (cvfixnum((FIXTYPE)(getslength(str)-1)));
X}
X
X/* xstrnullp - built-in function 'string-null?' */
XLVAL xstrnullp()
X{
X LVAL str;
X str = xlgastring();
X xllastarg();
X return (getslength(str) == 1 ? true : NIL);
X}
X
X/* xstrappend - built-in function 'string-append' */
XLVAL xstrappend()
X{
X LVAL *savesp,tmp,val;
X unsigned char *str;
X int saveargc,len;
X
X /* save the argument list */
X saveargc = xlargc;
X savesp = xlsp;
X
X /* find the length of the new string */
X for (len = 0; moreargs(); ) {
X tmp = xlgastring();
X len += (int)getslength(tmp) - 1;
X }
X
X /* restore the argument list */
X xlargc = saveargc;
X xlsp = savesp;
X
X /* create the result string */
X val = newstring(len+1);
X str = getstring(val);
X
X /* combine the strings */
X for (*str = '\0'; moreargs(); ) {
X tmp = nextarg();
X strcat(str,getstring(tmp));
X }
X
X /* return the new string */
X return (val);
X}
X
X/* xstrref - built-in function 'string-ref' */
XLVAL xstrref()
X{
X LVAL str,num;
X int n;
X
X /* get the string and the index */
X str = xlgastring();
X num = xlgafixnum();
X xllastarg();
X
X /* range check the index */
X if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1)
X xlerror("index out of range",num);
X
X /* return the character */
X return (cvchar(getstring(str)[n]));
X}
X
X/* xsubstring - built-in function 'substring' */
XLVAL xsubstring()
X{
X unsigned char *srcp,*dstp;
X int start,end,len;
X LVAL src,dst;
X
X /* get string and starting and ending positions */
X src = xlgastring();
X
X /* get the starting position */
X dst = xlgafixnum(); start = (int)getfixnum(dst);
X if (start < 0 || start > getslength(src) - 1)
X xlerror("index out of range",dst);
X
X /* get the ending position */
X if (moreargs()) {
X dst = xlgafixnum(); end = (int)getfixnum(dst);
X if (end < 0 || end > getslength(src) - 1)
X xlerror("index out of range",dst);
X }
X else
X end = getslength(src) - 1;
X xllastarg();
X
X /* setup the source pointer */
X srcp = getstring(src) + start;
X len = end - start;
X
X /* make a destination string and setup the pointer */
X dst = newstring(len+1);
X dstp = getstring(dst);
X
X /* copy the source to the destination */
X while (--len >= 0)
X *dstp++ = *srcp++;
X *dstp = '\0';
X
X /* return the substring */
X return (dst);
X}
X
X/* xstrlist - built-in function 'string->list' */
XLVAL xstrlist()
X{
X unsigned char *p;
X LVAL str;
X int size;
X
X /* get the vector */
X str = xlgastring();
X xllastarg();
X
X /* make a list from the vector */
X cpush(str);
X size = getslength(str)-1;
X for (xlval = NIL, p = &getstring(str)[size]; --size >= 0; )
X xlval = cons(cvchar(*--p),xlval);
X drop(1);
X return (xlval);
X}
X
X/* xliststring - built-in function 'list->string' */
XLVAL xliststring()
X{
X unsigned char *p;
X LVAL str;
X int size;
X
X /* get the list */
X xlval = xlgalist();
X xllastarg();
X
X /* make a vector from the list */
X size = length(xlval);
X str = newstring(size+1);
X for (p = getstring(str); --size >= 0; xlval = cdr(xlval))
X if (charp(car(xlval)))
X *p++ = getchcode(car(xlval));
X else
X xlbadtype(car(xlval));
X *p = '\0';
X return (str);
X}
X
X/* string comparision functions */
XLVAL xstrlss() { return (strcompare('<',FALSE)); } /* string<? */
XLVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<=? */
XLVAL xstreql() { return (strcompare('=',FALSE)); } /* string=? */
XLVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>=? */
XLVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string>? */
X
X/* string comparison functions (case insensitive) */
XLVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-ci<? */
XLVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-ci<=? */
XLVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-ci=? */
XLVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-ci>=? */
XLVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-ci>? */
X
X/* strcompare - compare strings */
XLOCAL LVAL strcompare(fcn,icase)
X int fcn,icase;
X{
X int start1,end1,start2,end2,ch1,ch2;
X unsigned char *p1,*p2;
X LVAL str1,str2;
X
X /* get the strings */
X str1 = xlgastring();
X str2 = xlgastring();
X xllastarg();
X
X /* setup the string pointers */
X p1 = getstring(str1); start1 = 0; end1 = getslength(str1);
X p2 = getstring(str2); start2 = 0; end2 = getslength(str2);
X
X /* compare the strings */
X for (; start1 < end1 && start2 < end2; ++start1,++start2) {
X ch1 = *p1++;
X ch2 = *p2++;
X if (icase) {
X if (isupper(ch1)) ch1 = tolower(ch1);
X if (isupper(ch2)) ch2 = tolower(ch2);
X }
X if (ch1 != ch2)
X switch (fcn) {
X case '<': return (ch1 < ch2 ? true : NIL);
X case 'L': return (ch1 <= ch2 ? true : NIL);
X case '=': return (NIL);
X case 'G': return (ch1 >= ch2 ? true : NIL);
X case '>': return (ch1 > ch2 ? true : NIL);
X }
X }
X
X /* check the termination condition */
X switch (fcn) {
X case '<': return (start1 >= end1 && start2 < end2 ? true : NIL);
X case 'L': return (start1 >= end1 ? true : NIL);
X case '=': return (start1 >= end1 && start2 >= end2 ? true : NIL);
X case 'G': return (start2 >= end2 ? true : NIL);
X case '>': return (start2 >= end2 && start1 < end1 ? true : NIL);
X }
X}
X
X/* xcharint - built-in function 'char->integer' */
XLVAL xcharint()
X{
X LVAL arg;
X arg = xlgachar();
X xllastarg();
X return (cvfixnum((FIXTYPE)getchcode(arg)));
X}
X
X/* xintchar - built-in function 'integer->char' */
XLVAL xintchar()
X{
X LVAL arg;
X arg = xlgafixnum();
X xllastarg();
X return (cvchar((int)getfixnum(arg)));
X}
X
X/* character comparision functions */
XLVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char<? */
XLVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<=? */
XLVAL xchreql() { return (chrcompare('=',FALSE)); } /* char=? */
XLVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>=? */
XLVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char>? */
X
X/* character comparision functions (case insensitive) */
XLVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-ci<? */
XLVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-ci<=? */
XLVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-ci=? */
XLVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-ci>=? */
XLVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-ci>? */
X
X/* chrcompare - compare characters */
XLOCAL LVAL chrcompare(fcn,icase)
X int fcn,icase;
X{
X int ch1,ch2;
X LVAL arg;
X
X /* get the characters */
X arg = xlgachar(); ch1 = getchcode(arg);
X arg = xlgachar(); ch2 = getchcode(arg);
X xllastarg();
X
X /* convert to lowercase if case insensitive */
X if (icase) {
X if (isupper(ch1)) ch1 = tolower(ch1);
X if (isupper(ch2)) ch2 = tolower(ch2);
X }
X
X /* compare the characters */
X switch (fcn) {
X case '<': return (ch1 < ch2 ? true : NIL);
X case 'L': return (ch1 <= ch2 ? true : NIL);
X case '=': return (ch1 == ch2 ? true : NIL);
X case 'G': return (ch1 >= ch2 ? true : NIL);
X case '>': return (ch1 > ch2 ? true : NIL);
X }
X}
X
X/* xcompile - built-in function 'compile' */
XLVAL xcompile()
X{
X extern LVAL xlcompile();
X LVAL env;
X
X /* get the expression to compile and the environment */
X xlval = xlgetarg();
X env = (moreargs() ? xlgaenv() : NIL);
X xllastarg();
X
X /* build the closure */
X cpush(env);
X xlval = xlcompile(xlval,env);
X xlval = cvclosure(xlval,env);
X drop(1);
X return (xlval);
X}
X
X/* xdecompile - built-in function 'decompile' */
XLVAL xdecompile()
X{
X LVAL fun,fptr;
X
X /* get the closure (or code) and file pointer */
X fun = xlgetarg();
X fptr = (moreargs() ? xlgaoport() : curoutput());
X xllastarg();
X
X /* make sure we got either a closure or a code object */
X if (!closurep(fun) && !methodp(fun))
X xlbadtype(fun);
X
X /* decompile (disassemble) the procedure */
X decode_procedure(fptr,fun);
X return (NIL);
X}
X
X/* xsave - save the memory image */
XLVAL xsave()
X{
X unsigned char *name;
X
X /* get the file name, verbose flag and print flag */
X name = getstring(xlgastring());
X xllastarg();
X
X /* save the memory image */
X return (xlisave(name) ? true : NIL);
X}
X
X/* xrestore - restore a saved memory image */
XLVAL xrestore()
X{
X extern jmp_buf top_level;
X unsigned char *name;
X
X /* get the file name, verbose flag and print flag */
X name = getstring(xlgastring());
X xllastarg();
X
X /* restore the saved memory image */
X if (!xlirestore(name))
X return (NIL);
X
X /* return directly to the top level */
X stdputstr("[ returning to the top level ]\n");
X longjmp(top_level,1);
X}
X
X/* xgc - function to force garbage collection */
XLVAL xgc()
X{
X extern FIXTYPE nnodes,nfree,gccalls,total;
X extern int nscount,vscount;
X int arg1,arg2;
X LVAL arg;
X
X /* check the argument list and call the garbage collector */
X if (moreargs()) {
X arg = xlgafixnum(); arg1 = (int)getfixnum(arg);
X arg = xlgafixnum(); arg2 = (int)getfixnum(arg);
X xllastarg();
X nexpand(arg1);
X vexpand(arg2);
X }
X else
X gc();
X
X /* return (gccalls nnodes nfree nscount vscount total) */
X xlval = cons(cvfixnum(total),NIL);
X xlval = cons(cvfixnum((FIXTYPE)vscount),xlval);
X xlval = cons(cvfixnum((FIXTYPE)nscount),xlval);
X xlval = cons(cvfixnum(nfree),xlval);
X xlval = cons(cvfixnum(nnodes),xlval);
X xlval = cons(cvfixnum(gccalls),xlval);
X return (xlval);
X}
X
X/* xerror - built-in function 'error' */
XLVAL xerror()
X{
X extern jmp_buf top_level;
X LVAL msg;
X
X /* display the error message */
X msg = xlgastring();
X errputstr("error: ");
X errputstr(getstring(msg));
X errputstr("\n");
X
X /* print each of the remaining arguments on separate lines */
X while (moreargs()) {
X errputstr(" ");
X errprint(xlgetarg());
X }
X
X /* print the function where the error occurred */
X errputstr("happened in: ");
X errprint(xlfun);
X
X /* call the handler */
X callerrorhandler();
X}
X
X/* xreset - built-in function 'reset' */
XLVAL xreset()
X{
X extern jmp_buf top_level;
X xllastarg();
X longjmp(top_level,1);
X}
X
X/* xgetarg - return a command line argument */
XLVAL xgetarg()
X{
X extern char **clargv;
X extern int clargc;
X LVAL arg;
X int n;
X arg = xlgafixnum(); n = (int)getfixnum(arg);
X xllastarg();
X return (n >= 0 && n < clargc ? cvstring(clargv[n]) : NIL);
X}
X
X/* xexit - exit to the operating system */
XLVAL xexit()
X{
X xllastarg();
X wrapup();
X}
END_OF_FILE
if test 27271 -ne `wc -c <'Src/xsfun2.c'`; then
echo shar: \"'Src/xsfun2.c'\" unpacked with wrong size!
fi
# end of 'Src/xsfun2.c'
fi
echo shar: End of archive 4 \(of 7\).
cp /dev/null ark4isdone
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.