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