![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam8.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: lam8.c,v 1.9 83/09/12 14:16:52 sklower Exp $"; ! 4: #endif ! 5: ! 6: /* -[Fri Aug 12 07:54:00 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: Lrplacx() ! 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( (lispval) (xports + (port - _iob))); ! 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: lispval Ipurcopy(); ! 832: ! 833: ! 834: lispval ! 835: Lpurcopy() ! 836: { ! 837: chkarg(1,"purcopy"); ! 838: return(Ipurcopy(lbot[0].val)); ! 839: } ! 840: ! 841: lispval ! 842: Ipurcopy(handy) ! 843: lispval handy; ! 844: { ! 845: extern int *beginsweep; ! 846: register lispval retv, curv, lv; ! 847: int i,size; ! 848: ! 849: switch(TYPE(handy)) { ! 850: ! 851: case DTPR: ! 852: retv = curv = pnewdot(); ! 853: lv = handy; ! 854: while(TRUE) ! 855: { ! 856: curv->d.car = Ipurcopy(lv->d.car); ! 857: if(TYPE(lv = lv->d.cdr) == DTPR) ! 858: { ! 859: curv->d.cdr = pnewdot(); ! 860: curv = curv->d.cdr; ! 861: } ! 862: else { ! 863: curv->d.cdr = Ipurcopy(lv); ! 864: break; ! 865: } ! 866: } ! 867: return(retv); ! 868: ! 869: case SDOT: ! 870: retv = curv = pnewsdot(); ! 871: lv = handy; ! 872: while(TRUE) ! 873: { ! 874: curv->s.I = lv->s.I; ! 875: if(lv->s.CDR == (lispval) 0) break; ! 876: lv = lv->s.CDR; ! 877: curv->s.CDR = pnewdot(); ! 878: curv = curv->s.CDR; ! 879: } ! 880: curv->s.CDR = 0; ! 881: return(retv); ! 882: ! 883: case INT: ! 884: if((int *)handy < beginsweep) return(handy); ! 885: retv = pnewint(); ! 886: retv->i = handy->i; ! 887: return(retv); ! 888: ! 889: case DOUB: ! 890: retv = pnewdoub(); ! 891: retv->r = handy->r; ! 892: return(retv); ! 893: ! 894: case HUNK2: ! 895: i = 0; ! 896: goto hunkit; ! 897: ! 898: case HUNK4: ! 899: i = 1; ! 900: goto hunkit; ! 901: ! 902: case HUNK8: ! 903: i = 2; ! 904: goto hunkit; ! 905: ! 906: case HUNK16: ! 907: i = 3; ! 908: goto hunkit; ! 909: ! 910: case HUNK32: ! 911: i = 4; ! 912: goto hunkit; ! 913: ! 914: case HUNK64: ! 915: i = 5; ! 916: goto hunkit; ! 917: ! 918: case HUNK128: ! 919: i = 6; ! 920: ! 921: hunkit: ! 922: retv = pnewhunk(i); ! 923: size = 2 << i ; /* number of elements to copy over */ ! 924: for( i = 0; i < size ; i++) ! 925: { ! 926: retv->h.hunk[i] = Ipurcopy(handy->h.hunk[i]); ! 927: } ! 928: return(retv); ! 929: ! 930: ! 931: ! 932: case STRNG: ! 933: #ifdef GCSTRINGS ! 934: { extern char purepage[]; ! 935: ! 936: if(purepage[((int)handy)>>9]==0) ! 937: return((lispval)pinewstr((char *)handy));} ! 938: ! 939: #endif ! 940: case ATOM: ! 941: case BCD: ! 942: case PORT: ! 943: return(handy); /* We don't want to purcopy these, yet ! 944: * it won't hurt if we don't mark them ! 945: * since they either aren't swept or ! 946: * will be marked in a special way ! 947: */ ! 948: case ARRAY: ! 949: error("purcopy: can't purcopy array structures",FALSE); ! 950: ! 951: default: ! 952: error(" bad type to purcopy ",FALSE); ! 953: /* NOTREACHED */ ! 954: } ! 955: } ! 956: ! 957: /* ! 958: * Lpurep returns t if the given arg is in pure space ! 959: */ ! 960: lispval ! 961: Lpurep() ! 962: { ! 963: lispval Ipurep(); ! 964: ! 965: chkarg(1,"purep"); ! 966: return(Ipurep(lbot->val)); ! 967: } ! 968: ! 969: ! 970: ! 971: /* vector functions */ ! 972: lispval newvec(), nveci(), Inewvector(); ! 973: ! 974: /* vector creation and initialization functions */ ! 975: lispval ! 976: Lnvec() ! 977: { ! 978: return(Inewvector(3)); ! 979: } ! 980: ! 981: lispval ! 982: Lnvecb() ! 983: { ! 984: return(Inewvector(0)); ! 985: } ! 986: ! 987: lispval ! 988: Lnvecw() ! 989: { ! 990: return(Inewvector(1)); ! 991: } ! 992: ! 993: lispval ! 994: Lnvecl() ! 995: { ! 996: return(Inewvector(2)); ! 997: } ! 998: ! 999: /* ! 1000: * (new-vector 'x_size ['g_fill] ['g_prop]) ! 1001: * class = 0: byte \ ! 1002: * = 1: word > immediate ! 1003: * = 2: long / ! 1004: * = 3: long ! 1005: */ ! 1006: lispval ! 1007: Inewvector(class) ! 1008: { ! 1009: register int i; ! 1010: register lispval handy; ! 1011: register lispval *handy2; ! 1012: char *chandy; ! 1013: short *whandy; ! 1014: long *lhandy; ! 1015: lispval sizearg, fillarg, proparg; ! 1016: int size, vsize; ! 1017: ! 1018: fillarg = proparg = nil; ! 1019: ! 1020: switch(np-lbot) { ! 1021: case 3: proparg = lbot[2].val; ! 1022: case 2: fillarg = lbot[1].val; ! 1023: case 1: sizearg = lbot[0].val; ! 1024: break; ! 1025: default: argerr("new-vector"); ! 1026: } ! 1027: ! 1028: while((TYPE(sizearg) != INT) || sizearg->i < 0) ! 1029: sizearg = errorh1(Vermisc,"new-vector: bad size for vector ",nil, ! 1030: TRUE,0,sizearg); ! 1031: size = sizearg->i; ! 1032: switch(class) ! 1033: { ! 1034: case 0: vsize = size * sizeof(char); ! 1035: break; ! 1036: case 1: vsize = size * sizeof(short); ! 1037: break; ! 1038: default: vsize = size * sizeof(long); ! 1039: break; ! 1040: } ! 1041: ! 1042: if(class != 3) handy = nveci(vsize); ! 1043: else handy = newvec(vsize); ! 1044: ! 1045: switch(class) ! 1046: { ! 1047: case 0: chandy = (char *)handy; ! 1048: for(i = 0 ; i < size ; i++) *chandy++ = (char) (fillarg->i); ! 1049: break; ! 1050: ! 1051: case 1: whandy = (short *)handy; ! 1052: for(i = 0 ; i < size ; i++) *whandy++ = (short) (fillarg->i); ! 1053: break; ! 1054: ! 1055: case 2: lhandy = (long *)handy; ! 1056: for(i = 0 ; i < size ; i++) *lhandy++ = (fillarg->i); ! 1057: break; ! 1058: ! 1059: case 3: handy2 = (lispval *)handy; ! 1060: for(i = 0 ; i < size ; i++) *handy2++ = fillarg; ! 1061: break; ! 1062: } ! 1063: handy->v.vector[-1] = proparg; ! 1064: return(handy); ! 1065: } ! 1066: ! 1067: lispval ! 1068: Lvectorp() ! 1069: { ! 1070: chkarg(1,"vectorp"); ! 1071: if(TYPE(lbot->val) == VECTOR) return(tatom); ! 1072: else return(nil); ! 1073: } ! 1074: ! 1075: lispval ! 1076: Lpvp() ! 1077: { ! 1078: chkarg(1,"vectorip"); ! 1079: if(TYPE(lbot->val) == VECTORI) return(tatom); ! 1080: else return(nil); ! 1081: } ! 1082: ! 1083: /* ! 1084: * int:vref vector[i] index class ! 1085: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long ! 1086: */ ! 1087: lispval ! 1088: LIvref() ! 1089: { ! 1090: register lispval vect; ! 1091: register int index; ! 1092: int class; ! 1093: ! 1094: chkarg(3,"int:vref"); ! 1095: vect = lbot[0].val; ! 1096: index = lbot[1].val->i; ! 1097: class = lbot[2].val->i; ! 1098: switch(class) ! 1099: { ! 1100: case 0: return(inewint(vect->vb.vectorb[index])); ! 1101: case 1: return(inewint(vect->vw.vectorw[index])); ! 1102: case 2: return(inewint(vect->vl.vectorl[index])); ! 1103: case 3: return(vect->v.vector[index]); ! 1104: } ! 1105: error("int:vref: impossible class detected",FALSE); ! 1106: /* NOTREACHED */ ! 1107: } ! 1108: ! 1109: /* ! 1110: * int:vset vector[i] index value class ! 1111: * class = 0: byte immed, 1: word immed, 2: long immed, 3: long ! 1112: */ ! 1113: lispval ! 1114: LIvset() ! 1115: { ! 1116: register lispval vect,value; ! 1117: register int index; ! 1118: int class; ! 1119: ! 1120: chkarg(4,"int:vset"); ! 1121: vect = lbot[0].val; ! 1122: index = lbot[1].val->i; ! 1123: value = lbot[2].val; ! 1124: class = lbot[3].val->i; ! 1125: switch(class) ! 1126: { ! 1127: case 0: vect->vb.vectorb[index] = (char)value->i; ! 1128: break; ! 1129: case 1: vect->vw.vectorw[index] = (short)value->i; ! 1130: break; ! 1131: case 2: vect->vl.vectorl[index] = value->i; ! 1132: break; ! 1133: case 3: vect->v.vector[index] = value; ! 1134: break; ! 1135: } ! 1136: return(value); ! 1137: } ! 1138: ! 1139: /* ! 1140: * LIvsize == (int:vsize 'vector 'x_shift) ! 1141: * return the vsize field of the vector shifted right by x_shift ! 1142: */ ! 1143: lispval ! 1144: LIvsize() ! 1145: { ! 1146: int typ; ! 1147: ! 1148: chkarg(2,"int:vsize"); ! 1149: return(inewint((lbot[0].val->vl.vectorl[VSizeOff]) >> lbot[1].val->i)); ! 1150: } ! 1151: ! 1152: lispval ! 1153: Lvprop() ! 1154: { ! 1155: int typ; ! 1156: chkarg(1,"vprop"); ! 1157: ! 1158: if(((typ = TYPE(lbot->val)) != VECTOR) && (typ != VECTORI)) ! 1159: errorh1(Vermisc,"vprop: non vector argument: ", nil, FALSE,0, ! 1160: lbot->val); ! 1161: return(lbot[0].val->v.vector[VPropOff]); ! 1162: } ! 1163: ! 1164: ! 1165: lispval ! 1166: Lvsp() ! 1167: { ! 1168: int typ; ! 1169: lispval vector, property; ! 1170: chkarg(2,"vsetprop"); ! 1171: ! 1172: vector = lbot->val; ! 1173: property = lbot[1].val; ! 1174: typ = TYPE(vector); ! 1175: ! 1176: if(typ != VECTOR && typ !=VECTORI) ! 1177: errorh1(Vermisc,"vsetprop: non vector argument: ", ! 1178: nil,FALSE,0,vector); ! 1179: vector->v.vector[VPropOff] = property; ! 1180: return(property); ! 1181: } ! 1182: ! 1183: ! 1184: /* vecequal ! 1185: * check if the two vector arguments are 'equal' ! 1186: * this is called by equal which has already checked that ! 1187: * the arguments are vector ! 1188: */ ! 1189: vecequal(v,w) ! 1190: lispval v,w; ! 1191: { ! 1192: int i; ! 1193: lispval vv, ww, ret; ! 1194: int vsize = (int) v->v.vector[VSizeOff]; ! 1195: int wsize = (int) w->v.vector[VSizeOff]; ! 1196: struct argent *oldlbot = lbot; ! 1197: lispval Lequal(); ! 1198: ! 1199: if(vsize != wsize) return(FALSE); ! 1200: ! 1201: vsize /= sizeof(int); /* determine number of entries */ ! 1202: ! 1203: for(i = 0 ; i < vsize ; i++) ! 1204: { ! 1205: vv = v->v.vector[i]; ! 1206: ww = w->v.vector[i]; ! 1207: /* avoid calling equal if they are eq */ ! 1208: if(vv != ww) ! 1209: { ! 1210: lbot = np; ! 1211: protect(vv); ! 1212: protect(ww); ! 1213: ret = Lequal(); ! 1214: np = lbot; ! 1215: lbot = oldlbot; ! 1216: if(ret == nil) return(FALSE); ! 1217: } ! 1218: } ! 1219: return(TRUE); ! 1220: } ! 1221: ! 1222: /* veciequal ! 1223: * check if the two vectori arguments are 'equal' ! 1224: * this is called by equal which has already checked that ! 1225: * the arguments are vector ! 1226: * Note: this would run faster if we did as many 'longword' ! 1227: * comparisons as possible and then did byte comparisons. ! 1228: * or if we used pointers instead of indexing. ! 1229: */ ! 1230: veciequal(v,w) ! 1231: lispval v,w; ! 1232: { ! 1233: char vv, ww; ! 1234: int i; ! 1235: int vsize = (int) v->v.vector[VSizeOff]; ! 1236: int wsize = (int) w->v.vector[VSizeOff]; ! 1237: ! 1238: if(vsize != wsize) return(FALSE); ! 1239: ! 1240: ! 1241: for(i = 0 ; i < vsize ; i++) ! 1242: { ! 1243: if(v->vb.vectorb[i] != w->vb.vectorb[i]) return(FALSE); ! 1244: } ! 1245: return(TRUE); ! 1246: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.