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