lam3.c

Functions

Labsval           X
Ladd1             X
Lalfalp           X
Ldiff             X
Lgetsyntax        X
Lgreaterp         X
Llessp            X
Lminus            X
Lmod              X
Lncons            X
Lnegp             X
Loblist           X
Lonep             X
Lsetsyn           X
Lsub1             X
Lzapline          X
Lzerop            X
cmpx              X
rpltab            X

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam3.c,v 1.4 84/04/06 23:08:13 layer Exp $";
   4: #endif
   5: 
   6: /*					-[Fri Aug  5 12:47:19 1983 by jkf]-
   7:  * 	lam3.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: # include "global.h"
  14: # include "chars.h"
  15: # include "chkrtab.h"
  16: 
  17: lispval
  18: Lalfalp()
  19: {
  20:     register char  *first, *second;
  21: 
  22:     chkarg(2,"alphalessp");
  23:     first = (char *) verify(lbot->val,"alphalessp: non symbol or string arg");
  24:     second = (char *) verify((lbot+1)->val,"alphalessp: non symbol or string arg");
  25:     if(strcmp(first,second) < 0)
  26:         return(tatom);
  27:     else
  28:         return(nil);
  29: }
  30: 
  31: lispval
  32: Lncons()
  33: {
  34:     register lispval handy;
  35: 
  36:     chkarg(1,"ncons");
  37:     handy = newdot();
  38:     handy->d.cdr = nil;
  39:     handy->d.car = lbot->val;
  40:     return(handy);
  41: }
  42: lispval
  43: Lzerop()
  44: {
  45:     register lispval handy;
  46: 
  47:     chkarg(1,"zerop");
  48:     handy = lbot->val;
  49:     switch(TYPE(handy)) {
  50:     case INT:
  51:         return(handy->i==0?tatom:nil);
  52:     case DOUB:
  53:         return(handy->r==0.0?tatom:nil);
  54:     }
  55:     return(nil);
  56: }
  57: lispval
  58: Lonep()
  59: {
  60:     register lispval handy;
  61:     lispval Ladd();
  62: 
  63:     handy = lbot->val;
  64:     switch(TYPE(handy)) {
  65:     case INT:
  66:         return(handy->i==1?tatom:nil);
  67:     case DOUB:
  68:         return(handy->r==1.0?tatom:nil);
  69:     case SDOT:
  70:         protect(inewint(0));
  71:         handy = Ladd();
  72:         if(TYPE(handy)!=INT || handy->i !=1)
  73:             return(nil);
  74:         else
  75:             return(tatom);
  76:     }
  77:     return(nil);
  78: }
  79: 
  80: lispval
  81: cmpx(lssp)
  82: {
  83:     register struct argent *argp;
  84:     register struct argent *outarg;
  85:     register struct argent *onp = np;
  86:     Savestack(3);
  87: 
  88: 
  89:     argp = lbot + 1;
  90:     outarg = np;
  91:     while(argp < onp) {
  92: 
  93:         np = outarg + 2;
  94:         lbot = outarg;
  95:         if(lssp)
  96:             *outarg = argp[-1], outarg[1]  = *argp++;
  97:         else
  98:             outarg[1]  = argp[-1], *outarg = *argp++;
  99:         lbot->val = Lsub();
 100:         np = lbot + 1;
 101:         if(Lnegp()==nil)
 102:         {
 103:             Restorestack();
 104:             return(nil);
 105:         }
 106:     }
 107:     Restorestack();
 108:     return(tatom);
 109: }
 110: 
 111: lispval
 112: Lgreaterp()
 113: {
 114:     register int typ;
 115:     /* do the easy cases first */
 116:     if(np-lbot == 2)
 117:     {   if((typ=TYPE(lbot->val)) == INT)
 118:         {    if((typ=TYPE(lbot[1].val)) == INT)
 119:            return((lbot[0].val->i - lbot[1].val->i) > 0 ? tatom : nil);
 120:          else if(typ == DOUB)
 121:           return((lbot[0].val->i - lbot[1].val->r) > 0.0 ? tatom : nil);
 122:         }
 123:         else if(typ == DOUB)
 124:         {    if((typ=TYPE(lbot[1].val)) == INT)
 125:           return((lbot[0].val->r - lbot[1].val->i) > 0.0 ? tatom : nil);
 126:          else if(typ == DOUB)
 127:           return((lbot[0].val->r - lbot[1].val->r) > 0.0 ? tatom : nil);
 128:         }
 129:     }
 130: 
 131:     return(cmpx(FALSE));
 132: }
 133: 
 134: lispval
 135: Llessp()
 136: {
 137:     register int typ;
 138:     /* do the easy cases first */
 139:     if(np-lbot == 2)
 140:     {   if((typ=TYPE(lbot->val)) == INT)
 141:         {    if((typ=TYPE(lbot[1].val)) == INT)
 142:            return((lbot[0].val->i - lbot[1].val->i) < 0 ? tatom : nil);
 143:          else if(typ == DOUB)
 144:           return((lbot[0].val->i - lbot[1].val->r) < 0.0 ? tatom : nil);
 145:         }
 146:         else if(typ == DOUB)
 147:         {    if((typ=TYPE(lbot[1].val)) == INT)
 148:           return((lbot[0].val->r - lbot[1].val->i) < 0.0 ? tatom : nil);
 149:          else if(typ == DOUB)
 150:           return((lbot[0].val->r - lbot[1].val->r) < 0.0 ? tatom : nil);
 151:         }
 152:     }
 153: 
 154:     return(cmpx(TRUE));
 155: }
 156: 
 157: lispval
 158: Ldiff()
 159: {
 160:     register lispval arg1,arg2;
 161:     register handy = 0;
 162: 
 163: 
 164:     chkarg(2,"Ldiff");
 165:     arg1 = lbot->val;
 166:     arg2 = (lbot+1)->val;
 167:     if(TYPE(arg1)==INT && TYPE(arg2)==INT) {
 168:         handy=arg1->i - arg2->i;
 169:     }
 170:     else error("non-numeric argument",FALSE);
 171:     return(inewint(handy));
 172: }
 173: 
 174: lispval
 175: Lmod()
 176: {
 177:     register lispval arg1,arg2;
 178:     lispval  handy;
 179:     struct sdot fake1, fake2;
 180:     fake2.CDR = 0;
 181:     fake1.CDR = 0;
 182: 
 183:     chkarg(2,"mod");
 184:     handy = arg1 = lbot->val;
 185:     arg2 = (lbot+1)->val;
 186:     switch(TYPE(arg1)) {
 187:     case SDOT:
 188:         switch(TYPE(arg2)) {
 189:         case SDOT:          /* both are already bignums */
 190:             break;
 191:         case INT:           /* convert arg2 to bignum   */
 192:             fake2.I = arg2->i;
 193:             arg2 =(lispval) &fake2;
 194:             break;
 195:         default:
 196:             error("non-numeric argument",FALSE);
 197:         }
 198:         break;
 199:     case INT:
 200:         switch(TYPE(arg2)) {
 201:         case SDOT:          /* convert arg1 to bignum */
 202:             fake1.I = arg1->i;
 203:             arg1 =(lispval) &fake1;
 204:             break;
 205:         case INT:           /* both are fixnums 	  */
 206:             return( inewint ((arg1->i) % (arg2->i)) );
 207:         default:
 208:             error("non-numeric argument",FALSE);
 209:         }
 210:         break;
 211:     default:
 212:         error("non-numeric argument",FALSE);
 213:     }
 214:     if(TYPE((lbot+1)->val)==INT && lbot[1].val->i==0)
 215:         return(handy);
 216:     divbig(arg1,arg2,(lispval *)0,&handy);
 217:     if(handy==((lispval)&fake1))
 218:         handy = inewint(fake1.I);
 219:     if(handy==((lispval)&fake2))
 220:         handy = inewint(fake2.I);
 221:     return(handy);
 222: }
 223: lispval
 224: Ladd1()
 225: {
 226:     register lispval handy;
 227:     lispval Ladd();
 228:     Savestack(1); /* fixup entry mask */
 229:     chkarg(1,"add1");
 230: 
 231:     /* simple test first */
 232:     if((TYPE(lbot->val) == INT) && (lbot->val->i < MaxINT))
 233:     {
 234:         Restorestack();
 235:         return(inewint(lbot->val->i + 1));
 236:     }
 237: 
 238:     handy = rdrint;
 239:     handy->i = 1;
 240:     protect(handy);
 241:     handy=Ladd();
 242:     Restorestack();
 243:     return(handy);
 244: 
 245: }
 246: 
 247: 
 248: 
 249: lispval
 250: Lsub1()
 251: {
 252:     register lispval handy;
 253:     lispval Ladd();
 254:     Savestack(1); /* fixup entry mask */
 255:     chkarg(1,"sub1");
 256: 
 257:     if((TYPE(lbot->val) == INT) && (lbot->val->i > MinINT))
 258:     {
 259:         Restorestack();
 260:         return(inewint(lbot->val->i - 1));
 261:     }
 262: 
 263:     handy = rdrint;
 264:     handy->i = - 1;
 265:     protect(handy);
 266:     handy=Ladd();
 267:     Restorestack();
 268:     return(handy);
 269: }
 270: 
 271: lispval
 272: Lminus()
 273: {
 274:     register lispval arg1, handy;
 275:     lispval subbig();
 276: 
 277:     chkarg(1,"minus");
 278:     arg1 = lbot->val;
 279:     handy = nil;
 280:     switch(TYPE(arg1)) {
 281:     case INT:
 282:         handy= inewint(0 - arg1->i);
 283:         break;
 284:     case DOUB:
 285:         handy = newdoub();
 286:         handy->r = -arg1->r;
 287:         break;
 288:     case SDOT: { struct sdot dummyb;
 289:         handy = (lispval) &dummyb;
 290:         handy->s.I = 0;
 291:         handy->s.CDR = (lispval) 0;
 292:         handy = subbig(handy,arg1);
 293:         break; }
 294: 
 295:     default:
 296:         error("non-numeric argument",FALSE);
 297:     }
 298:     return(handy);
 299: }
 300: 
 301: lispval
 302: Lnegp()
 303: {
 304:     register lispval handy = np[-1].val, work;
 305:     register flag = 0;
 306: 
 307: loop:
 308:     switch(TYPE(handy)) {
 309:     case INT:
 310:         if(handy->i < 0) flag = TRUE;
 311:         break;
 312:     case DOUB:
 313:         if(handy->r < 0) flag = TRUE;
 314:         break;
 315:     case SDOT:
 316:         for(work = handy;
 317:             work->s.CDR!=(lispval) 0;
 318:             work = work->s.CDR) {;}
 319:         if(work->s.I < 0) flag = TRUE;
 320:         break;
 321:     default:
 322:         handy = errorh1(Vermisc,
 323:                   "minusp: Non-(int,real,bignum) arg: ",
 324:                   nil,
 325:                   TRUE,
 326:                   0,
 327:                   handy);
 328:         goto loop;
 329:     }
 330:     if(flag) return(tatom);
 331:     return(nil);
 332: }
 333: 
 334: lispval
 335: Labsval()
 336: {
 337:     register lispval arg1;
 338: 
 339:     chkarg(1,"absval");
 340:     arg1 = lbot->val;
 341:     if(Lnegp()!=nil) return(Lminus());
 342: 
 343:     return(arg1);
 344: }
 345: 
 346: /*
 347:  *
 348:  * (oblist)
 349:  *
 350:  * oblist returns a list of all symbols in the oblist
 351:  *
 352:  * written by jkf.
 353:  */
 354: lispval
 355: Loblist()
 356: {
 357:     int indx;
 358:     lispval headp, tailp ;
 359:     struct atom *symb ;
 360:     extern int hashtop;
 361:     Savestack(0);
 362: 
 363:     headp = tailp = newdot(); /* allocate first DTPR */
 364:     protect(headp);     /*protect the list from garbage collection*/
 365:                 /*line added by kls			  */
 366: 
 367:     for( indx=0 ; indx <= hashtop-1 ; indx++ ) /* though oblist */
 368:     {
 369:     for( symb = hasht[indx] ;
 370:          symb != (struct atom *) CNIL ;
 371:          symb = symb-> hshlnk)
 372:     {
 373:         if(TYPE(symb) != ATOM)
 374:         {   printf(" non symbol in hasht[%d] = %x: ",indx,symb);
 375:         printr((lispval) symb,stdout);
 376:         printf(" \n");
 377:         fflush(stdout);
 378:         }
 379:         tailp->d.car = (lispval) symb  ; /* remember this atom */
 380:         tailp = tailp->d.cdr = newdot() ; /* link to next DTPR */
 381:     }
 382:     }
 383: 
 384:     tailp->d.cdr = nil ; /* close the list unfortunately throwing away
 385: 			  the last DTPR
 386: 			  */
 387:     Restorestack();
 388:     return(headp);
 389: }
 390: 
 391: /*
 392:  * Maclisp setsyntax function:
 393:  *    (setsyntax c s x)
 394:  * c represents character either by fixnum or atom
 395:  * s is the atom "macro" or the atom "splicing" (in which case x is the
 396:  * macro to be invoked); or nil (meaning don't change syntax of c); or
 397:  * (well thats enough for now) if s is a fixnum then we modify the bits
 398:  * for c in the readtable.
 399:  */
 400: 
 401: lispval
 402: Lsetsyn()
 403: {
 404:     register lispval s, c;
 405:     register struct argent *mynp;
 406:     register index;
 407:     lispval x   /*  ,debugmode  */;
 408:     extern unsigned char *ctable;
 409:     extern lispval Istsrch();
 410: 
 411:     switch(np-lbot) {
 412:     case 2:
 413:         x= nil;         /* only 2 args given */
 414:     case 3:
 415:         x = lbot[2].val;    /* all three args given */
 416:         break;
 417:     default:
 418:         argerr("setsyntax");
 419:     }
 420:     s = Vreadtable->a.clb;
 421:     chkrtab(s);
 422:     /* debugging code
 423: 	debugmode = Istsrch(matom("debugging"))->d.cdr->d.cdr->d.cdr;
 424: 	if(debugmode)  printf("Readtable addr: %x\n",ctable);
 425: 	  end debugging code */
 426:     mynp = lbot;
 427:     c = (mynp++)->val;
 428:     s = (mynp++)->val;
 429: 
 430:     switch(TYPE(c)) {
 431:     default:
 432:         error("neither fixnum, atom or string as char to setsyntax",FALSE);
 433: 
 434:     case ATOM:
 435:         index = *(c->a.pname);
 436:         if((c->a.pname)[1])
 437:             errorh1(Vermisc,"Only 1 char atoms to setsyntax",
 438:                  nil,FALSE,0,c);
 439:         break;
 440: 
 441:     case INT:
 442:         index = c->i;
 443:         break;
 444: 
 445:     case STRNG:
 446:         index = (int) *((char *) c);
 447:     }
 448:     switch(TYPE(s)) {
 449:     case ATOM:
 450:         if(s==splice || s==macro) {
 451:             if(s==splice)
 452:                 ctable[index] = VSPL;
 453:             else if(s==macro)
 454:                 ctable[index] = VMAC;
 455:             if(TYPE(c)!=ATOM) {
 456:                 strbuf[0] = index;
 457:                 strbuf[1] = 0;
 458:                 c = (getatom(TRUE));
 459:             }
 460:             Iputprop(c,x,lastrtab);
 461:             return(tatom);
 462:         }
 463: 
 464:         /* ... fall into */
 465:     default:  errorh1(Vermisc,"int:setsyntax : illegal second argument ",
 466:                 nil,FALSE,0,s);
 467:         /* not reached */
 468: 
 469:     case INT:
 470:         switch(synclass(s->i)) {
 471:         case CESC: Xesc = (char) index; break;
 472:         case CDQ: Xdqc = (char) index; break;
 473:         case CSD: Xsdc = (char) index;  /* string */
 474:         }
 475: 
 476:         if(synclass(ctable[index])==CESC   /* if we changed the current esc */
 477:           && (synclass(s->i)!=CESC)          /* to something else, pick current */
 478:           && Xesc == (char) index) {
 479:                 ctable[index] = s->i;
 480:             rpltab(CESC,&Xesc);
 481:         }
 482:         else if(synclass(ctable[index])==CDQ   /*  likewise for double quote */
 483:                && synclass(s->i) != CDQ
 484:                && Xdqc == (char) index)  {
 485:             ctable[index] = s->i;
 486:             rpltab(CDQ,&Xdqc);
 487:         }
 488:         else if(synclass(ctable[index]) == CSD  /* and for string delimiter */
 489:             && synclass(s->i) != CSD
 490:             && Xsdc == (char) index) {
 491:              ctable[index] = s->i;
 492:              rpltab(CSD,&Xsdc);
 493:         }
 494:         else ctable[index] = s->i;
 495: 
 496:         break;
 497: 
 498:     }
 499:     return(tatom);
 500: }
 501: 
 502: /*
 503:  * this aux function is used by setsyntax to determine the new current
 504:  * escape or double quote character.  It scans the character table for
 505:  * the first character with the given class (either VESC or VDQ) and
 506:  * puts that character in Xesc or Xdqc (whichever is pointed to by
 507:  * addr).
 508:  */
 509: rpltab(cclass,addr)
 510: char cclass;
 511: unsigned char *addr;
 512: {
 513:     register int i;
 514:     extern unsigned char *ctable;
 515:     for(i=0; i<=127 && synclass(ctable[i]) != cclass; i++);
 516:     if(i<=127) *addr = (unsigned char) i;
 517:     else *addr = '\0';
 518: }
 519: 
 520: 
 521: /*
 522:  * int:getsyntax from lisp.
 523:  * returns the fixnum syntax code from the readtable for the given character.
 524:  * to be used by the lisp-code function getsyntax, not to be used by
 525:  * joe user.
 526:  */
 527: lispval
 528: Lgetsyntax()
 529: {
 530:     register char *name;
 531:     int number, typ;
 532:     lispval handy;
 533: 
 534:     chkarg(1,"int:getsyntax");
 535:     handy = lbot[0].val;
 536:     while (1)
 537:     {
 538:     if((typ = TYPE(handy)) == ATOM)
 539:     {
 540:         name = handy->a.pname;
 541:     }
 542:     else if (typ == STRNG)
 543:     {
 544:         name = (char *)handy;
 545:     }
 546:     else if(typ == INT)
 547:     {
 548:         number = handy->i;
 549:         break;
 550:     }
 551:     else {
 552:         handy =
 553:           errorh1(Vermisc,"int:getsyntax : bad character ",
 554:                 nil,TRUE,0,handy);
 555:         continue;   /* start at the top */
 556:     }
 557:     /* figure out the number of the first byte */
 558:     number = (int) name[0];
 559:     if(name[1] != '\0')
 560:     {
 561:         handy = errorh1(Vermisc,
 562:         "int:getsyntax : only single character allowed ",
 563:         nil,TRUE,0,handy);
 564:     }
 565:     else break;
 566:     }
 567:     /* see if number is within range */
 568:     if(number < 0 || number > 255)
 569:         errorh1(Vermisc,"int:getsyntax : character number out of range ",nil,
 570:         FALSE,0,inewint(number));
 571:     chkrtab(Vreadtable->a.clb);  /* make sure readtable is correct */
 572:     return(inewint(ctable[number]));
 573: }
 574: 
 575: 
 576: 
 577: 
 578: lispval
 579: Lzapline()
 580: {
 581:     register FILE *port;
 582:     extern FILE * rdrport;
 583: 
 584:     port = rdrport;
 585:     while (!feof(port) && (getc(port)!='\n') );
 586:     return(nil);
 587: }