![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to lam6.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / lisp|
Return to lam6.c CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / lisp |
1.1 ! root 1: static char *sccsid = "@(#)lam6.c 34.2 10/6/80"; ! 2: ! 3: #include "global.h" ! 4: #include <signal.h> ! 5: FILE * ! 6: mkstFI(base,count,flag) ! 7: char *base; ! 8: char flag; ! 9: { ! 10: register FILE *p = stderr; ! 11: ! 12: /* find free file descriptor */ ! 13: for(;p->_flag&(_IOREAD|_IOWRT);p++) ! 14: if(p >= _iob + _NFILE) ! 15: error("Too many open files to do readlist",FALSE); ! 16: p->_flag = _IOSTRG | flag; ! 17: p->_cnt = count; ! 18: p->_base = base; ! 19: p->_ptr = base; ! 20: p->_file = -1; ! 21: return(p); ! 22: } ! 23: lispval ! 24: Lreadli() ! 25: { ! 26: register lispval work, handy; ! 27: register FILE *p; ! 28: register char *string; ! 29: register struct argent *lbot, *np; ! 30: struct argent *olbot; ! 31: FILE *opiport = piport; ! 32: lispval Lread(); ! 33: int count; ! 34: ! 35: if(lbot->val==nil) { /*effectively, return(matom(""));*/ ! 36: strbuf[0] = 0; ! 37: return(getatom()); ! 38: } ! 39: chkarg(1,"readlist"); ! 40: count = 1; ! 41: ! 42: /* compute length of list */ ! 43: for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) ! 44: count++; ! 45: string = (char *) alloca(count); ! 46: p = mkstFI(string, count - 1, _IOREAD); ! 47: for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) { ! 48: handy = work->d.car; ! 49: switch(TYPE(handy)) { ! 50: case SDOT: ! 51: case INT: ! 52: *string++=handy->i; ! 53: break; ! 54: case ATOM: ! 55: *string++ = *(handy->a.pname); ! 56: break; ! 57: case STRNG: ! 58: *string++ = *(char *)handy; ! 59: break; ! 60: default: ! 61: error("Non atom or int to readlist",FALSE); ! 62: } ! 63: } ! 64: *string = 0; ! 65: olbot = lbot; ! 66: lbot = np; ! 67: protect(P(p)); ! 68: work = Lread(); ! 69: lbot = olbot; ! 70: frstFI(p); ! 71: return(work); ! 72: } ! 73: frstFI(p) ! 74: register FILE *p; ! 75: { ! 76: p->_flag=0; ! 77: p->_base=0; ! 78: p->_cnt = 0; ! 79: p->_ptr = 0; ! 80: p->_file = 0; ! 81: } ! 82: lispval ! 83: Lgetenv() ! 84: { ! 85: register struct argent *mylbot=lbot; ! 86: snpand(1); ! 87: if((TYPE(mylbot->val))!=ATOM) ! 88: error("argument to getenv must be atom",FALSE); ! 89: ! 90: strcpy(strbuf,getenv(mylbot->val->a.pname)); ! 91: return(getatom()); ! 92: } ! 93: lispval ! 94: Lboundp() ! 95: { ! 96: register struct argent *mynp=lbot; ! 97: register lispval result, handy; ! 98: snpand(3); ! 99: ! 100: if((TYPE(mynp->val))!=ATOM) ! 101: error("argument to boundp must be atom",FALSE); ! 102: if( (handy = mynp->val)->a.clb==CNIL) ! 103: result = nil; ! 104: else ! 105: (result = newdot())->d.cdr = handy->a.clb; ! 106: return(result); ! 107: } ! 108: lispval ! 109: Lplist() ! 110: { ! 111: register lispval atm; ! 112: snpand(1); ! 113: /* get property list of an atom or disembodied property list */ ! 114: ! 115: chkarg(1,"plist"); ! 116: atm = lbot->val; ! 117: switch(TYPE(atm)) { ! 118: case ATOM: ! 119: case DTPR: ! 120: break; ! 121: default: ! 122: error("Only Atoms and disembodied property lists allowed for plist",FALSE); ! 123: } ! 124: if(atm==nil) return(nilplist); ! 125: return(atm->a.plist); ! 126: } ! 127: lispval ! 128: Lsetpli() ! 129: { /* set the property list of the given atom to the given list */ ! 130: register lispval atm, vall; ! 131: register lispval dum1, dum2; ! 132: register struct argent *lbot, *np; ! 133: ! 134: chkarg(2,"setplist"); ! 135: atm = lbot->val; ! 136: if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE); ! 137: vall = (np-1)->val; ! 138: if (TYPE(vall)!= DTPR && vall !=nil) ! 139: error("Second argument must be a list",FALSE); ! 140: if (atm==nil) ! 141: nilplist = vall; ! 142: else ! 143: atm->a.plist = vall; ! 144: return(vall); ! 145: } ! 146: ! 147: lispval ! 148: Lsignal() ! 149: { ! 150: register struct argent *mylbot = lbot; ! 151: int i; register lispval handy, old; ! 152: ! 153: snpand(3); ! 154: if(lbot-np==1)protect(nil); ! 155: chkarg(2,"signal"); ! 156: handy = mylbot[AD].val; ! 157: if(TYPE(handy)!=INT) ! 158: error("First arg to signal must be an int",FALSE); ! 159: i = handy->i & 15; ! 160: handy = mylbot[AD+1].val; ! 161: if(TYPE(handy)!=ATOM) ! 162: error("Second arg to signal must be an atom",FALSE); ! 163: old = sigacts[i]; ! 164: if(old==0) old = nil; ! 165: if(handy==nil) ! 166: sigacts[i]=((lispval) 0); ! 167: else ! 168: sigacts[i]=handy; ! 169: return(old); ! 170: } ! 171: lispval ! 172: Lassq() ! 173: { ! 174: register lispval work, handy, dum1, dum2; ! 175: register struct argent *lbot, *np; ! 176: ! 177: chkarg(2,"assq"); ! 178: for(work = lbot[AD+1].val; ! 179: work->d.car->d.car!=lbot->val&& work!=nil; ! 180: work = work->d.cdr); ! 181: return(work->d.car); ! 182: } ! 183: lispval ! 184: Lkilcopy() ! 185: { ! 186: if(fork()==0) { ! 187: asm(".byte 0"); ! 188: } ! 189: } ! 190: lispval ! 191: Larg() ! 192: { ! 193: register lispval handy; register offset, count; ! 194: snpand(3); ! 195: ! 196: handy = lexpr_atom->a.clb; ! 197: if(handy==CNIL || TYPE(handy)!=DTPR) ! 198: error("Arg: not in context of Lexpr.",FALSE); ! 199: count = ((long *)handy->d.cdr) -1 - (long *)handy->d.car; ! 200: if(np==lbot || lbot->val==nil) ! 201: return(inewint(count+1)); ! 202: if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 ) ! 203: error("Out of bounds: arg to \"Arg\"",FALSE); ! 204: return( ((struct argent *)handy->d.car)[offset].val); ! 205: } ! 206: lispval ! 207: Lsetarg() ! 208: { ! 209: register lispval handy, work; ! 210: register limit, index; ! 211: register struct argent *lbot, *np; ! 212: ! 213: chkarg(2,"setarg"); ! 214: handy = lexpr_atom->a.clb; ! 215: if(handy==CNIL || TYPE(handy)!=DTPR) ! 216: error("Arg: not in context of Lexpr.",FALSE); ! 217: limit = ((long *)handy->d.cdr) - 1 - (long *)(work = handy->d.car); ! 218: handy = lbot->val; ! 219: if(TYPE(handy)!=INT) ! 220: error("setarg: first argument not integer",FALSE); ! 221: if((index = handy->i - 1) < 0 || index > limit) ! 222: error("setarg: index out of range"); ! 223: return(((struct argent *) work)[index].val = lbot[1].val); ! 224: } ! 225: lispval ! 226: Lptime(){ ! 227: extern int GCtime; ! 228: int lgctime = GCtime; ! 229: static struct tbuf { ! 230: long mytime; ! 231: long allelse[3]; ! 232: } current; ! 233: register lispval result, handy; ! 234: ! 235: snpand(2); ! 236: times(¤t); ! 237: result = newdot(); ! 238: handy = result; ! 239: protect(result); ! 240: result->d.cdr = newdot(); ! 241: result->d.car = inewint(current.mytime); ! 242: handy = result->d.cdr; ! 243: handy->d.car = inewint(lgctime); ! 244: handy->d.cdr = nil; ! 245: if(GCtime==0) ! 246: GCtime = 1; ! 247: return(result); ! 248: } ! 249: ! 250: /* (err [value] [flag]) ! 251: where if value is present, it is the value to throw to the errset. ! 252: flag if present must evaluate to nil, as we always evaluate value ! 253: before unwinding stack ! 254: */ ! 255: ! 256: lispval Lerr() ! 257: { ! 258: register lispval handy; ! 259: lispval errorh(); ! 260: char *mesg = "call to err"; /* default message */ ! 261: ! 262: snpand(1); ! 263: if(np==lbot) protect(nil); ! 264: ! 265: if ((np >= lbot + 2) && ((lbot+1)->val != nil)) ! 266: error("Second arg to err must be nil",FALSE); ! 267: if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM)) ! 268: mesg = lbot->val->a.pname; /* new message if atom */ ! 269: ! 270: return(errorh(Vererr,mesg,lbot->val,nil)); ! 271: } ! 272: lispval ! 273: Ltyi() ! 274: { ! 275: register FILE *port; ! 276: char val; ! 277: snpand(1); ! 278: ! 279: if(lbot-np==0)protect(nil); ! 280: port = okport(lbot->val,okport(Vpiport->a.clb,stdin)); ! 281: ! 282: ! 283: fflush(stdout); /* flush any pending output characters */ ! 284: val = getc(port); ! 285: if(val==EOF) ! 286: { ! 287: clearerr(port); ! 288: if(sigintcnt > 0) sigcall(SIGINT); /* eof might mean int */ ! 289: } ! 290: return(inewint(val)); ! 291: } ! 292: lispval ! 293: Ltyipeek() ! 294: { ! 295: register FILE *port; ! 296: char val; ! 297: snpand(1); ! 298: ! 299: if(lbot-np==0) protect(nil); ! 300: port = okport(lbot->val,okport(Vpiport->a.clb,stdin)); ! 301: ! 302: fflush(stdout); /* flush any pending output characters */ ! 303: val = getc(port); ! 304: if(val==EOF) ! 305: clearerr(port); ! 306: ungetc(val,port); ! 307: return(inewint(val)); ! 308: } ! 309: lispval ! 310: Ltyo() ! 311: { ! 312: register FILE *port; ! 313: register lispval handy, where; ! 314: char val; ! 315: ! 316: snpand(3); ! 317: ! 318: switch(np-lbot) { ! 319: case 1: ! 320: protect(nil); ! 321: case 2: break; ! 322: default: ! 323: argerr("tyo"); ! 324: } ! 325: handy = lbot->val; ! 326: if(TYPE(handy)!=INT) ! 327: error("Tyo demands number for 1st arg",FALSE); ! 328: val = handy->i; ! 329: ! 330: where = lbot[1].val; ! 331: port = (FILE *) okport(where,okport(Vpoport->a.clb,stdout)); ! 332: putc(val,port); ! 333: return(handy); ! 334: } ! 335: ! 336: #include "chkrtab.h" ! 337: ! 338: lispval ! 339: Imkrtab(current) ! 340: { ! 341: extern struct rtab { ! 342: char ctable[132]; ! 343: } initread; ! 344: register lispval handy; extern lispval lastrtab; ! 345: ! 346: static int cycle = 0; ! 347: static char *nextfree; ! 348: ! 349: if((cycle++)%3==0) { ! 350: nextfree = (char *) csegment(str_name,512,FALSE); ! 351: } ! 352: handy = newarray(); ! 353: handy->ar.data = nextfree; ! 354: if(current == 0) ! 355: *(struct rtab *)nextfree = initread; ! 356: else ! 357: *(struct rtab *)nextfree = *(struct rtab *)ctable; ! 358: handy->ar.delta = inewint(4); ! 359: handy->ar.length = inewint(sizeof(struct rtab)/sizeof(int)); ! 360: handy->ar.accfun = handy->ar.aux = nil; ! 361: nextfree += sizeof(struct rtab); ! 362: return(handy); ! 363: } ! 364: ! 365: /* makereadtable - arg : t or nil ! 366: returns a readtable, t means return a copy of the initial readtable ! 367: ! 368: nil means return a copy of the current readtable ! 369: */ ! 370: lispval ! 371: Lmakertbl() ! 372: { ! 373: lispval handy = Vreadtable->a.clb; ! 374: chkrtab(handy); ! 375: ! 376: if(lbot==np) error("makereadtable: wrong number of args",FALSE); ! 377: ! 378: if(TYPE(lbot->val) != ATOM) ! 379: error("makereadtable: arg must be atom",FALSE); ! 380: ! 381: if(lbot->val == nil) return(Imkrtab(1)); ! 382: else return(Imkrtab(0)); ! 383: } ! 384: ! 385: lispval ! 386: Lcpy1() ! 387: { ! 388: register lispval handy = lbot->val, result = handy; ! 389: ! 390: top: ! 391: switch(TYPE(handy)) ! 392: { ! 393: case INT: ! 394: result = inewint(handy->i); ! 395: break; ! 396: case VALUE: ! 397: (result = newval())->l = handy->l; ! 398: break; ! 399: case DOUB: ! 400: (result = newdoub())->r = handy->r; ! 401: break; ! 402: default: ! 403: lbot->val = ! 404: errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy); ! 405: goto top; ! 406: } ! 407: return(result); ! 408: } ! 409: ! 410: /* copyint* . This returns a copy of its integer argument. The copy will ! 411: * be a fresh integer cell, and will not point into the read only ! 412: * small integer table. ! 413: */ ! 414: lispval ! 415: Lcopyint() ! 416: { ! 417: register lispval handy = lbot->val; ! 418: register lispval ret; ! 419: ! 420: while (TYPE(handy) != INT) ! 421: { handy=errorh(Vermisc,"copyint* : non integer arg",nil,TRUE,0,handy);} ! 422: (ret = newint())->i = handy->i; ! 423: return(ret); ! 424: } ! 425: ! 426:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.