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

   1: #ifndef lint
   2: static char *rcsid =
   3:    "$Header: lam8.c,v 1.16 85/03/24 11:04:31 sklower Exp $";
   4: #endif
   5: 
   6: /*					-[Thu Sep 29 22:24:10 1983 by jkf]-
   7:  * 	lam8.c				$Locker:  $
   8:  * lambda functions
   9:  *
  10:  * (c) copyright 1982, Regents of the University of California
  11:  */
  12: 
  13: #include "global.h"
  14: #include <sys/types.h>
  15: #include <sys/stat.h>
  16: #include "frame.h"
  17: 
  18: /* various functions from the c math library */
  19: double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp();
  20: extern int current;
  21: 
  22: lispval Imath(func)
  23: double (*func)();
  24: {
  25:     register lispval handy;
  26:     register double res;
  27:     chkarg(1,"Math functions");
  28: 
  29:     switch(TYPE(handy=lbot->val)) {
  30:      case INT: res = func((double)handy->i);
  31:            break;
  32: 
  33:      case DOUB: res = func(handy->r);
  34:            break;
  35: 
  36:      default:  error("Non fixnum or flonum to math function",FALSE);
  37:     }
  38:     handy = newdoub();
  39:     handy->r = res;
  40:     return(handy);
  41: }
  42: lispval Lsin()
  43: {
  44:     return(Imath(sin));
  45: }
  46: 
  47: lispval Lcos()
  48: {
  49:     return(Imath(cos));
  50: }
  51: 
  52: lispval Lasin()
  53: {
  54:     return(Imath(asin));
  55: }
  56: 
  57: lispval Lacos()
  58: {
  59:     return(Imath(acos));
  60: }
  61: 
  62: lispval Lsqrt()
  63: {
  64:     return(Imath(sqrt));
  65: }
  66: lispval Lexp()
  67: {
  68:     return(Imath(exp));
  69: }
  70: 
  71: lispval Llog()
  72: {
  73:     return(Imath(log));
  74: }
  75: 
  76: /* although we call this atan, it is really atan2 to the c-world,
  77:    that is, it takes two args
  78:  */
  79: lispval Latan()
  80: {
  81:     register lispval arg;
  82:     register double arg1v;
  83:     register double res;
  84:     chkarg(2,"arctan");
  85: 
  86:     switch(TYPE(arg=lbot->val)) {
  87: 
  88:     case INT:  arg1v = (double) arg->i;
  89:            break;
  90: 
  91:     case DOUB: arg1v = arg->r;
  92:            break;
  93: 
  94:     default:   error("Non fixnum or flonum arg to atan2",FALSE);
  95:     }
  96: 
  97:     switch(TYPE(arg = (lbot+1)->val)) {
  98: 
  99:     case INT: res = atan2(arg1v,(double) arg->i);
 100:           break;
 101: 
 102:     case DOUB: res = atan2(arg1v, arg->r);
 103:           break;
 104: 
 105:     default:  error("Non fixnum or flonum to atan2",FALSE);
 106:     }
 107:     arg = newdoub();
 108:     arg->r = res;
 109:     return(arg);
 110: }
 111: 
 112: /* (random) returns a fixnum in the range -2**30 to 2**30 -1
 113:    (random fixnum) returns a fixnum in the range 0 to fixnum-1
 114:  */
 115: lispval
 116: Lrandom()
 117: {
 118:     register int curval;
 119:     float pow();
 120: 
 121:     curval = rand();    /* get numb from 0 to 2**31-1 */
 122: 
 123:     if(np==lbot) return(inewint(curval-(int)pow((double)2,(double)30)));
 124: 
 125:     if((TYPE(lbot->val) != INT)
 126:         || (lbot->val->i <= 0)) errorh1(Vermisc,"random: non fixnum arg:",
 127:                          nil, FALSE, 0, lbot->val);
 128: 
 129:     return(inewint(curval % lbot->val->i ));
 130: 
 131: }
 132: lispval
 133: Lmakunb()
 134: {
 135:     register lispval work;
 136: 
 137:     chkarg(1,"makunbound");
 138:     work = lbot->val;
 139:     if(work==nil || (TYPE(work)!=ATOM))
 140:         return(work);
 141:     work->a.clb = CNIL;
 142:     return(work);
 143: }
 144: 
 145: lispval
 146: Lfseek()
 147: {
 148: 
 149:     FILE *f;
 150:     long offset, whence;
 151:     lispval retp;
 152: 
 153:     chkarg(3,"fseek");          /* Make sure there are three arguments*/
 154: 
 155:     f = lbot->val->p;       /* Get first argument into f */
 156:     if (TYPE(lbot->val)!=PORT)  /* Check type of first */
 157:         error("fseek: First argument must be a port.",FALSE);
 158: 
 159:     offset = lbot[1].val->i;    /* Get second argument */
 160:     if (TYPE(lbot[1].val)!=INT)
 161:         error("fseek: Second argument must be an integer.",FALSE);
 162: 
 163:     whence = lbot[2].val->i;    /* Get last arg	*/
 164:     if (TYPE(lbot[2].val)!=INT)
 165:         error("fseek: Third argument must be an integer.",FALSE);
 166: 
 167:     if (fseek(f, offset, (int)whence) == -1)
 168:         error("fseek: Illegal parameters.",FALSE);
 169: 
 170:     retp = inewint(ftell(f));
 171: 
 172:     return((lispval) retp);
 173: }
 174: 
 175: /* function hashtabstat  : return list of number of members in  each bucket */
 176: lispval Lhashst()
 177: {
 178:     register lispval handy,cur;
 179:     register struct atom *pnt;
 180:     int i,cnt;
 181:     extern int hashtop;
 182:     Savestack(3);
 183: 
 184:     handy = newdot();
 185:     protect(handy);
 186:     cur = handy;
 187:     for(i = 0; i < hashtop; i++)
 188:     {
 189:         pnt = hasht[i];
 190:         for(cnt = 0; pnt != (struct atom *) CNIL ; pnt=pnt->hshlnk , cnt++);
 191:         cur->d.cdr = newdot();
 192:         cur = cur->d.cdr;
 193:         cur->d.car = inewint(cnt);
 194:     }
 195:     cur->d.cdr = nil;
 196:     Restorestack();
 197:     return(handy->d.cdr);
 198: }
 199: 
 200: 
 201: /* Lctcherr
 202:   this routine should only be called by the unwind protect simulation
 203:   lisp code
 204:   It is called after an unwind-protect frame has been entered and
 205:   evalated and we want to get on with the error or throw
 206:   We only handle the case where there are 0 to 2 extra arguments to the
 207:   error call.
 208: */
 209: lispval
 210: Lctcherr()
 211: {
 212:     register lispval handy;
 213:     lispval type,messg,valret,contuab,uniqid,datum1,datum2;
 214: 
 215:     chkarg(1,"I-throw-err");
 216: 
 217:     handy = lbot->val;
 218: 
 219:     if(TYPE(handy->d.car) == INT)
 220:     {   /* continuing a non error (throw,reset, etc) */
 221:         Inonlocalgo((int)handy->d.car->i,
 222:                 handy->d.cdr->d.car,
 223:                 handy->d.cdr->d.cdr->d.car);
 224:         /* NOT REACHED */
 225:     }
 226: 
 227:     if(handy->d.car != nil)
 228:     {
 229:         errorh1(Vermisc,"I-do-throw: first element not fixnum or nil",
 230:                nil,FALSE,0,handy);
 231:     }
 232: 
 233:     /* decode the arg list */
 234:     handy = handy->d.cdr;
 235:     type = handy->d.car;
 236:     handy = handy->d.cdr;
 237:     messg = handy->d.car;
 238:     handy = handy->d.cdr;
 239:     valret = handy->d.car;
 240:     handy = handy->d.cdr;
 241:     contuab = handy->d.car;
 242:     handy = handy->d.cdr;
 243:     uniqid = handy->d.car;
 244:     handy = handy->d.cdr;
 245: 
 246:     /* if not extra args */
 247:     if(handy == nil)
 248:     {
 249:       errorh(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i);
 250:     }
 251:     datum1 = handy->d.car;
 252:     handy = handy->d.cdr;
 253: 
 254:     /* if one extra arg */
 255:     if(handy == nil)
 256:     {
 257:       errorh1(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i,datum1);
 258:     }
 259: 
 260:     /* if two or more extra args, just use first 2 */
 261:     datum2 = handy->d.car;
 262:     errorh2(type,messg->a.pname,valret,(int)contuab->i,(int)uniqid->i,datum1,datum2);
 263: }
 264: 
 265: /*
 266:  *	(*makhunk '<fixnum>)
 267:  *			  <fixnum>
 268:  * Create a hunk of size 2       . <fixnum> must be between 0 and 6.
 269:  *
 270:  */
 271: 
 272: lispval
 273: LMakhunk()
 274: {
 275:     register int hsize, hcntr;
 276:     register lispval result;
 277: 
 278:     chkarg(1,"Makehunk");
 279:     if (TYPE(lbot->val)==INT)
 280:     {
 281:         hsize = lbot->val->i;       /* size of hunk (0-6) */
 282:         if ((hsize >= 0) && (hsize <= 6))
 283:         {
 284:             result = newhunk(hsize);
 285:             hsize = 2 << hsize; /* size of hunk (2-128) */
 286:             for (hcntr = 0; hcntr < hsize; hcntr++)
 287:                 result->h.hunk[hcntr] = hunkfree;
 288:         }
 289:         else
 290:             error("*makhunk: Illegal hunk size", FALSE);
 291:     return(result);
 292:     }
 293:     else
 294:         error("*makhunk: First arg must be an fixnum",FALSE);
 295:     /* NOTREACHED */
 296: }
 297: 
 298: /*
 299:  *	(cxr '<fixnum> '<hunk>)
 300:  * Returns the <fixnum>'th element of <hunk>
 301:  *
 302:  */
 303: lispval
 304: Lcxr()
 305: {
 306:     register lispval temp;
 307: 
 308:     chkarg(2,"cxr");
 309:     if (TYPE(lbot->val)!=INT)
 310:         error("cxr: First arg must be a fixnum", FALSE);
 311:     else
 312:     {
 313:         if (! HUNKP(lbot[1].val))
 314:             error("cxr: Second arg must be a hunk", FALSE);
 315:         else
 316:             if ( (lbot->val->i >= 0) &&
 317:                  (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
 318:             {
 319:                 temp = lbot[1].val->h.hunk[lbot->val->i];
 320:                 if (temp != hunkfree)
 321:                     return(temp);
 322:                 else
 323:                     error("cxr: Arg outside of hunk range",
 324:                           FALSE);
 325:             }
 326:             else
 327:                 error("cxr: Arg outside of hunk range", FALSE);
 328:     }
 329:     /* NOTREACHED */
 330: }
 331: 
 332: /*
 333:  *	(rplacx '<fixnum> '<hunk> '<expr>)
 334:  * Replaces the <fixnum>'th element of <hunk> with <expr>.
 335:  *
 336:  */
 337: lispval
 338: Lrplcx()
 339: {
 340:     lispval *handy;
 341:     chkarg(3,"rplacx");
 342:     if (TYPE(lbot->val)!=INT)
 343:         error("rplacx: First arg must be a fixnum", FALSE);
 344:     else
 345:     {
 346:         if (! HUNKP(lbot[1].val))
 347:             error("rplacx: Second arg must be a hunk", FALSE);
 348:         else
 349:         {
 350:             if ( (lbot->val->i >= 0) &&
 351:                  (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
 352:             {
 353:                if (*(handy = &(lbot[1].val->h.hunk[lbot->val->i]))
 354:                     != hunkfree)
 355:                     *handy  = lbot[2].val;
 356:                 else
 357:                     error("rplacx: Arg outside hunk range", FALSE);
 358:             }
 359:             else
 360:                 error("rplacx: Arg outside hunk range", FALSE);
 361:         }
 362:     }
 363:     return(lbot[1].val);
 364: }
 365: 
 366: /*
 367:  *	(*rplacx '<fixnum> '<hunk> '<expr>)
 368:  * Replaces the <fixnum>'th element of <hunk> with <expr>. This is the
 369:  * same as (rplacx ...) except with this function you can replace EMPTY's.
 370:  *
 371:  */
 372: lispval
 373: Lstarrpx()
 374: {
 375:     chkarg(3,"*rplacx");
 376:     if (TYPE(lbot->val)!=INT)
 377:         error("*rplacx: First arg must be a fixnum", FALSE);
 378:     else
 379:     {
 380:         if (! HUNKP(lbot[1].val))
 381:             error("*rplacx: Second arg must be a hunk", FALSE);
 382:         else
 383:         {
 384:             if ( (lbot->val->i >= 0) &&
 385:                  (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) )
 386:                 lbot[1].val->h.hunk[lbot->val->i] = lbot[2].val;
 387:             else
 388:                 error("*rplacx: Arg outside hunk range", FALSE);
 389:         }
 390:     }
 391:     return(lbot[1].val);
 392: }
 393: 
 394: /*
 395:  *	(hunksize '<hunk>)
 396:  * Returns the size of <hunk>
 397:  *
 398:  */
 399: lispval
 400: Lhunksize()
 401: {
 402:     register int size,i;
 403: 
 404:     chkarg(1,"hunksize");
 405:     if (HUNKP(lbot->val))
 406:     {
 407:         size = 2 << HUNKSIZE(lbot->val);
 408:         for (i = size-1; i >= 0; i--)
 409:         {
 410:             if (lbot->val->h.hunk[i] != hunkfree)
 411:             {
 412:                 size = i + 1;
 413:                 break;
 414:             }
 415:         }
 416:         return( inewint(size) );
 417:     }
 418:     else
 419:         error("hunksize: First argument must me a hunk", FALSE);
 420:             /* NOTREACHED */
 421: }
 422: 
 423: /*
 424:  * (hunk-to-list 'hunk)	returns a list of the hunk elements
 425:  */
 426: lispval
 427: Lhtol()
 428: {
 429:     register lispval handy,retval,last;
 430:     register int i;
 431:     int size;
 432:     Savestack(4);
 433: 
 434:     chkarg(1,"hunk-to-list");
 435:     handy = lbot->val;
 436:     if(!(HUNKP(handy)))
 437:         errorh1(Vermisc,"hunk-to-list: non hunk argument: ", nil,0,FALSE,
 438:             handy);
 439:     size = 2 << HUNKSIZE(handy);
 440:     retval = nil;
 441:     for(i=0 ; i < size ; i++)
 442:     {
 443:     if(handy->h.hunk[i] != hunkfree)
 444:     {
 445:         if(retval==nil)
 446:         {
 447:             protect(retval=newdot());
 448:         last = retval;
 449:         }
 450:         else {
 451:         last = (last->d.cdr = newdot());
 452:         }
 453:         last->d.car = handy->h.hunk[i];
 454:     }
 455:     else break;
 456:     }
 457:     Restorestack();
 458:     return(retval);
 459: }
 460: 
 461: /*
 462:  *	(fileopen  filename mode)
 463:  * open a file for read, write, or append the arguments can be either
 464:  * strings or atoms.
 465:  */
 466: lispval
 467: Lfileopen()
 468: {
 469:     FILE *port;
 470:     register lispval name;
 471:     register lispval mode;
 472:     register char *namech;
 473:     register char *modech;
 474: 
 475:     chkarg(2,"fileopen");
 476:     name = lbot->val;
 477:     mode = lbot[1].val;
 478: 
 479:     namech = (char *) verify(name,"fileopen:args must be atoms or strings");
 480:     modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
 481: 
 482:     while (modech[0] != 'r' && modech[0] != 'w' && modech[0] != 'a')
 483:     {
 484:         mode = errorh(Vermisc,"Modes are only r, w, a.",nil,TRUE,31);
 485:         modech = (char *) verify(mode,"fileopen:args must be atoms or strings");
 486:     }
 487: 
 488:     while ((port = fopen(namech, modech)) == NULL)
 489:     {
 490:         name = errorh1(Vermisc,"Unable to open file.",nil,TRUE,31,name);
 491:         namech = (char *) verify(name,"fileopen:args must be atoms or strings");
 492:     }
 493:         /* xports is a FILE *, cc complains about adding pointers */
 494: 
 495:     ioname[PN(port)] = (lispval) inewstr(namech);   /* remember name */
 496:     return(P(port));
 497: }
 498: 
 499: /*
 500:  *	(*invmod '<number> '<modulus>)
 501:  * This function returns the inverse of  <number>
 502:  * mod <modulus> in balanced representation
 503:  * It is used in vaxima as a speed enhancement.
 504:  */
 505: 
 506: static lispval
 507: Ibalmod(invmodp)
 508: {
 509:     register long mod_div_2, number, modulus;
 510: 
 511:     chkarg(2,"*mod");
 512:     if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT))
 513:     {
 514:         modulus = lbot[1].val->i;
 515:         if(invmodp) number = invmod(lbot->val->i , modulus);
 516:         else number = lbot->val->i % modulus;
 517:         mod_div_2 = modulus / 2;
 518:         if (number < 0)
 519:         {
 520:             if (number < (-mod_div_2))
 521:                 number += modulus;
 522:         }
 523:         else
 524:         {
 525:             if (number > mod_div_2)
 526:                 number -= modulus;
 527:         }
 528:         return( inewint(number) );
 529:     }
 530:     else
 531:         error("*mod: Arguments must be fixnums", FALSE);
 532:     /* NOTREACHED */
 533: }
 534: 
 535: invmod (n,modulus)
 536: long n , modulus;
 537: 
 538: {
 539:     long a1,a2,a3,y1,y2,y3,q;
 540: 
 541:     a1 = modulus;
 542:     a2 = n;
 543:     y1 = 0;
 544:     y2= 1;
 545:     goto step3;
 546: step2:
 547:     q = a1 /a2; /*truncated quotient */
 548:     a3= mmuladd(modulus-a2,q,a1,modulus);
 549:     y3= mmuladd(modulus-y2,q,y1,modulus);
 550:     a1 = a2;
 551:     a2= a3;
 552:     y1=y2;
 553:     y2=y3;
 554: step3:
 555:     if (a2==0) error("invmod: inverse of zero divisor",TRUE);
 556:     else if (a2 != 1) goto step2;
 557:     else return (y2);
 558:     /* NOTREACHED */
 559: }
 560: 
 561: lispval
 562: Lstarinvmod()
 563: {
 564:     return(Ibalmod(TRUE));
 565: }
 566: 
 567: /*
 568:  *	(*mod '<number> '<modulus>)
 569:  * This function returns <number> mod <modulus> (for balanced modulus).
 570:  * It is used in vaxima as a speed enhancement.
 571:  */
 572: lispval
 573: LstarMod()
 574: {
 575:     return(Ibalmod(FALSE));
 576: }
 577: 
 578: lispval
 579: Llsh()
 580: {
 581:     register struct argent *mylbot = lbot;
 582:     int val,shift;
 583: 
 584:     chkarg(2,"lsh");
 585:     if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT))
 586:         errorh2(Vermisc,
 587:                "Non ints to lsh",
 588:                nil,FALSE,0,mylbot->val,mylbot[1].val);
 589:     val = mylbot[0].val->i;
 590:     shift = mylbot[1].val->i;
 591:     if(shift < -32 || shift > 32)
 592:       return(inewint(0));
 593:     if (shift < 0)
 594:         val = val >> -shift;
 595:     else
 596:         val = val << shift;
 597:     if((val < 0) && (shift < 0))
 598:     {   /* special case: the vax doesn't have a logical shift
 599: 		   instruction, so we must zero out the ones which
 600: 		   will propogate from the sign position
 601: 		*/
 602:         return(inewint ( val & ~(0x80000000 >> -(shift+1))));
 603:     }
 604:     else return( inewint(val));
 605: }
 606: 
 607: /* very temporary function to test the validity of the bind stack */
 608: 
 609: bndchk()
 610: {
 611:     register struct nament *npt;
 612:     register lispval in2;
 613: 
 614:     in2 = inewint(200);
 615:     for(npt=orgbnp; npt < bnp; npt++)
 616:     {  if((int) npt->atm < (int) in2) abort();
 617:     }
 618: }
 619: 
 620: /*
 621:  *	formatted printer for lisp data
 622:  *    use: (cprintf formatstring datum [port])
 623:  */
 624: lispval
 625: Lcprintf()
 626: {
 627:     FILE *p;
 628:     char *fstrng;
 629:     lispval v;
 630:     if(np-lbot == 2) protect(nil);  /* write to standard output port */
 631:     chkarg(3,"cprintf");
 632: 
 633:     fstrng = (char *)verify(lbot->val,"cprintf: first arg not string or symbol");
 634: 
 635:     p = okport(lbot[2].val,okport(Vpoport->a.clb,poport));
 636: 
 637:     switch(TYPE(v=lbot[1].val)) {
 638: 
 639:     case INT:  fprintf(p,fstrng,v->i);
 640:            break;
 641: 
 642:     case DOUB: fprintf(p,fstrng,v->r);
 643:            break;
 644: 
 645:     case ATOM: fprintf(p,fstrng,v->a.pname);
 646:            break;
 647: 
 648:     case STRNG:fprintf(p,fstrng,v);
 649:            break;
 650: 
 651:     default:   error("cprintf: Illegal second argument",FALSE);
 652:    };
 653: 
 654:    return(lbot[1].val);
 655: }
 656: 
 657: 
 658: /*
 659:  * C style sprintf: (sprintf "format" {<arg-list>})
 660:  *
 661:  * This function stacks the arguments onto the C stack in reverse
 662:  * order and then calls sprintf with one argument...This is what the
 663:  * C compiler does, so it works just fine. The return value is the
 664:  * string that is the result of the sprintf.
 665:  */
 666: lispval
 667: Lsprintf()
 668: {
 669:     register struct argent *argp;
 670:     register int j;
 671:     char sbuf[600], *sprintf();         /* better way? */
 672:     Keepxs();
 673: 
 674:     if (np-lbot == 0) {
 675:         argerr("sprintf");
 676:     }
 677:     if (TYPE(lbot->val)==STRNG || TYPE(lbot->val)==INT) {
 678:         for (argp = np-1; argp >= lbot; argp--) {
 679:             switch(TYPE(argp->val)) {
 680:               case ATOM:
 681:                 stack((long)argp->val->a.pname);
 682:                 break;
 683: 
 684:               case DOUB:
 685: #ifndef SPISFP
 686:                 stack(argp->val->r);
 687: #else
 688:                 {double rr = argp->val->r;
 689:                 stack(((long *)&rr)[1]);
 690:                 stack(((long *)&rr)[0]);}
 691: #endif
 692:                 break;
 693: 
 694:               case INT:
 695:                 stack(argp->val->i);
 696:                 break;
 697: 
 698:               case STRNG:
 699:                 stack((long)argp->val);
 700:                 break;
 701: 
 702:               default:
 703:                 error("sprintf: Bad data type to sprintf",
 704:                         FALSE);
 705:             }
 706:         }
 707:         sprintf(sbuf);
 708:         for (j = 0; j < np-lbot; j++)
 709:             unstack();
 710:     } else
 711:         error("sprintf: First arg must be an atom or string", FALSE);
 712:     Freexs();
 713:     return ((lispval) inewstr(sbuf));
 714: }
 715: 
 716: lispval
 717: Lprobef()
 718: {
 719:     char *name;
 720:     chkarg(1,"probef");
 721: 
 722:     name = (char *)verify(lbot->val,"probef: not symbol or string arg ");
 723: 
 724:     if(access(name,0) == 0) return(tatom);
 725:     else return(nil);
 726: }
 727: 
 728: lispval
 729: Lsubstring()
 730: {   register char *name;
 731:     register lispval index,length;
 732:     int restofstring = FALSE;
 733:     int len,ind,reallen;
 734: 
 735:     switch (np-lbot)
 736:     {
 737:       case 2: restofstring = TRUE;
 738:           break;
 739: 
 740:       case 3: break;
 741: 
 742:       default: chkarg(3,"substring");
 743:     }
 744: 
 745:     name = (char *)verify(lbot[0].val,"substring: not symbol or string arg ");
 746: 
 747:     while (TYPE(index = lbot[1].val) != INT)
 748:     {  lbot[1].val = errorh1(Vermisc,"substring: non integer index ",nil,
 749:                             TRUE,0,index);
 750:     }
 751: 
 752:     len = strlen(name);
 753:     ind = index->i;
 754: 
 755:     if(ind < 0) ind = len+1 + ind;
 756: 
 757:     if(ind < 1 || ind > len) return(nil);   /*index out of bounds*/
 758:     if(restofstring) return((lispval)inewstr(name+ind-1));
 759: 
 760:     while (TYPE(length = lbot[2].val) != INT)
 761:     { lbot[2].val = errorh1(Vermisc,"substring: not integer length ",nil,
 762:                            TRUE,0,length);
 763:     }
 764: 
 765:     if((reallen = length->i ) < 0 || (reallen + ind) > len)
 766:       return((lispval)inewstr(name+ind-1));
 767: 
 768:     strncpy(strbuf,name+ind-1,reallen);
 769:     strbuf[reallen] = '\0';
 770:     return((lispval)newstr(0));
 771: }
 772: 
 773: /*
 774:  * This is substringn
 775:  */
 776: lispval
 777: Lsstrn()
 778: {
 779:     register char *name;
 780:     register int len,ind,reallen;
 781:     lispval index,length;
 782:     int restofstring = FALSE;
 783:     Savestack(4);
 784: 
 785:     if((np-lbot) == 2) restofstring = TRUE;
 786:     else { chkarg(3,"substringn");}
 787: 
 788:     name = (char *) verify(lbot[0].val,"substringn: non symbol or string arg ");
 789: 
 790:     while (TYPE(index = lbot[1].val) != INT)
 791:     {  lbot[1].val = errorh1(Vermisc,"substringn: non integer index ",nil,
 792:                             TRUE,0,index);
 793:     }
 794: 
 795:     if(!restofstring)
 796:     {
 797:         while (TYPE(length = lbot[2].val) != INT)
 798:         { lbot[2].val = errorh1(Vermisc,"substringn: not integer length ",
 799:                             nil, TRUE,0,length);
 800:         }
 801:         reallen = length->i;
 802:     }
 803:     else reallen = -1;
 804: 
 805:     len = strlen(name);
 806:     ind = index->i;
 807:     if(ind < 0) ind = len + 1 + ind;
 808:     if( ind < 1 || ind > len) return(nil);
 809: 
 810:     if(reallen == 0)
 811:         return((lispval)inewint(*(name + ind - 1)));
 812:     else {
 813:         char *pnt = name + ind - 1;
 814:         char *last = name + len -1;
 815:         lispval cur,start;
 816: 
 817:         protect(cur = start = newdot());
 818:         cur->d.car = inewint(*pnt);
 819:         while(++pnt <= last && --reallen != 0)
 820:         {
 821:            cur->d.cdr = newdot();
 822:            cur = cur->d.cdr;
 823:            cur->d.car = inewint(*pnt);
 824:         }
 825:         Restorestack();
 826:         return(start);
 827:     }
 828: 
 829: }
 830: 
 831: 
 832: /*
 833:  * (character-index 'string 'char)
 834:  * return the index of char in the string.
 835:  * return nil if not present
 836:  * char can be a fixnum (representing a character)
 837:  *  a symbol or string (in which case the first char is used)
 838:  *
 839:  */
 840: 
 841: #if os_unix_ts
 842: #define index strchr
 843: #endif
 844: lispval
 845: Lcharindex()
 846: {
 847:     register char *string;
 848:     register char ch;
 849:     char *str2;
 850: 
 851:     chkarg(2,"character-index");
 852: 
 853: 
 854:     string = (char *)verify(lbot[0].val,"character-index: non symbol or string arg ");
 855:     if(TYPE(lbot[1].val) == INT)
 856:         ch = (char) lbot[1].val->i;
 857:     else {
 858:         str2 = (char *) verify(lbot[1].val,"character-index: bad first argument ");
 859:     ch = *str2; /* grab the first character */
 860:     }
 861: 
 862:     if((str2 = (char *) index(string,ch)) ==  0) return(nil); /* not there */
 863:     /* return 1-based index of character */
 864:     return(inewint(str2-string+1));
 865: }
 866: 
 867: 
 868: lispval Ipurcopy();
 869: 
 870: 
 871: lispval
 872: Lpurcopy()
 873: {
 874:     chkarg(1,"purcopy");
 875:     return(Ipurcopy(lbot[0].val));
 876: }
 877: 
 878: lispval
 879: Ipurcopy(handy)
 880: lispval handy;
 881: {
 882:     extern int *beginsweep;
 883:     register lispval retv, curv, lv;
 884:     int i,size;
 885: 
 886:     switch(TYPE(handy)) {
 887: 
 888:     case DTPR:
 889:            retv = curv = pnewdot();
 890:            lv = handy;
 891:            while(TRUE)
 892:            {
 893:               curv->d.car = Ipurcopy(lv->d.car);
 894:               if(TYPE(lv = lv->d.cdr) == DTPR)
 895:               {
 896:               curv->d.cdr = pnewdot();
 897:               curv = curv->d.cdr;
 898:               }
 899:               else {
 900:               curv->d.cdr = Ipurcopy(lv);
 901:               break;
 902:               }
 903:             }
 904:             return(retv);
 905: 
 906:     case SDOT:
 907:             retv = curv = pnewsdot();
 908:             lv = handy;
 909:             while(TRUE)
 910:             {
 911:             curv->s.I = lv->s.I;
 912:             if(lv->s.CDR == (lispval) 0) break;
 913:             lv = lv->s.CDR;
 914:             curv->s.CDR = pnewdot();
 915:             curv = curv->s.CDR;
 916:             }
 917:             curv->s.CDR = 0;
 918:             return(retv);
 919: 
 920:     case INT:
 921:             if((int *)handy < beginsweep) return(handy);
 922:             retv = pnewint();
 923:             retv->i = handy->i;
 924:             return(retv);
 925: 
 926:     case DOUB:
 927:             retv = pnewdb();
 928:             retv->r = handy->r;
 929:             return(retv);
 930: 
 931:     case HUNK2:
 932:         i = 0;
 933:         goto hunkit;
 934: 
 935:     case HUNK4:
 936:         i = 1;
 937:         goto hunkit;
 938: 
 939:     case HUNK8:
 940:         i = 2;
 941:         goto hunkit;
 942: 
 943:     case HUNK16:
 944:         i = 3;
 945:         goto hunkit;
 946: 
 947:     case HUNK32:
 948:         i = 4;
 949:         goto hunkit;
 950: 
 951:     case HUNK64:
 952:         i = 5;
 953:         goto hunkit;
 954: 
 955:     case HUNK128:
 956:         i = 6;
 957: 
 958:         hunkit:
 959:         retv = pnewhunk(i);
 960:         size = 2 << i ; /* number of elements to copy over */
 961:         for( i = 0; i < size ; i++)
 962:         {
 963:             retv->h.hunk[i] = Ipurcopy(handy->h.hunk[i]);
 964:         }
 965:         return(retv);
 966: 
 967: 
 968: 
 969:     case STRNG:
 970: #ifdef GCSTRINGS
 971:         { extern char purepage[];
 972: 
 973:           if(purepage[((int)handy)>>9]==0)
 974:             return((lispval)pinewstr((char *)handy));}
 975: 
 976: #endif
 977:     case ATOM:
 978:     case BCD:
 979:     case PORT:
 980:         return(handy);  /* We don't want to purcopy these, yet
 981: 				 * it won't hurt if we don't mark them
 982: 				 * since they either aren't swept or
 983: 				 * will be marked in a special way
 984: 				 */
 985:     case ARRAY:
 986:         error("purcopy: can't purcopy array structures",FALSE);
 987: 
 988:     default:
 989:         error(" bad type to purcopy ",FALSE);
 990:     /* NOTREACHED */
 991:     }
 992: }
 993: 
 994: /*
 995:  * Lpurep returns t if the given arg is in pure space
 996:  */
 997: lispval
 998: Lpurep()
 999: {
1000:     lispval Ipurep();
1001: 
1002:     chkarg(1,"purep");
1003:     return(Ipurep(lbot->val));
1004: }
1005: 
1006: 
1007: 
1008: /* vector functions */
1009: lispval newvec(), nveci(), Inewvector();
1010: 
1011: /* vector creation and initialization functions */
1012: lispval
1013: Lnvec()
1014: {
1015:     return(Inewvector(3));
1016: }
1017: 
1018: lispval
1019: Lnvecb()
1020: {
1021:     return(Inewvector(0));
1022: }
1023: 
1024: lispval
1025: Lnvecw()
1026: {
1027:     return(Inewvector(1));
1028: }
1029: 
1030: lispval
1031: Lnvecl()
1032: {
1033:     return(Inewvector(2));
1034: }
1035: 
1036: /*
1037:  * (new-vector 'x_size ['g_fill] ['g_prop])
1038:  * class = 0: byte \
1039:  *       = 1: word  > immediate
1040:  *       = 2: long /
1041:  *	 = 3: long
1042:  */
1043: lispval
1044: Inewvector(class)
1045: {
1046:     register int i;
1047:     register lispval handy;
1048:     register lispval *handy2;
1049:     char *chandy;
1050:     short *whandy;
1051:     long *lhandy;
1052:     lispval sizearg, fillarg, proparg;
1053:     int size, vsize;
1054: 
1055:     fillarg = proparg = nil;
1056: 
1057:     switch(np-lbot) {
1058:     case 3: proparg = lbot[2].val;
1059:     case 2: fillarg = lbot[1].val;
1060:     case 1: sizearg = lbot[0].val;
1061:         break;
1062:     default: argerr("new-vector");
1063:     }
1064: 
1065:     while((TYPE(sizearg) != INT) || sizearg->i < 0)
1066:     sizearg = errorh1(Vermisc,"new-vector: bad size for vector ",nil,
1067:                 TRUE,0,sizearg);
1068:     size = sizearg->i;
1069:     switch(class)
1070:     {
1071:     case 0: vsize = size * sizeof(char);
1072:         break;
1073:     case 1: vsize = size * sizeof(short);
1074:         break;
1075:     default: vsize = size * sizeof(long);
1076:         break;
1077:     }
1078: 
1079:     if(class != 3) handy = nveci(vsize);
1080:     else handy = newvec(vsize);
1081: 
1082:     switch(class)
1083:     {
1084:     case 0: chandy = (char *)handy;
1085:             for(i = 0 ; i < size ; i++) *chandy++ = (char) (fillarg->i);
1086:         break;
1087: 
1088:     case 1: whandy = (short *)handy;
1089:             for(i = 0 ; i < size ; i++) *whandy++ = (short) (fillarg->i);
1090:         break;
1091: 
1092:     case 2: lhandy = (long *)handy;
1093:             for(i = 0 ; i < size ; i++) *lhandy++ = (fillarg->i);
1094:         break;
1095: 
1096:     case 3: handy2 = (lispval *)handy;
1097:         for(i = 0 ; i < size ; i++) *handy2++ = fillarg;
1098:         break;
1099:     }
1100:     handy->v.vector[-1] = proparg;
1101:     return(handy);
1102: }
1103: 
1104: lispval
1105: Lvectorp()
1106: {
1107:     chkarg(1,"vectorp");
1108:     if(TYPE(lbot->val) == VECTOR) return(tatom);
1109:     else return(nil);
1110: }
1111: 
1112: lispval
1113: Lpvp()
1114: {
1115:     chkarg(1,"vectorip");
1116:     if(TYPE(lbot->val) == VECTORI) return(tatom);
1117:     else return(nil);
1118: }
1119: 
1120: /*
1121:  * int:vref  vector[i] index class
1122:  *  class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1123:  *
1124:  * also do C style dereferencing of pointers.  This is a temporary
1125:  * hack until we decide if we can live without it:
1126:  *  class = 4: char, 5: short, 6: long, 7: float, 8: double
1127:  */
1128: lispval
1129: LIvref()
1130: {
1131:     register lispval vect;
1132:     register int index;
1133:     int class;
1134:     double value;
1135: 
1136:     chkarg(3,"int:vref");
1137:     vect = lbot[0].val;
1138:     index = lbot[1].val->i;
1139:     class = lbot[2].val->i;
1140:     switch(class)
1141:     {
1142:         case 0: return(inewint(vect->vb.vectorb[index]));
1143:         case 1: return(inewint(vect->vw.vectorw[index]));
1144:         case 2: return(inewint(vect->vl.vectorl[index]));
1145:     case 3: return(vect->v.vector[index]);
1146:     case 4: return(inewint(*(char *)(vect->i+index)));
1147:     case 5: return(inewint(*(short *)(vect->i+index)));
1148:     case 6: return(inewint(*(long *)(vect->i+index)));
1149:     case 7: value = *(float *) (vect->i+index);
1150:         vect = newdoub();
1151:         vect->r = value;
1152:         return(vect);
1153:     case 8: value = *(double *) (vect->i+index);
1154:         vect = newdoub();
1155:         vect->r = value;
1156:         return(vect);
1157:     }
1158:     error("int:vref: impossible class detected",FALSE);
1159:     /* NOTREACHED */
1160: }
1161: 
1162: /*
1163:  * int:vset vector[i] index value class
1164:  *  class = 0: byte immed, 1: word immed, 2: long immed, 3: long
1165:  */
1166: lispval
1167: LIvset()
1168: {
1169:     register lispval vect,value;
1170:     register int index;
1171:     int class;
1172: 
1173:     chkarg(4,"int:vset");
1174:     vect = lbot[0].val;
1175:     index = lbot[1].val->i;
1176:     value = lbot[2].val;
1177:     class = lbot[3].val->i;
1178:     switch(class)
1179:     {
1180:         case 0: vect->vb.vectorb[index] = (char)value->i;
1181:         break;
1182:         case 1: vect->vw.vectorw[index] = (short)value->i;
1183:         break;
1184:         case 2: vect->vl.vectorl[index] = value->i;
1185:         break;
1186:     case 3: vect->v.vector[index] = value;
1187:         break;
1188:     case 4: *(char *) (vect->i+index) = value->i;
1189:         break;
1190:     case 5: *(short *) (vect->i+index) = value->i;
1191:         break;
1192:     case 6: *(long *) (vect->i+index) = value->i;
1193:         break;
1194:     case 7: *(float *) (vect->i+index) = value->r;
1195:         break;
1196:     case 8: *(double *) (vect->i+index) = value->r;
1197:         break;
1198:     default:
1199:     error("int:vref: impossible class detected",FALSE);
1200:     }
1201:     return(value);
1202: }
1203: 
1204: /*
1205:  * LIvsize == (int:vsize 'vector 'x_shift)
1206:  *  return the vsize field of the vector shifted right by x_shift
1207:  */
1208: lispval
1209: LIvsize()
1210: {
1211:     int typ;
1212: 
1213:     chkarg(2,"int:vsize");
1214:     return(inewint((lbot[0].val->vl.vectorl[VSizeOff]) >> lbot[1].val->i));
1215: }
1216: 
1217: lispval
1218: Lvprop()
1219: {
1220:     int typ;
1221:     chkarg(1,"vprop");
1222: 
1223:     if(((typ = TYPE(lbot->val)) != VECTOR) && (typ != VECTORI))
1224:         errorh1(Vermisc,"vprop: non vector argument: ", nil, FALSE,0,
1225:             lbot->val);
1226:     return(lbot[0].val->v.vector[VPropOff]);
1227: }
1228: 
1229: 
1230: lispval
1231: Lvsp()
1232: {
1233:     int typ;
1234:     lispval vector, property;
1235:     chkarg(2,"vsetprop");
1236: 
1237:     vector = lbot->val;
1238:     property = lbot[1].val;
1239:     typ = TYPE(vector);
1240: 
1241:     if(typ != VECTOR && typ !=VECTORI)
1242:         errorh1(Vermisc,"vsetprop: non vector argument: ",
1243:                 nil,FALSE,0,vector);
1244:     vector->v.vector[VPropOff] = property;
1245:     return(property);
1246: }
1247: 
1248: 
1249: /* vecequal
1250:  *  check if the two vector arguments are 'equal'
1251:  *  this is called by equal which has already checked that
1252:  *  the arguments are vector
1253:  */
1254: vecequal(v,w)
1255: lispval v,w;
1256: {
1257:     int i;
1258:     lispval vv, ww, ret;
1259:     int vsize = (int) v->v.vector[VSizeOff];
1260:     int wsize = (int) w->v.vector[VSizeOff];
1261:     struct argent *oldlbot = lbot;
1262:     lispval Lequal();
1263: 
1264:     if(vsize != wsize) return(FALSE);
1265: 
1266:     vsize /= sizeof(int);   /* determine number of entries */
1267: 
1268:     for(i = 0 ; i < vsize ; i++)
1269:     {
1270:     vv = v->v.vector[i];
1271:     ww = w->v.vector[i];
1272:     /* avoid calling equal if they are eq */
1273:     if(vv != ww)
1274:     {
1275:         lbot = np;
1276:         protect(vv);
1277:         protect(ww);
1278:         ret = Lequal();
1279:         np = lbot;
1280:         lbot = oldlbot;
1281:         if(ret == nil)  return(FALSE);
1282:     }
1283:     }
1284:     return(TRUE);
1285: }
1286: 
1287: /* veciequal
1288:  *  check if the two vectori arguments are 'equal'
1289:  *  this is called by equal which has already checked that
1290:  *  the arguments are vector
1291:  *  Note: this would run faster if we did as many 'longword'
1292:  *  comparisons as possible and then did byte comparisons.
1293:  *  or if we used pointers instead of indexing.
1294:  */
1295: veciequal(v,w)
1296: lispval v,w;
1297: {
1298:     char vv, ww;
1299:     int i;
1300:     int vsize = (int) v->v.vector[VSizeOff];
1301:     int wsize = (int) w->v.vector[VSizeOff];
1302: 
1303:     if(vsize != wsize) return(FALSE);
1304: 
1305: 
1306:     for(i = 0 ; i < vsize ; i++)
1307:     {
1308:     if(v->vb.vectorb[i] != w->vb.vectorb[i]) return(FALSE);
1309:     }
1310:     return(TRUE);
1311: }

Defined functions

Defined variables

Defined macros