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