![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lamr.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 lamr.c CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: lamr.c 1.2 83/06/04 02:15:48 sklower Exp $"; ! 4: #endif ! 5: ! 6: /* -[Sat Jan 29 13:09:59 1983 by jkf]- ! 7: * lamr.c $Locker: $ ! 8: * lambda functions ! 9: * ! 10: * (c) copyright 1982, Regents of the University of California ! 11: */ ! 12: ! 13: # include "global.h" ! 14: ! 15: /* ! 16: * ! 17: * Lalloc ! 18: * ! 19: * This lambda allows allocation of pages from lisp. The first ! 20: * argument is the name of a space, n pages of which are allocated, ! 21: * if possible. Returns the number of pages allocated. ! 22: */ ! 23: ! 24: lispval ! 25: Lalloc() ! 26: { ! 27: long n; ! 28: chkarg(2,"alloc"); ! 29: if(TYPE((lbot+1)->val) != INT && (lbot+1)->val != nil ) ! 30: error("2nd argument to allocate must be an integer",FALSE); ! 31: n = 1; ! 32: if((lbot+1)->val != nil) n = (lbot+1)->val->i; ! 33: return(alloc((lbot)->val,n)); /* call alloc to do the work */ ! 34: } ! 35: ! 36: lispval ! 37: Lsizeof() ! 38: { ! 39: chkarg(1,"sizeof"); ! 40: return(inewint(csizeof(lbot->val))); ! 41: } ! 42: ! 43: lispval ! 44: Lsegment() ! 45: { ! 46: chkarg(2,"segment"); ! 47: chek: while(TYPE(np[-1].val) != INT ) ! 48: np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE); ! 49: if( np[-1].val->i < 0 ) ! 50: { ! 51: np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE); ! 52: goto chek; ! 53: } ! 54: return(csegment(typenum((lbot)->val),(int)(np[-1].val->i),FALSE)); ! 55: } ! 56: ! 57: /* Lforget *************************************************************/ ! 58: /* */ ! 59: /* This function removes an atom from the hash table. */ ! 60: ! 61: lispval ! 62: Lforget() ! 63: { ! 64: char *name; ! 65: struct atom *buckpt; ! 66: int hash; ! 67: chkarg(1,"forget"); ! 68: if(TYPE(lbot->val) != ATOM) ! 69: error("remob: non-atom argument",FALSE); ! 70: name = lbot->val->a.pname; ! 71: hash = hashfcn(name); ! 72: ! 73: /* We have found the hash bucket for the atom, now we remove it */ ! 74: ! 75: if( hasht[hash] == (struct atom *)lbot->val ) ! 76: { ! 77: hasht[hash] = lbot->val->a.hshlnk; ! 78: lbot->val->a.hshlnk = (struct atom *)CNIL; ! 79: return(lbot->val); ! 80: } ! 81: ! 82: buckpt = hasht[hash]; ! 83: while(buckpt != (struct atom *)CNIL) ! 84: { ! 85: if(buckpt->hshlnk == (struct atom *)lbot->val) ! 86: { ! 87: buckpt->hshlnk = lbot->val->a.hshlnk; ! 88: lbot->val->a.hshlnk = (struct atom *)CNIL; ! 89: return(lbot->val); ! 90: } ! 91: buckpt = buckpt->hshlnk; ! 92: } ! 93: ! 94: /* Whoops! Guess it wasn't in the hash table after all. */ ! 95: ! 96: return(lbot->val); ! 97: } ! 98: ! 99: lispval ! 100: Lgetl() ! 101: { ! 102: chkarg(1,"getlength"); ! 103: if(TYPE(lbot->val) != ARRAY) ! 104: error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE); ! 105: return(lbot->val->ar.length); ! 106: } ! 107: ! 108: lispval ! 109: Lputl() ! 110: { ! 111: chkarg(2,"putlength"); ! 112: if(TYPE((lbot)->val) != ARRAY) ! 113: error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE); ! 114: chek: while(TYPE(np[-1].val) != INT) ! 115: np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE); ! 116: if(np[-1].val->i <= 0) ! 117: { ! 118: np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE); ! 119: goto chek; ! 120: } ! 121: return((lbot)->val->ar.length = np[-1].val); ! 122: } ! 123: lispval ! 124: Lgetdel() ! 125: { ! 126: chkarg(1,"getdelta"); ! 127: if(TYPE(lbot->val) != ARRAY) ! 128: error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE); ! 129: return(lbot->val->ar.delta); ! 130: } ! 131: ! 132: lispval ! 133: Lputdel() ! 134: { ! 135: chkarg(2,"putdelta"); ! 136: if(TYPE((np-2)->val) != ARRAY) ! 137: error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE); ! 138: chek: while(TYPE(np[-1].val) != INT) ! 139: np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE); ! 140: if(np[-1].val->i <= 0) ! 141: { ! 142: np[-1].val = error("Array delta must be positive",TRUE); ! 143: goto chek; ! 144: } ! 145: return((lbot)->val->ar.delta = np[-1].val); ! 146: } ! 147: ! 148: lispval ! 149: Lgetaux() ! 150: { ! 151: chkarg(1,"getaux"); ! 152: if(TYPE(lbot->val)!=ARRAY) ! 153: error("Arg to getaux must be an array", FALSE); ! 154: return(lbot->val->ar.aux); ! 155: } ! 156: ! 157: lispval ! 158: Lputaux() ! 159: { ! 160: chkarg(2,"putaux"); ! 161: ! 162: if(TYPE((lbot)->val)!=ARRAY) ! 163: error("1st Arg to putaux must be array", FALSE); ! 164: return((lbot)->val->ar.aux = np[-1].val); ! 165: } ! 166: ! 167: lispval ! 168: Lgetdata() ! 169: { ! 170: chkarg(1,"getdata"); ! 171: if(TYPE(lbot->val)!=ARRAY) ! 172: error("Arg to getdata must be an array", FALSE); ! 173: return((lispval)lbot->val->ar.data); ! 174: } ! 175: ! 176: lispval ! 177: Lputdata() ! 178: { ! 179: chkarg(2,"putdata"); ! 180: ! 181: if(TYPE(lbot->val)!=ARRAY) ! 182: error("1st Arg to putaux must be array", FALSE); ! 183: return((lispval)(lbot->val->ar.data = (char *)(lbot[1].val))); ! 184: } ! 185: ! 186: lispval ! 187: Lgeta() ! 188: { ! 189: chkarg(1,"getaccess"); ! 190: if(TYPE(lbot->val) != ARRAY) ! 191: error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE); ! 192: return(lbot->val->ar.accfun); ! 193: } ! 194: ! 195: lispval ! 196: Lputa() ! 197: { ! 198: chkarg(2,"putaccess"); ! 199: if(TYPE((lbot)->val) != ARRAY) ! 200: error("ARG TO PUTACCESS MUST BE ARRAY",FALSE); ! 201: return((lbot)->val->ar.accfun = np[-1].val); ! 202: } ! 203: ! 204: lispval ! 205: Lmarray() ! 206: { ! 207: register lispval handy; ! 208: ! 209: chkarg(5,"marray"); ! 210: ! 211: (handy = newarray()); /* get a new array cell */ ! 212: handy->ar.data=(char *)lbot->val;/* insert data address */ ! 213: handy->ar.accfun = lbot[1].val; /* insert access function */ ! 214: handy->ar.aux = lbot[2].val; /* insert aux data */ ! 215: handy->ar.length = lbot[3].val; /* insert length */ ! 216: handy->ar.delta = lbot[4].val; /* push delta arg */ ! 217: return(handy); ! 218: } ! 219: ! 220: lispval ! 221: Lgetentry() ! 222: { ! 223: chkarg(1,"getentry"); ! 224: if( TYPE(lbot->val) != BCD ) ! 225: error("ARG TO GETENTRY MUST BE FUNCTION",FALSE); ! 226: return((lispval)(lbot->val->bcd.start)); ! 227: } ! 228: ! 229: lispval ! 230: Lgetlang() ! 231: { ! 232: chkarg(1,"getlang"); ! 233: while(TYPE(lbot->val)!=BCD) ! 234: lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE); ! 235: return(lbot->val->bcd.language); ! 236: } ! 237: ! 238: lispval ! 239: Lputlang() ! 240: { ! 241: chkarg(2,"putlang"); ! 242: while(TYPE((lbot)->val)!=BCD) ! 243: lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE); ! 244: (lbot)->val->bcd.language = np[-1].val; ! 245: return(np[-1].val); ! 246: } ! 247: ! 248: lispval ! 249: Lgetparams() ! 250: { ! 251: chkarg(1,"getparams"); ! 252: if(TYPE(np[-1].val)!=BCD) ! 253: error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE); ! 254: return(np[-1].val->bcd.params); ! 255: } ! 256: ! 257: lispval ! 258: Lputparams() ! 259: { ! 260: chkarg(2,"putparams"); ! 261: if(TYPE((lbot)->val)!=BCD) ! 262: error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE); ! 263: return((lbot)->val->bcd.params = np[-1].val); ! 264: } ! 265: ! 266: lispval ! 267: Lgetdisc() ! 268: { ! 269: chkarg(1,"getdisc"); ! 270: if(TYPE(np[-1].val) != BCD) ! 271: error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE); ! 272: return(np[-1].val->bcd.discipline); ! 273: } ! 274: ! 275: lispval ! 276: Lputdisc() ! 277: { ! 278: chkarg(2,"putdisc"); ! 279: if(TYPE(np[-2].val) != BCD) ! 280: error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE); ! 281: return((np-2)->val->bcd.discipline = np[-1].val); ! 282: } ! 283: ! 284: lispval ! 285: Lgetloc() ! 286: { ! 287: chkarg(1,"getloc"); ! 288: if(TYPE(lbot->val)!=BCD) ! 289: error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE); ! 290: return(lbot->val->bcd.loctab); ! 291: } ! 292: ! 293: lispval ! 294: Lputloc() ! 295: { ! 296: chkarg(2,"putloc"); ! 297: if(TYPE((lbot+1)->val)!=BCD); ! 298: error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE); ! 299: (lbot)->val->bcd.loctab = (lbot+1)->val; ! 300: return((lbot+1)->val); ! 301: } ! 302: ! 303: lispval ! 304: Lmfunction() ! 305: { ! 306: register lispval handy; ! 307: chkarg(2,"mfunction"); ! 308: handy = (newfunct()); /* get a new function cell */ ! 309: handy->bcd.start = (lispval (*)())((np-5)->val); /* insert entry point */ ! 310: handy->bcd.discipline = ((np-4)->val); /* insert discipline */ ! 311: #ifdef ROWAN ! 312: handy->language = (np-3)->val; /* insert language */ ! 313: handy->params = ((np-2)->val); /* insert parameters */ ! 314: handy->loctab = ((np-1)->val); /* insert local table */ ! 315: #endif ! 316: return(handy); ! 317: } ! 318: ! 319: /** Lreplace ************************************************************/ ! 320: /* */ ! 321: /* Destructively modifies almost any kind of data. */ ! 322: ! 323: lispval ! 324: Lreplace() ! 325: { ! 326: register lispval a1, a2; ! 327: register int t; ! 328: chkarg(2,"replace"); ! 329: ! 330: if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val)) ! 331: error("REPLACE ARGS MUST BE SAME TYPE",FALSE); ! 332: ! 333: switch( t ) ! 334: { ! 335: ! 336: case VALUE: a1->l = a2->l; ! 337: return( a1 ); ! 338: ! 339: case INT: a1->i = a2->i; ! 340: return( a1 ); ! 341: ! 342: ! 343: case ARRAY: a1->ar.data = a2->ar.data; ! 344: a1->ar.accfun = a2->ar.accfun; ! 345: a1->ar.length = a2->ar.length; ! 346: a1->ar.delta = a2->ar.delta; ! 347: return( a1 ); ! 348: ! 349: case DOUB: a1->r = a2->r; ! 350: return( a1 ); ! 351: ! 352: case SDOT: ! 353: case DTPR: a1->d.car = a2->d.car; ! 354: a1->d.cdr = a2->d.cdr; ! 355: return( a1 ); ! 356: case BCD: a1->bcd.start = a2->bcd.start; ! 357: a1->bcd.discipline = a2->bcd.discipline; ! 358: return( a1 ); ! 359: default: ! 360: errorh1(Vermisc,"Replace: cannot handle the type of this arg", ! 361: nil,FALSE,0,a1); ! 362: } ! 363: /* NOTREACHED */ ! 364: } ! 365: ! 366: /* Lvaluep */ ! 367: ! 368: lispval ! 369: Lvaluep() ! 370: { ! 371: chkarg(1,"valuep"); ! 372: if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil); ! 373: } ! 374: ! 375: CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ } ! 376: ! 377: lispval ! 378: Lod() ! 379: { ! 380: int i; ! 381: chkarg(2,"od"); ! 382: ! 383: while( TYPE(np[-1].val) != INT ) ! 384: np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE); ! 385: ! 386: for( i = 0; i < np->val->i; ++i ) ! 387: printf(copval(odform,CNIL)->a.pname,((int *)(np[-2].val))[i]); ! 388: ! 389: dmpport(poport); ! 390: return(nil); ! 391: } ! 392: lispval ! 393: Lfake() ! 394: { ! 395: chkarg(1,"fake"); ! 396: ! 397: if( TYPE(lbot->val) != INT ) ! 398: error("ARG TO FAKE MUST BE INTEGER",TRUE); ! 399: ! 400: return((lispval)(lbot->val->i)); ! 401: } ! 402: ! 403: /* this used to be Lwhat, but was changed to Lmaknum for maclisp ! 404: compatiblity ! 405: */ ! 406: lispval ! 407: Lmaknum() ! 408: { ! 409: chkarg(1,"maknum"); ! 410: return(inewint((int)(lbot->val))); ! 411: } ! 412: lispval ! 413: Lderef() ! 414: { ! 415: chkarg(1,"deref"); ! 416: ! 417: if( TYPE(lbot->val) != INT ) ! 418: error("arg to deref must be integer",TRUE); ! 419: ! 420: return(inewint(*(int *)(lbot->val->i))); ! 421: } ! 422: ! 423: lispval ! 424: Lpname() ! 425: { ! 426: chkarg(1,"pname"); ! 427: if(TYPE(lbot->val) != ATOM) ! 428: error("ARG TO PNAME MUST BE AN ATOM",FALSE); ! 429: return((lispval)(lbot->val->a.pname)); ! 430: } ! 431: ! 432: lispval ! 433: Larrayref() ! 434: { ! 435: chkarg(2,"arrayref"); ! 436: if(TYPE((lbot)->val) != ARRAY) ! 437: error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE); ! 438: vtemp = (lbot + 1)->val; ! 439: chek: while(TYPE(vtemp) != INT) ! 440: vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE); ! 441: if( vtemp->i < 0 ) ! 442: { ! 443: vtemp = error("NEGATIVE ARRAY OFFSET",TRUE); ! 444: goto chek; ! 445: } ! 446: if( vtemp->i >= (np-2)->val->ar.length->i ) ! 447: { ! 448: vtemp = error("ARRAY OFFSET TOO LARGE",TRUE); ! 449: goto chek; ! 450: } ! 451: vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i)); ! 452: /* compute address of desired item */ ! 453: return(vtemp); ! 454: ! 455: } ! 456: ! 457: lispval ! 458: Lptr() ! 459: { ! 460: chkarg(1,"ptr"); ! 461: return(inewval(lbot->val)); ! 462: } ! 463: ! 464: lispval ! 465: Llctrace() ! 466: { ! 467: chkarg(1,"lctrace"); ! 468: lctrace = (int)(lbot->val->a.clb); ! 469: return((lispval)lctrace); ! 470: } ! 471: ! 472: lispval ! 473: Lslevel() ! 474: { ! 475: return(inewint(np-orgnp-2)); ! 476: } ! 477: ! 478: lispval ! 479: Lsimpld() ! 480: { ! 481: register lispval pt; ! 482: register char *cpt = strbuf; ! 483: ! 484: chkarg(1,"simpld"); ! 485: ! 486: for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr); ! 487: ! 488: if( atmlen > STRBLEN ) ! 489: { ! 490: error("LCODE WAS TOO LONG",TRUE); ! 491: return((lispval)inewstr("")); ! 492: } ! 493: ! 494: for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.car->i; ! 495: *cpt = 0; ! 496: ! 497: return((lispval)newstr(1)); ! 498: } ! 499: ! 500: ! 501: /* Lopval *************************************************************/ ! 502: /* */ ! 503: /* Routine which allows system registers and options to be examined */ ! 504: /* and modified. Calls copval, the routine which is called by c code */ ! 505: /* to do the same thing from inside the system. */ ! 506: ! 507: lispval ! 508: Lopval() ! 509: { ! 510: lispval quant; ! 511: ! 512: if( lbot == np ) ! 513: return(error("bad call to opval",TRUE)); ! 514: quant = lbot->val; /* get name of sys variable */ ! 515: while( TYPE(quant) != ATOM ) ! 516: quant = error("first arg to opval must be an atom",TRUE); ! 517: ! 518: if(np > lbot+1) vtemp = (lbot+1)->val ; ! 519: else vtemp = CNIL; ! 520: return(copval(quant,vtemp)); ! 521: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.