Commit | Line | Data |
---|---|---|
a22cc832 JF |
1 | #include "global.h" |
2 | FILE * | |
3 | mkstFI(base,count,flag) | |
4 | char *base; | |
5 | char flag; | |
6 | { | |
7 | register FILE *p = stderr; | |
8 | ||
9 | /* find free file descriptor */ | |
10 | for(;p->_flag&(_IOREAD|_IOWRT);p++) | |
11 | if(p >= _iob + _NFILE) | |
12 | error("Too many open files to do readlist",FALSE); | |
13 | p->_flag = _IOSTRG | flag; | |
14 | p->_cnt = count; | |
15 | p->_base = base; | |
16 | p->_ptr = base; | |
17 | p->_file = -1; | |
18 | return(p); | |
19 | } | |
20 | lispval | |
21 | Lreadli() | |
22 | { | |
23 | register lispval work, handy; | |
24 | register FILE *p; | |
25 | register char *string; | |
26 | register struct argent *lbot, *np; | |
27 | struct argent *olbot; | |
28 | FILE *opiport = piport; | |
29 | lispval Lread(); | |
30 | int count; | |
31 | ||
32 | chkarg(1); | |
33 | if(lbot->val==nil) { /*effectively, return(matom(""));*/ | |
34 | strbuf[0] = 0; | |
35 | return(getatom()); | |
36 | } | |
37 | count = 1; | |
38 | ||
39 | /* compute length of list */ | |
40 | for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) | |
41 | count++; | |
42 | string = (char *) alloca(count); | |
43 | p = mkstFI(string, count - 1, _IOREAD); | |
44 | for(work = lbot->val; TYPE(work)==DTPR; work=work->cdr) { | |
45 | handy = work->car; | |
46 | switch(TYPE(handy)) { | |
47 | case SDOT: | |
48 | case INT: | |
49 | *string++=handy->i; | |
50 | break; | |
51 | case ATOM: | |
52 | *string++ = *(handy->pname); | |
53 | break; | |
54 | default: | |
55 | error("Non atom or int to readlist",FALSE); | |
56 | } | |
57 | } | |
58 | *string = 0; | |
59 | olbot = lbot; | |
60 | lbot = np; | |
61 | protect(P(p)); | |
62 | work = Lread(); | |
63 | lbot = olbot; | |
64 | frstFI(p); | |
65 | return(work); | |
66 | } | |
67 | frstFI(p) | |
68 | register FILE *p; | |
69 | { | |
70 | p->_flag=0; | |
71 | p->_base=0; | |
72 | p->_cnt = 0; | |
73 | p->_ptr = 0; | |
74 | p->_file = 0; | |
75 | } | |
76 | lispval | |
77 | Lgetenv() | |
78 | { | |
79 | register struct argent *mylbot=lbot; | |
80 | snpand(1); | |
81 | if((TYPE(mylbot->val))!=ATOM) | |
82 | error("argument to getenv must be atom",FALSE); | |
83 | ||
84 | strcpy(strbuf,getenv(mylbot->val->pname)); | |
85 | return(getatom()); | |
86 | } | |
87 | lispval | |
88 | Lboundp() | |
89 | { | |
90 | register struct argent *mynp=lbot; | |
91 | register lispval result, handy; | |
92 | snpand(3); | |
93 | ||
94 | if((TYPE(mynp->val))!=ATOM) | |
95 | error("argument to boundp must be atom",FALSE); | |
96 | if( (handy = mynp->val)->clb==CNIL) | |
97 | result = nil; | |
98 | else | |
99 | (result = newdot())->cdr = handy->clb; | |
100 | return(result); | |
101 | } | |
102 | lispval | |
103 | Lplist() | |
104 | { | |
105 | register lispval atm; | |
106 | snpand(0); | |
107 | /* get property list of an atom or disembodied property list */ | |
108 | ||
109 | chkarg(1); | |
110 | atm = lbot->val; | |
111 | switch(TYPE(atm)) { | |
112 | case ATOM: | |
113 | case DTPR: | |
114 | break; | |
115 | default: | |
116 | error("Only Atoms and disembodied property lists allowed for plist",FALSE); | |
117 | } | |
118 | if(atm==nil) return(nilplist); | |
119 | return(atm->plist); | |
120 | } | |
121 | lispval | |
122 | Lsetpli() | |
123 | { /* set the property list of the given atom to the given list */ | |
124 | register lispval atm, vall; | |
125 | register lispval dum1, dum2; | |
126 | register struct argent *lbot, *np; | |
127 | snpand(2); | |
128 | ||
129 | chkarg(2); | |
130 | atm = lbot->val; | |
131 | if (TYPE(atm) != ATOM) error("First argument must be an atom",FALSE); | |
132 | vall = (np-1)->val; | |
133 | if (TYPE(vall)!= DTPR && vall !=nil) | |
134 | error("Second argument must be a list",FALSE); | |
135 | if (atm==nil) | |
136 | nilplist = vall; | |
137 | else | |
138 | atm->plist = vall; | |
139 | return(vall); | |
140 | } | |
141 | ||
142 | lispval | |
143 | Lsignal() | |
144 | { | |
145 | register struct argent *mylbot = lbot; | |
146 | extern lispval sigacts[16]; | |
147 | int i; register lispval handy, old; | |
148 | chkarg(2); | |
149 | ||
150 | handy = mylbot[AD].val; | |
151 | if(TYPE(handy)!=INT) | |
152 | error("First arg to signal must be an int",FALSE); | |
153 | i = handy->i & 15; | |
154 | handy = mylbot[AD+1].val; | |
155 | if(TYPE(handy)!=ATOM) | |
156 | error("Second arg to signal must be an atom",FALSE); | |
157 | old = sigacts[i]; | |
158 | if(old==0) old = nil; | |
159 | if(handy==nil) | |
160 | sigacts[i]=((lispval) 0); | |
161 | else | |
162 | sigacts[i]=handy; | |
163 | return(old); | |
164 | } | |
165 | lispval | |
166 | Lassq() | |
167 | { | |
168 | register lispval work, handy, dum1, dum2; | |
169 | register struct argent *lbot, *np; | |
170 | snpand(2); | |
171 | ||
172 | chkarg(2); | |
173 | for(work = lbot[AD+1].val; | |
174 | work->car->car!=lbot->val&& work!=nil; | |
175 | work = work->cdr); | |
176 | return(work->car); | |
177 | } | |
178 | lispval | |
179 | Lkilcopy() | |
180 | { | |
181 | if(fork()==0) { | |
182 | asm(".byte 0"); | |
183 | } | |
184 | } | |
185 | lispval | |
186 | Larg() | |
187 | { | |
188 | register lispval handy; register offset, count; | |
189 | snpand(3); | |
190 | ||
191 | handy = lexpr_atom->clb; | |
192 | if(handy==CNIL || TYPE(handy)!=DTPR) | |
193 | error("Arg: not in context of Lexpr.",FALSE); | |
194 | count = ((long *)handy->cdr) - (long *)handy->car; | |
195 | if(np==lbot || lbot->val==nil) | |
196 | return(inewint(count)); | |
197 | if(TYPE(lbot->val)!=INT || (offset = lbot->val->i - 1) > count || offset < 0 ) | |
198 | error("Out of bonds: arg to \"Arg\"",FALSE); | |
199 | return( ((struct argent *)handy->car)[offset].val); | |
200 | } | |
201 | lispval | |
202 | Lptime(){ | |
203 | extern int GCtime; | |
204 | int lgctime = GCtime; | |
205 | static struct tbuf { | |
206 | long mytime; | |
207 | long allelse[3]; | |
208 | } current; | |
209 | register lispval result, handy; | |
210 | ||
211 | snpand(2); | |
212 | times(¤t); | |
213 | result = newdot(); | |
214 | handy = result; | |
215 | protect(result); | |
216 | result->cdr = newdot(); | |
217 | result->car = inewint(current.mytime); | |
218 | handy = result->cdr; | |
219 | handy->car = inewint(lgctime); | |
220 | handy->cdr = nil; | |
221 | if(GCtime==0) | |
222 | GCtime = 1; | |
223 | return(result); | |
224 | } | |
225 | ||
226 | /* (err [value] [flag]) | |
227 | where if value is present, it is the value to throw to the errset. | |
228 | flag if present must evaluate to nil, as we always evaluate value | |
229 | before unwinding stack | |
230 | */ | |
231 | ||
232 | lispval Lerr() | |
233 | { | |
234 | register lispval handy; | |
235 | lispval errorh(); | |
236 | char *mesg = "call to err"; /* default message */ | |
237 | ||
238 | chkarg(1); | |
239 | ||
240 | if ((np >= lbot + 2) && ((lbot+1)->val != nil)) | |
241 | error("Second arg to err must be nil",FALSE); | |
242 | if ((lbot->val != nil) && (TYPE(lbot->val) == ATOM)) | |
243 | mesg = lbot->val->pname; /* new message if atom */ | |
244 | ||
245 | return(errorh(Vererr,mesg,lbot->val,nil)); | |
246 | } | |
247 | lispval | |
248 | Ltyi() | |
249 | { | |
250 | register FILE *port; | |
251 | register char val; | |
252 | ||
253 | chkarg(1); | |
254 | port = okport(lbot->val,okport(Vpiport->clb,stdin)); | |
255 | ||
256 | ||
257 | fflush(stdout); /* flush any pending output characters */ | |
258 | val = getc(port); | |
259 | return(inewint(val)); | |
260 | } | |
261 | lispval | |
262 | Ltyipeek() | |
263 | { | |
264 | register FILE *port; | |
265 | register char val; | |
266 | ||
267 | chkarg(1); | |
268 | port = okport(lbot->val,okport(Vpiport->clb,stdin)); | |
269 | ||
270 | fflush(stdout); /* flush any pending output characters */ | |
271 | val = getc(port); | |
272 | ungetc(val,port); | |
273 | return(inewint(val)); | |
274 | } | |
275 | lispval | |
276 | Ltyo() | |
277 | { | |
278 | register FILE *port; | |
279 | register lispval handy, where; | |
280 | register char val; | |
281 | register struct argent *lbot, *np; | |
282 | ||
283 | chkarg(2); | |
284 | handy = lbot->val; | |
285 | if(TYPE(handy)!=INT) | |
286 | error("Tyo demands number for 1st arg",FALSE); | |
287 | val = handy->i; | |
288 | ||
289 | where = lbot[1].val; | |
290 | port = (FILE *) okport(where,okport(Vpoport->clb,stdout)); | |
291 | putc(val,port); | |
292 | return(handy); | |
293 | } | |
294 | lispval | |
295 | Imkrtab(current) | |
296 | { | |
297 | extern struct rtab { | |
298 | char ctable[132]; | |
299 | } initread; | |
300 | register lispval handy; extern lispval lastrtab; | |
301 | static int cycle = 0; | |
302 | static char *nextfree; | |
303 | if((cycle++)%3==0) { | |
304 | nextfree = (char *) csegment(int_name,128); | |
305 | } | |
306 | handy = newarray(); | |
307 | handy->data = nextfree; | |
308 | if(current == 0) | |
309 | *(struct rtab *)nextfree = initread; | |
310 | else | |
311 | *(struct rtab *)nextfree = *(struct rtab *)ctable; | |
312 | handy->delta = inewint(4); | |
313 | handy->length = inewint(sizeof(struct rtab)/sizeof(int)); | |
314 | handy->accfun = handy->aux = nil; | |
315 | nextfree += sizeof(struct rtab); | |
316 | return(handy); | |
317 | } | |
318 | ||
319 | /* makereadtable - arg : t or nil | |
320 | returns a readtable, t means return a copy of the initial readtable | |
321 | ||
322 | nil means return a copy of the current readtable | |
323 | */ | |
324 | lispval | |
325 | Lmakertbl() | |
326 | { | |
327 | if(lbot==np) error("makereadtable: wrong number of args",FALSE); | |
328 | ||
329 | if(TYPE(lbot->val) != ATOM) | |
330 | error("makereadtable: arg must be atom",FALSE); | |
331 | ||
332 | if(lbot->val == nil) return(Imkrtab(1)); | |
333 | else return(Imkrtab(0)); | |
334 | } | |
335 | lispval | |
336 | Lcpy1() | |
337 | { | |
338 | register lispval handy = lbot->val, result = handy; | |
339 | ||
340 | top: | |
341 | switch(TYPE(handy)) | |
342 | { | |
343 | case INT: | |
344 | result = inewint(handy->i); | |
345 | break; | |
346 | case VALUE: | |
347 | (result = newval())->l = handy->l; | |
348 | break; | |
349 | case DOUB: | |
350 | (result = newdoub())->r = handy->r; | |
351 | break; | |
352 | default: | |
353 | lbot->val = | |
354 | errorh(Vermisc,"Bad arg to cpy1",nil,TRUE,67,handy); | |
355 | goto top; | |
356 | } | |
357 | return(result); | |
358 | } |