![[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] / 43BSDReno / pgrm / lisp / franz|
Return to lam6.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: lam6.c,v 1.7 85/03/24 11:04:21 sklower Exp $";
4: #endif
5:
6: /* -[Sun Sep 4 08:56:19 1983 by jkf]-
7: * lam6.c $Locker: $
8: * lambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13: #include "global.h"
14: #include "frame.h"
15: #include <signal.h>
16: #include <sys/types.h>
17: #include <sys/times.h>
18: #include "chkrtab.h"
19: #include "chars.h"
20:
21:
22: lispval
23: Lreadli()
24: {
25: register lispval work, handy;
26: register FILE *p;
27: register char *string; char *alloca();
28: FILE *fstopen();
29: lispval Lread();
30: int count;
31: pbuf pb;
32: Savestack(4);
33: #ifdef SPISFP
34: Keepxs();
35: #endif
36:
37: if(lbot->val==nil) { /*effectively, return(matom(""));*/
38: strbuf[0] = 0;
39: return(getatom(FALSE));
40: }
41: chkarg(1,"readlist");
42: count = 1;
43:
44: /* compute length of list */
45: for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr)
46: count++;
47: string = alloca(count);
48: p = fstopen(string, count - 1, "r");
49: for(work = lbot->val; TYPE(work)==DTPR; work=work->d.cdr) {
50: handy = work->d.car;
51: switch(TYPE(handy)) {
52: case SDOT:
53: case INT:
54: *string++=handy->i;
55: break;
56: case ATOM:
57: *string++ = *(handy->a.pname);
58: break;
59: case STRNG:
60: *string++ = *(char *)handy;
61: break;
62: default:
63: fclose(p);
64: error("Non atom or int to readlist",FALSE);
65: }
66: }
67: *string = 0;
68: errp = Pushframe(F_CATCH,Veruwpt,nil); /* must unwind protect
69: so can deallocate p
70: */
71: switch(retval) { lispval Lctcherr();
72: case C_THROW:
73: /* an error has occured and we are given a chance
74: to unwind before the control goes higher
75: lispretval contains the error descriptor in
76: it's cdr
77: */
78: fclose(p); /* free port */
79: errp = Popframe();
80: Freexs();
81: lbot = np;
82: protect(lispretval->d.cdr); /* error descriptor */
83: return(Lctcherr()); /* do a I-do-throw */
84:
85: case C_INITIAL:
86: lbot = np;
87: protect(P(p));
88: work = Lread(); /* error could occur here */
89: Freexs();
90: fclose(p); /* whew.. no errors */
91: errp = Popframe(); /* remove unwind-protect */
92: Restorestack();
93: return(work);
94: }
95: /* NOTREACHED */
96: }
97:
98: lispval
99: Lgetenv()
100: {
101: char *getenv(), *strcpy();
102: char *res;
103: chkarg(1,"getenv");
104:
105:
106: if((TYPE(lbot->val))!=ATOM)
107: error("argument to getenv must be atom",FALSE);
108:
109: res = getenv(lbot->val->a.pname);
110: if(res) strcpy(strbuf,res);
111: else strbuf[0] = '\0';
112: return(getatom(FALSE));
113: }
114:
115: lispval
116: Lboundp()
117: {
118: register lispval result, handy;
119:
120: chkarg(1,"boundp");
121:
122: if((TYPE(lbot->val))!=ATOM)
123: error("argument to boundp must be symbol",FALSE);
124: if( (handy = lbot->val)->a.clb==CNIL)
125: result = nil;
126: else
127: (result = newdot())->d.cdr = handy->a.clb;
128: return(result);
129: }
130:
131:
132: lispval
133: Lplist()
134: {
135: register lispval atm;
136: /* get property list of an atom or disembodied property list */
137:
138: chkarg(1,"plist");
139: atm = lbot->val;
140: switch(TYPE(atm)) {
141: case ATOM:
142: case DTPR:
143: break;
144: default:
145: error("Only Atoms and disembodied property lists allowed for plist",FALSE);
146: }
147: if(atm==nil) return(nilplist);
148: return(atm->a.plist);
149: }
150:
151:
152: lispval
153: Lsetpli()
154: { /* set the property list of the given atom to the given list */
155: register lispval atm, vall;
156:
157: chkarg(2,"setplist");
158: atm = lbot->val;
159: if (TYPE(atm) != ATOM)
160: error("setplist: First argument must be an symbol",FALSE);
161: vall = (np-1)->val;
162: if (TYPE(vall)!= DTPR && vall !=nil)
163: error("setplist: Second argument must be a list",FALSE);
164: if (atm==nil)
165: nilplist = vall;
166: else
167: atm->a.plist = vall;
168: return(vall);
169: }
170:
171: lispval
172: Lsignal()
173: {
174: register lispval handy, old, routine;
175: int i;
176: int sginth();
177:
178: switch(np-lbot) {
179:
180: case 1: routine = nil; /* second arg defaults to nil */
181: break;
182:
183: case 2: routine = lbot[1].val;
184: break; /* both args given */
185:
186: default: argerr("signal");
187: }
188:
189: handy = lbot->val;
190: if(TYPE(handy)!=INT)
191: error("First arg to signal must be an int",FALSE);
192: i = handy->i & 15;
193:
194: if(TYPE(routine)!=ATOM)
195: error("Second arg to signal must be an atom",FALSE);
196: old = sigacts[i];
197:
198: if(old==0) old = nil;
199:
200: if(routine==nil)
201: sigacts[i]=((lispval) 0);
202: else
203: sigacts[i]=routine;
204: if(routine == nil)
205: signal(i,SIG_IGN); /* ignore this signals */
206: else if (old == nil)
207: signal(i,sginth); /* look for this signal */
208: if(i == SIGINT) sigintcnt = 0; /* clear memory */
209: return(old);
210: }
211:
212: lispval
213: Lassq()
214: {
215: register lispval work, handy;
216:
217: chkarg(2,"assq");
218:
219: for(work = lbot[1].val, handy = lbot[0].val;
220: (work->d.car->d.car != handy) && (work != nil);
221: work = work->d.cdr);
222: return(work->d.car);
223: }
224:
225: lispval
226: Lkilcopy()
227: {
228: if(fork()==0) {
229: abort();
230: }
231: }
232:
233: lispval
234: Larg()
235: {
236: register lispval handy; register offset, count;
237:
238: handy = lexpr_atom->a.clb;
239: if(handy==CNIL || TYPE(handy)!=DTPR)
240: error("Arg: not in context of Lexpr.",FALSE);
241: count = ((long *)handy->d.cdr) -1 - (long *)handy->d.car;
242: if(np==lbot || lbot->val==nil)
243: return(inewint(count+1));
244: if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 )
245: error("Out of bounds: arg to \"Arg\"",FALSE);
246: return( ((struct argent *)handy->d.car)[offset].val);
247: }
248:
249: lispval
250: Lsetarg()
251: {
252: register lispval handy, work;
253: register limit, index;
254:
255: chkarg(2,"setarg");
256: handy = lexpr_atom->a.clb;
257: if(handy==CNIL || TYPE(handy)!=DTPR)
258: error("Arg: not in context of Lexpr.",FALSE);
259: limit = ((long *)handy->d.cdr) - 1 - (long *)(work = handy->d.car);
260: handy = lbot->val;
261: if(TYPE(handy)!=INT)
262: error("setarg: first argument not integer",FALSE);
263: if((index = handy->i - 1) < 0 || index > limit)
264: error("setarg: index out of range",FALSE);
265: return(((struct argent *) work)[index].val = lbot[1].val);
266: }
267:
268: lispval
269: Lptime(){
270: extern int gctime;
271: int lgctime = gctime;
272: struct tms current;
273: register lispval result, handy;
274: Savestack(2);
275:
276: times(¤t);
277: result = newdot();
278: handy = result;
279: protect(result);
280: result->d.cdr = newdot();
281: result->d.car = inewint(current.tms_utime);
282: handy = result->d.cdr;
283: handy->d.car = inewint(lgctime);
284: handy->d.cdr = nil;
285: if(gctime==0)
286: gctime = 1;
287: Restorestack();
288: return(result);
289: }
290:
291: /* (err-with-message message [value])
292: 'message' is the error message to print.
293: 'value' is the value to return from the errset (if present).
294: it defaults to nil.
295: The message may not be printed if there is an (errset ... nil)
296: pending.
297: */
298:
299: lispval Lerr()
300: {
301: lispval errorh();
302: lispval valret = nil;
303: char *mesg;
304:
305:
306: switch(np-lbot) {
307: case 2: valret = lbot[1].val; /* return non nil */
308: case 1: mesg = (char *)verify(lbot[0].val,
309: "err-with-message: non atom or string arg");
310: break;
311: default: argerr("err-with-message");
312: }
313:
314: return(errorh(Vererr,mesg,valret,FALSE,1));
315: }
316:
317: /*
318: * (tyi ['p_port ['g_eofval]])
319: * normally -1 is return on eof, but g_eofval will be returned if given.
320: */
321: lispval
322: Ltyi()
323: {
324: register FILE *port;
325: register lispval handy;
326: lispval eofval;
327: int val; /* really char but getc returns int on eof */
328: int eofvalgiven;
329:
330: handy = nil; /* default port */
331: eofvalgiven = FALSE; /* assume no eof value given */
332: switch(np-lbot)
333: {
334: case 2: eofval = lbot[1].val;
335: eofvalgiven = TRUE;
336: case 1: handy = lbot[0].val; /* port to read */
337: case 0:
338: break;
339: default: argerr("tyi");
340: }
341:
342: port = okport(handy,okport(Vpiport->a.clb,stdin));
343:
344:
345: fflush(stdout); /* flush any pending output characters */
346: val = getc(port);
347: if(val==EOF)
348: {
349: clearerr(port);
350: if(sigintcnt > 0) sigcall(SIGINT); /* eof might mean int */
351: if(eofvalgiven) return(eofval);
352: else return(inewint(-1));
353: }
354: return(inewint(val));
355: }
356:
357: /* Untyi (added by DNC Feb. '80) - (untyi number port) puts the
358: character with ascii code number in the front of the input buffer of
359: port. Note that this buffer is limited to 1 character. That buffer is
360: also written by tyipeek, so a peek followed by an untyi will result in
361: the loss of the peeked char.
362: */
363:
364: lispval
365: Luntyi()
366: {
367:
368: lispval port,ch;
369:
370: port = nil;
371:
372: switch(np-lbot) {
373: case 2: port = lbot[1].val;
374: case 1: ch = lbot[0].val;
375: break;
376: default:
377: argerr("untyi");
378: }
379:
380: if(TYPE(ch) != INT) {
381: errorh1(Vermisc, "untyi: expects fixnum character ",
382: nil,FALSE,0,ch);
383: }
384:
385: ungetc((int) ch->i,okport(port,okport(Vpiport->a.clb,stdin)));
386: return(ch);
387: }
388:
389: lispval
390: Ltyipeek()
391: {
392: register FILE *port;
393: register lispval handy;
394: int val;
395:
396: switch(np-lbot)
397: {
398: case 0: handy = nil; /* default port */
399: break;
400: case 1: handy = lbot->val;
401: break;
402: default: argerr("tyipeek");
403: }
404:
405: port = okport(handy,okport(Vpiport->a.clb,stdin));
406:
407: fflush(stdout); /* flush any pending output characters */
408: val = getc(port);
409: if(val==EOF)
410: clearerr(port);
411: ungetc(val,port);
412: return(inewint(val));
413: }
414:
415: lispval
416: Ltyo()
417: {
418: register FILE *port;
419: register lispval handy, where;
420: char val;
421:
422: switch(np-lbot)
423: {
424: case 1: where = nil; /* default port */
425: break;
426: case 2: where = lbot[1].val;
427: break;
428: default: argerr("tyo");
429: }
430:
431: handy = lbot->val;
432: if(TYPE(handy)!=INT)
433: error("Tyo demands number for 1st arg",FALSE);
434: val = handy->i;
435:
436: port = (FILE *) okport(where,okport(Vpoport->a.clb,stdout));
437: putc(val,port);
438: return(handy);
439: }
440:
441: lispval
442: Imkrtab(current)
443: {
444: extern struct rtab {
445: unsigned char ctable[132];
446: } initread;
447: register lispval handy; extern lispval lastrtab;
448:
449: static int cycle = 0;
450: static char *nextfree;
451: Savestack(3);
452:
453: if((cycle++)%3==0) {
454: nextfree = (char *) csegment(STRNG,1,FALSE);
455: mrtabspace = (lispval) nextfree;
456: /* need to protect partially allocated read tables
457: from garbage collection. */
458: }
459: handy = newarray();
460: protect(handy);
461:
462: handy->ar.data = nextfree;
463: if(current == 0)
464: *(struct rtab *)nextfree = initread;
465: else
466: {
467: register index = 0; register char *cp = nextfree;
468: lispval c;
469:
470: *(struct rtab *)cp = *(struct rtab *)ctable;
471: for(; index < 128; index++) {
472: switch(synclass(cp[index])) {
473: case CSPL: case CSSPL: case CMAC: case CSMAC:
474: case CINF: case CSINF:
475: strbuf[0] = index;
476: strbuf[1] = 0;
477: c = (getatom(TRUE));
478: Iputprop(c,Iget(c,lastrtab),handy);
479: }
480: }
481: }
482: handy->ar.delta = inewint(4);
483: handy->ar.length = inewint(sizeof(struct rtab)/sizeof(int));
484: handy->ar.accfun = handy->ar.aux = nil;
485: nextfree += sizeof(struct rtab);
486: Restorestack();
487: return(handy);
488: }
489:
490: /* makereadtable - arg : t or nil
491: returns a readtable, t means return a copy of the initial readtable
492:
493: nil means return a copy of the current readtable
494: */
495: lispval
496: Lmakertbl()
497: {
498: lispval handy = Vreadtable->a.clb;
499: lispval value;
500: chkrtab(handy);
501:
502: if(lbot==np) value = nil;
503: else if(TYPE(value=(lbot->val)) != ATOM)
504: error("makereadtable: arg must be atom",FALSE);
505:
506: if(value == nil) return(Imkrtab(1));
507: else return(Imkrtab(0));
508: }
509:
510: lispval
511: Lcpy1()
512: {
513: register lispval handy = lbot->val, result = handy;
514:
515: top:
516: switch(TYPE(handy))
517: {
518: case INT:
519: result = inewint(handy->i);
520: break;
521: case VALUE:
522: (result = newval())->l = handy->l;
523: break;
524: case DOUB:
525: (result = newdoub())->r = handy->r;
526: break;
527: default:
528: lbot->val =
529: errorh1(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy);
530: goto top;
531: }
532: return(result);
533: }
534:
535: /* copyint* . This returns a copy of its integer argument. The copy will
536: * be a fresh integer cell, and will not point into the read only
537: * small integer table.
538: */
539: lispval
540: Lcopyint()
541: {
542: register lispval handy = lbot->val;
543: register lispval ret;
544:
545: while (TYPE(handy) != INT)
546: { handy=errorh1(Vermisc,"copyint* : non integer arg",nil,TRUE,0,handy);}
547: (ret = newint())->i = handy->i;
548: return(ret);
549: }
550:
551:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.