Commit | Line | Data |
---|---|---|
8cd657f4 JF |
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 | } |