BSD 3 development

[unix-history] / usr / src / cmd / lisp / lam6.c

#include "global.h"
FILE *
mkstFI(base,count,flag)
char *base;
char flag;
{
       register FILE *p = stderr;

       /* find free file descriptor */
       for(;p->_flag&(_IOREAD|_IOWRT);p++)
               if(p >= _iob + _NFILE)
                       error("Too many open files to do readlist",FALSE);
       p->_flag = _IOSTRG | flag;
       p->_cnt = count;
       p->_base = base;
       p->_ptr = base;
       p->_file = -1;
       return(p);
}
lispval
Lreadli()
{
       register lispval work, handy;
       register FILE *p;
       register char *string;
       register struct argent *lbot, *np;
       struct argent *olbot;
       FILE *opiport = piport;
       lispval Lread();
       int count;

       chkarg(1);
       if(lbot->val==nil) {            /*effectively, return(matom(""));*/
               strbuf[0] = 0;
               return(getatom());
       }
       count = 1;

       /* compute length of list */
       for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr)
               count++;
       string = (char *) alloca(count);
       p = mkstFI(string, count - 1, _IOREAD);
       for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) {
               handy = work->car;
               switch(TYPE(handy)) {
               case SDOT:
               case INT:
                       *string++=handy->i;
                       break;
               case ATOM:
                       *string++ = *(handy->pname);
                       break;
               default:
                       error("Non atom or int to readlist",FALSE);
               }
       }
       *string = 0;
       olbot = lbot;
       lbot = np;
       protect(P(p));
       work = Lread();
       lbot = olbot;
       frstFI(p);
       return(work);
}
frstFI(p)
register FILE *p;
{
       p->_flag=0;
       p->_base=0;
       p->_cnt = 0;
       p->_ptr = 0;
       p->_file = 0;
}
lispval
Lgetenv()
{
       register struct argent *mylbot=lbot;
       snpand(1);
       if((TYPE(mylbot->val))!=ATOM)
               error("argument to getenv must be atom",FALSE);

       strcpy(strbuf,getenv(mylbot->val->pname));
       return(getatom());
}
lispval
Lboundp()
{
       register struct argent *mynp=lbot;
       register lispval result, handy;
       snpand(3);

       if((TYPE(mynp->val))!=ATOM)
               error("argument to boundp must be atom",FALSE);
       if( (handy = mynp->val)->clb==CNIL)
               result = nil;
       else
               (result = newdot())->cdr = handy->clb;
       return(result);
}
lispval
Lplist()
{       
       register lispval atm;
       snpand(0);
       /* get property list of an atom or disembodied property list */

       chkarg(1);
       atm = lbot->val;
       switch(TYPE(atm)) {
       case ATOM:
       case DTPR:
               break;
       default:
               error("Only Atoms and disembodied property lists allowed for plist",FALSE);
       }
       if(atm==nil) return(nilplist);
       return(atm->plist);
}
lispval
Lsetpli()
{       /* set the property list of the given atom to the given list */
       register lispval atm, vall;
       register lispval dum1, dum2;
       register struct argent *lbot, *np;
       snpand(2);

       chkarg(2);
       atm = lbot->val;
       if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE);
       vall = (np-1)->val;
       if (TYPE(vall)!= DTPR && vall !=nil)
           error("Second argument must be a list",FALSE);
       if (atm==nil)
               nilplist = vall;
       else
               atm->plist = vall;
       return(vall);
}

lispval
Lsignal()
{
       register struct argent *mylbot = lbot;
       extern lispval sigacts[16];
       int i; register lispval handy, old;
       chkarg(2);

       handy = mylbot[AD].val;
       if(TYPE(handy)!=INT)
               error("First arg to signal must be an int",FALSE);
       i = handy->i & 15;
       handy = mylbot[AD+1].val;
       if(TYPE(handy)!=ATOM)
               error("Second arg to signal must be an atom",FALSE);
       old = sigacts[i];
       if(old==0) old = nil;
       if(handy==nil)
               sigacts[i]=((lispval) 0);
       else
               sigacts[i]=handy;
       return(old);
}
lispval
Lassq()
{
       register lispval work, handy, dum1, dum2;
       register struct argent *lbot, *np;
       snpand(2);

       chkarg(2);
       for(work = lbot[AD+1].val;
               work->car->car!=lbot->val&& work!=nil;
               work = work->cdr);
       return(work->car);
}
lispval
Lkilcopy()
{
       if(fork()==0) {
               asm(".byte 0");
       }
}
lispval
Larg()
{
       register lispval handy; register offset, count;
       snpand(3);

       handy = lexpr_atom->clb;
       if(handy==CNIL || TYPE(handy)!=DTPR)
               error("Arg: not in context of Lexpr.",FALSE);
       count = ((long *)handy->cdr) - (long *)handy->car;
       if(np==lbot || lbot->val==nil)
               return(inewint(count));
       if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
               error("Out of bonds: arg to \"Arg\"",FALSE);
       return( ((struct argent *)handy->car)[offset].val);
}
lispval
Lptime(){
       extern int GCtime;
       int lgctime = GCtime;
       static struct tbuf {
               long    mytime;
               long    allelse[3];
       } current;
       register lispval result, handy;

       snpand(2);
       times(&current);
       result = newdot();
       handy = result;
       protect(result);
       result->cdr = newdot();
       result->car = inewint(current.mytime);
       handy = result->cdr;
       handy->car = inewint(lgctime);
       handy->cdr = nil;
       if(GCtime==0)
               GCtime = 1;
       return(result);
}

/* (err [value] [flag]) 
  where if value is present, it is the value to throw to the errset.
  flag if present must evaluate to nil, as we always evaluate value
  before unwinding stack
*/

lispval Lerr()
{
       register lispval handy;
       lispval errorh();
       char *mesg = "call to err";  /* default message */

       chkarg(1);

       if ((np >= lbot + 2) && ((lbot+1)->val != nil))
               error("Second arg to err must be nil",FALSE);
       if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM))
           mesg = lbot->val->pname;            /* new message if atom */
                               
       return(errorh(Vererr,mesg,lbot->val,nil));
}
lispval
Ltyi()
{
       register FILE *port;
       register char val;

       chkarg(1);
       port = okport(lbot->val,okport(Vpiport->clb,stdin));


       fflush(stdout);         /* flush any pending output characters */
       val = getc(port);
       return(inewint(val));
}
lispval
Ltyipeek()
{
       register FILE *port;
       register char val;

       chkarg(1);
       port = okport(lbot->val,okport(Vpiport->clb,stdin));

       fflush(stdout);         /* flush any pending output characters */
       val = getc(port);
       ungetc(val,port);
       return(inewint(val));
}
lispval
Ltyo()
{
       register FILE *port;
       register lispval handy, where;
       register char val;
       register struct argent *lbot, *np;

       chkarg(2);
       handy = lbot->val;
       if(TYPE(handy)!=INT)
               error("Tyo demands number for 1st arg",FALSE);
       val = handy->i;

       where = lbot[1].val;
       port = (FILE *) okport(where,okport(Vpoport->clb,stdout));
       putc(val,port);
       return(handy);
}
lispval
Imkrtab(current)
{
       extern struct rtab {
               char ctable[132];
       } initread;
       register lispval handy; extern lispval lastrtab;
       static int cycle = 0;
       static char *nextfree;
       if((cycle++)%3==0) {
               nextfree = (char *) csegment(int_name,128);
       }
       handy = newarray();
       handy->data = nextfree;
       if(current == 0)
               *(struct rtab *)nextfree = initread;
       else
               *(struct rtab *)nextfree = *(struct rtab *)ctable;
       handy->delta = inewint(4);
       handy->length = inewint(sizeof(struct rtab)/sizeof(int));
       handy->accfun = handy->aux  = nil;
       nextfree += sizeof(struct rtab);
       return(handy);
}

/* makereadtable - arg : t or nil
       returns a readtable, t means return a copy of the initial readtable

                            nil means return a copy of the current readtable
*/
lispval
Lmakertbl()
{
       if(lbot==np) error("makereadtable: wrong number of args",FALSE);

       if(TYPE(lbot->val) != ATOM) 
               error("makereadtable: arg must be atom",FALSE);

       if(lbot->val == nil) return(Imkrtab(1));
       else return(Imkrtab(0));
}
lispval
Lcpy1()
{
       register lispval handy = lbot->val, result = handy;

top:
       switch(TYPE(handy))
       {
       case INT:
               result = inewint(handy->i);
               break;
       case VALUE:
               (result = newval())->l = handy->l;
               break;
       case DOUB:
               (result = newdoub())->r = handy->r;
               break;
       default:
               lbot->val =
                   errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
               goto top;
       }
       return(result);
}