![[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] / 43BSD / ucb / lisp / franz|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 ! root 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: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.