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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam7.c,v 1.8 84/04/06 23:09:07 layer Exp $";
   4: #endif
   5: 
   6: /*					-[Fri Aug  5 12:51:31 1983 by jkf]-
   7:  * 	lam7.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include <signal.h>
  15: 
  16: char *sprintf();
  17: 
  18: lispval
  19: Lfork() {
  20:     int pid;
  21: 
  22:     chkarg(0,"fork");
  23:     if ((pid=fork())) {
  24:         return(inewint(pid));
  25:     } else
  26:         return(nil);
  27: }
  28: 
  29: lispval
  30: Lwait()
  31: {
  32:     register lispval ret, temp;
  33:     int status = -1, pid;
  34:     Savestack(2);
  35: 
  36: 
  37:     chkarg(0,"wait");
  38:     pid = wait(&status);
  39:     ret = newdot();
  40:     protect(ret);
  41:     temp = inewint(pid);
  42:     ret->d.car = temp;
  43:     temp = inewint(status);
  44:     ret->d.cdr = temp;
  45:     Restorestack();
  46:     return(ret);
  47: }
  48: 
  49: lispval
  50: Lpipe()
  51: {
  52:     register lispval ret, temp;
  53:     int pipes[2];
  54:     Savestack(2);
  55: 
  56:     chkarg(0,"pipe");
  57:     pipes[0] = -1;
  58:     pipes[1] = -1;
  59:     pipe(pipes);
  60:     ret = newdot();
  61:     protect(ret);
  62:     temp = inewint(pipes[0]);
  63:     ret->d.car = temp;
  64:     temp = inewint(pipes[1]);
  65:     ret->d.cdr = temp;
  66:     Restorestack();
  67:     return(ret);
  68: }
  69: 
  70: lispval
  71: Lfdopen()
  72: {
  73:     register lispval fd, type;
  74:     FILE *ptr;
  75: 
  76:     chkarg(2,"fdopen");
  77:     type = (np-1)->val;
  78:     fd = lbot->val;
  79:     if( TYPE(fd)!=INT )
  80:         return(nil);
  81:     if ( (ptr=fdopen((int)fd->i, (char *)type->a.pname))==NULL)
  82:         return(nil);
  83:     return(P(ptr));
  84: }
  85: 
  86: lispval
  87: Lexece()
  88: {
  89:     lispval fname, arglist, envlist, temp;
  90:     char *args[100], *envs[100], estrs[1024];
  91:     char *p, *cp, **argsp;
  92: 
  93:     fname = nil;
  94:     arglist = nil;
  95:     envlist = nil;
  96: 
  97:     switch(np-lbot) {
  98:     case 3: envlist = lbot[2].val;
  99:     case 2: arglist = lbot[1].val;
 100:     case 1: fname   = lbot[0].val;
 101:     case 0: break;
 102:     default:
 103:         argerr("exece");
 104:     }
 105: 
 106:     while (TYPE(fname)!=ATOM)
 107:        fname = error("exece: non atom function name",TRUE);
 108:     while (TYPE(arglist)!=DTPR && arglist!=nil)
 109:         arglist = error("exece: non list arglist",TRUE);
 110:     for (argsp=args; arglist!=nil; arglist=arglist->d.cdr) {
 111:         temp = arglist->d.car;
 112:         if (TYPE(temp)!=ATOM)
 113:             error("exece: non atom argument seen",FALSE);
 114:         *argsp++ = temp->a.pname;
 115:     }
 116:     *argsp = 0;
 117:     if (TYPE(envlist)!=DTPR && envlist!=nil)
 118:         return(nil);
 119:     for (argsp=envs,cp=estrs; envlist!=nil; envlist=envlist->d.cdr) {
 120:         temp = envlist->d.car;
 121:         if (TYPE(temp)!=DTPR || TYPE(temp->d.car)!=ATOM
 122:           || TYPE(temp->d.cdr)!=ATOM)
 123:              error("exece: Bad enviroment list",FALSE);
 124:         *argsp++ = cp;
 125:         for (p=temp->d.car->a.pname; (*cp++ = *p++);) ;
 126:         *(cp-1) = '=';
 127:         for (p=temp->d.cdr->a.pname; (*cp++ = *p++);) ;
 128:     }
 129:     *argsp = 0;
 130: 
 131:     return(inewint(execve(fname->a.pname, args, envs)));
 132: }
 133: 
 134: /* Lprocess -
 135:  * C code to implement the *process function
 136:  * call:
 137:  * 	(*process 'st_command ['s_readp ['s_writep]])
 138:  * where st_command is the command to execute
 139:  *   s_readp is non nil if you want a port to read from returned
 140:  *   s_writep is non nil if you want a port to write to returned
 141:  *   both flags default to nil
 142:  * *process returns
 143:  *    the exit status of the process if s_readp and s_writep not given
 144:  *	(in this case the parent waits for the child to finish)
 145:  *    a list of (readport writeport childpid) if one of s_readp or s_writep
 146:  *    is given.  If only s_readp is non nil, then writeport will be nil,
 147:  *    If only s_writep is non nil, then readport will be nil
 148:  */
 149: 
 150: lispval
 151: Lprocess()
 152: {
 153:     int wflag , childsi , childso , child;
 154:     lispval handy;
 155:     char *command, *p;
 156:     int writep, readp;
 157:     int itemp;
 158:     int (*handler)(), (*signal())();
 159:     FILE *bufs[2],*obufs[2], *fpipe();
 160:     Savestack(0);
 161: 
 162:     writep = readp = FALSE;
 163:     wflag = TRUE;
 164: 
 165:     switch(np-lbot) {
 166:     case 3:  if(lbot[2].val != nil) writep = TRUE;
 167:     case 2:  if(lbot[1].val != nil) readp = TRUE;
 168:          wflag = 0;
 169:     case 1:  command = (char *) verify(lbot[0].val,
 170:                         "*process: non atom first arg");
 171:          break;
 172:     default:
 173:         argerr("*process");
 174:     }
 175: 
 176:     childsi = 0;
 177:     childso = 1;
 178: 
 179:     /* if there will be communication between the processes,
 180: 	 * it will be through these pipes:
 181: 	 *  parent ->  bufs[1] ->  bufs[0] -> child    if writep
 182: 	 *  parent <- obufs[0] <- obufs[1] <- parent   if readp
 183: 	 */
 184:     if(writep) {
 185:         fpipe(bufs);
 186:         childsi = fileno(bufs[0]);
 187:     }
 188: 
 189:     if(readp) {
 190:         fpipe(obufs);
 191:         childso = fileno(obufs[1]);
 192:     }
 193: 
 194:     handler = signal(SIGINT,SIG_IGN);
 195:     if((child = vfork()) == 0 ) {
 196:             /* if we will wait for the child to finish
 197: 		 * and if the process had ignored interrupts before
 198: 		 * we were called, then leave them ignored, else
 199: 		 * set it back the the default (death)
 200: 		 */
 201:         if(wflag && handler != SIG_IGN)
 202:             signal(2,SIG_DFL);
 203: 
 204:         if(writep) {
 205:             close(0);
 206:             dup(childsi);
 207:         }
 208:         if (readp) {
 209:             close(1);
 210:             dup(childso);
 211:         }
 212:         if ((p = (char *)getenv("SHELL")) != (char *)0) {
 213:             execlp(p , p, "-c",command,0);
 214:             _exit(-1); /* if exec fails, signal problems*/
 215:         } else {
 216:             execlp("csh", "csh", "-c",command,0);
 217:             execlp("sh", "sh", "-c",command,0);
 218:             _exit(-1); /* if exec fails, signal problems*/
 219:         }
 220:     }
 221: 
 222:     /* close the duplicated file descriptors
 223: 	 * e.g. if writep is true then we've created two desriptors,
 224: 	 *  bufs[0] and bufs[1],  we will write to bufs[1] and the
 225: 	 *  child (who has a copy of our bufs[0]) will read from bufs[0]
 226: 	 *  We (the parent) close bufs[0] since we will not be reading
 227: 	 *  from it.
 228: 	 */
 229:     if(writep) fclose(bufs[0]);
 230:     if(readp) fclose(obufs[1]);
 231: 
 232:     if(wflag && child!= -1) {
 233:         int status=0;
 234:         /* we await the death of the child */
 235:         while(wait(&status)!=child) {}
 236:         /* the child has died */
 237:         signal(2,handler);  /* restore the interrupt handler */
 238:         itemp = status >> 8;
 239:         Restorestack();
 240:         return(inewint(itemp)); /* return its status */
 241:     }
 242:     /* we are not waiting for the childs death
 243: 	 * build a list containing the write and read ports
 244: 	 */
 245:     protect(handy = newdot());
 246:     handy->d.cdr = newdot();
 247:     handy->d.cdr->d.cdr = newdot();
 248:     if(readp) {
 249:         handy->d.car = P(obufs[0]);
 250:         ioname[PN(obufs[0])] = (lispval) inewstr((char *) "from-process");
 251:     }
 252:     if(writep) {
 253:         handy->d.cdr->d.car = P(bufs[1]);
 254:         ioname[PN(bufs[1])] = (lispval) inewstr((char *) "to-process");
 255:     }
 256:     handy->d.cdr->d.cdr->d.car = (lispval) inewint(child);
 257:     signal(SIGINT,handler);
 258:     Restorestack();
 259:     return(handy);
 260: }
 261: 
 262: extern int gensymcounter;
 263: 
 264: lispval
 265: Lgensym()
 266: {
 267:     lispval arg;
 268:     char leader;
 269: 
 270:     switch(np-lbot)
 271:     {
 272:         case 0: arg = nil;
 273:             break;
 274:         case 1: arg = lbot->val;
 275:             break;
 276:         default: argerr("gensym");
 277:     }
 278:     leader = 'g';
 279:     if (arg != nil && TYPE(arg)==ATOM)
 280:         leader = arg->a.pname[0];
 281:     sprintf(strbuf, "%c%05d", leader, gensymcounter++);
 282:     atmlen = 7;
 283:     return((lispval)newatom(0));
 284: }
 285: 
 286: extern struct types {
 287: char    *next_free;
 288: int space_left,
 289:     space,
 290:     type,
 291:     type_len;           /*  note type_len is in units of int */
 292: lispval *items,
 293:     *pages,
 294:     *type_name;
 295: struct heads
 296:     *first;
 297: } atom_str ;
 298: 
 299: lispval
 300: Lremprop()
 301: {
 302:     register struct argent *argp;
 303:     register lispval pptr, ind, opptr;
 304:     lispval atm;
 305:     int disemp = FALSE;
 306: 
 307:     chkarg(2,"remprop");
 308:     argp = lbot;
 309:     ind = argp[1].val;
 310:     atm = argp->val;
 311:     switch (TYPE(atm)) {
 312:     case DTPR:
 313:         pptr = atm->d.cdr;
 314:         disemp = TRUE;
 315:         break;
 316:     case ATOM:
 317:         if((lispval)atm==nil)
 318:             pptr = nilplist;
 319:         else
 320:             pptr = atm->a.plist;
 321:         break;
 322:     default:
 323:         errorh1(Vermisc, "remprop: Illegal first argument :",
 324:                nil, FALSE, 0, atm);
 325:     }
 326:     opptr = nil;
 327:     if (pptr==nil)
 328:         return(nil);
 329:     while(TRUE) {
 330:         if (TYPE(pptr->d.cdr)!=DTPR)
 331:             errorh1(Vermisc, "remprop: Bad property list",
 332:                    nil, FALSE, 0,atm);
 333:         if (pptr->d.car == ind) {
 334:             if( opptr != nil)
 335:                 opptr->d.cdr = pptr->d.cdr->d.cdr;
 336:             else if(disemp)
 337:                 atm->d.cdr = pptr->d.cdr->d.cdr;
 338:             else if(atm==nil)
 339:                 nilplist = pptr->d.cdr->d.cdr;
 340:             else
 341:                 atm->a.plist = pptr->d.cdr->d.cdr;
 342:             return(pptr->d.cdr);
 343:         }
 344:         if ((pptr->d.cdr)->d.cdr == nil) return(nil);
 345:         opptr = pptr->d.cdr;
 346:         pptr = (pptr->d.cdr)->d.cdr;
 347:     }
 348: }
 349: 
 350: lispval
 351: Lbcdad()
 352: {
 353:     lispval ret, temp;
 354: 
 355:     chkarg(1,"bcdad");
 356:     temp = lbot->val;
 357:     if (TYPE(temp)!=ATOM)
 358:         error("ONLY ATOMS HAVE FUNCTION BINDINGS", FALSE);
 359:     temp = temp->a.fnbnd;
 360:     if (TYPE(temp)!=BCD)
 361:         return(nil);
 362:     ret = newint();
 363:     ret->i = (int)temp;
 364:     return(ret);
 365: }
 366: 
 367: lispval
 368: Lstringp()
 369: {
 370:     chkarg(1,"stringp");
 371:     if (TYPE(lbot->val)==STRNG)
 372:         return(tatom);
 373:     return(nil);
 374: }
 375: 
 376: lispval
 377: Lsymbolp()
 378: {
 379:     chkarg(1,"symbolp");
 380:     if (TYPE(lbot->val)==ATOM)
 381:         return(tatom);
 382:     return(nil);
 383: }
 384: 
 385: lispval
 386: Lrematom()
 387: {
 388:     register lispval temp;
 389: 
 390:     chkarg(1,"rematom");
 391:     temp = lbot->val;
 392:     if (TYPE(temp)!=ATOM)
 393:         return(nil);
 394:     temp->a.fnbnd = nil;
 395:     temp->a.pname = (char *)CNIL;
 396:     temp->a.plist = nil;
 397:     (atom_items->i)--;
 398:     (atom_str.space_left)++;
 399:     temp->a.clb=(lispval)atom_str.next_free;
 400:     atom_str.next_free=(char *) temp;
 401:     return(tatom);
 402: }
 403: 
 404: #define QUTMASK 0200
 405: #define VNUM 0000
 406: 
 407: lispval
 408: Lprname()
 409: {
 410:     lispval a, ret;
 411:     register lispval work, prev;
 412:     char    *front, *temp; int clean;
 413:     char ctemp[100];
 414:     extern unsigned char *ctable;
 415:     Savestack(2);
 416: 
 417:     chkarg(1,"prname");
 418:     a = lbot->val;
 419:     switch (TYPE(a)) {
 420:         case INT:
 421:             sprintf(ctemp,"%d",a->i);
 422:             break;
 423: 
 424:         case DOUB:
 425:             sprintf(ctemp,"%f",a->r);
 426:             break;
 427: 
 428:         case ATOM:
 429:             temp = front = a->a.pname;
 430:             clean = *temp;
 431:             if (*temp == '-') temp++;
 432:             clean = clean && (ctable[*temp] != VNUM);
 433:             while (clean && *temp)
 434:                 clean = (!(ctable[*temp++] & QUTMASK));
 435:             if (clean)
 436:                 strncpy(ctemp, front, 99);
 437:             else
 438:                 sprintf(ctemp,"\"%s\"",front);
 439:             break;
 440: 
 441:         default:
 442:             error("prname does not support this type", FALSE);
 443:     }
 444:     temp = ctemp;
 445:     protect(ret = prev = newdot());
 446:     while (*temp) {
 447:         prev->d.cdr = work = newdot();
 448:         strbuf[0] = *temp++;
 449:         strbuf[1] = 0;
 450:         work->d.car = getatom(FALSE);
 451:         work->d.cdr = nil;
 452:         prev = work;
 453:     }
 454:     Restorestack();
 455:     return(ret->d.cdr);
 456: }
 457: 
 458: lispval
 459: Lexit()
 460: {
 461:     register lispval handy;
 462:     if(np-lbot==0) franzexit(0);
 463:     handy = lbot->val;
 464:     if(TYPE(handy)==INT)
 465:         franzexit((int) handy->i);
 466:     franzexit(-1);
 467: }
 468: lispval
 469: Iimplode(unintern)
 470: {
 471:     register lispval handy, work;
 472:     register char *cp = strbuf;
 473:     extern int atmlen;  /* used by newatom and getatom */
 474:     extern char *atomtoolong();
 475: 
 476:     chkarg(1,"implode");
 477:     for(handy = lbot->val; handy!=nil; handy = handy->d.cdr)
 478:     {
 479:         work = handy->d.car;
 480:         if(cp >= endstrb)
 481:             cp = atomtoolong(cp);
 482:     again:
 483:         switch(TYPE(work))
 484:         {
 485:         case ATOM:
 486:             *cp++ = work->a.pname[0];
 487:             break;
 488:         case SDOT:
 489:             *cp++ = work->s.I;
 490:             break;
 491:         case INT:
 492:             *cp++ = work->i;
 493:             break;
 494:         case STRNG:
 495:             *cp++ = * (char *) work;
 496:             break;
 497:         default:
 498:             work = errorh1(Vermisc,"implode/maknam: Illegal type for this arg:",nil,FALSE,44,work);
 499:             goto again;
 500:         }
 501:     }
 502:     *cp = 0;
 503:     if(unintern) return((lispval)newatom(FALSE));
 504:     else return((lispval) getatom(FALSE));
 505: }
 506: 
 507: lispval
 508: Lmaknam()
 509: {
 510:     return(Iimplode(TRUE));     /* unintern result */
 511: }
 512: 
 513: lispval
 514: Limplode()
 515: {
 516:     return(Iimplode(FALSE));    /* intern result */
 517: }
 518: 
 519: lispval
 520: Lntern()
 521: {
 522:     register int hash;
 523:     register lispval handy,atpr;
 524: 
 525: 
 526:     chkarg(1,"intern");
 527:     if(TYPE(handy=lbot->val) != ATOM)
 528:         errorh1(Vermisc,"non atom to intern ",nil,FALSE,0,handy);
 529:     /* compute hash of pname of arg */
 530:     hash = hashfcn(handy->a.pname);
 531: 
 532:     /* search for atom with same pname on hash list */
 533: 
 534:     atpr = (lispval) hasht[hash];
 535:     for(atpr = (lispval) hasht[hash]
 536:          ; atpr != CNIL
 537:          ; atpr = (lispval)atpr->a.hshlnk)
 538:     {
 539:         if(strcmp(atpr->a.pname,handy->a.pname) == 0) return(atpr);
 540:     }
 541: 
 542:     /* not there yet, put the given one on */
 543: 
 544:     handy->a.hshlnk = hasht[hash];
 545:     hasht[hash] = (struct atom *)handy;
 546:     return(handy);
 547: }
 548: 
 549: /*** Ibindvars :: lambda bind values to variables
 550: 	called with a list of variables and values.
 551: 	does the special binding and returns a fixnum which represents
 552: 	the value of bnp before the binding
 553: 	Use by compiled progv's.
 554:  ***/
 555: lispval
 556: Ibindvars()
 557: {
 558:     register lispval vars,vals,handy;
 559:     struct nament *oldbnp = bnp;
 560: 
 561:     chkarg(2,"int:bindvars");
 562: 
 563:     vars = lbot[0].val;
 564:     vals = lbot[1].val;
 565: 
 566:     if(vars == nil) return(inewint(oldbnp));
 567: 
 568:     if(TYPE(vars) != DTPR)
 569:       errorh1(Vermisc,"progv (int:bindvars): bad first argument ", nil,
 570:             FALSE,0,vars);
 571:    if((vals != nil) && (TYPE(vals) != DTPR))
 572:      errorh1(Vermisc,"progv (int:bindvars): bad second argument ",nil,
 573:             FALSE,0,vals);
 574: 
 575:    for( ; vars != nil ; vars = vars->d.cdr , vals=vals->d.cdr)
 576:    {
 577:        handy = vars->d.car;
 578:        if(TYPE(handy) != ATOM)
 579:           errorh1(Vermisc,"progv (int:bindvars): non symbol argument to bind ",
 580:         nil,FALSE,0,handy);
 581:        PUSHDOWN(handy,vals->d.car);
 582:    }
 583:    return(inewint(oldbnp));
 584: }
 585: 
 586: 
 587: /*** Iunbindvars :: unbind the variable stacked by Ibindvars
 588:      called by compiled progv's
 589:  ***/
 590: 
 591: lispval
 592: Iunbindvars()
 593: {
 594:     struct nament *oldbnp;
 595: 
 596:     chkarg(1,"int:unbindvars");
 597:     oldbnp = (struct nament *) (lbot[0].val->i);
 598:     if((oldbnp < orgbnp)  || ( oldbnp > bnp))
 599:        errorh1(Vermisc,"int:unbindvars: bad bnp value given ",nil,FALSE,0,
 600:             lbot[0].val);
 601:     popnames(oldbnp);
 602:     return(nil);
 603: }
 604: 
 605: /*
 606:  * (time-string ['x_milliseconds])
 607:  * if given no argument, returns the current time as a string
 608:  * if given an argument which is a fixnum representing the current time
 609:  * as a fixnum, it generates a string from that
 610:  *
 611:  * the format of the string returned is that defined in the Unix manual
 612:  * except the trailing newline is removed.
 613:  *
 614:  */
 615: lispval
 616: Ltymestr()
 617: {
 618:     long timevalue;
 619:     char *retval;
 620: 
 621:     switch(np-lbot)
 622:     {
 623:     case 0: time(&timevalue);
 624:         break;
 625:     case 1: while (TYPE(lbot[0].val) != INT)
 626:               lbot[0].val =
 627:              errorh(Vermisc,"time-string: non fixnum argument ",
 628:                     nil,TRUE,0,lbot[0].val);
 629:         timevalue = lbot[0].val->i;
 630:         break;
 631:     default:
 632:         argerr("time-string");
 633:     }
 634: 
 635:     retval = (char *) ctime(&timevalue);
 636:     /* remove newline character */
 637:     retval[strlen(retval)-1] = '\0';
 638:     return((lispval) inewstr(retval));
 639: }

Defined functions

Defined variables

Defined struct's

Defined macros