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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: fex1.c,v 1.5 85/03/24 11:03:51 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Sat Mar  5 19:50:28 1983 by layer]-
   7:  * 	fex1.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 "frame.h"
  16: 
  17: /* Nprog ****************************************************************/
  18: /* This first sets the local variables to nil while saving their old	*/
  19: /* values on the name stack.  Then, pointers to various things are	*/
  20: /* saved as this function may be returned to by an "Ngo" or by a	*/
  21: /* "Lreturn".  At the end is the loop that cycles through the contents	*/
  22: /* of the prog.								*/
  23: 
  24: lispval
  25: Nprog() {
  26:     register lispval where, temp;
  27:     struct nament *savedbnp = bnp;
  28:     extern struct frame *errp;
  29:     pbuf pb;
  30:     extern int retval;
  31:     extern lispval lispretval;
  32: 
  33:     if((np-lbot) < 1) chkarg(1,"prog");
  34: 
  35:     /* shallow bind the local variables to nil */
  36:     if(lbot->val->d.car != nil)
  37:     {
  38:         for( where = lbot->val->d.car ; where != nil; where = where->d.cdr )
  39:         {
  40:             if(TYPE(where) != DTPR || TYPE(temp=where->d.car) != ATOM)
  41:             errorh1(Vermisc,
  42:                "Illegal local variable list in prog ",nil,FALSE,
  43:                1,where);
  44:                 PUSHDOWN(temp,nil);
  45:         }
  46:     }
  47: 
  48:     /* put a frame on the stack which can be 'return'ed to or 'go'ed to */
  49:     errp = Pushframe(F_PROG,nil,nil);
  50: 
  51:     where = lbot->val->d.cdr;   /* first thing in the prog body */
  52: 
  53:     switch (retval) {
  54:     case C_RET: /*
  55: 			 * returning from this prog, value to return
  56: 			 * is in lispretval
  57: 			 */
  58:             errp = Popframe();
  59:             popnames(savedbnp);
  60:             return(lispretval);
  61: 
  62:     case C_GO:  /*
  63: 			 * going to a certain label, label to go to in
  64: 			 * in lispretval
  65: 			 */
  66:             where = (lbot->val)->d.cdr;
  67:             while ((TYPE(where) == DTPR)
  68:                    && (where->d.car != lispretval))
  69:                 where = where->d.cdr;
  70:             if (where->d.car == lispretval) {
  71:                 popnames(errp->svbnp);
  72:                 break;
  73:             }
  74:             /* label not found in this prog, must
  75: 			 * go up to higher prog
  76: 			 */
  77:             errp = Popframe();  /* go to next frame */
  78:             Inonlocalgo(C_GO,lispretval,nil);
  79: 
  80:             /* NOT REACHED */
  81: 
  82:     case C_INITIAL: break;
  83: 
  84:     }
  85: 
  86:     while (TYPE(where) == DTPR)
  87:         {
  88:         temp = where->d.car;
  89:         if((TYPE(temp))!=ATOM) eval(temp);
  90:         where = where->d.cdr;
  91:         }
  92:     if((where != nil) && (TYPE(where) != DTPR))
  93:         errorh1(Vermisc,"Illegal form in prog body ", nil,FALSE,0,where);
  94:     errp = Popframe();
  95:     popnames(savedbnp); /* pop off locals */
  96:     return(nil);
  97: }
  98: 
  99: lispval globtag;
 100: /*
 101:    Ncatch is now linked to the lisp symbol *catch , which has the form
 102:      (*catch tag form)
 103:     tag is evaluated and then the catch entry is set up.
 104:       then form is evaluated
 105:     finally the catch entry is removed.
 106: 
 107:   *catch is still an nlambda since its arguments should not be evaluated
 108:    before this routine is called.
 109: 
 110:    (catch form [tag]) is translated to (*catch 'tag form) by a macro.
 111:  */
 112: lispval
 113: Ncatch()
 114: {
 115:     register lispval tag;
 116:     pbuf pb;
 117:     Savestack(3);       /* save stack pointers */
 118: 
 119:     if((TYPE(lbot->val))!=DTPR) return(nil);
 120:     protect(tag = eval(lbot->val->d.car));  /* protect tag from gc */
 121: 
 122:     errp = Pushframe(F_CATCH,tag,nil);
 123: 
 124:     switch(retval) {
 125: 
 126:     case C_THROW:   /*
 127: 		       	 * value thrown is in lispretval
 128: 		       	 */
 129:             break;
 130: 
 131:     case C_INITIAL: /*
 132: 			 * calculate value of expression
 133: 			 */
 134:              lispretval = eval(lbot->val->d.cdr->d.car);
 135:     }
 136: 
 137: 
 138:     errp = Popframe();
 139:     Restorestack();
 140:     return(lispretval);
 141: }
 142: /* (errset form [flag])
 143:    if present, flag determines if the error message will be printed
 144:    if an error reaches the errset.
 145:    if no error occurs, errset returns a list of one element, the
 146:     value returned from form.
 147:    if an error occurs, nil is usually returned although it could
 148:     be non nil if err threw a non nil value
 149:  */
 150: 
 151: lispval Nerrset()
 152: {
 153:     lispval temp,flag;
 154:     pbuf pb;
 155:     Savestack(0);
 156: 
 157:     if(TYPE(lbot->val) != DTPR) return(nil);    /* no form */
 158: 
 159:     /* evaluate and save flag first */
 160:     flag = lbot->val->d.cdr;
 161:     if(TYPE(flag) == DTPR) flag = eval(flag->d.car);
 162:     else flag = tatom;  /* if not present , assume t */
 163:     protect(flag);
 164: 
 165:     errp = Pushframe(F_CATCH,Verall,flag);
 166: 
 167:     switch(retval) {
 168: 
 169:     case C_THROW:   /*
 170: 			 * error thrown to this routine, value thrown is
 171: 			 * in lispretval
 172: 			 */
 173:             break;
 174: 
 175:     case C_INITIAL: /*
 176: 			 * normally just evaluate expression and listify it.
 177: 			 */
 178:             temp = eval(lbot->val->d.car);
 179:             protect(temp);
 180:             (lispretval = newdot())->d.car = temp;
 181:             break;
 182:     }
 183: 
 184:     errp = Popframe();
 185:     Restorestack();
 186:     return(lispretval);
 187: }
 188: 
 189: /* this was changed from throw to *throw 21nov79
 190:    it is now a lambda and really should be called Lthrow
 191: */
 192: lispval
 193: Nthrow()
 194: {
 195:     switch(np-lbot) {
 196:     case 0:
 197:         protect(nil);
 198:     case 1:
 199:         protect(nil);
 200:     case 2: break;
 201:     default:
 202:         argerr("throw");
 203:     }
 204:     Inonlocalgo(C_THROW,lbot->val,(lbot+1)->val);
 205:     /* NOT REACHED */
 206: }
 207: 
 208: 
 209: 
 210: /* Ngo ******************************************************************/
 211: /* First argument only is checked - and must be an atom or evaluate	*/
 212: /* to one.								*/
 213: lispval
 214: Ngo()
 215: {
 216:     register lispval temp;
 217:     chkarg(1,"go");
 218: 
 219:     temp = (lbot->val)->d.car;
 220:     if (TYPE(temp) != ATOM)
 221:     {
 222:     temp = eval(temp);
 223:     while(TYPE(temp) != ATOM)
 224:       temp = errorh1(Vermisc,"Illegal tag to go to",nil,TRUE, 0,lbot->val);
 225:     }
 226:     Inonlocalgo(C_GO,temp,nil);
 227:     /* NOT REACHED */
 228: }
 229: 
 230: 
 231: /* Nreset ***************************************************************/
 232: /* All arguments are ignored.  This just returns-from-break to depth 0.	*/
 233: lispval
 234: Nreset()
 235: {
 236:     Inonlocalgo(C_RESET,inewint(0),nil);
 237: }
 238: 
 239: 
 240: 
 241: /* Nbreak ***************************************************************/
 242: /* If first argument is not nil, this is evaluated and printed.  Then	*/
 243: /* error is called with the "breaking" message.				*/
 244: 
 245: lispval
 246: Nbreak()
 247: {
 248:     register lispval hold; register FILE *port;
 249:     port = okport(Vpoport->a.clb,stdout);
 250:     fprintf(port,"Breaking:");
 251: 
 252:     if ((hold = lbot->val) != nil && ((hold = hold->d.car) != nil))
 253:     {
 254:         printr(hold,port);
 255:     }
 256:     putc('\n',port);
 257:     dmpport(port);
 258:     return(errorh(Verbrk,"",nil,TRUE,0));
 259: }
 260: 
 261: 
 262: /* Nexit ****************************************************************/
 263: /* Just calls lispend with no message.					*/
 264: Nexit()
 265:     {
 266:     lispend("");
 267:     }
 268: 
 269: 
 270: /* Nsys *****************************************************************/
 271: /* Just calls lispend with no message.					*/
 272: 
 273: lispval
 274: Nsys()
 275:     {
 276:     lispend("");
 277:     }
 278: 
 279: 
 280: 
 281: 
 282: lispval
 283: Ndef() {
 284:     register lispval arglist, body, name, form;
 285: 
 286:     form = lbot->val;
 287:     name = form->d.car;
 288:     body = form->d.cdr->d.car;
 289:     arglist = body->d.cdr->d.car;
 290:     if((TYPE(arglist))!=DTPR && arglist != nil)
 291:         error("Warning: defining function with nonlist of args",
 292:             TRUE);
 293:     name->a.fnbnd = body;
 294:     return(name);
 295: }
 296: 
 297: 
 298: lispval
 299: Nquote()
 300: {
 301:     return((lbot->val)->d.car);
 302: }
 303: 
 304: 
 305: lispval
 306: Nsetq()
 307: {   register lispval handy, where, value;
 308:     register int lefttype;
 309: 
 310:     value = nil;
 311: 
 312:     for(where = lbot->val; where != nil; where = handy->d.cdr) {
 313:         handy = where->d.cdr;
 314:         if((TYPE(handy))!=DTPR)
 315:             error("odd number of args to setq",FALSE);
 316:         if((lefttype=TYPE(where->d.car))==ATOM) {
 317:             if(where->d.car==nil)
 318:                 error("Attempt to set nil",FALSE);
 319:             where->d.car->a.clb = value = eval(handy->d.car);
 320:          }else if(lefttype==VALUE)
 321:             where->d.car->l = value = eval(handy->d.car);
 322:         else errorh1(Vermisc,
 323:                 "Can only setq atoms or values",nil,FALSE,0,
 324:                         where->d.car);
 325:     }
 326:     return(value);
 327: }
 328: 
 329: 
 330: lispval
 331: Ncond()
 332: {
 333:     register lispval  where, last;
 334: 
 335:     where = lbot->val;
 336:     last = nil;
 337:     for(;;) {
 338:         if ((TYPE(where))!=DTPR)
 339:             break;
 340:         if ((TYPE(where->d.car))!=DTPR)
 341:             break;
 342:         if ((last=eval((where->d.car)->d.car)) != nil)
 343:             break;
 344:         where = where->d.cdr;
 345:     }
 346: 
 347:     if ((TYPE(where)) != DTPR)
 348:             return(nil);
 349:     where = (where->d.car)->d.cdr;
 350:     while ((TYPE(where))==DTPR) {
 351:             last = eval(where->d.car);
 352:             where = where->d.cdr;
 353:     }
 354:     return(last);
 355: }
 356: 
 357: lispval
 358: Nand()
 359: {
 360:     register lispval current, temp;
 361: 
 362:     current = lbot->val;
 363:     temp = tatom;
 364:     while (current != nil)
 365:         if ( (temp = current->d.car)!=nil && (temp = eval(temp))!=nil)
 366:             current = current->d.cdr;
 367:         else {
 368:             current = nil;
 369:             temp = nil;
 370:         }
 371:     return(temp);
 372: }
 373: 
 374: 
 375: lispval
 376: Nor()
 377: {
 378:     register lispval current, temp;
 379: 
 380:     current = lbot->val;
 381:     temp = nil;
 382:     while (current != nil)
 383:         if ( (temp = eval(current->d.car)) == nil)
 384:             current = current->d.cdr;
 385:         else
 386:             break;
 387:     return(temp);
 388: }

Defined functions

Defined variables