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