![[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] / 43BSD / ucb / lisp / franz|
Return to lamr.c CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / franz |
1.1 ! root 1: #ifndef lint ! 2: static char *rcsid = ! 3: "$Header: lamr.c,v 1.6 84/04/06 23:14:05 layer 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: Lgtentry() ! 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 (*)())((lbot)->val); /* insert entry point */ ! 310: handy->bcd.discipline = ((lbot+1)->val); /* insert discipline */ ! 311: return(handy); ! 312: } ! 313: ! 314: /** Lreplace ************************************************************/ ! 315: /* */ ! 316: /* Destructively modifies almost any kind of data. */ ! 317: ! 318: lispval ! 319: Lreplace() ! 320: { ! 321: register lispval a1, a2; ! 322: register int t; ! 323: chkarg(2,"replace"); ! 324: ! 325: if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val)) ! 326: error("REPLACE ARGS MUST BE SAME TYPE",FALSE); ! 327: ! 328: switch( t ) ! 329: { ! 330: ! 331: case VALUE: a1->l = a2->l; ! 332: return( a1 ); ! 333: ! 334: case INT: a1->i = a2->i; ! 335: return( a1 ); ! 336: ! 337: ! 338: case ARRAY: a1->ar.data = a2->ar.data; ! 339: a1->ar.accfun = a2->ar.accfun; ! 340: a1->ar.length = a2->ar.length; ! 341: a1->ar.delta = a2->ar.delta; ! 342: return( a1 ); ! 343: ! 344: case DOUB: a1->r = a2->r; ! 345: return( a1 ); ! 346: ! 347: case SDOT: ! 348: case DTPR: a1->d.car = a2->d.car; ! 349: a1->d.cdr = a2->d.cdr; ! 350: return( a1 ); ! 351: case BCD: a1->bcd.start = a2->bcd.start; ! 352: a1->bcd.discipline = a2->bcd.discipline; ! 353: return( a1 ); ! 354: default: ! 355: errorh1(Vermisc,"Replace: cannot handle the type of this arg", ! 356: nil,FALSE,0,a1); ! 357: } ! 358: /* NOTREACHED */ ! 359: } ! 360: ! 361: /* Lvaluep */ ! 362: ! 363: lispval ! 364: Lvaluep() ! 365: { ! 366: chkarg(1,"valuep"); ! 367: if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil); ! 368: } ! 369: ! 370: CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ } ! 371: ! 372: lispval ! 373: Lod() ! 374: { ! 375: int i; ! 376: chkarg(2,"od"); ! 377: ! 378: while( TYPE(np[-1].val) != INT ) ! 379: np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE); ! 380: ! 381: for( i = 0; i < np->val->i; ++i ) ! 382: printf(copval(odform,CNIL)->a.pname,((int *)(np[-2].val))[i]); ! 383: ! 384: dmpport(poport); ! 385: return(nil); ! 386: } ! 387: lispval ! 388: Lfake() ! 389: { ! 390: chkarg(1,"fake"); ! 391: ! 392: if( TYPE(lbot->val) != INT ) ! 393: error("ARG TO FAKE MUST BE INTEGER",TRUE); ! 394: ! 395: return((lispval)(lbot->val->i)); ! 396: } ! 397: ! 398: /* this used to be Lwhat, but was changed to Lmaknum for maclisp ! 399: compatiblity ! 400: */ ! 401: lispval ! 402: Lmaknum() ! 403: { ! 404: chkarg(1,"maknum"); ! 405: return(inewint((int)(lbot->val))); ! 406: } ! 407: lispval ! 408: Lderef() ! 409: { ! 410: chkarg(1,"deref"); ! 411: ! 412: if( TYPE(lbot->val) != INT ) ! 413: error("arg to deref must be integer",TRUE); ! 414: ! 415: return(inewint(*(int *)(lbot->val->i))); ! 416: } ! 417: ! 418: lispval ! 419: Lpname() ! 420: { ! 421: chkarg(1,"pname"); ! 422: if(TYPE(lbot->val) != ATOM) ! 423: error("ARG TO PNAME MUST BE AN ATOM",FALSE); ! 424: return((lispval)(lbot->val->a.pname)); ! 425: } ! 426: ! 427: lispval ! 428: Larayref() ! 429: { ! 430: chkarg(2,"arrayref"); ! 431: if(TYPE((lbot)->val) != ARRAY) ! 432: error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE); ! 433: vtemp = (lbot + 1)->val; ! 434: chek: while(TYPE(vtemp) != INT) ! 435: vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE); ! 436: if( vtemp->i < 0 ) ! 437: { ! 438: vtemp = error("NEGATIVE ARRAY OFFSET",TRUE); ! 439: goto chek; ! 440: } ! 441: if( vtemp->i >= (np-2)->val->ar.length->i ) ! 442: { ! 443: vtemp = error("ARRAY OFFSET TOO LARGE",TRUE); ! 444: goto chek; ! 445: } ! 446: vtemp = (lispval)((np-2)->val->ar.data + ((np-2)->val->ar.delta->i)*(vtemp->i)); ! 447: /* compute address of desired item */ ! 448: return(vtemp); ! 449: ! 450: } ! 451: ! 452: lispval ! 453: Lptr() ! 454: { ! 455: chkarg(1,"ptr"); ! 456: return(inewval(lbot->val)); ! 457: } ! 458: ! 459: lispval ! 460: Llctrace() ! 461: { ! 462: chkarg(1,"lctrace"); ! 463: lctrace = (int)(lbot->val->a.clb); ! 464: return((lispval)lctrace); ! 465: } ! 466: ! 467: lispval ! 468: Lslevel() ! 469: { ! 470: return(inewint(np-orgnp-2)); ! 471: } ! 472: ! 473: lispval ! 474: Lsimpld() ! 475: { ! 476: register lispval pt; ! 477: register char *cpt = strbuf; ! 478: ! 479: chkarg(1,"simpld"); ! 480: ! 481: for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->d.cdr); ! 482: ! 483: if( atmlen > STRBLEN ) ! 484: { ! 485: error("LCODE WAS TOO LONG",TRUE); ! 486: return((lispval)inewstr("")); ! 487: } ! 488: ! 489: for(pt=np->val; NOTNIL(pt); pt = pt->d.cdr) *(cpt++) = pt->d.car->i; ! 490: *cpt = 0; ! 491: ! 492: return((lispval)newstr(1)); ! 493: } ! 494: ! 495: ! 496: /* Lopval *************************************************************/ ! 497: /* */ ! 498: /* Routine which allows system registers and options to be examined */ ! 499: /* and modified. Calls copval, the routine which is called by c code */ ! 500: /* to do the same thing from inside the system. */ ! 501: ! 502: lispval ! 503: Lopval() ! 504: { ! 505: lispval quant; ! 506: ! 507: if( lbot == np ) ! 508: return(error("bad call to opval",TRUE)); ! 509: quant = lbot->val; /* get name of sys variable */ ! 510: while( TYPE(quant) != ATOM ) ! 511: quant = error("first arg to opval must be an atom",TRUE); ! 512: ! 513: if(np > lbot+1) vtemp = (lbot+1)->val ; ! 514: else vtemp = CNIL; ! 515: return(copval(quant,vtemp)); ! 516: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.