4.3BSD - /usr/src/ucb/lisp/franz/lamr.c

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lamr.c,v 1.6 84/04/06 23:14:05 layer Exp $";
   4: #endif
   5: 
   6: /*					-[Sat Jan 29 13:09:59 1983 by jkf]-
   7:  * 	lamr.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: # include "global.h"
  14: 
  15: /*
  16:  *
  17:  *  Lalloc
  18:  *
  19:  *  This lambda allows allocation of pages from lisp.  The first
  20:  *  argument is the name of a space, n pages of which are allocated,
  21:  *  if possible.  Returns the number of pages allocated.
  22:  */
  23: 
  24: lispval
  25: Lalloc()
  26:     {
  27:     long n;
  28:     chkarg(2,"alloc");
  29:     if(TYPE((lbot+1)->val) != INT && (lbot+1)->val != nil )
  30:         error("2nd argument to allocate must be an integer",FALSE);
  31:     n = 1;
  32:     if((lbot+1)->val != nil) n = (lbot+1)->val->i;
  33:     return(alloc((lbot)->val,n));   /*  call alloc to do the work  */
  34:     }
  35: 
  36: lispval
  37: Lsizeof()
  38:     {
  39:     chkarg(1,"sizeof");
  40:     return(inewint(csizeof(lbot->val)));
  41:     }
  42: 
  43: lispval
  44: Lsegment()
  45:     {
  46:     chkarg(2,"segment");
  47: chek:   while(TYPE(np[-1].val) != INT )
  48:         np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE);
  49:     if( np[-1].val->i < 0 )
  50:         {
  51:         np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE);
  52:         goto chek;
  53:         }
  54:     return(csegment(typenum((lbot)->val),(int)(np[-1].val->i),FALSE));
  55:     }
  56: 
  57: /*  Lforget  *************************************************************/
  58: /*									*/
  59: /*  This function removes an atom from the hash table.			*/
  60: 
  61: lispval
  62: Lforget()
  63:     {
  64:     char *name;
  65:     struct atom *buckpt;
  66:     int hash;
  67:     chkarg(1,"forget");
  68:     if(TYPE(lbot->val) != ATOM)
  69:         error("remob: non-atom argument",FALSE);
  70:     name = lbot->val->a.pname;
  71:     hash = hashfcn(name);
  72: 
  73:     /*  We have found the hash bucket for the atom, now we remove it  */
  74: 
  75:     if( hasht[hash] == (struct atom *)lbot->val )
  76:         {
  77:         hasht[hash] = lbot->val->a.hshlnk;
  78:         lbot->val->a.hshlnk = (struct atom *)CNIL;
  79:         return(lbot->val);
  80:         }
  81: 
  82:     buckpt = hasht[hash];
  83:     while(buckpt != (struct atom *)CNIL)
  84:         {
  85:         if(buckpt->hshlnk == (struct atom *)lbot->val)
  86:             {
  87:             buckpt->hshlnk = lbot->val->a.hshlnk;
  88:             lbot->val->a.hshlnk = (struct atom *)CNIL;
  89:             return(lbot->val);
  90:             }
  91:         buckpt = buckpt->hshlnk;
  92:         }
  93: 
  94:     /*  Whoops!  Guess it wasn't in the hash table after all.  */
  95: 
  96:     return(lbot->val);
  97:     }
  98: 
  99: lispval
 100: Lgetl()
 101:     {
 102:     chkarg(1,"getlength");
 103:     if(TYPE(lbot->val) != ARRAY)
 104:         error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE);
 105:     return(lbot->val->ar.length);
 106:     }
 107: 
 108: lispval
 109: Lputl()
 110:     {
 111:     chkarg(2,"putlength");
 112:     if(TYPE((lbot)->val) != ARRAY)
 113:         error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE);
 114: chek:   while(TYPE(np[-1].val) != INT)
 115:         np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE);
 116:     if(np[-1].val->i <= 0)
 117:         {
 118:         np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE);
 119:         goto chek;
 120:         }
 121:     return((lbot)->val->ar.length = np[-1].val);
 122:     }
 123: lispval
 124: Lgetdel()
 125:     {
 126:     chkarg(1,"getdelta");
 127:     if(TYPE(lbot->val) != ARRAY)
 128:         error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE);
 129:     return(lbot->val->ar.delta);
 130:     }
 131: 
 132: lispval
 133: Lputdel()
 134:     {
 135:     chkarg(2,"putdelta");
 136:     if(TYPE((np-2)->val) != ARRAY)
 137:         error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE);
 138: chek:   while(TYPE(np[-1].val) != INT)
 139:         np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE);
 140:     if(np[-1].val->i <= 0)
 141:         {
 142:         np[-1].val = error("Array delta must be positive",TRUE);
 143:         goto chek;
 144:         }
 145:     return((lbot)->val->ar.delta = np[-1].val);
 146:     }
 147: 
 148: lispval
 149: Lgetaux()
 150:     {
 151:     chkarg(1,"getaux");
 152:     if(TYPE(lbot->val)!=ARRAY)
 153:         error("Arg to getaux must be an array", FALSE);
 154:     return(lbot->val->ar.aux);
 155:     }
 156: 
 157: lispval
 158: Lputaux()
 159:     {
 160:     chkarg(2,"putaux");
 161: 
 162:     if(TYPE((lbot)->val)!=ARRAY)
 163:         error("1st Arg to putaux must be array", FALSE);
 164:     return((lbot)->val->ar.aux = np[-1].val);
 165:     }
 166: 
 167: lispval
 168: Lgetdata()
 169:     {
 170:     chkarg(1,"getdata");
 171:     if(TYPE(lbot->val)!=ARRAY)
 172:         error("Arg to getdata must be an array", FALSE);
 173:     return((lispval)lbot->val->ar.data);
 174:     }
 175: 
 176: lispval
 177: Lputdata()
 178:     {
 179:     chkarg(2,"putdata");
 180: 
 181:     if(TYPE(lbot->val)!=ARRAY)
 182:         error("1st Arg to putaux must be array", FALSE);
 183:     return((lispval)(lbot->val->ar.data = (char *)(lbot[1].val)));
 184:     }
 185: 
 186: lispval
 187: Lgeta()
 188:     {
 189:     chkarg(1,"getaccess");
 190:     if(TYPE(lbot->val) != ARRAY)
 191:         error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE);
 192:     return(lbot->val->ar.accfun);
 193:     }
 194: 
 195: lispval
 196: Lputa()
 197:     {
 198:     chkarg(2,"putaccess");
 199:     if(TYPE((lbot)->val) != ARRAY)
 200:         error("ARG TO PUTACCESS MUST BE ARRAY",FALSE);
 201:     return((lbot)->val->ar.accfun = np[-1].val);
 202:     }
 203: 
 204: lispval
 205: Lmarray()
 206: {
 207:     register lispval handy;
 208: 
 209:     chkarg(5,"marray");
 210: 
 211:     (handy = newarray());       /*  get a new array cell  */
 212:     handy->ar.data=(char *)lbot->val;/*  insert data address  */
 213:     handy->ar.accfun = lbot[1].val; /*  insert access function  */
 214:     handy->ar.aux = lbot[2].val;    /*  insert aux data  */
 215:     handy->ar.length = lbot[3].val; /*  insert length  */
 216:     handy->ar.delta = lbot[4].val;  /*  push delta arg  */
 217:     return(handy);
 218:     }
 219: 
 220: lispval
 221: Lgtentry()
 222:     {
 223:     chkarg(1,"getentry");
 224:     if( TYPE(lbot->val) != BCD )
 225:         error("ARG TO GETENTRY MUST BE FUNCTION",FALSE);
 226:     return((lispval)(lbot->val->bcd.start));
 227:     }
 228: 
 229: lispval
 230: Lgetlang()
 231:     {
 232:     chkarg(1,"getlang");
 233:     while(TYPE(lbot->val)!=BCD)
 234:         lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
 235:     return(lbot->val->bcd.language);
 236:     }
 237: 
 238: lispval
 239: Lputlang()
 240:     {
 241:     chkarg(2,"putlang");
 242:     while(TYPE((lbot)->val)!=BCD)
 243:         lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE);
 244:     (lbot)->val->bcd.language = np[-1].val;
 245:     return(np[-1].val);
 246:     }
 247: 
 248: lispval
 249: Lgetparams()
 250:     {
 251:     chkarg(1,"getparams");
 252:     if(TYPE(np[-1].val)!=BCD)
 253:         error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE);
 254:     return(np[-1].val->bcd.params);
 255:     }
 256: 
 257: lispval
 258: Lputparams()
 259:     {
 260:     chkarg(2,"putparams");
 261:     if(TYPE((lbot)->val)!=BCD)
 262:         error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE);
 263:     return((lbot)->val->bcd.params = np[-1].val);
 264:     }
 265: 
 266: lispval
 267: Lgetdisc()
 268:     {
 269:     chkarg(1,"getdisc");
 270:     if(TYPE(np[-1].val) != BCD)
 271:         error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE);
 272:     return(np[-1].val->bcd.discipline);
 273:     }
 274: 
 275: lispval
 276: Lputdisc()
 277:     {
 278:     chkarg(2,"putdisc");
 279:     if(TYPE(np[-2].val) != BCD)
 280:         error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE);
 281:     return((np-2)->val->bcd.discipline  = np[-1].val);
 282:     }
 283: 
 284: lispval
 285: Lgetloc()
 286:     {
 287:     chkarg(1,"getloc");
 288:     if(TYPE(lbot->val)!=BCD)
 289:         error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE);
 290:     return(lbot->val->bcd.loctab);
 291:     }
 292: 
 293: lispval
 294: Lputloc()
 295:     {
 296:     chkarg(2,"putloc");
 297:     if(TYPE((lbot+1)->val)!=BCD);
 298:         error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE);
 299:     (lbot)->val->bcd.loctab = (lbot+1)->val;
 300:     return((lbot+1)->val);
 301:     }
 302: 
 303: lispval
 304: Lmfunction()
 305:     {
 306:     register lispval handy;
 307:     chkarg(2,"mfunction");
 308:     handy = (newfunct());   /*  get a new function cell  */
 309:     handy->bcd.start = (lispval (*)())((lbot)->val);    /* insert entry point */
 310:     handy->bcd.discipline = ((lbot+1)->val); /*  insert discipline  */
 311:     return(handy);
 312:     }
 313: 
 314: /** Lreplace ************************************************************/
 315: /*									*/
 316: /*  Destructively modifies almost any kind of data.		 	*/
 317: 
 318: lispval
 319: Lreplace()
 320:     {
 321:     register lispval a1, a2;
 322:     register int t;
 323:     chkarg(2,"replace");
 324: 
 325:     if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val))
 326:         error("REPLACE ARGS MUST BE SAME TYPE",FALSE);
 327: 
 328:     switch( t )
 329:         {
 330: 
 331:     case VALUE: a1->l = a2->l;
 332:             return( a1 );
 333: 
 334:     case INT:   a1->i = a2->i;
 335:             return( a1 );
 336: 
 337: 
 338:     case ARRAY: a1->ar.data = a2->ar.data;
 339:             a1->ar.accfun = a2->ar.accfun;
 340:             a1->ar.length = a2->ar.length;
 341:             a1->ar.delta = a2->ar.delta;
 342:             return( a1 );
 343: 
 344:     case DOUB:  a1->r = a2->r;
 345:             return( a1 );
 346: 
 347:     case SDOT:
 348:     case DTPR:  a1->d.car = a2->d.car;
 349:             a1->d.cdr = a2->d.cdr;
 350:             return( a1 );
 351:     case BCD:   a1->bcd.start = a2->bcd.start;
 352:             a1->bcd.discipline = a2->bcd.discipline;
 353:             return( a1 );
 354:     default:
 355:             errorh1(Vermisc,"Replace: cannot handle the type of this arg",
 356:                          nil,FALSE,0,a1);
 357:         }
 358:     /* NOTREACHED */
 359:     }
 360: 
 361: /* Lvaluep */
 362: 
 363: lispval
 364: Lvaluep()
 365:     {
 366:     chkarg(1,"valuep");
 367:     if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil);
 368:     }
 369: 
 370: CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ }
 371: 
 372: lispval
 373: Lod()
 374:     {
 375:     int i;
 376:     chkarg(2,"od");
 377: 
 378:     while( TYPE(np[-1].val) != INT )
 379:         np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE);
 380: 
 381:     for( i = 0; i < np->val->i; ++i )
 382:         printf(copval(odform,CNIL)->a.pname,((int *)(np[-2].val))[i]);
 383: 
 384:     dmpport(poport);
 385:     return(nil);
 386:     }
 387: lispval
 388: Lfake()
 389:     {
 390:     chkarg(1,"fake");
 391: 
 392:     if( TYPE(lbot->val) != INT )
 393:         error("ARG TO FAKE MUST BE INTEGER",TRUE);
 394: 
 395:     return((lispval)(lbot->val->i));
 396:     }
 397: 
 398:     /* this used to be Lwhat, but was changed to Lmaknum for maclisp
 399: 	   compatiblity
 400: 	*/
 401: lispval
 402: Lmaknum()
 403:     {
 404:     chkarg(1,"maknum");
 405:     return(inewint((int)(lbot->val)));
 406:     }
 407: lispval
 408: Lderef()
 409:     {
 410:     chkarg(1,"deref");
 411: 
 412:     if( TYPE(lbot->val) != INT )
 413:         error("arg to deref must be integer",TRUE);
 414: 
 415:     return(inewint(*(int *)(lbot->val->i)));
 416:     }
 417: 
 418: lispval
 419: Lpname()
 420:     {
 421:     chkarg(1,"pname");
 422:     if(TYPE(lbot->val) != ATOM)
 423:         error("ARG TO PNAME MUST BE AN ATOM",FALSE);
 424:     return((lispval)(lbot->val->a.pname));
 425:     }
 426: 
 427: lispval
 428: Larayref()
 429:     {
 430:     chkarg(2,"arrayref");
 431:     if(TYPE((lbot)->val) != ARRAY)
 432:         error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE);
 433:     vtemp = (lbot + 1)->val;
 434: chek:   while(TYPE(vtemp) != INT)
 435:         vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE);
 436:     if( vtemp->i < 0 )
 437:         {
 438:         vtemp = error("NEGATIVE ARRAY OFFSET",TRUE);
 439:         goto chek;
 440:         }
 441:     if( vtemp->i >= (np-2)->val->ar.length->i )
 442:         {
 443:         vtemp = error("ARRAY OFFSET TOO LARGE",TRUE);
 444:         goto chek;
 445:         }
 446:     vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i));
 447:         /*  compute address of desired item  */
 448:     return(vtemp);
 449: 
 450:     }
 451: 
 452: lispval
 453: Lptr()
 454:     {
 455:     chkarg(1,"ptr");
 456:     return(inewval(lbot->val));
 457:     }
 458: 
 459: lispval
 460: Llctrace()
 461:     {
 462:     chkarg(1,"lctrace");
 463:     lctrace = (int)(lbot->val->a.clb);
 464:     return((lispval)lctrace);
 465:     }
 466: 
 467: lispval
 468: Lslevel()
 469:     {
 470:     return(inewint(np-orgnp-2));
 471:     }
 472: 
 473: lispval
 474: Lsimpld()
 475:     {
 476:     register lispval pt;
 477:     register char *cpt = strbuf;
 478: 
 479:     chkarg(1,"simpld");
 480: 
 481:     for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr);
 482: 
 483:     if( atmlen > STRBLEN )
 484:         {
 485:         error("LCODE WAS TOO LONG",TRUE);
 486:         return((lispval)inewstr(""));
 487:         }
 488: 
 489:     for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.car->i;
 490:     *cpt = 0;
 491: 
 492:     return((lispval)newstr(1));
 493:     }
 494: 
 495: 
 496: /*  Lopval  *************************************************************/
 497: /*									*/
 498: /*  Routine which allows system registers and options to be examined	*/
 499: /*  and modified.  Calls copval, the routine which is called by c code	*/
 500: /*  to do the same thing from inside the system.			*/
 501: 
 502: lispval
 503: Lopval()
 504: {
 505:     lispval quant;
 506: 
 507:     if( lbot == np )
 508:         return(error("bad call to opval",TRUE));
 509:     quant = lbot->val;   /*  get name of sys variable  */
 510:     while( TYPE(quant) != ATOM )
 511:         quant = error("first arg to opval must be an atom",TRUE);
 512: 
 513:     if(np > lbot+1)  vtemp = (lbot+1)->val ;
 514:     else vtemp = CNIL;
 515:     return(copval(quant,vtemp));
 516: }

Defined functions

Defined variables