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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam6.c,v 1.7 85/03/24 11:04:21 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Sun Sep  4 08:56:19 1983 by jkf]-
   7:  * 	lam6.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include "frame.h"
  15: #include <signal.h>
  16: #include <sys/types.h>
  17: #include <sys/times.h>
  18: #include "chkrtab.h"
  19: #include "chars.h"
  20: 
  21: 
  22: lispval
  23: Lreadli()
  24: {
  25:     register lispval work, handy;
  26:     register FILE *p;
  27:     register char *string; char *alloca();
  28:     FILE *fstopen();
  29:     lispval Lread();
  30:     int count;
  31:     pbuf pb;
  32:     Savestack(4);
  33: #ifdef SPISFP
  34:     Keepxs();
  35: #endif
  36: 
  37:     if(lbot->val==nil) {        /*effectively, return(matom(""));*/
  38:         strbuf[0] = 0;
  39:         return(getatom(FALSE));
  40:     }
  41:     chkarg(1,"readlist");
  42:     count = 1;
  43: 
  44:     /* compute length of list */
  45:     for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr)
  46:         count++;
  47:     string = alloca(count);
  48:     p = fstopen(string, count - 1, "r");
  49:     for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) {
  50:         handy = work->d.car;
  51:         switch(TYPE(handy)) {
  52:         case SDOT:
  53:         case INT:
  54:             *string++=handy->i;
  55:             break;
  56:         case ATOM:
  57:             *string++ = *(handy->a.pname);
  58:             break;
  59:         case STRNG:
  60:             *string++ = *(char *)handy;
  61:             break;
  62:         default:
  63:                 fclose(p);
  64:             error("Non atom or int to readlist",FALSE);
  65:         }
  66:     }
  67:     *string = 0;
  68:     errp = Pushframe(F_CATCH,Veruwpt,nil);  /* must unwind protect
  69: 						   so can deallocate p
  70: 						 */
  71:     switch(retval) { lispval Lctcherr();
  72:     case C_THROW:
  73:             /* an error has occured and we are given a chance
  74: 			   to unwind before the control goes higher
  75: 			   lispretval contains the error descriptor in
  76: 			   it's cdr
  77: 			 */
  78:               fclose(p);    /* free port */
  79:               errp = Popframe();
  80:               Freexs();
  81:               lbot = np;
  82:               protect(lispretval->d.cdr); /* error descriptor */
  83:               return(Lctcherr());   /* do a I-do-throw */
  84: 
  85:     case C_INITIAL:
  86:             lbot = np;
  87:             protect(P(p));
  88:             work = Lread();  /* error  could occur here */
  89:             Freexs();
  90:             fclose(p);  /* whew.. no errors */
  91:             errp = Popframe();  /* remove unwind-protect */
  92:             Restorestack();
  93:             return(work);
  94:     }
  95:     /* NOTREACHED */
  96: }
  97: 
  98: lispval
  99: Lgetenv()
 100: {
 101:     char *getenv(), *strcpy();
 102:     char *res;
 103:     chkarg(1,"getenv");
 104: 
 105: 
 106:     if((TYPE(lbot->val))!=ATOM)
 107:         error("argument to getenv must be atom",FALSE);
 108: 
 109:     res = getenv(lbot->val->a.pname);
 110:     if(res) strcpy(strbuf,res);
 111:     else strbuf[0] = '\0';
 112:     return(getatom(FALSE));
 113: }
 114: 
 115: lispval
 116: Lboundp()
 117: {
 118:     register lispval result, handy;
 119: 
 120:     chkarg(1,"boundp");
 121: 
 122:     if((TYPE(lbot->val))!=ATOM)
 123:         error("argument to boundp must be symbol",FALSE);
 124:     if( (handy = lbot->val)->a.clb==CNIL)
 125:         result = nil;
 126:     else
 127:         (result = newdot())->d.cdr = handy->a.clb;
 128:     return(result);
 129: }
 130: 
 131: 
 132: lispval
 133: Lplist()
 134: {
 135:     register lispval atm;
 136:     /* get property list of an atom or disembodied property list */
 137: 
 138:     chkarg(1,"plist");
 139:     atm = lbot->val;
 140:     switch(TYPE(atm)) {
 141:     case ATOM:
 142:     case DTPR:
 143:         break;
 144:     default:
 145:         error("Only Atoms and disembodied property lists allowed for plist",FALSE);
 146:     }
 147:     if(atm==nil) return(nilplist);
 148:     return(atm->a.plist);
 149: }
 150: 
 151: 
 152: lispval
 153: Lsetpli()
 154: {   /* set the property list of the given atom to the given list */
 155:     register lispval atm, vall;
 156: 
 157:     chkarg(2,"setplist");
 158:     atm = lbot->val;
 159:     if (TYPE(atm) != ATOM)
 160:        error("setplist: First argument must be an symbol",FALSE);
 161:     vall = (np-1)->val;
 162:     if (TYPE(vall)!= DTPR && vall !=nil)
 163:         error("setplist: Second argument must be a list",FALSE);
 164:     if (atm==nil)
 165:         nilplist = vall;
 166:     else
 167:         atm->a.plist = vall;
 168:     return(vall);
 169: }
 170: 
 171: lispval
 172: Lsignal()
 173: {
 174:     register lispval handy, old, routine;
 175:     int i;
 176:     int sginth();
 177: 
 178:     switch(np-lbot) {
 179: 
 180:     case 1: routine = nil;      /* second arg defaults to nil */
 181:         break;
 182: 
 183:     case 2: routine = lbot[1].val;
 184:         break;          /* both args given 		*/
 185: 
 186:     default: argerr("signal");
 187:     }
 188: 
 189:     handy = lbot->val;
 190:     if(TYPE(handy)!=INT)
 191:         error("First arg to signal must be an int",FALSE);
 192:     i = handy->i & 15;
 193: 
 194:     if(TYPE(routine)!=ATOM)
 195:         error("Second arg to signal must be an atom",FALSE);
 196:     old = sigacts[i];
 197: 
 198:     if(old==0) old = nil;
 199: 
 200:     if(routine==nil)
 201:         sigacts[i]=((lispval) 0);
 202:     else
 203:         sigacts[i]=routine;
 204:     if(routine == nil)
 205:         signal(i,SIG_IGN);  /* ignore this signals */
 206:     else if (old == nil)
 207:         signal(i,sginth);   /* look for this signal */
 208:     if(i == SIGINT) sigintcnt = 0; /* clear memory */
 209:     return(old);
 210: }
 211: 
 212: lispval
 213: Lassq()
 214: {
 215:     register lispval work, handy;
 216: 
 217:     chkarg(2,"assq");
 218: 
 219:     for(work = lbot[1].val, handy = lbot[0].val;
 220:         (work->d.car->d.car != handy) && (work != nil);
 221:         work = work->d.cdr);
 222:     return(work->d.car);
 223: }
 224: 
 225: lispval
 226: Lkilcopy()
 227: {
 228:     if(fork()==0) {
 229:         abort();
 230:     }
 231: }
 232: 
 233: lispval
 234: Larg()
 235: {
 236:     register lispval handy; register offset, count;
 237: 
 238:     handy = lexpr_atom->a.clb;
 239:     if(handy==CNIL || TYPE(handy)!=DTPR)
 240:         error("Arg: not in context of Lexpr.",FALSE);
 241:     count = ((long *)handy->d.cdr) -1 - (long *)handy->d.car;
 242:     if(np==lbot || lbot->val==nil)
 243:         return(inewint(count+1));
 244:     if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
 245:         error("Out of bounds: arg to \"Arg\"",FALSE);
 246:     return( ((struct argent *)handy->d.car)[offset].val);
 247: }
 248: 
 249: lispval
 250: Lsetarg()
 251: {
 252:     register lispval handy, work;
 253:     register limit, index;
 254: 
 255:     chkarg(2,"setarg");
 256:     handy = lexpr_atom->a.clb;
 257:     if(handy==CNIL || TYPE(handy)!=DTPR)
 258:         error("Arg: not in context of Lexpr.",FALSE);
 259:     limit = ((long *)handy->d.cdr) - 1 -  (long *)(work = handy->d.car);
 260:     handy = lbot->val;
 261:     if(TYPE(handy)!=INT)
 262:         error("setarg: first argument not integer",FALSE);
 263:     if((index = handy->i - 1) < 0 || index > limit)
 264:         error("setarg: index out of range",FALSE);
 265:     return(((struct argent *) work)[index].val = lbot[1].val);
 266: }
 267: 
 268: lispval
 269: Lptime(){
 270:     extern int gctime;
 271:     int lgctime = gctime;
 272:     struct tms current;
 273:     register lispval result, handy;
 274:     Savestack(2);
 275: 
 276:     times(&current);
 277:     result = newdot();
 278:     handy = result;
 279:     protect(result);
 280:     result->d.cdr = newdot();
 281:     result->d.car = inewint(current.tms_utime);
 282:     handy = result->d.cdr;
 283:     handy->d.car = inewint(lgctime);
 284:     handy->d.cdr = nil;
 285:     if(gctime==0)
 286:         gctime = 1;
 287:     Restorestack();
 288:     return(result);
 289: }
 290: 
 291: /* (err-with-message message [value])
 292:    'message' is the error message to print.
 293:    'value' is the value to return from the errset (if present).
 294: 	it defaults to nil.
 295:     The message may not be printed if there is an (errset ... nil)
 296:     pending.
 297:  */
 298: 
 299: lispval Lerr()
 300: {
 301:     lispval errorh();
 302:     lispval valret = nil;
 303:     char *mesg;
 304: 
 305: 
 306:     switch(np-lbot) {
 307:      case 2: valret = lbot[1].val;  /* return non nil */
 308:      case 1: mesg = (char *)verify(lbot[0].val,
 309:                   "err-with-message: non atom or string arg");
 310:          break;
 311:      default: argerr("err-with-message");
 312:     }
 313: 
 314:     return(errorh(Vererr,mesg,valret,FALSE,1));
 315: }
 316: 
 317: /*
 318:  *  (tyi ['p_port ['g_eofval]])
 319:  * normally -1 is return on eof, but g_eofval will be returned if given.
 320:  */
 321: lispval
 322: Ltyi()
 323: {
 324:     register FILE *port;
 325:     register lispval handy;
 326:     lispval eofval;
 327:     int val;    /* really char but getc returns int on eof */
 328:     int eofvalgiven;
 329: 
 330:     handy = nil;   /* default port */
 331:     eofvalgiven = FALSE;  /* assume no eof value given */
 332:     switch(np-lbot)
 333:     {
 334:         case 2:  eofval = lbot[1].val;
 335:                  eofvalgiven = TRUE;
 336:         case 1:  handy = lbot[0].val;   /* port to read */
 337:         case 0:
 338:              break;
 339:         default: argerr("tyi");
 340:     }
 341: 
 342:     port = okport(handy,okport(Vpiport->a.clb,stdin));
 343: 
 344: 
 345:     fflush(stdout);     /* flush any pending output characters */
 346:     val = getc(port);
 347:     if(val==EOF)
 348:     {
 349:         clearerr(port);
 350:         if(sigintcnt > 0) sigcall(SIGINT);  /* eof might mean int */
 351:         if(eofvalgiven) return(eofval);
 352:         else return(inewint(-1));
 353:     }
 354:     return(inewint(val));
 355: }
 356: 
 357: /* Untyi (added by DNC Feb. '80) - (untyi number port) puts the
 358:    character with ascii code number in the front of the input buffer of
 359:    port.  Note that this buffer is limited to 1 character.  That buffer is
 360:    also written by tyipeek, so a peek followed by an untyi will result in
 361:    the loss of the peeked char.
 362:  */
 363: 
 364: lispval
 365: Luntyi()
 366: {
 367: 
 368:     lispval port,ch;
 369: 
 370:     port = nil;
 371: 
 372:     switch(np-lbot) {
 373:     case 2: port = lbot[1].val;
 374:     case 1: ch = lbot[0].val;
 375:         break;
 376:     default:
 377:         argerr("untyi");
 378:     }
 379: 
 380:     if(TYPE(ch) != INT) {
 381:        errorh1(Vermisc, "untyi: expects fixnum character ",
 382:                 nil,FALSE,0,ch);
 383:     }
 384: 
 385:     ungetc((int) ch->i,okport(port,okport(Vpiport->a.clb,stdin)));
 386:     return(ch);
 387: }
 388: 
 389: lispval
 390: Ltyipeek()
 391: {
 392:     register FILE *port;
 393:     register lispval handy;
 394:     int val;
 395: 
 396:     switch(np-lbot)
 397:     {
 398:         case 0:  handy = nil;   /* default port */
 399:              break;
 400:         case 1:  handy = lbot->val;
 401:              break;
 402:         default: argerr("tyipeek");
 403:     }
 404: 
 405:     port = okport(handy,okport(Vpiport->a.clb,stdin));
 406: 
 407:     fflush(stdout);     /* flush any pending output characters */
 408:     val = getc(port);
 409:     if(val==EOF)
 410:         clearerr(port);
 411:     ungetc(val,port);
 412:     return(inewint(val));
 413: }
 414: 
 415: lispval
 416: Ltyo()
 417: {
 418:     register FILE *port;
 419:     register lispval handy, where;
 420:     char val;
 421: 
 422:     switch(np-lbot)
 423:     {
 424:         case 1:  where = nil;   /* default port */
 425:              break;
 426:         case 2:  where = lbot[1].val;
 427:              break;
 428:         default: argerr("tyo");
 429:     }
 430: 
 431:     handy = lbot->val;
 432:     if(TYPE(handy)!=INT)
 433:         error("Tyo demands number for 1st arg",FALSE);
 434:     val = handy->i;
 435: 
 436:     port = (FILE *) okport(where,okport(Vpoport->a.clb,stdout));
 437:     putc(val,port);
 438:     return(handy);
 439: }
 440: 
 441: lispval
 442: Imkrtab(current)
 443: {
 444:     extern struct rtab {
 445:         unsigned char ctable[132];
 446:     } initread;
 447:     register lispval handy; extern lispval lastrtab;
 448: 
 449:     static int cycle = 0;
 450:     static char *nextfree;
 451:     Savestack(3);
 452: 
 453:     if((cycle++)%3==0) {
 454:         nextfree = (char *) csegment(STRNG,1,FALSE);
 455:         mrtabspace = (lispval) nextfree;
 456:         /* need to protect partially allocated read tables
 457: 		   from garbage collection. */
 458:     }
 459:     handy = newarray();
 460:     protect(handy);
 461: 
 462:     handy->ar.data = nextfree;
 463:     if(current == 0)
 464:         *(struct rtab *)nextfree = initread;
 465:     else
 466:     {
 467:         register index = 0; register char *cp = nextfree;
 468:         lispval c;
 469: 
 470:         *(struct rtab *)cp = *(struct rtab *)ctable;
 471:         for(; index < 128; index++) {
 472:             switch(synclass(cp[index])) {
 473:             case CSPL: case CSSPL: case CMAC: case CSMAC:
 474:             case CINF: case CSINF:
 475:             strbuf[0] = index;
 476:             strbuf[1] = 0;
 477:             c = (getatom(TRUE));
 478:             Iputprop(c,Iget(c,lastrtab),handy);
 479:             }
 480:         }
 481:     }
 482:     handy->ar.delta = inewint(4);
 483:     handy->ar.length = inewint(sizeof(struct rtab)/sizeof(int));
 484:     handy->ar.accfun = handy->ar.aux  = nil;
 485:     nextfree += sizeof(struct rtab);
 486:     Restorestack();
 487:     return(handy);
 488: }
 489: 
 490: /* makereadtable - arg : t or nil
 491: 	returns a readtable, t means return a copy of the initial readtable
 492: 
 493: 			     nil means return a copy of the current readtable
 494: */
 495: lispval
 496: Lmakertbl()
 497: {
 498:     lispval handy = Vreadtable->a.clb;
 499:     lispval value;
 500:     chkrtab(handy);
 501: 
 502:     if(lbot==np) value = nil;
 503:     else if(TYPE(value=(lbot->val)) != ATOM)
 504:         error("makereadtable: arg must be atom",FALSE);
 505: 
 506:     if(value == nil) return(Imkrtab(1));
 507:     else return(Imkrtab(0));
 508: }
 509: 
 510: lispval
 511: Lcpy1()
 512: {
 513:     register lispval handy = lbot->val, result = handy;
 514: 
 515: top:
 516:     switch(TYPE(handy))
 517:     {
 518:     case INT:
 519:         result = inewint(handy->i);
 520:         break;
 521:     case VALUE:
 522:         (result = newval())->l = handy->l;
 523:         break;
 524:     case DOUB:
 525:         (result = newdoub())->r = handy->r;
 526:         break;
 527:     default:
 528:         lbot->val =
 529:             errorh1(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
 530:         goto top;
 531:     }
 532:     return(result);
 533: }
 534: 
 535: /* copyint* . This returns a copy of its integer argument.  The copy will
 536:  *	 be a fresh integer cell, and will not point into the read only
 537:  *	 small integer table.
 538:  */
 539: lispval
 540: Lcopyint()
 541: {
 542:     register lispval handy = lbot->val;
 543:     register lispval ret;
 544: 
 545:     while (TYPE(handy) != INT)
 546:     { handy=errorh1(Vermisc,"copyint* : non integer arg",nil,TRUE,0,handy);}
 547:     (ret = newint())->i = handy->i;
 548:     return(ret);
 549: }

Defined functions

Defined variables

Defined struct's