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