Commit | Line | Data |
---|---|---|
4619ba6b JF |
1 | # include "global.h" |
2 | # include <a.out.h> | |
3 | ||
4 | /************************************************************************/ | |
5 | /* */ | |
6 | /* Lalloc */ | |
7 | /* */ | |
8 | /* This lambda allows allocation of pages from lisp. The first */ | |
9 | /* argument is the name of a space, n pages of which are allocated, */ | |
10 | /* if possible. Returns the number of pages allocated. */ | |
11 | ||
12 | lispval | |
13 | Lalloc() | |
14 | { | |
15 | int n; | |
16 | register struct argent *mylbot = lbot; | |
17 | snpand(1); | |
18 | chkarg(2); | |
19 | if(TYPE((mylbot+1)->val) != INT && (mylbot+1)->val != nil ) | |
20 | error("2nd ARGUMENT TO ALLOCATE MUST BE AN INTEGER",FALSE); | |
21 | n = 1; | |
22 | if((mylbot+1)->val != nil) n = (mylbot+1)->val->i; | |
23 | return(alloc((mylbot)->val,n)); /* call alloc to do the work */ | |
24 | } | |
25 | ||
26 | lispval | |
27 | Lsizeof() | |
28 | { | |
29 | chkarg(1); | |
30 | return(inewint(csizeof(lbot->val))); | |
31 | } | |
32 | ||
33 | lispval | |
34 | Lsegment() | |
35 | { | |
36 | chkarg(2); | |
37 | chek: while(TYPE(np[-1].val) != INT ) | |
38 | np[-1].val=error("LENGTH ARG TO SEGMENT MUST BE INTEGER",TRUE); | |
39 | if( np[-1].val->i < 0 ) | |
40 | { | |
41 | np[-1].val = error("LENGTH ARG TO SEGMENT MUST BE POSITIVE",TRUE); | |
42 | goto chek; | |
43 | } | |
44 | return(csegment((lbot)->val,np[-1].val->i)); | |
45 | } | |
46 | ||
47 | /* Lforget *************************************************************/ | |
48 | /* */ | |
49 | /* This function removes an atom from the hash table. */ | |
50 | ||
51 | lispval | |
52 | Lforget() | |
53 | { | |
54 | char c,*name; | |
55 | struct atom *buckpt; | |
56 | int hash; | |
57 | chkarg(1); | |
58 | if(TYPE(lbot->val) != ATOM) | |
59 | error("CANNOT FORGET NON-ATOM",FALSE); | |
60 | name = lbot->val->pname; | |
61 | hash = 0; | |
62 | while( (c = *name++) != NULL_CHAR) hash ^= c; | |
63 | hash = hash & 0177; | |
64 | ||
65 | /* We have found the hash bucket for the atom, now we remove it */ | |
66 | ||
67 | if( hasht[hash] == (struct atom *)lbot->val ) | |
68 | { | |
69 | hasht[hash] = lbot->val->hshlnk; | |
70 | lbot->val->hshlnk = (struct atom *)CNIL; | |
71 | return(lbot->val); | |
72 | } | |
73 | ||
74 | buckpt = hasht[hash]; | |
75 | while(buckpt != (struct atom *)CNIL) | |
76 | { | |
77 | if(buckpt->hshlnk == (struct atom *)lbot->val) | |
78 | { | |
79 | buckpt->hshlnk = lbot->val->hshlnk; | |
80 | lbot->val->hshlnk = (struct atom *)CNIL; | |
81 | return(lbot->val); | |
82 | } | |
83 | buckpt = buckpt->hshlnk; | |
84 | } | |
85 | ||
86 | /* Whoops! Guess it wasn't in the hash table after all. */ | |
87 | ||
88 | return(lbot->val); | |
89 | } | |
90 | ||
91 | lispval | |
92 | Lgetl() | |
93 | { | |
94 | chkarg(1); | |
95 | if(TYPE(lbot->val) != ARRAY) | |
96 | error("ARG TO GETLENGTH MUST BE AN ARRAY",TRUE); | |
97 | return(lbot->val->length); | |
98 | } | |
99 | ||
100 | lispval | |
101 | Lputl() | |
102 | { | |
103 | chkarg(2); | |
104 | if(TYPE((lbot)->val) != ARRAY) | |
105 | error("ARG TO PUTLENGTH MUST BE AN ARRAY",FALSE); | |
106 | chek: while(TYPE(np[-1].val) != INT) | |
107 | np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",FALSE); | |
108 | if(np[-1].val->i <= 0) | |
109 | { | |
110 | np[-1].val = error("ARRAY LENGTH MUST BE POSITIVE",TRUE); | |
111 | goto chek; | |
112 | } | |
113 | return((lbot)->val->length = np[-1].val); | |
114 | } | |
115 | lispval | |
116 | Lgetdel() | |
117 | { | |
118 | chkarg(1); | |
119 | if(TYPE(lbot->val) != ARRAY) | |
120 | error("ARG TO GETDELTA MUST BE AN ARRAY",FALSE); | |
121 | return(lbot->val->delta); | |
122 | } | |
123 | ||
124 | lispval | |
125 | Lputdel() | |
126 | { | |
127 | chkarg(2); | |
128 | if(TYPE((np-2)->val) != ARRAY) | |
129 | error("ARG TO PUTDELTA MUST BE AN ARRAY",FALSE); | |
130 | chek: while(TYPE(np[-1].val) != INT) | |
131 | np[-1].val = error("ARRAY LENGTH MUST BE AN INTEGER",TRUE); | |
132 | if(np[-1].val->i <= 0) | |
133 | { | |
134 | np[-1].val = error("ARRAY DELTA MUST BE POSITIVE",TRUE); | |
135 | goto chek; | |
136 | } | |
137 | return((lbot)->val->delta = np[-1].val); | |
138 | } | |
139 | ||
140 | lispval | |
141 | Lgetaux() | |
142 | { | |
143 | chkarg(1); | |
144 | if(TYPE(lbot->val)!=ARRAY) | |
145 | error("ARG TO GETAUX MUST BE ARRAY",FALSE); | |
146 | return(lbot->val->aux); | |
147 | } | |
148 | ||
149 | lispval | |
150 | Lputaux() | |
151 | { | |
152 | chkarg(2); | |
153 | ||
154 | if(TYPE((lbot)->val)!=ARRAY) | |
155 | error("1st ARG TO PUTAUX MUST BBE ARRAY",FALSE); | |
156 | return((lbot)->val->aux = np[-1].val); | |
157 | } | |
158 | ||
159 | lispval | |
160 | Lgeta() | |
161 | { | |
162 | chkarg(1); | |
163 | if(TYPE(lbot->val) != ARRAY) | |
164 | error("ARG TO GETACCESS MUST BE AN ARRAY",FALSE); | |
165 | return(lbot->val->accfun); | |
166 | } | |
167 | ||
168 | lispval | |
169 | Lputa() | |
170 | { | |
171 | chkarg(2); | |
172 | if(TYPE((lbot)->val) != ARRAY) | |
173 | error("ARG TO PUTACCESS MUST BE ARRAY",FALSE); | |
174 | return((lbot)->val->accfun = np[-1].val); | |
175 | } | |
176 | ||
177 | lispval | |
178 | Lmarray() | |
179 | { | |
180 | register struct argent *mylbot = lbot; | |
181 | register lispval handy; | |
182 | snpand(2); | |
183 | chkarg(5); | |
184 | (handy = newarray()); /* get a new array cell */ | |
185 | handy->data=(char *)mylbot->val;/* insert data address */ | |
186 | handy->accfun = mylbot[1].val; /* insert access function */ | |
187 | handy->aux = mylbot[2].val; /* insert aux data */ | |
188 | handy->length = mylbot[3].val; /* insert length */ | |
189 | handy->delta = mylbot[4].val; /* push delta arg */ | |
190 | return(handy); | |
191 | } | |
192 | ||
193 | lispval | |
194 | Lgetentry() | |
195 | { | |
196 | chkarg(1); | |
197 | if( TYPE(lbot->val) != BCD ) | |
198 | error("ARG TO GETENTRY MUST BE FUNCTION",FALSE); | |
199 | return((lispval)(lbot->val->entry)); | |
200 | } | |
201 | ||
202 | lispval | |
203 | Lgetlang() | |
204 | { | |
205 | chkarg(1); | |
206 | while(TYPE(lbot->val)!=BCD) | |
207 | lbot->val = error("ARG TO GETLANG MUST BE FUNCTION DESCRIPTOR",TRUE); | |
208 | return(lbot->val->language); | |
209 | } | |
210 | ||
211 | lispval | |
212 | Lputlang() | |
213 | { | |
214 | chkarg(2); | |
215 | while(TYPE((lbot)->val)!=BCD) | |
216 | lbot->val = error("FIRST ARG TO PUTLANG MUST BE FUNCTION DESCRIPTOR",TRUE); | |
217 | (lbot)->val->language = np[-1].val; | |
218 | return(np[-1].val); | |
219 | } | |
220 | ||
221 | lispval | |
222 | Lgetparams() | |
223 | { | |
224 | chkarg(1); | |
225 | if(TYPE(np[-1].val)!=BCD) | |
226 | error("ARG TO GETPARAMS MUST BE A FUNCTION DESCRIPTOR",FALSE); | |
227 | return(np[-1].val->params); | |
228 | } | |
229 | ||
230 | lispval | |
231 | Lputparams() | |
232 | { | |
233 | chkarg(2); | |
234 | if(TYPE((lbot)->val)!=BCD) | |
235 | error("1st ARG TO PUTPARAMS MUST BE FUNCTION DESCRIPTOR",FALSE); | |
236 | return((lbot)->val->params = np[-1].val); | |
237 | } | |
238 | ||
239 | lispval | |
240 | Lgetdisc() | |
241 | { | |
242 | chkarg(1); | |
243 | if(TYPE(np[-1].val) != BCD) | |
244 | error("ARGUMENT OF GETDISC MUST BE FUNCTION",FALSE); | |
245 | return(np[-1].val->discipline); | |
246 | } | |
247 | ||
248 | lispval | |
249 | Lputdisc() | |
250 | { | |
251 | chkarg(2); | |
252 | if(TYPE(np[-2].val) != BCD) | |
253 | error("ARGUMENT OF PUTDISC MUST BE FUNCTION",FALSE); | |
254 | return((np-2)->val->discipline = np[-1].val); | |
255 | } | |
256 | ||
257 | lispval | |
258 | Lgetloc() | |
259 | { | |
260 | chkarg(1); | |
261 | if(TYPE(lbot->val)!=BCD) | |
262 | error("ARGUMENT TO GETLOC MUST BE FUNCTION",FALSE); | |
263 | return(lbot->val->loctab); | |
264 | } | |
265 | ||
266 | lispval | |
267 | Lputloc() | |
268 | { | |
269 | chkarg(2); | |
270 | if(TYPE((lbot+1)->val)!=BCD); | |
271 | error("FIRST ARGUMENT TO PUTLOC MUST BE FUNCTION",FALSE); | |
272 | (lbot)->val->loctab = (lbot+1)->val; | |
273 | return((lbot+1)->val); | |
274 | } | |
275 | ||
276 | lispval | |
277 | Lmfunction() | |
278 | { | |
279 | register lispval handy; | |
280 | chkarg(5); | |
281 | handy = (newfunct()); /* get a new function cell */ | |
282 | handy->entry = (lispval (*)())((np-5)->val); /* insert entry point */ | |
283 | handy->discipline = ((np-4)->val); /* insert discipline */ | |
284 | #ifdef ROWAN | |
285 | handy->language = (np-3)->val; /* insert language */ | |
286 | handy->params = ((np-2)->val); /* insert parameters */ | |
287 | handy->loctab = ((np-1)->val); /* insert local table */ | |
288 | #endif | |
289 | return(handy); | |
290 | } | |
291 | ||
292 | /** Lreplace ************************************************************/ | |
293 | /* */ | |
294 | /* Destructively modifies almost any kind of data. */ | |
295 | ||
296 | lispval | |
297 | Lreplace() | |
298 | { | |
299 | register lispval a1, a2; | |
300 | register int t; | |
301 | chkarg(2); | |
302 | ||
303 | if((t = TYPE(a1 = (lbot)->val)) != TYPE(a2 = np[-1].val)) | |
304 | error("REPLACE ARGS MUST BE SAME TYPE",FALSE); | |
305 | ||
306 | switch( t ) | |
307 | { | |
308 | case ATOM: error("REPLACE CANNOT STORE ATOMS",FALSE); | |
309 | ||
310 | case VALUE: a1->l = a2->l; | |
311 | return( a1 ); | |
312 | ||
313 | case INT: a1->i = a2->i; | |
314 | return( a1 ); | |
315 | ||
316 | case STRNG: error("STORE CANNOT STORE STRINGS",FALSE); | |
317 | ||
318 | case ARRAY: a1->data = a2->data; | |
319 | a1->accfun = a2->accfun; | |
320 | a1->length = a2->length; | |
321 | a1->delta = a2->delta; | |
322 | return( a1 ); | |
323 | ||
324 | case DOUB: a1->r = a2->r; | |
325 | return( a1 ); | |
326 | ||
327 | case SDOT: | |
328 | case DTPR: a1->car = a2->car; | |
329 | a1->cdr = a2->cdr; | |
330 | return( a1 ); | |
331 | case BCD: a1->entry = a2->entry; | |
332 | a1->discipline = a2->discipline; | |
333 | return( a1 ); | |
334 | } | |
335 | /* NOT REACHED */ | |
336 | } | |
337 | ||
338 | /* Lvaluep */ | |
339 | ||
340 | lispval | |
341 | Lvaluep() | |
342 | { | |
343 | chkarg(1); | |
344 | if( TYPE(lbot->val) == VALUE ) return(tatom); else return(nil); | |
345 | } | |
346 | ||
347 | CNTTYP() { return; /* HI! COUNT ONE TYPE CALL! */ } | |
348 | ||
349 | lispval | |
350 | Lod() | |
351 | { | |
352 | int i; | |
353 | chkarg(2); | |
354 | ||
355 | while( TYPE(np[-1].val) != INT ) | |
356 | np[-1].val = error("2nd ARG TO OD MUST BE INTEGER",TRUE); | |
357 | ||
358 | for( i = 0; i < np->val->i; ++i ) | |
359 | printf(copval(odform,CNIL)->pname,(int *)(np[-2].val)[i]); | |
360 | ||
361 | dmpport(poport); | |
362 | return(nil); | |
363 | } | |
364 | lispval | |
365 | Lfake() | |
366 | { | |
367 | chkarg(1); | |
368 | ||
369 | if( TYPE(lbot->val) != INT ) | |
370 | error("ARG TO FAKE MUST BE INTEGER",TRUE); | |
371 | ||
372 | return((lispval)(lbot->val->i)); | |
373 | } | |
374 | ||
375 | lispval | |
376 | Lwhat() | |
377 | { | |
378 | chkarg(1); | |
379 | return(inewint((int)(lbot->val))); | |
380 | } | |
381 | ||
382 | lispval | |
383 | Lpname() | |
384 | { | |
385 | chkarg(1); | |
386 | if(TYPE(lbot->val) != ATOM) | |
387 | error("ARG TO PNAME MUST BE AN ATOM",FALSE); | |
388 | return((lispval)(lbot->val->pname)); | |
389 | } | |
390 | ||
391 | lispval | |
392 | Larrayref() | |
393 | { | |
394 | chkarg(2); | |
395 | if(TYPE((lbot)->val) != ARRAY) | |
396 | error("FIRST ARG TO ARRAYREF MUST BE ARRAY",FALSE); | |
397 | vtemp = (lbot + 1)->val; | |
398 | chek: while(TYPE(vtemp) != INT) | |
399 | vtemp = error("SECOND ARG TO ARRAYREF MUST BE INTEGER",TRUE); | |
400 | if( vtemp->i < 0 ) | |
401 | { | |
402 | vtemp = error("NEGATIVE ARRAY OFFSET",TRUE); | |
403 | goto chek; | |
404 | } | |
405 | if( vtemp->i >= (np-2)->val->length->i ) | |
406 | { | |
407 | vtemp = error("ARRAY OFFSET TOO LARGE",TRUE); | |
408 | goto chek; | |
409 | } | |
410 | vtemp = (lispval)((np-2)->val->data + ((np-2)->val->delta->i)*(vtemp->i)); | |
411 | /* compute address of desired item */ | |
412 | return(vtemp); | |
413 | ||
414 | } | |
415 | ||
416 | lispval | |
417 | Lptr() | |
418 | { | |
419 | chkarg(1); | |
420 | return(inewval(lbot->val)); | |
421 | } | |
422 | ||
423 | lispval | |
424 | Llctrace() | |
425 | { | |
426 | chkarg(1); | |
427 | lctrace = (int)(lbot->val->clb); | |
428 | return((lispval)lctrace); | |
429 | } | |
430 | ||
431 | lispval | |
432 | Lslevel() | |
433 | { | |
434 | return(inewint(np-orgnp-2)); | |
435 | } | |
436 | ||
437 | lispval | |
438 | Lsimpld() | |
439 | { | |
440 | register lispval pt; | |
441 | register char *cpt = strbuf; | |
442 | ||
443 | chkarg(1); | |
444 | ||
445 | for(atmlen=1, pt=np->val; NOTNIL(pt); ++atmlen, pt = pt->cdr); | |
446 | ||
447 | if( atmlen > STRBLEN ) | |
448 | { | |
449 | error("LCODE WAS TOO LONG",TRUE); | |
450 | return((lispval)inewstr("")); | |
451 | } | |
452 | ||
453 | for(pt=np->val; NOTNIL(pt); pt = pt->cdr) *(cpt++) = pt->car->i; | |
454 | *cpt = 0; | |
455 | ||
456 | return((lispval)newstr()); | |
457 | } | |
458 | ||
459 | ||
460 | /* Lopval *************************************************************/ | |
461 | /* */ | |
462 | /* Routine which allows system registers and options to be examined */ | |
463 | /* and modified. Calls copval, the routine which is called by c code */ | |
464 | /* to do the same thing from inside the system. */ | |
465 | ||
466 | lispval | |
467 | Lopval() | |
468 | { | |
469 | lispval quant; | |
470 | snpand(0); | |
471 | ||
472 | if( lbot == np ) | |
473 | return(error("BAD CALL TO OPVAL",TRUE)); | |
474 | quant = lbot->val; /* get name of sys variable */ | |
475 | while( TYPE(quant) != ATOM ) | |
476 | quant = error("FIRST ARG TO OPVAL MUST BE AN ATOM",TRUE); | |
477 | ||
478 | if(np > lbot+1) vtemp = (lbot+1)->val ; | |
479 | else vtemp = CNIL; | |
480 | return(copval(quant,vtemp)); | |
481 | } | |
482 |