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