![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fex4.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 fex4.c CVS log | Up to [CSRG BSD Unix] / 43BSDReno / pgrm / lisp / franz |
1.1 root 1: #ifndef lint
2: static char *rcsid =
3: "$Header: fex4.c,v 1.5 85/03/13 17:19:04 sklower Exp $";
4: #endif
5:
6: /* -[Sat Jan 29 12:40:56 1983 by jkf]-
7: * fex4.c $Locker: $
8: * nlambda functions
9: *
10: * (c) copyright 1982, Regents of the University of California
11: */
12:
13:
14: #include "global.h"
15: #include "lfuncs.h"
16: #include "chkrtab.h"
17: #include <signal.h>
18: #include <sys/types.h>
19:
20: #if (os_4_2 || os_4_3)
21: #include <sys/time.h>
22: #else
23: #include <time.h>
24: #endif
25:
26: /* this is now a lambda function instead of a nlambda.
27: the only reason that it wasn't a lambda to begin with is that
28: the person who wrote it didn't know how to write a lexpr
29: - jkf
30: */
31: lispval
32: Lsyscall() {
33: register lispval temp;
34: register struct argent *aptr;
35: register int acount = 1;
36: extern syscall();
37: int args[50];
38: Savestack(3);
39:
40: /* there must be at least one argument */
41:
42: if (np==lbot) { chkarg(1,"syscall"); }
43:
44: aptr = lbot;
45: temp = lbot->val;
46: if (TYPE(temp) != INT) {
47: Restorestack();
48: return(error("syscall: bad first argument ", FALSE));
49: }
50: args[acount++] = temp->i;
51: while( ++aptr < np && acount < 48) {
52: temp = aptr->val;
53: switch(TYPE(temp)) {
54:
55: case ATOM:
56: args[acount++] = (int)temp->a.pname;
57: break;
58:
59: case STRNG:
60: args[acount++] = (int) temp;
61: break;
62:
63: case INT:
64: args[acount++] = (int)temp->i;
65: break;
66:
67: default:
68: Restorestack();
69: return(error("syscall: arg not symbol, string or fixnum", FALSE));
70: }
71: }
72:
73: Restorestack();
74: args[0] = acount - 1;
75: return(inewint(callg_(syscall,args)));
76: }
77:
78: /* eval-when: this has the form (eval-when <list> <form1> <form2> ...)
79: where the list may contain any combination of `eval', `load', `compile'.
80: The interpreter (us) looks for the atom `eval', if it is present
81: we treat the rest of the forms as a progn.
82: */
83:
84: lispval
85: Nevwhen()
86: {
87: register lispval handy;
88: register lispval handy2;
89: Savestack(2);
90:
91: for (handy=(lbot->val)->d.car ; handy != nil ; handy = handy->d.cdr) {
92: if (handy->d.car == (lispval) Veval) {
93: lbot=np;
94: protect(((lbot-1)->val)->d.cdr);
95: handy2 = Nprogn();
96: Restorestack();
97: return(handy2);
98: }
99: }
100:
101:
102: Restorestack();
103: return(nil); /* eval not seen */
104: }
105:
106:
107: /* Status functions.
108: * These operate on the statuslist stlist which has the form:
109: * ( status_elem_1 status_elem_2 status_elem_3 ...)
110: * where each status element has the form:
111: * ( name readcode setcode . readvalue)
112: * where
113: * name - name of the status feature (the first arg to the status
114: * function).
115: * readcode - fixnum which tells status how to read the value of
116: * this status name. The codes are #defined.
117: * setcode - fixnum which tells sstatus how to set the value of
118: * this status name
119: * readvalue - the value of the status feature is usually stored
120: * here.
121: *
122: * Readcodes:
123: *
124: * ST_READ - if no second arg, return readvalue.
125: * if the second arg is given, we return t if it is eq to
126: * the readvalue.
127: * ST_FEATR - used in (status feature xxx) where we test for xxx being
128: * in the status features list
129: * ST_SYNT - used in (status syntax c) where we return c's syntax code
130: * ST_INTB - read stattab entry
131: * ST_NFETR - used in (status nofeature xxx) where we test for xxx not
132: * being in the status features list
133: * ST_DMPR - read the dumpmode
134: * ST_UNDEF - return the undefined functions in the transfer table
135: *
136: * Setcodes:
137: * ST_NO - if not allowed to set this status through sstatus.
138: * ST_SET - if the second arg is made the readvalue.
139: * ST_FEATW - for (sstatus feature xxx), we add xxx to the
140: * (status features) list.
141: * ST_TOLC - if non nil, map upper case chars in atoms to lc.
142: * ST_CORE - if non nil, have bus errors and segmentation violations
143: * dump core, if nil have them produce a bad-mem err msg
144: * ST_INTB - set stattab table entry
145: * ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
146: * from the status feature list.
147: * ST_DMPW - set the dumpmode
148: * ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
149: * calls from BCD functions to BCD functions
150: * ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
151: */
152:
153: lispval
154: Nstatus()
155: {
156: register lispval handy,curitm,valarg;
157: int indx,ctim;
158: int typ;
159: char *cp;
160: char *ctime();
161: struct tm *lctime,*localtime();
162: extern unsigned char *ctable;
163: extern int dmpmode;
164: extern lispval chktt();
165: lispval Istsrch();
166: Savestack(3);
167:
168: if(lbot->val == nil) return(nil);
169: handy = lbot->val; /* arg list */
170:
171: while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE);
172:
173: curitm = Istsrch(handy->d.car); /* look for feature */
174:
175: if( curitm == nil ) return(nil); /* non existant */
176:
177: if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
178: else valarg = handy->d.cdr->d.car;
179:
180: /* now do the processing with curitm pointing to the requested
181: item in the status list
182: */
183:
184: switch( typ = curitm->d.cdr->d.car->i ) { /* look at readcode */
185:
186:
187: case ST_READ:
188: curitm = Istsrch(handy->d.car); /* look for name */
189: if(curitm == nil) return(nil);
190: if( valarg != (lispval) CNIL)
191: error("status: Second arg not allowed.",FALSE);
192: else return(curitm->d.cdr->d.cdr->d.cdr);
193:
194: case ST_NFETR: /* look for feature present */
195: case ST_FEATR: /* look for feature */
196: curitm = Istsrch(matom("features"));
197: if( valarg == (lispval) CNIL)
198: error("status: need second arg",FALSE);
199:
200: for( handy = curitm->d.cdr->d.cdr->d.cdr;
201: handy != nil;
202: handy = handy->d.cdr)
203: if(handy->d.car == valarg)
204: return(typ == ST_FEATR ? tatom : nil);
205:
206: return(typ == ST_FEATR ? nil : tatom);
207:
208: case ST_SYNT: /* want character syntax */
209: handy = Vreadtable->a.clb;
210: chkrtab(handy);
211: if( valarg == (lispval) CNIL)
212: error("status: need second arg",FALSE);
213:
214: while (TYPE(valarg) != ATOM)
215: valarg = error("status: second arg must be atom",TRUE);
216:
217: indx = valarg->a.pname[0]; /* get first char */
218:
219: if(valarg->a.pname[1] != '\0')
220: error("status: only one character atom allowed",FALSE);
221:
222: handy = inewint((long) ctable[indx]);
223: return(handy);
224:
225: case ST_RINTB:
226: return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);
227:
228: case ST_DMPR:
229: return(inewint(dmpmode));
230:
231: case ST_CTIM:
232: ctim = time((time_t *)0);
233: cp = ctime(&ctim);
234: cp[24] = '\0';
235: return(matom(cp));
236:
237: case ST_LOCT:
238: ctim = time((time_t *)0);
239: lctime = localtime(&ctim);
240: (handy = newdot())->d.car = inewint(lctime->tm_sec);
241: protect(handy);
242: handy->d.cdr = (valarg = newdot());
243: valarg->d.car = inewint(lctime->tm_min);
244: valarg->d.cdr = (curitm = newdot());
245: curitm->d.car = inewint(lctime->tm_hour);
246: curitm->d.cdr = (valarg = newdot());
247: valarg->d.car = inewint(lctime->tm_mday);
248: valarg->d.cdr = (curitm = newdot());
249: curitm->d.car = inewint(lctime->tm_mon);
250: curitm->d.cdr = (valarg = newdot());
251: valarg->d.car = inewint(lctime->tm_year);
252: valarg->d.cdr = (curitm = newdot());
253: curitm->d.car = inewint(lctime->tm_wday);
254: curitm->d.cdr = (valarg = newdot());
255: valarg->d.car = inewint(lctime->tm_yday);
256: valarg->d.cdr = (curitm = newdot());
257: curitm->d.car = inewint(lctime->tm_isdst);
258: Restorestack();
259: return(handy);
260:
261: case ST_ISTTY:
262: return( (isatty(0) == TRUE ? tatom : nil));
263:
264: case ST_UNDEF:
265: return(chktt());
266: }
267: error("Internal error in status: Couldn't figure out request",FALSE);
268: /* NOTREACHED */
269: }
270: lispval
271: Nsstatus()
272: {
273: register lispval handy;
274: lispval Isstatus();
275:
276: handy = lbot->val;
277:
278: while( TYPE(handy) != DTPR || TYPE(handy->d.cdr) != DTPR)
279: handy = error("sstatus: Bad args",TRUE);
280:
281: return(Isstatus(handy->d.car,handy->d.cdr->d.car));
282: }
283:
284: /* Isstatus - internal routine to do a set status. */
285: lispval
286: Isstatus(curnam,curval)
287: lispval curnam,curval;
288: {
289: register lispval curitm,head;
290: lispval Istsrch(),Iaddstat();
291: int badmr(),clrtt();
292: extern int uctolc, dmpmode, bcdtrsw, gcstrings;
293:
294: curitm = Istsrch(curnam);
295: /* if doesnt exist, make one up */
296:
297: if(curitm == nil) curitm = Iaddstat(curnam,ST_READ,ST_SET,nil);
298:
299: switch (curitm->d.cdr->d.cdr->d.car->i) {
300:
301: case ST_NO: error("sstatus: cannot set this status",FALSE);
302:
303: case ST_SET: goto setit;
304:
305: case ST_FEATW: curitm = Istsrch(matom("features"));
306: (curnam = newdot())->d.car = curval;
307: curnam->d.cdr = curitm->d.cdr->d.cdr->d.cdr; /* old val */
308: curitm->d.cdr->d.cdr->d.cdr = curnam;
309: return(curval);
310:
311: case ST_NFETW: /* remove from features list */
312: curitm = Istsrch(matom("features"))->d.cdr->d.cdr;
313: for(head = curitm->d.cdr; head != nil; head = head->d.cdr)
314: {
315: if(head->d.car == curval) curitm->d.cdr = head->d.cdr;
316: else curitm = head;
317: }
318: return(nil);
319:
320:
321: case ST_TOLC: if(curval == nil) uctolc = FALSE;
322: else uctolc = TRUE;
323: goto setit;
324:
325: case ST_CORE: if(curval == nil)
326: {
327: signal(SIGBUS,badmr); /* catch bus errors */
328: signal(SIGSEGV,badmr); /* and segmentation viols */
329: }
330: else {
331: signal(SIGBUS,SIG_DFL); /* let them core dump */
332: signal(SIGSEGV,SIG_DFL);
333: }
334: goto setit;
335:
336: case ST_INTB:
337: stattab[curitm->d.cdr->d.cdr->d.cdr->i] = curval;
338: return(curval);
339:
340: case ST_DMPW:
341: if(TYPE(curval) != INT ||
342: (curval->i != 413 &&
343: curval->i != 407 &&
344: curval->i != 410)) errorh1(Vermisc,"sstatus: bad dump mode:",
345: nil,FALSE,0,curval);
346: dmpmode= curval->i;
347: return(curval);
348:
349: case ST_AUTR:
350: if(curval != nil) Sautor = (lispval) TRUE;
351: else Sautor = FALSE;
352: goto setit;
353:
354: case ST_TRAN:
355: if(curval != nil)
356: {
357: Strans = (lispval) TRUE;
358: /* the atom `on' set to set up all table
359: * to their bcd fcn if possible
360: */
361: if(curval == matom("on")) clrtt(1);
362: }
363: else {
364: Strans = (lispval) FALSE;
365: clrtt(0); /* clear all transfer tables */
366: }
367: goto setit;
368: case ST_BCDTR:
369: if(curval == nil) bcdtrsw = FALSE;
370: else bcdtrsw = TRUE;
371: goto setit;
372: case ST_GCSTR:
373: if(curval == nil) gcstrings = FALSE;
374: else gcstrings = TRUE;
375: goto setit;
376: }
377:
378: setit: /* store value in status list */
379: curitm->d.cdr->d.cdr->d.cdr = curval;
380: return(curval);
381:
382:
383: }
384:
385: /* Istsrch - utility routine to search the status list for the
386: name given as an argument. If such an entry is not found,
387: we return nil
388: */
389:
390: lispval Istsrch(nam)
391: lispval nam;
392: {
393: register lispval handy;
394:
395: for(handy = stlist ; handy != nil ; handy = handy->d.cdr)
396: if(handy->d.car->d.car == nam) return(handy->d.car);
397:
398: return(nil);
399: }
400:
401: /* Iaddstat - add a status entry to the status list */
402: /* return new entry in status list */
403:
404: lispval
405: Iaddstat(name,readcode,setcode,valu)
406: lispval name,valu;
407: int readcode,setcode;
408: {
409: register lispval handy,handy2;
410: Savestack(2);
411:
412:
413: protect(handy=newdot()); /* build status list here */
414:
415: (handy2 = newdot())->d.car = name;
416:
417: handy->d.car = handy2;
418:
419: ((handy2->d.cdr = newdot())->d.car = newint())->i = readcode;
420:
421: handy2 = handy2->d.cdr;
422:
423: ((handy2->d.cdr = newdot())->d.car = newint())->i = setcode;
424:
425: handy2->d.cdr->d.cdr = valu;
426:
427: /* link this one in */
428:
429: handy->d.cdr = stlist;
430: stlist = handy;
431:
432: Restorestack();
433: return(handy->d.car); /* return new item in stlist */
434: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.