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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: fex4.c,v 1.5 85/03/13 17:19:04 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Sat Jan 29 12:40:56 1983 by jkf]-
   7:  * 	fex4.c				$Locker:  $
   8:  * nlambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: 
  14: #include "global.h"
  15: #include "lfuncs.h"
  16: #include "chkrtab.h"
  17: #include <signal.h>
  18: #include <sys/types.h>
  19: 
  20: #if (os_4_2 || os_4_3)
  21: #include <sys/time.h>
  22: #else
  23: #include <time.h>
  24: #endif
  25: 
  26: /* this is now a lambda function instead of a nlambda.
  27:    the only reason that it wasn't a lambda to begin with is that
  28:    the person who wrote it didn't know how to write a lexpr
  29: 						- jkf
  30: */
  31: lispval
  32: Lsyscall() {
  33:     register lispval temp;
  34:     register struct argent *aptr;
  35:     register int acount = 1;
  36:     extern syscall();
  37:     int args[50];
  38:     Savestack(3);
  39: 
  40:     /* there must be at least one argument */
  41: 
  42:     if (np==lbot) { chkarg(1,"syscall"); }
  43: 
  44:     aptr = lbot;
  45:     temp = lbot->val;
  46:     if (TYPE(temp) != INT) {
  47:         Restorestack();
  48:         return(error("syscall: bad first argument ", FALSE));
  49:     }
  50:     args[acount++] = temp->i;
  51:     while( ++aptr < np && acount < 48) {
  52:         temp = aptr->val;
  53:         switch(TYPE(temp)) {
  54: 
  55:             case ATOM:
  56:                 args[acount++] = (int)temp->a.pname;
  57:                 break;
  58: 
  59:             case STRNG:
  60:                 args[acount++] = (int) temp;
  61:                 break;
  62: 
  63:             case INT:
  64:                 args[acount++] = (int)temp->i;
  65:                 break;
  66: 
  67:             default:
  68:                 Restorestack();
  69:                 return(error("syscall: arg not symbol, string or fixnum", FALSE));
  70:         }
  71:     }
  72: 
  73:     Restorestack();
  74:     args[0] = acount - 1;
  75:     return(inewint(callg_(syscall,args)));
  76: }
  77: 
  78: /* eval-when: this has the form (eval-when <list> <form1> <form2> ...)
  79:    where the list may contain any combination of `eval', `load', `compile'.
  80:    The interpreter (us) looks for the atom `eval', if it is present
  81:    we treat the rest of the forms as a progn.
  82: */
  83: 
  84: lispval
  85: Nevwhen()
  86: {
  87:     register lispval handy;
  88:     register lispval handy2;
  89:     Savestack(2);
  90: 
  91:     for (handy=(lbot->val)->d.car ; handy != nil ; handy = handy->d.cdr) {
  92:        if (handy->d.car == (lispval) Veval) {
  93:         lbot=np;
  94:         protect(((lbot-1)->val)->d.cdr);
  95:         handy2 = Nprogn();
  96:         Restorestack();
  97:         return(handy2);
  98:         }
  99:     }
 100: 
 101: 
 102:     Restorestack();
 103:     return(nil);    /* eval not seen */
 104: }
 105: 
 106: 
 107: /*	Status functions.
 108:  *  These operate on the statuslist stlist which has the form:
 109:  *	( status_elem_1 status_elem_2 status_elem_3 ...)
 110:  *  where each status element has the form:
 111:  *	( name readcode setcode .  readvalue)
 112:  *  where
 113:  *	name - name of the status feature (the first arg to the status
 114:  *		function).
 115:  *	readcode - fixnum which tells status how to read the value of
 116:  *		this status name.  The codes are #defined.
 117:  *	setcode - fixnum which tells sstatus how to set the value of
 118:  *		this status name
 119:  *	readvalue - the value of the status feature is usually stored
 120:  *		here.
 121:  *
 122:  * Readcodes:
 123:  *
 124:  *	ST_READ - if no second arg, return readvalue.
 125:  *		  if the second arg is given, we return t if it is eq to
 126:  *		  the readvalue.
 127:  *	ST_FEATR - used in (status feature xxx) where we test for xxx being
 128:  *		  in the status features list
 129:  *	ST_SYNT - used in (status syntax c) where we return c's syntax code
 130:  *	ST_INTB - read stattab entry
 131:  *	ST_NFETR - used in (status nofeature xxx) where we test for xxx not
 132:  *		  being in the status features list
 133:  *	ST_DMPR - read the dumpmode
 134:  *	ST_UNDEF - return the undefined functions in the transfer table
 135:  *
 136:  * Setcodes:
 137:  *	ST_NO -  if not allowed to set this status through sstatus.
 138:  *	ST_SET - if the second arg is made the readvalue.
 139:  *	ST_FEATW - for (sstatus feature xxx), we add xxx to the
 140:  *		  (status features) list.
 141:  *	ST_TOLC - if non nil, map upper case chars in atoms to lc.
 142:  *	ST_CORE - if non nil, have bus errors and segmentation violations
 143:  *		  dump core, if nil have them produce a bad-mem err msg
 144:  *	ST_INTB - set stattab table entry
 145:  *	ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
 146:  *		   from the status feature list.
 147:  *	ST_DMPW - set the dumpmode
 148:  *	ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
 149:  *		   calls from BCD functions to BCD functions
 150:  *	ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
 151:  */
 152: 
 153: lispval
 154: Nstatus()
 155: {
 156:     register lispval handy,curitm,valarg;
 157:     int indx,ctim;
 158:     int typ;
 159:     char *cp;
 160:     char *ctime();
 161:     struct tm *lctime,*localtime();
 162:     extern unsigned char *ctable;
 163:     extern int dmpmode;
 164:     extern lispval chktt();
 165:     lispval Istsrch();
 166:     Savestack(3);
 167: 
 168:     if(lbot->val == nil) return(nil);
 169:     handy = lbot->val;      /* arg list */
 170: 
 171:     while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE);
 172: 
 173:     curitm = Istsrch(handy->d.car); /* look for feature */
 174: 
 175:     if( curitm == nil ) return(nil);    /* non existant */
 176: 
 177:     if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
 178:     else valarg = handy->d.cdr->d.car;
 179: 
 180:     /* now do the processing with curitm pointing to the requested
 181: 	   item in the status list
 182: 	 */
 183: 
 184:     switch( typ = curitm->d.cdr->d.car->i ) {   /* look at readcode */
 185: 
 186: 
 187:     case ST_READ:
 188:         curitm = Istsrch(handy->d.car); /* look for name */
 189:         if(curitm == nil) return(nil);
 190:         if( valarg != (lispval) CNIL)
 191:             error("status: Second arg not allowed.",FALSE);
 192:         else return(curitm->d.cdr->d.cdr->d.cdr);
 193: 
 194:     case ST_NFETR:              /* look for feature present */
 195:     case ST_FEATR:              /* look for feature */
 196:         curitm = Istsrch(matom("features"));
 197:         if( valarg == (lispval) CNIL)
 198:             error("status: need second arg",FALSE);
 199: 
 200:         for( handy = curitm->d.cdr->d.cdr->d.cdr;
 201:              handy != nil;
 202:              handy = handy->d.cdr)
 203:            if(handy->d.car == valarg)
 204:              return(typ == ST_FEATR ? tatom : nil);
 205: 
 206:         return(typ == ST_FEATR ? nil : tatom);
 207: 
 208:     case ST_SYNT:               /* want character syntax */
 209:         handy = Vreadtable->a.clb;
 210:         chkrtab(handy);
 211:         if( valarg == (lispval) CNIL)
 212:             error("status: need second arg",FALSE);
 213: 
 214:         while (TYPE(valarg) != ATOM)
 215:             valarg = error("status: second arg must be atom",TRUE);
 216: 
 217:         indx = valarg->a.pname[0];  /* get first char */
 218: 
 219:         if(valarg->a.pname[1] != '\0')
 220:             error("status: only one character atom allowed",FALSE);
 221: 
 222:         handy = inewint((long) ctable[indx]);
 223:         return(handy);
 224: 
 225:     case ST_RINTB:
 226:         return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);
 227: 
 228:     case ST_DMPR:
 229:         return(inewint(dmpmode));
 230: 
 231:     case ST_CTIM:
 232:          ctim = time((time_t *)0);
 233:          cp = ctime(&ctim);
 234:          cp[24] = '\0';
 235:          return(matom(cp));
 236: 
 237:     case ST_LOCT:
 238:          ctim = time((time_t *)0);
 239:          lctime = localtime(&ctim);
 240:          (handy = newdot())->d.car = inewint(lctime->tm_sec);
 241:          protect(handy);
 242:          handy->d.cdr =  (valarg = newdot());
 243:          valarg->d.car = inewint(lctime->tm_min);
 244:          valarg->d.cdr = (curitm = newdot());
 245:          curitm->d.car = inewint(lctime->tm_hour);
 246:          curitm->d.cdr = (valarg = newdot());
 247:          valarg->d.car = inewint(lctime->tm_mday);
 248:          valarg->d.cdr = (curitm = newdot());
 249:          curitm->d.car = inewint(lctime->tm_mon);
 250:          curitm->d.cdr = (valarg = newdot());
 251:          valarg->d.car = inewint(lctime->tm_year);
 252:          valarg->d.cdr = (curitm = newdot());
 253:          curitm->d.car = inewint(lctime->tm_wday);
 254:          curitm->d.cdr = (valarg = newdot());
 255:          valarg->d.car = inewint(lctime->tm_yday);
 256:          valarg->d.cdr = (curitm = newdot());
 257:          curitm->d.car = inewint(lctime->tm_isdst);
 258:          Restorestack();
 259:          return(handy);
 260: 
 261:     case ST_ISTTY:
 262:         return( (isatty(0) == TRUE ? tatom : nil));
 263: 
 264:     case ST_UNDEF:
 265:         return(chktt());
 266:     }
 267:     error("Internal error in status: Couldn't figure out request",FALSE);
 268:     /* NOTREACHED */
 269: }
 270: lispval
 271: Nsstatus()
 272: {
 273:     register lispval handy;
 274:     lispval Isstatus();
 275: 
 276:     handy = lbot->val;
 277: 
 278:     while( TYPE(handy) != DTPR || TYPE(handy->d.cdr) != DTPR)
 279:          handy = error("sstatus: Bad args",TRUE);
 280: 
 281:     return(Isstatus(handy->d.car,handy->d.cdr->d.car));
 282: }
 283: 
 284: /* Isstatus - internal routine to do a set status.	*/
 285: lispval
 286: Isstatus(curnam,curval)
 287: lispval curnam,curval;
 288: {
 289:     register lispval curitm,head;
 290:     lispval Istsrch(),Iaddstat();
 291:     int badmr(),clrtt();
 292:     extern int uctolc, dmpmode, bcdtrsw, gcstrings;
 293: 
 294:     curitm = Istsrch(curnam);
 295:     /* if doesnt exist, make one up */
 296: 
 297:     if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
 298: 
 299:     switch (curitm->d.cdr->d.cdr->d.car->i) {
 300: 
 301:     case ST_NO: error("sstatus: cannot set this status",FALSE);
 302: 
 303:     case ST_SET: goto setit;
 304: 
 305:     case ST_FEATW: curitm = Istsrch(matom("features"));
 306:               (curnam = newdot())->d.car = curval;
 307:               curnam->d.cdr = curitm->d.cdr->d.cdr->d.cdr;  /* old val */
 308:               curitm->d.cdr->d.cdr->d.cdr = curnam;
 309:               return(curval);
 310: 
 311:     case ST_NFETW:  /* remove from features list */
 312:               curitm = Istsrch(matom("features"))->d.cdr->d.cdr;
 313:               for(head = curitm->d.cdr; head != nil; head = head->d.cdr)
 314:               {
 315:                if(head->d.car == curval) curitm->d.cdr = head->d.cdr;
 316:                else curitm = head;
 317:               }
 318:               return(nil);
 319: 
 320: 
 321:     case ST_TOLC: if(curval == nil) uctolc = FALSE;
 322:               else uctolc = TRUE;
 323:               goto setit;
 324: 
 325:     case ST_CORE: if(curval == nil)
 326:               {
 327:             signal(SIGBUS,badmr);    /* catch bus errors */
 328:             signal(SIGSEGV,badmr); /* and segmentation viols */
 329:               }
 330:               else {
 331:             signal(SIGBUS,SIG_DFL); /* let them core dump */
 332:             signal(SIGSEGV,SIG_DFL);
 333:               }
 334:               goto setit;
 335: 
 336:     case ST_INTB:
 337:               stattab[curitm->d.cdr->d.cdr->d.cdr->i] = curval;
 338:               return(curval);
 339: 
 340:     case ST_DMPW:
 341:               if(TYPE(curval) != INT ||
 342:              (curval->i != 413    &&
 343:               curval->i != 407    &&
 344:               curval->i != 410)) errorh1(Vermisc,"sstatus: bad dump mode:",
 345:                           nil,FALSE,0,curval);
 346:               dmpmode= curval->i;
 347:               return(curval);
 348: 
 349:      case ST_AUTR:
 350:               if(curval != nil) Sautor = (lispval) TRUE;
 351:               else Sautor = FALSE;
 352:               goto setit;
 353: 
 354:      case ST_TRAN:
 355:               if(curval != nil)
 356:               {
 357:                  Strans = (lispval) TRUE;
 358:                  /* the atom `on' set to set up all table
 359: 			      * to their bcd fcn if possible
 360: 			      */
 361:                  if(curval == matom("on")) clrtt(1);
 362:               }
 363:               else {
 364:                  Strans = (lispval) FALSE;
 365:                  clrtt(0);  /* clear all transfer tables */
 366:               }
 367:               goto setit;
 368:     case ST_BCDTR:
 369:               if(curval == nil) bcdtrsw = FALSE;
 370:               else bcdtrsw = TRUE;
 371:               goto setit;
 372:     case ST_GCSTR:
 373:               if(curval == nil) gcstrings = FALSE;
 374:               else gcstrings = TRUE;
 375:               goto setit;
 376:     }
 377: 
 378:     setit:        /* store value in status list */
 379:               curitm->d.cdr->d.cdr->d.cdr = curval;
 380:               return(curval);
 381: 
 382: 
 383: }
 384: 
 385: /* Istsrch - utility routine to search the status list for the
 386:    name given as an argument.  If such an entry is not found,
 387:    we return nil
 388:  */
 389: 
 390: lispval Istsrch(nam)
 391: lispval nam;
 392: {
 393:     register lispval handy;
 394: 
 395:     for(handy = stlist ; handy != nil ; handy = handy->d.cdr)
 396:       if(handy->d.car->d.car == nam) return(handy->d.car);
 397: 
 398:     return(nil);
 399: }
 400: 
 401: /* Iaddstat - add a status entry to the status list	*/
 402: /*	return new entry in status list */
 403: 
 404: lispval
 405: Iaddstat(name,readcode,setcode,valu)
 406: lispval name,valu;
 407: int readcode,setcode;
 408: {
 409:     register lispval handy,handy2;
 410:     Savestack(2);
 411: 
 412: 
 413:     protect(handy=newdot());    /* build status list here */
 414: 
 415:     (handy2 = newdot())->d.car = name;
 416: 
 417:     handy->d.car = handy2;
 418: 
 419:     ((handy2->d.cdr = newdot())->d.car = newint())->i = readcode;
 420: 
 421:     handy2 = handy2->d.cdr;
 422: 
 423:     ((handy2->d.cdr = newdot())->d.car = newint())->i = setcode;
 424: 
 425:     handy2->d.cdr->d.cdr = valu;
 426: 
 427:     /* link this one in */
 428: 
 429:     handy->d.cdr = stlist;
 430:     stlist = handy;
 431: 
 432:     Restorestack();
 433:     return(handy->d.car);   /* return new item in stlist */
 434: }

Defined functions

Defined variables