BSD 3 development

Work on file usr/src/cmd/lisp/lam7.c
Work on file usr/src/cmd/lisp/lamr.c

Synthesized-from: 3bsd

diff --git a/usr/src/cmd/lisp/lam7.c b/usr/src/cmd/lisp/lam7.c
new file mode 100644 (file)
index 0000000..2b2bd12
--- /dev/null
+++ b/usr/src/cmd/lisp/lam7.c
@@ -0,0 +1,357 @@
+#include "global.h"
+
+lispval
+Lfork() {
+       register lispval temp;
+       int pid;
+
+       chkarg(0);
+       if ((pid=fork())) {
+               temp = newint();
+               temp->i = pid;
+               return(temp);
+       } else
+               return(nil);
+}
+
+lispval
+Lwait()
+{
+       register lispval ret, temp;
+       int status = -1, pid;
+       snpand(2);
+
+
+       chkarg(0);
+       pid = wait(&status);
+       ret = newdot();
+       protect(ret);
+       temp = newint();
+       temp->i = pid;
+       ret->car = temp;
+       temp = newint();
+       temp->i = status;
+       ret->cdr = temp;
+       return(ret);
+}
+
+lispval
+Lpipe()
+{
+       register lispval ret, temp;
+       int pipes[2];
+
+       chkarg(0);
+       pipes[0] = -1;
+       pipes[1] = -1;
+       pipe(pipes);
+       ret = newdot();
+       protect(ret);
+       temp = newint();
+       temp->i = pipes[0];
+       ret->car = temp;
+       temp = newint();
+       temp->i = pipes[1];
+       ret->cdr = temp;
+       return(ret);
+}
+
+lispval
+Lfdopen()
+{
+       register lispval fd, type;
+       FILE *ptr;
+
+       chkarg(2);
+       type = (np-1)->val;
+       fd = lbot->val;
+       if( TYPE(fd)!=INT )
+               return(nil);
+       if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
+               return(nil);
+       return(P(ptr));
+}
+
+lispval
+Lexece()
+{
+       lispval fname, arglist, envlist, temp;
+       char *args[100], *envs[100], estrs[1024];
+       char *p, *cp, **sp;
+       snpand(0);
+
+       chkarg(3);
+       envlist = (--np)->val;
+       arglist = (--np)->val;
+       fname = (--np)->val;
+       if (TYPE(fname)!=ATOM)
+               return(nil);
+       if (TYPE(arglist)!=DTPR && arglist!=nil)
+               return(nil);    
+       for (sp=args; arglist!=nil; arglist=arglist->d.cdr) {
+               temp = arglist->d.car;
+               if (TYPE(temp)!=ATOM)
+                       return(nil);
+               *sp++ = temp->a.pname;
+       }
+       *sp = 0;
+       if (TYPE(envlist)!=DTPR && envlist!=nil)
+               return(nil);
+       for (sp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
+               temp = envlist->d.car;
+               if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
+                 || TYPE(temp->d.cdr)!=ATOM)
+                       return(nil);
+               *sp++ = cp;
+               for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
+               *(cp-1) = '=';
+               for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
+       }
+       *sp = 0;
+       execve(fname->a.pname, args, envs);
+       return(nil);
+}
+       
+lispval
+Lgensym()
+{
+       lispval arg;
+       char leader;
+       static int counter = 0;
+
+       chkarg(1);
+       arg = lbot->val;
+       leader = 'g';
+       if (arg != nil && TYPE(arg)==ATOM)
+               leader = arg->a.pname[0];
+       sprintf(strbuf, "%c%05d", leader, counter++);
+       atmlen = 7;
+       return((lispval)newatom());
+}
+extern struct types {
+char   *next_free;
+int    space_left,
+       space,
+       type,
+       type_len;                       /*  note type_len is in units of int */
+lispval *items,
+       *pages,
+       *type_name;
+struct heads
+       *first;
+} atom_str ;
+
+lispval
+Lremprop()
+{
+       register struct argent *argp;
+       register lispval pptr, ind, opptr;
+       register struct argent *lbot, *np;
+       lispval atm;
+       int disemp = FALSE;
+
+       chkarg(2);
+       argp = lbot;
+       ind = argp[1].val;
+       atm = argp->val;
+       switch (TYPE(atm)) {
+       case DTPR:
+               pptr = atm->cdr;
+               disemp = TRUE;
+               break;
+       case ATOM:
+               if((lispval)atm==nil)
+                       pptr = nilplist;
+               else
+                       pptr = atm->plist;
+               break;
+       default:
+               errorh(Vermisc, "remprop: Illegal first argument :",
+                      nil, FALSE, 0, atm);
+       }
+       opptr = nil;
+       if (pptr==nil) 
+               return(nil);
+       while(TRUE) {
+               if (TYPE(pptr->cdr)!=DTPR)
+                       errorh(Vermisc, "remprop: Bad property list",
+                              nil, FALSE, 0,atm);
+               if (pptr->car == ind) {
+                       if( opptr != nil)
+                               opptr->cdr = pptr->cdr->cdr;
+                       else if(disemp)
+                               atm->cdr = pptr->cdr->cdr;
+                       else if(atm==nil)
+                               nilplist = pptr->cdr->cdr;
+                       else
+                               atm->plist = pptr->cdr->cdr;
+                       return(pptr->cdr);
+               }
+               if ((pptr->cdr)->cdr == nil) return(nil);
+               opptr = pptr->cdr;
+               pptr = (pptr->cdr)->cdr;
+       }
+}
+
+lispval
+Lbcdad()
+{
+       lispval ret, temp;
+
+       chkarg(1);
+       temp = lbot->val;
+       if (TYPE(temp)!=ATOM)
+               error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
+       temp = temp->fnbnd;
+       if (TYPE(temp)!=BCD)
+               return(nil);
+       ret = newint();
+       ret->i = (int)temp;
+       return(ret);
+}
+
+lispval
+Lstringp()
+{
+       chkarg(1);
+       if (TYPE(lbot->val)==STRNG)
+               return(tatom);
+       return(nil);
+}
+
+lispval
+Lsymbolp()
+{
+       chkarg(1);
+       if (TYPE(lbot->val)==ATOM)
+               return(tatom);
+       return(nil);
+}
+
+lispval
+Lrematom()
+{
+       register lispval temp;
+
+       chkarg(1);
+       temp = lbot->val;
+       if (TYPE(temp)!=ATOM)
+               return(nil);
+       temp->a.fnbnd = nil;
+       temp->a.pname = (char *)CNIL;
+       temp->a.plist = nil;
+       (atom_items->i)--;
+       (atom_str.space_left)++;
+       temp->a.clb=(lispval)atom_str.next_free;
+       atom_str.next_free=(char *) temp;
+       return(tatom);
+}
+
+#define QUTMASK 0200
+#define VNUM 0000
+
+lispval
+Lprname()
+{
+       lispval a, ret;
+       register lispval work, prev;
+       char    *front, *temp; int clean;
+       char ctemp[100];
+       extern char *ctable;
+       snpand(2);
+
+       chkarg(1);
+       a = lbot->val;
+       switch (TYPE(a)) {
+               case INT:
+                       sprintf(ctemp,"%d",a->i);
+                       break;
+
+               case DOUB:
+                       sprintf(ctemp,"%f",a->r);
+                       break;
+       
+               case ATOM:
+                       temp = front = a->pname;
+                       clean = *temp;
+                       if (*temp == '-') temp++;
+                       clean = clean && (ctable[*temp] != VNUM);
+                       while (clean && *temp)
+                               clean = (!(ctable[*temp++] & QUTMASK));
+                       if (clean)
+                               strcpyn(ctemp, front, 99);
+                       else    
+                               sprintf(ctemp,"\"%s\"",front);
+                       break;
+       
+               default:
+                       error("prname does not support this type", FALSE);
+       }
+       temp = ctemp;
+       protect(ret = prev = newdot());
+       while (*temp) {
+               prev->cdr = work = newdot();
+               strbuf[0] = *temp++;
+               strbuf[1] = 0;
+               work->car = getatom();
+               work->cdr = nil;
+               prev = work;
+       }
+       return(ret->cdr);
+}
+Lexit()
+{
+       register lispval handy;
+       if(np-lbot==0) exit(0);
+       handy = lbot->val;
+       if(TYPE(handy)==INT)
+               exit(handy->i);
+       exit(-1);
+}
+lispval
+Iimplode(unintern)
+{
+       register lispval handy, work;
+       register char *cp = strbuf;
+       extern int atmlen;      /* used by newatom and getatom */
+
+       chkarg(1);
+       for(handy = lbot->val; handy!=nil; handy = handy->cdr)
+       {
+               work = handy->car;
+               if(cp >= endstrb)
+                       errorh(Vermisc,"maknam/impode argument exceeds buffer",nil,FALSE,43,lbot->val);
+       again:
+               switch(TYPE(work))
+               {
+               case ATOM:
+                       *cp++ = work->pname[0];
+                       break;
+               case SDOT:
+               case INT:
+                       *cp++ = work->i;
+                       break;
+               case STRNG:
+                       *cp++ = * (char *) work;
+                       break;
+               default:
+                       work = errorh(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
+                       goto again;
+               }
+       }
+       *cp = 0;
+       if(unintern) return((lispval)newatom());
+       else return((lispval) getatom());
+}
+
+lispval
+Lmaknam()
+{
+       return(Iimplode(TRUE));         /* unintern result */
+}
+
+lispval
+Limplode()
+{
+       return(Iimplode(FALSE));        /* intern result */
+}

diff --git a/usr/src/cmd/lisp/lamr.c b/usr/src/cmd/lisp/lamr.c
new file mode 100644 (file)
index 0000000..ea6427e
--- /dev/null
+++ b/usr/src/cmd/lisp/lamr.c
@@ -0,0 +1,482 @@
+# include "global.h"
+# include <a.out.h>
+
+/************************************************************************/
+/*                                                                     */
+/*  Lalloc                                                             */
+/*                                                                     */
+/*  This lambda allows allocation of pages from lisp.  The first       */
+/*  argument is the name of a space, n pages of which are allocated,   */
+/*  if possible.  Returns the number of pages allocated.               */
+
+lispval
+Lalloc()
+       {
+       int n;
+       register struct argent *mylbot = lbot;
+       snpand(1);
+       chkarg(2);
+       if(TYPE((mylbot+1)->val) != INT && (mylbot+1)->val != nil )
+               error("2nd ARGUMENT TO ALLOCATE MUST BE AN INTEGER",FALSE);
+       n = 1;
+       if((mylbot+1)->val != nil) n = (mylbot+1)->val->i;
+       return(alloc((mylbot)->val,n)); /*  call alloc to do the work  */
+       }
+
+lispval
+Lsizeof()
+       {
+       chkarg(1);
+       return(inewint(csizeof(lbot->val)));
+       }
+
+lispval
+Lsegment()
+       {
+       chkarg(2);
+chek:  while(TYPE(np[-1].val) != INT )
+               np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
+       if( np[-1].val->i < 0 )
+               {
+               np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
+               goto chek;
+               }
+       return(csegment((lbot)->val,np[-1].val->i));
+       }
+
+/*  Lforget  *************************************************************/
+/*                                                                     */
+/*  This function removes an atom from the hash table.                 */
+
+lispval
+Lforget()
+       {
+       char c,*name;
+       struct atom *buckpt;
+       int hash;
+       chkarg(1);
+       if(TYPE(lbot->val) != ATOM)
+               error("CANNOT FORGET NON-ATOM",FALSE);
+       name = lbot->val->pname;
+       hash = 0;
+       while( (c = *name++) != NULL_CHAR) hash ^= c;
+       hash = hash & 0177;
+
+       /*  We have found the hash bucket for the atom, now we remove it  */
+
+       if( hasht[hash] == (struct atom *)lbot->val )
+               {
+               hasht[hash] = lbot->val->hshlnk;
+               lbot->val->hshlnk = (struct atom *)CNIL;
+               return(lbot->val);
+               }
+
+       buckpt = hasht[hash];
+       while(buckpt != (struct atom *)CNIL)
+               {
+               if(buckpt->hshlnk == (struct atom *)lbot->val)
+                       {
+                       buckpt->hshlnk = lbot->val->hshlnk;
+                       lbot->val->hshlnk = (struct atom *)CNIL;
+                       return(lbot->val);
+                       }
+               buckpt = buckpt->hshlnk;
+               }
+
+       /*  Whoops!  Guess it wasn't in the hash table after all.  */
+
+       return(lbot->val);
+       }
+
+lispval
+Lgetl()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val) != ARRAY)
+               error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
+       return(lbot->val->length);
+       }
+
+lispval
+Lputl()
+       {
+       chkarg(2);
+       if(TYPE((lbot)->val) != ARRAY)
+               error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
+chek:  while(TYPE(np[-1].val) != INT)
+               np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
+       if(np[-1].val->i <= 0)
+               {
+               np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
+               goto chek;
+               }
+       return((lbot)->val->length = np[-1].val);
+       }
+lispval
+Lgetdel()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val) != ARRAY)
+               error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
+       return(lbot->val->delta);
+       }
+
+lispval
+Lputdel()
+       {
+       chkarg(2);
+       if(TYPE((np-2)->val) != ARRAY)
+               error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
+chek:  while(TYPE(np[-1].val) != INT)
+               np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
+       if(np[-1].val->i <= 0)
+               {
+               np[-1].val = error("ARRAY DELTA MUST BE POSITIVE",TRUE);
+               goto chek;
+               }
+       return((lbot)->val->delta = np[-1].val);
+       }
+
+lispval
+Lgetaux()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val)!=ARRAY)
+               error("ARG TO GETAUX MUST BE ARRAY",FALSE);
+       return(lbot->val->aux);
+       }
+
+lispval
+Lputaux()
+       {
+       chkarg(2);
+
+       if(TYPE((lbot)->val)!=ARRAY)
+               error("1st ARG TO PUTAUX MUST BBE ARRAY",FALSE);
+       return((lbot)->val->aux = np[-1].val);
+       }
+
+lispval
+Lgeta()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val) != ARRAY)
+               error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
+       return(lbot->val->accfun);
+       }
+
+lispval
+Lputa()
+       {
+       chkarg(2);
+       if(TYPE((lbot)->val) != ARRAY)
+               error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
+       return((lbot)->val->accfun = np[-1].val);
+       }
+
+lispval
+Lmarray()
+{
+       register struct argent *mylbot = lbot;
+       register lispval handy;
+       snpand(2);
+       chkarg(5);
+       (handy = newarray());           /*  get a new array cell  */
+       handy->data=(char *)mylbot->val;/*  insert data address  */
+       handy->accfun = mylbot[1].val;  /*  insert access function  */
+       handy->aux = mylbot[2].val;     /*  insert aux data  */
+       handy->length = mylbot[3].val;  /*  insert length  */
+       handy->delta = mylbot[4].val;   /*  push delta arg  */
+       return(handy);
+       }
+
+lispval
+Lgetentry()
+       {
+       chkarg(1);
+       if( TYPE(lbot->val) != BCD )
+               error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
+       return((lispval)(lbot->val->entry));
+       }
+
+lispval
+Lgetlang()
+       {
+       chkarg(1);
+       while(TYPE(lbot->val)!=BCD)
+               lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
+       return(lbot->val->language);
+       }
+
+lispval
+Lputlang()
+       {
+       chkarg(2);
+       while(TYPE((lbot)->val)!=BCD)
+               lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
+       (lbot)->val->language = np[-1].val;
+       return(np[-1].val);
+       }
+
+lispval
+Lgetparams()
+       {
+       chkarg(1);
+       if(TYPE(np[-1].val)!=BCD)
+               error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
+       return(np[-1].val->params);
+       }
+
+lispval
+Lputparams()
+       {
+       chkarg(2);
+       if(TYPE((lbot)->val)!=BCD)
+               error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
+       return((lbot)->val->params = np[-1].val);
+       }
+
+lispval
+Lgetdisc()
+       {
+       chkarg(1);
+       if(TYPE(np[-1].val) != BCD)
+               error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
+       return(np[-1].val->discipline);
+       }
+
+lispval
+Lputdisc()
+       {
+       chkarg(2);
+       if(TYPE(np[-2].val) != BCD)
+               error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
+       return((np-2)->val->discipline  = np[-1].val);
+       }
+
+lispval
+Lgetloc()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val)!=BCD)
+               error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
+       return(lbot->val->loctab);
+       }
+
+lispval
+Lputloc()
+       {
+       chkarg(2);
+       if(TYPE((lbot+1)->val)!=BCD);
+               error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
+       (lbot)->val->loctab = (lbot+1)->val;
+       return((lbot+1)->val);
+       }
+
+lispval
+Lmfunction()
+       {
+       register lispval handy;
+       chkarg(5);
+       handy = (newfunct());   /*  get a new function cell  */
+       handy->entry = (lispval (*)())((np-5)->val);    /* insert entry point */
+       handy->discipline = ((np-4)->val); /*  insert discipline  */
+#ifdef ROWAN
+       handy->language = (np-3)->val;  /*  insert language  */
+       handy->params = ((np-2)->val);     /*  insert parameters  */
+       handy->loctab = ((np-1)->val);  /*  insert local table  */
+#endif
+       return(handy);
+       }
+
+/** Lreplace ************************************************************/
+/*                                                                     */
+/*  Destructively modifies almost any kind of data.                    */
+
+lispval
+Lreplace()
+       {
+       register lispval a1, a2;
+       register int t;
+       chkarg(2);
+
+       if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
+               error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
+
+       switch( t )
+               {
+       case ATOM:      error("REPLACE CANNOT STORE ATOMS",FALSE);
+
+       case VALUE:     a1->l = a2->l;
+                       return( a1 );
+
+       case INT:       a1->i = a2->i;
+                       return( a1 );
+
+       case STRNG:     error("STORE CANNOT STORE STRINGS",FALSE);
+
+       case ARRAY:     a1->data = a2->data;
+                       a1->accfun = a2->accfun;
+                       a1->length = a2->length;
+                       a1->delta = a2->delta;
+                       return( a1 );
+
+       case DOUB:      a1->r = a2->r;
+                       return( a1 );
+
+       case SDOT:
+       case DTPR:      a1->car = a2->car;
+                       a1->cdr = a2->cdr;
+                       return( a1 );
+       case BCD:       a1->entry = a2->entry;
+                       a1->discipline = a2->discipline;
+                       return( a1 );
+               }
+       /* NOT REACHED */
+       }
+
+/* Lvaluep */
+
+lispval
+Lvaluep()
+       {
+       chkarg(1);
+       if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
+       }
+
+CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
+
+lispval
+Lod()
+       {
+       int i;
+       chkarg(2);
+
+       while( TYPE(np[-1].val) != INT )
+               np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
+
+       for( i = 0; i < np->val->i; ++i )
+               printf(copval(odform,CNIL)->pname,(int *)(np[-2].val)[i]);
+
+       dmpport(poport);
+       return(nil);
+       }
+lispval
+Lfake()
+       {
+       chkarg(1);
+
+       if( TYPE(lbot->val) != INT )
+               error("ARG TO FAKE MUST BE INTEGER",TRUE);
+
+       return((lispval)(lbot->val->i));
+       }
+
+lispval
+Lwhat()
+       {
+       chkarg(1);
+       return(inewint((int)(lbot->val)));
+       }
+
+lispval
+Lpname()
+       {
+       chkarg(1);
+       if(TYPE(lbot->val) != ATOM)
+               error("ARG TO PNAME MUST BE AN ATOM",FALSE);
+       return((lispval)(lbot->val->pname));
+       }
+
+lispval
+Larrayref()
+       {
+       chkarg(2);
+       if(TYPE((lbot)->val) != ARRAY)
+               error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
+       vtemp = (lbot + 1)->val;
+chek:  while(TYPE(vtemp) != INT)
+               vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
+       if( vtemp->i < 0 )
+               {
+               vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
+               goto chek;
+               }
+       if( vtemp->i >= (np-2)->val->length->i )
+               {
+               vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
+               goto chek;
+               }
+       vtemp = (lispval)((np-2)->val->data + ((np-2)->val->delta->i)*(vtemp->i));
+               /*  compute address of desired item  */
+       return(vtemp);
+                       
+       }
+
+lispval
+Lptr()
+       {
+       chkarg(1);
+       return(inewval(lbot->val));
+       }
+
+lispval
+Llctrace()
+       {
+       chkarg(1);
+       lctrace = (int)(lbot->val->clb);
+       return((lispval)lctrace);
+       }
+
+lispval
+Lslevel()
+       {
+       return(inewint(np-orgnp-2));
+       }
+
+lispval
+Lsimpld()
+       {
+       register lispval pt;
+       register char *cpt = strbuf;
+
+       chkarg(1);
+
+       for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->cdr);
+
+       if( atmlen > STRBLEN )
+               {
+               error("LCODE WAS TOO LONG",TRUE);
+               return((lispval)inewstr(""));
+               }
+
+       for(pt=np->val; NOTNIL(pt); pt = pt->cdr) *(cpt++) = pt->car->i;
+       *cpt = 0;
+
+       return((lispval)newstr());
+       }
+       
+       
+/*  Lopval  *************************************************************/
+/*                                                                     */
+/*  Routine which allows system registers and options to be examined   */
+/*  and modified.  Calls copval, the routine which is called by c code */
+/*  to do the same thing from inside the system.                       */
+
+lispval 
+Lopval()
+       {
+       lispval quant;
+       snpand(0);
+
+       if( lbot == np )
+               return(error("BAD CALL TO OPVAL",TRUE));
+       quant = lbot->val;       /*  get name of sys variable  */
+       while( TYPE(quant) != ATOM )
+               quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE);
+
+       if(np > lbot+1)  vtemp = (lbot+1)->val ;
+       else vtemp = CNIL;
+       return(copval(quant,vtemp));
+}
+