![[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] / 40BSD / cmd / lisp|
Return to lam8.c CVS log | Up to [CSRG BSD Unix] / 40BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)lam8.c 34.5 11/7/80"; ! 2: ! 3: #include "global.h" ! 4: #include <sys/types.h> ! 5: #include <pagsiz.h> ! 6: #include "naout.h" ! 7: ! 8: /* various functions from the c math library */ ! 9: double sin(),cos(),asin(),acos(),atan2(),sqrt(), log(), exp(); ! 10: extern int current; ! 11: ! 12: lispval Imath(func) ! 13: double (*func)(); ! 14: { ! 15: register lispval handy; ! 16: register double res; ! 17: chkarg(1,"Math functions"); ! 18: ! 19: switch(TYPE(handy=lbot->val)) { ! 20: case INT: res = func((double)handy->i); ! 21: break; ! 22: ! 23: case DOUB: res = func(handy->r); ! 24: break; ! 25: ! 26: default: error("Non fixnum or flonum to math function",FALSE); ! 27: } ! 28: handy = newdoub(); ! 29: handy->r = res; ! 30: return(handy); ! 31: } ! 32: lispval Lsin() ! 33: { ! 34: return(Imath(sin)); ! 35: } ! 36: ! 37: lispval Lcos() ! 38: { ! 39: return(Imath(cos)); ! 40: } ! 41: ! 42: lispval Lasin() ! 43: { ! 44: return(Imath(asin)); ! 45: } ! 46: ! 47: lispval Lacos() ! 48: { ! 49: return(Imath(acos)); ! 50: } ! 51: ! 52: lispval Lsqrt() ! 53: { ! 54: return(Imath(sqrt)); ! 55: } ! 56: lispval Lexp() ! 57: { ! 58: return(Imath(exp)); ! 59: } ! 60: ! 61: lispval Llog() ! 62: { ! 63: return(Imath(log)); ! 64: } ! 65: ! 66: /* although we call this atan, it is really atan2 to the c-world, ! 67: that is, it takes two args ! 68: */ ! 69: lispval Latan() ! 70: { ! 71: register lispval arg; ! 72: register double arg1v; ! 73: register double res; ! 74: chkarg(2,"arctan"); ! 75: ! 76: switch(TYPE(arg=lbot->val)) { ! 77: ! 78: case INT: arg1v = (double) arg->i; ! 79: break; ! 80: ! 81: case DOUB: arg1v = arg->r; ! 82: break; ! 83: ! 84: default: error("Non fixnum or flonum arg to atan2",FALSE); ! 85: } ! 86: ! 87: switch(TYPE(arg = (lbot+1)->val)) { ! 88: ! 89: case INT: res = atan2(arg1v,(double) arg->i); ! 90: break; ! 91: ! 92: case DOUB: res = atan2(arg1v, arg->r); ! 93: break; ! 94: ! 95: default: error("Non fixnum or flonum to atan2",FALSE); ! 96: } ! 97: arg = newdoub(); ! 98: arg->r = res; ! 99: return(arg); ! 100: } ! 101: ! 102: /* (random) returns a fixnum in the range -2**30 to 2**30 -1 ! 103: (random fixnum) returns a fixnum in the range 0 to fixnum-1 ! 104: */ ! 105: lispval ! 106: Lrandom() ! 107: { ! 108: register int curval; ! 109: float pow(); ! 110: ! 111: curval = rand(); /* get numb from 0 to 2**31-1 */ ! 112: ! 113: if(np==lbot) return(inewint(curval-(int)pow((double)2,(double)30))); ! 114: ! 115: if((TYPE(lbot->val) != INT) ! 116: || (lbot->val->i <= 0)) errorh(Vermisc,"random: non fixnum arg:", ! 117: nil, FALSE, 0, lbot->val); ! 118: ! 119: return(inewint(curval % lbot->val->i )); ! 120: ! 121: } ! 122: lispval ! 123: Lmakunb() ! 124: { ! 125: register lispval work; ! 126: ! 127: chkarg(1,"makunbound"); ! 128: work = lbot->val; ! 129: if(work==nil || (TYPE(work)!=ATOM)) ! 130: return(work); ! 131: work->a.clb = CNIL; ! 132: return(work); ! 133: } ! 134: lispval ! 135: Lpolyev() ! 136: { ! 137: register int count; ! 138: register double *handy, *base; ! 139: register struct argent *argp, *lbot, *np; ! 140: lispval result; int type; ! 141: ! 142: count = 2 * (((int) np) - (int) lbot); ! 143: if(count == 0) ! 144: return(inewint(0)); ! 145: if(count == 8) ! 146: return(lbot->val); ! 147: base = handy = (double *) alloca(count); ! 148: for(argp = lbot; argp < np; argp++) { ! 149: while((type = TYPE(argp->val))!=DOUB && type!=INT) ! 150: argp->val = (lispval) errorh(Vermisc,"%%machine-polyev:non-real arg",nil,TRUE,73,lbot,argp->val); ! 151: if(TYPE(argp->val)==INT) { ! 152: *handy++ = argp->val->i; ! 153: } else ! 154: *handy++ = argp->val->r; ! 155: } ! 156: count = count/sizeof(double) - 2; ! 157: asm("polyd (r9),r11,8(r9)"); ! 158: asm("movd r0,(r9)"); ! 159: result = newdoub(); ! 160: result->r = *base; ! 161: return(result); ! 162: } ! 163: typedef struct doub { ! 164: unsigned short f1:7,expt:8,sign:1; ! 165: unsigned short f2,f3p1:14,f3p2:2,f4; ! 166: } *dp; ! 167: ! 168: typedef struct quad2 { ! 169: unsigned long g4:16,g3p1:14; ! 170: } *qp2; ! 171: ! 172: typedef struct quad1 { ! 173: unsigned long g3p2:2,g2:16,g1:7,hide:1; ! 174: } *qp1; ! 175: ! 176: static long workbuf[2]; ! 177: static int exponent; ! 178: static Idebig() ! 179: { ! 180: register lispval work; ! 181: register dp rdp; ! 182: register qp1 rqp1; ! 183: register qp2 rqp2; ! 184: register struct argent *lbot,np; ! 185: workbuf[1] = workbuf[0] = 0; ! 186: ! 187: work = lbot->val; /* Unfold mantissa */ ! 188: rqp2 = (qp2) workbuf + 1; ! 189: rqp1 = (qp1) workbuf; ! 190: rdp = (dp) work; ! 191: rqp2->g4 = rdp->f4; ! 192: rqp2->g3p1 = rdp->f3p1; ! 193: rqp1->g3p2 = rdp->f3p2; ! 194: rqp1->g2 = rdp->f2; ! 195: rqp1->g1 = rdp->f1; ! 196: rqp1->hide = 1; ! 197: if(rdp->sign) { ! 198: workbuf[0] = (- workbuf[0]); ! 199: if(workbuf[1] = (- workbuf[1]) & 0xC0000000) ! 200: workbuf[0]--; ! 201: } ! 202: /* calcuate exponent and adjustment */ ! 203: exponent = -129 - 55 + (int) rdp->expt; ! 204: } ! 205: lispval ! 206: Lfdecom() ! 207: { ! 208: register lispval result, handy; ! 209: register dum1,dum2; ! 210: register struct argent *lbot,*np; ! 211: ! 212: chkarg(1,"Decompose-float"); ! 213: while(TYPE(lbot->val)!=DOUB) ! 214: lbot->val = error("Decompose-float: Non-real argument",TRUE); ! 215: Idebig(); ! 216: np++->val = result = handy = newdot(); ! 217: handy->d.car = inewint(exponent); ! 218: handy = handy->d.cdr = newdot(); ! 219: handy = handy->d.car = newsdot(); ! 220: handy->s.I = workbuf[1]; ! 221: handy = handy->s.CDR = newsdot(); ! 222: handy->s.I = workbuf[0]; ! 223: } ! 224: ! 225: lispval ! 226: Lfseek() ! 227: { ! 228: register lispval result, handy; ! 229: register dum1,dum2; ! 230: register struct argent *lbot,*np; ! 231: ! 232: FILE *f; ! 233: long disk_addr, offset, whence; ! 234: lispval retp; ! 235: ! 236: chkarg(3,"fseek"); /* Make sure there are three arguments*/ ! 237: ! 238: f = lbot->val->p; /* Get first argument into f */ ! 239: if (TYPE(lbot->val)!=PORT) /* Check type of first */ ! 240: error("fseek: First argument must be a port.",FALSE); ! 241: ! 242: offset = lbot[1].val->i; /* Get second argument */ ! 243: if (TYPE(lbot[1].val)!=INT) ! 244: error("fseek: Second argument must be an integer.",FALSE); ! 245: ! 246: whence = lbot[2].val->i; /* Get last arg */ ! 247: if (TYPE(lbot[2].val)!=INT) ! 248: error("fseek: Third argument must be an integer.",FALSE); ! 249: ! 250: if (fseek(f, offset, whence) == -1) ! 251: error("fseek: Illegal parameters.",FALSE); ! 252: ! 253: retp = inewint(ftell(f)); ! 254: ! 255: return((lispval) retp); ! 256: } ! 257: ! 258: /* function hashtabstat : return list of number of members in each bucket */ ! 259: lispval Lhashst() ! 260: { ! 261: register lispval handy,cur; ! 262: register struct atom *pnt; ! 263: int i,cnt; ! 264: extern int hashtop; ! 265: snpand(3); ! 266: ! 267: handy = newdot(); ! 268: protect(handy); ! 269: cur = handy; ! 270: for(i = 0; i < hashtop; i++) ! 271: { ! 272: pnt = hasht[i]; ! 273: for(cnt = 0; pnt != (struct atom *) CNIL ; pnt=pnt->hshlnk , cnt++); ! 274: cur->d.cdr = newdot(); ! 275: cur = cur->d.cdr; ! 276: cur->d.car = inewint(cnt); ! 277: } ! 278: cur->d.cdr = nil; ! 279: return(handy->d.cdr); ! 280: } ! 281: ! 282: ! 283: /* Lctcherr ! 284: this routine should only be called by the unwind protect simulation ! 285: lisp code ! 286: It is called after an unwind-protect frame has been entered and ! 287: evalated and we want to get on with the error or throw ! 288: We only handle the case where there are 0 to 2 extra arguments to the ! 289: error call. ! 290: */ ! 291: lispval ! 292: Lctcherr() ! 293: { ! 294: register lispval handy; ! 295: lispval type,messg,valret,contuab,uniqid,datum1,datum2; ! 296: snpand(1); ! 297: ! 298: if(lbot-np==0) protect(nil); ! 299: if((handy = lbot->val) == nil) return(nil); ! 300: ! 301: if(handy->d.car == tatom) ! 302: { /* continuaing a throw */ ! 303: Idothrow(handy->d.cdr->d.car, handy->d.cdr->d.cdr->d.car); ! 304: error("ctcherr: throw label gone!",FALSE); ! 305: } ! 306: ! 307: /* decode the arg list */ ! 308: handy = handy->d.cdr; ! 309: type = handy->d.car; ! 310: handy = handy->d.cdr; ! 311: messg = handy->d.car; ! 312: handy = handy->d.cdr; ! 313: valret = handy->d.car; ! 314: handy = handy->d.cdr; ! 315: contuab = handy->d.car; ! 316: handy = handy->d.cdr; ! 317: uniqid = handy->d.car; ! 318: handy = handy->d.cdr; ! 319: ! 320: /* if not extra args */ ! 321: if(handy == nil) ! 322: { ! 323: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i); ! 324: } ! 325: datum1 = handy->d.car; ! 326: handy = handy->d.cdr; ! 327: ! 328: /* if one extra arg */ ! 329: if(handy == nil) ! 330: { ! 331: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1); ! 332: } ! 333: ! 334: /* if two or more extra args, just use first 2 */ ! 335: datum2 = handy->d.car; ! 336: errorh(type,messg->a.pname,valret,contuab->i,uniqid->i,datum1,datum2); ! 337: } ! 338: ! 339: /* ! 340: * (*makhunk '<fixnum>) ! 341: * <fixnum> ! 342: * Create a hunk of size 2 . <fixnum> must be between 0 and 6. ! 343: * ! 344: */ ! 345: ! 346: lispval ! 347: LMakhunk() ! 348: { ! 349: register int hsize, hcntr; ! 350: register lispval result; ! 351: ! 352: chkarg(1,"Makehunk"); ! 353: if (TYPE(lbot->val)==INT) ! 354: { ! 355: hsize = lbot->val->i; /* size of hunk (0-6) */ ! 356: if ((hsize >= 0) && (hsize <= 6)) ! 357: { ! 358: result = newhunk(hsize); ! 359: hsize = 2 << hsize; /* size of hunk (2-128) */ ! 360: for (hcntr = 0; hcntr < hsize; hcntr++) ! 361: result->h.hunk[hcntr] = hunkfree; ! 362: } ! 363: else ! 364: error("*makhunk: Illegal hunk size", FALSE); ! 365: return(result); ! 366: } ! 367: else ! 368: error("*makhunk: First arg must be an fixnum",FALSE); ! 369: } ! 370: ! 371: /* ! 372: * (cxr '<fixnum> '<hunk>) ! 373: * Returns the <fixnum>'th element of <hunk> ! 374: * ! 375: */ ! 376: lispval ! 377: Lcxr() ! 378: { ! 379: register lispval temp; ! 380: ! 381: chkarg(2,"cxr"); ! 382: if (TYPE(lbot->val)!=INT) ! 383: error("cxr: First arg must be a fixnum", FALSE); ! 384: else ! 385: { ! 386: if (! HUNKP(lbot[1].val)) ! 387: error("cxr: Second arg must be a hunk", FALSE); ! 388: else ! 389: if ( (lbot->val->i >= 0) && ! 390: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) ) ! 391: { ! 392: temp = lbot[1].val->h.hunk[lbot->val->i]; ! 393: if (temp != hunkfree) ! 394: return(temp); ! 395: else ! 396: error("cxr: Arg outside of hunk range", ! 397: FALSE); ! 398: } ! 399: else ! 400: error("cxr: Arg outside of hunk range", FALSE); ! 401: } ! 402: } ! 403: ! 404: /* ! 405: * (rplacx '<fixnum> '<hunk> '<expr>) ! 406: * Replaces the <fixnum>'th element of <hunk> with <expr>. ! 407: * ! 408: */ ! 409: lispval ! 410: Lrplacx() ! 411: { ! 412: lispval *handy; ! 413: chkarg(3,"rplacx"); ! 414: if (TYPE(lbot->val)!=INT) ! 415: error("rplacx: First arg must be a fixnum", FALSE); ! 416: else ! 417: { ! 418: if (! HUNKP(lbot[1].val)) ! 419: error("rplacx: Second arg must be a hunk", FALSE); ! 420: else ! 421: { ! 422: if ( (lbot->val->i >= 0) && ! 423: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) ) ! 424: { ! 425: if (*(handy = &(lbot[1].val->h.hunk[lbot->val->i])) ! 426: != hunkfree) ! 427: *handy = lbot[2].val; ! 428: else ! 429: error("rplacx: Arg outside hunk range", FALSE); ! 430: } ! 431: else ! 432: error("rplacx: Arg outside hunk range", FALSE); ! 433: } ! 434: } ! 435: return(lbot[1].val); ! 436: } ! 437: ! 438: /* ! 439: * (*rplacx '<fixnum> '<hunk> '<expr>) ! 440: * Replaces the <fixnum>'th element of <hunk> with <expr>. This is the ! 441: * same as (rplacx ...) except with this function you can replace EMPTY's. ! 442: * ! 443: */ ! 444: lispval ! 445: Lstarrpx() ! 446: { ! 447: chkarg(3,"*rplacx"); ! 448: if (TYPE(lbot->val)!=INT) ! 449: error("*rplacx: First arg must be a fixnum", FALSE); ! 450: else ! 451: { ! 452: if (! HUNKP(lbot[1].val)) ! 453: error("*rplacx: Second arg must be a hunk", FALSE); ! 454: else ! 455: { ! 456: if ( (lbot->val->i >= 0) && ! 457: (lbot->val->i < (2 << HUNKSIZE(lbot[1].val))) ) ! 458: lbot[1].val->h.hunk[lbot->val->i] = lbot[2].val; ! 459: else ! 460: error("*rplacx: Arg outside hunk range", FALSE); ! 461: } ! 462: } ! 463: return(lbot[1].val); ! 464: } ! 465: ! 466: /* ! 467: * (hunksize '<hunk>) ! 468: * Returns the size of <hunk> ! 469: * ! 470: */ ! 471: lispval ! 472: Lhunksize() ! 473: { ! 474: register int size,i; ! 475: ! 476: chkarg(1,"hunksize"); ! 477: if (HUNKP(lbot->val)) ! 478: { ! 479: size = 2 << HUNKSIZE(lbot->val); ! 480: for (i = size-1; i >= 0; i--) ! 481: { ! 482: if (lbot->val->h.hunk[i] != hunkfree) ! 483: { ! 484: size = i + 1; ! 485: break; ! 486: } ! 487: } ! 488: return( inewint(size) ); ! 489: } ! 490: else ! 491: error("hunksize: First argument must me a hunk", FALSE); ! 492: } ! 493: ! 494: /* ! 495: * (fileopen filename mode) ! 496: * open a file for read, write, or append the arguments can be either ! 497: * strings or atoms. ! 498: */ ! 499: lispval ! 500: Lfileopen() ! 501: { ! 502: FILE *port; ! 503: register lispval name; ! 504: register lispval mode; ! 505: register char *namech; ! 506: register char *modech; ! 507: register struct argent *lbot, *np; ! 508: int typ; ! 509: ! 510: chkarg(2,"fileopen"); ! 511: name = lbot->val; ! 512: mode = lbot[1].val; ! 513: ! 514: namech = (char *) verify(name,"fileopen:args must be atoms or strings"); ! 515: modech = (char *) verify(mode,"fileopen:args must be atoms or strings"); ! 516: ! 517: while (modech[0] != 'r' && modech[0] != 'w' && modech[0] != 'a') ! 518: { ! 519: mode = errorh(Vermisc,"Modes are only r, w, a.",nil,TRUE,31,(char *) 0); ! 520: modech = (char *) verify(mode,"fileopen:args must be atoms or strings"); ! 521: } ! 522: ! 523: while ((port = fopen(namech, modech)) == NULL) ! 524: { ! 525: name = errorh(Vermisc,"Unable to open file.",nil,TRUE,31,name); ! 526: namech = (char *) verify(name,"fileopen:args must be atoms or strings"); ! 527: } ! 528: /* xports is a FILE *, cc complains about adding pointers */ ! 529: ! 530: return( (lispval) (xports + (port - _iob))); ! 531: } ! 532: ! 533: /* ! 534: * (*mod '<number> '<modulus>) ! 535: * This function returns <number> mod <modulus> (for balanced modulus). ! 536: * It is used in vaxima as a speed enhancement. ! 537: */ ! 538: lispval ! 539: LstarMod() ! 540: { ! 541: register int mod_div_2, number, modulus; ! 542: ! 543: chkarg(2,"*mod"); ! 544: if ((TYPE(lbot->val) == INT) && (TYPE(lbot[1].val) == INT)) ! 545: { ! 546: modulus = lbot[1].val->i; ! 547: number = lbot->val->i % modulus; ! 548: mod_div_2 = modulus / 2; ! 549: if (number < 0) ! 550: { ! 551: if (number < (-mod_div_2)) ! 552: number += modulus; ! 553: } ! 554: else ! 555: { ! 556: if (number > mod_div_2) ! 557: number -= modulus; ! 558: } ! 559: return( inewint(number) ); ! 560: } ! 561: else ! 562: error("*mod: Arguments must be fixnums", FALSE); ! 563: } ! 564: lispval ! 565: Llsh() ! 566: { ! 567: register struct argent *mylbot = lbot; ! 568: int val,shift; ! 569: ! 570: chkarg(2,"lsh"); ! 571: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT)) ! 572: errorh(Vermisc, ! 573: "Non ints to lsh", ! 574: nil,FALSE,0,mylbot->val,mylbot[1].val); ! 575: val = mylbot[0].val->i; ! 576: shift = mylbot[1].val->i; ! 577: if(shift < -32 || shift > 32) ! 578: return(inewint(0)); ! 579: val = val << shift; /* do the shift */ ! 580: if((val < 0) && (shift < 0)) ! 581: { /* special case: the vax doesn't have a logical shift ! 582: instruction, so we must zero out the ones which ! 583: will propogate from the sign position ! 584: */ ! 585: return(inewint ( val & ~(0x80000000 << (shift+1)))); ! 586: } ! 587: else return( inewint(val)); ! 588: } ! 589: ! 590: lispval ! 591: Lrot() ! 592: { ! 593: register rot,val; /* these must be the first registers */ ! 594: register struct argent *mylbot = lbot; ! 595: ! 596: chkarg(2,"rot"); ! 597: if((TYPE(mylbot->val) != INT) || (TYPE(mylbot[1].val) != INT)) ! 598: errorh(Vermisc, ! 599: "Non ints to rot", ! 600: nil,FALSE,0,mylbot->val,mylbot[1].val); ! 601: val = mylbot[0].val->i; ! 602: rot = mylbot[1].val->i; ! 603: rot = rot % 32 ; /* bring it down below one byte in size */ ! 604: asm(" rotl r11,r10,r10 "); /* rotate val by rot and put back in val */ ! 605: return( inewint(val)); ! 606: } ! 607: ! 608: /*----------------- vms routines to simulate dumplisp -------------------- */ ! 609: #ifdef VMS ! 610: ! 611: extern char firstalloc[]; ! 612: extern int lsbrkpnt; ! 613: extern char zfreespace[]; ! 614: extern int end; ! 615: ! 616: #define roundup(a,b) (((a-1)|(b-1))+1) ! 617: lispval ! 618: Lsavelsp() ! 619: { ! 620: char *filnm; ! 621: int fp,i,num,start; ! 622: ! 623: chkarg(1,"savelisp"); ! 624: ! 625: filnm = (char *) verify(lbot->val, "savelisp: non atom arg"); ! 626: if((fp=creat(filnm,0666)) < 0) ! 627: errorh(Vermisc,"savelisp: can't open file",nil,FALSE,0, ! 628: lbot->val); ! 629: start = roundup((int)firstalloc,PAGSIZ); ! 630: num = roundup(((int)lsbrkpnt)-NBPG-start,PAGSIZ); ! 631: if((num = write(fp,start,num)) <= 0) ! 632: error("savelisp: write failed ",FALSE); ! 633: printf(" %x bytes written from %x to %x \n",num,start,start+num-1); ! 634: close(fp); ! 635: return(tatom); ! 636: } ! 637: ! 638: lispval ! 639: Lrestlsp() ! 640: { ! 641: char *filnm; ! 642: int fp,i,num,start; ! 643: extern int xcycle; ! 644: ! 645: chkarg(1,"restorelisp"); ! 646: ! 647: filnm = (char *) verify(lbot->val,"restorelisp: non atom arg"); ! 648: if((fp=open(filnm,0)) < 0) ! 649: errorh(Vermisc,"restorelisp: can't open file",nil,FALSE,0, ! 650: lbot->val); ! 651: ! 652: start = roundup((int)firstalloc,PAGSIZ); ! 653: if((num = vread(fp,start,((int)&end)-start)) <= 0) ! 654: error("restorelisp: read failed " ,FALSE); ! 655: printf(" %x bytes read into %x to %x\n",num,start,start+num-1); ! 656: xcycle = 0; /* indicate no saved pages to xsbrk */ ! 657: close(fp); ! 658: bnp = orgbnp; ! 659: lbot = np = orgnp; ! 660: contval = 0; ! 661: reset(BRRETB); /* reset */ ! 662: } ! 663: #endif ! 664: ! 665: /*----------------------------------------------------------- */ ! 666: ! 667: ! 668: /* getaddress -- ! 669: * ! 670: * (getaddress '|_entry1| 'fncname1 '|_entry2| 'fncname2 ...) ! 671: * ! 672: * binds value of symbol |_entry1| to function defition of atom fncname1, etc. ! 673: * ! 674: * returns fnc-binding of fncname1. ! 675: * ! 676: */ ! 677: ! 678: lispval ! 679: Lgetaddress(){ ! 680: register struct argent *mlbot = lbot; ! 681: register lispval work; ! 682: register int numberofargs, i; ! 683: register struct argent *lbot, *np; ! 684: char *gstab(); ! 685: char ostabf[128]; ! 686: struct nlist NTABLE[100]; ! 687: lispval dispget(); ! 688: ! 689: snpand(2); ! 690: ! 691: if(np-lbot == 2) protect(nil); /* allow 2 args */ ! 692: numberofargs = (np - lbot)/3; ! 693: if(numberofargs * 3 != np-lbot) ! 694: error("getaddress: arguments must come in triples ",FALSE); ! 695: ! 696: for ( i=0; i<numberofargs; i++,mlbot += 3) { ! 697: NTABLE[i].n_value = 0; ! 698: mlbot[0].val = verify(mlbot[0].val,"Incorrect entry specification for binding"); ! 699: NTABLE[i].n_un.n_name = (char *) mlbot[0].val; ! 700: while(TYPE(mlbot[1].val) != ATOM) ! 701: mlbot[1].val = errorh(Vermisc, ! 702: "Bad associated atom name for binding", ! 703: nil,TRUE,0,mlbot[1].val); ! 704: mlbot[2].val = dispget(mlbot[2].val,"getaddress: Incorrect discipline specification ",Vsubrou->a.pname); ! 705: } ! 706: NTABLE[(numberofargs)].n_un.n_name = ""; ! 707: strcpyn(ostabf,gstab(),128); ! 708: if ( nlist(ostabf,NTABLE) == -1 ) { ! 709: errorh(Vermisc,"Getaddress: Bad file",nil,FALSE,0,inewstr(ostabf)); ! 710: } else ! 711: for (i=0,mlbot=lbot+1; i<numberofargs; i++,mlbot+=3) { ! 712: if ( NTABLE[i].n_value == 0 ) ! 713: fprintf(stderr,"Undefined symbol: %s\n", ! 714: NTABLE[i].n_un.n_name); ! 715: else { ! 716: work= newfunct(); ! 717: work->bcd.entry = (lispval (*) ())NTABLE[i].n_value; ! 718: work->bcd.discipline = mlbot[1].val; ! 719: mlbot->val->a.fnbnd = work; ! 720: } ! 721: }; ! 722: return(lbot[1].val->a.fnbnd); ! 723: }; ! 724: ! 725: /* very temporary function to test the validity of the bind stack */ ! 726: ! 727: bndchk() ! 728: { ! 729: register struct nament *npt; ! 730: register lispval in2; ! 731: ! 732: in2 = inewint(200); ! 733: for(npt=orgbnp; npt < bnp; npt++) ! 734: { if((int) npt->atm < (int) in2) asm(" halt "); ! 735: } ! 736: } ! 737: ! 738: /* ! 739: * formatted printer for lisp data ! 740: * use: (cprintf formatstring datum [port]) ! 741: */ ! 742: lispval ! 743: Lcprintf() ! 744: { ! 745: FILE *p; ! 746: char *fstrng; ! 747: lispval v; ! 748: if(np-lbot == 2) protect(nil); /* write to standard output port */ ! 749: chkarg(3,"cprintf"); ! 750: ! 751: fstrng = (char *)verify(lbot->val,"cprintf: first arg not string or symbol"); ! 752: ! 753: p = okport(lbot[2].val,okport(Vpoport->a.clb,poport)); ! 754: ! 755: switch(TYPE(v=lbot[1].val)) { ! 756: ! 757: case INT: fprintf(p,fstrng,v->i); ! 758: break; ! 759: ! 760: case DOUB: fprintf(p,fstrng,v->r); ! 761: break; ! 762: ! 763: case ATOM: fprintf(p,fstrng,v->a.pname); ! 764: break; ! 765: ! 766: case STRNG:fprintf(p,fstrng,v); ! 767: break; ! 768: ! 769: default: error("cprintf: Illegal second argument",FALSE); ! 770: }; ! 771: ! 772: return(lbot[1].val); ! 773: } ! 774: ! 775: lispval ! 776: Lprobef() ! 777: { ! 778: char *name; ! 779: chkarg(1,"probef"); ! 780: ! 781: name = (char *)verify(lbot->val,"probef: not symbol or string arg "); ! 782: ! 783: if(access(name,0) == 0) return(tatom); ! 784: else return(nil); ! 785: } ! 786: ! 787: lispval ! 788: Lsubstring() ! 789: { register char *name; ! 790: register lispval index,length; ! 791: int restofstring = FALSE; ! 792: int len,ind,reallen; ! 793: extern char strbuf[]; ! 794: ! 795: switch (np-lbot) ! 796: { ! 797: case 2: restofstring = TRUE; ! 798: break; ! 799: ! 800: case 3: break; ! 801: ! 802: default: chkarg(3,"substring"); ! 803: } ! 804: ! 805: name = (char *)verify(lbot[0].val,"substring: not symbol or string arg "); ! 806: ! 807: while (TYPE(index = lbot[1].val) != INT) ! 808: { lbot[1].val = errorh(Vermisc,"substring: non integer index ",nil, ! 809: TRUE,0,index); ! 810: } ! 811: ! 812: len = strlen(name); ! 813: ind = index->i; ! 814: ! 815: if(ind < 0) ind = len+1 + ind; ! 816: ! 817: if(ind < 1 || ind > len) return(nil); /*index out of bounds*/ ! 818: if(restofstring) return((lispval)inewstr(name+ind-1)); ! 819: ! 820: while (TYPE(length = lbot[2].val) != INT) ! 821: { lbot[2].val = errorh(Vermisc,"substring: not integer length ",nil, ! 822: TRUE,0,length); ! 823: } ! 824: ! 825: if((reallen = length->i ) < 0 || (reallen + ind) > len) ! 826: return((lispval)inewstr(name+ind-1)); ! 827: ! 828: strncpy(strbuf,name+ind-1,reallen); ! 829: strbuf[reallen] = '\0'; ! 830: return((lispval)newstr()); ! 831: } ! 832: ! 833: lispval ! 834: Lsubstringn() ! 835: { ! 836: register char *name; ! 837: register int len,ind,reallen; ! 838: lispval index,length; ! 839: int restofstring = FALSE; ! 840: snpand(4); ! 841: ! 842: if((np-lbot) == 2) restofstring = TRUE; ! 843: else { chkarg(3,"substringn");} ! 844: ! 845: name = (char *) verify(lbot[0].val,"substringn: non symbol or string arg "); ! 846: ! 847: while (TYPE(index = lbot[1].val) != INT) ! 848: { lbot[1].val = errorh(Vermisc,"substringn: non integer index ",nil, ! 849: TRUE,0,index); ! 850: } ! 851: ! 852: if(!restofstring) ! 853: { ! 854: while (TYPE(length = lbot[2].val) != INT) ! 855: { lbot[2].val = errorh(Vermisc,"substringn: not integer length ", ! 856: nil, TRUE,0,length); ! 857: } ! 858: reallen = length->i; ! 859: } ! 860: else reallen = -1; ! 861: ! 862: len = strlen(name); ! 863: ind = index->i; ! 864: if(ind < 0) ind = len + 1 + ind; ! 865: if( ind < 1 || ind > len) return(nil); ! 866: ! 867: if(reallen == 0) ! 868: return((lispval)inewint(*(name + ind - 1))); ! 869: else { ! 870: char *pnt = name + ind - 1; ! 871: char *last = name + len -1; ! 872: lispval cur,start; ! 873: ! 874: protect(cur = start = newdot()); ! 875: cur->d.car = inewint(*pnt); ! 876: while(++pnt <= last && --reallen != 0) ! 877: { ! 878: cur->d.cdr = newdot(); ! 879: cur = cur->d.cdr; ! 880: cur->d.car = inewint(*pnt); ! 881: } ! 882: return(start); ! 883: } ! 884: ! 885: } ! 886:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.