![[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] / 40BSD / cmd / lisp|
Return to lam6.c CVS log | Up to [CSRG BSD Unix] / 40BSD / 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.