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