Commit | Line | Data |
---|---|---|
8cd657f4 JF |
1 | |
2 | # include "global.h" | |
3 | # include <sgtty.h> | |
4 | # include "chkrtab.h" | |
5 | /**************************************************************************/ | |
6 | /* */ | |
7 | /* file: ccdfns.i */ | |
8 | /* contents: LISP functions coded in C */ | |
9 | /* */ | |
10 | /* These include LISP primitives, numeric and boolean functions and */ | |
11 | /* predicates, some list-processing functions, i/o support functions */ | |
12 | /* and control flow functions (e.g. cont, break). */ | |
13 | /* There are two types of functions: lambda (prefixed "L") and nlambda */ | |
14 | /* (prefixed "N"). */ | |
15 | /* Lambda's all call chkarg to insure that at least the minimum number */ | |
16 | /* of necessary arguments are on the namestack. */ | |
17 | /* All functions take their arguments from the namestack in a read- */ | |
18 | /* only manner, and return their results via the normal C value */ | |
19 | /* return mechanism. */ | |
20 | /* */ | |
21 | ||
22 | ||
23 | ||
24 | lispval | |
25 | Leval() | |
26 | { | |
27 | register lispval temp; | |
28 | ||
29 | chkarg(1); | |
30 | temp = lbot->val; | |
31 | return(eval(temp)); | |
32 | } | |
33 | ||
34 | lispval | |
35 | Lxcar() | |
36 | { register int typ; | |
37 | register lispval temp, result; | |
38 | ||
39 | chkarg(1); | |
40 | temp = lbot->val; | |
41 | if (((typ = TYPE(temp)) == DTPR) || (typ == ATOM)) | |
42 | return(temp -> car); | |
43 | else if(typ == SDOT) { | |
44 | result = inewint(temp->i); | |
45 | return(result); | |
46 | } else if(Schainp!=nil && typ==ATOM) | |
47 | return(nil); | |
48 | else | |
49 | return(error("BAD ARG TO CAR",FALSE)); | |
50 | ||
51 | } | |
52 | ||
53 | lispval | |
54 | Lxcdr() | |
55 | { register int typ; | |
56 | register lispval temp, result; | |
57 | ||
58 | chkarg(1); | |
59 | temp = lbot->val; | |
60 | if(temp==nil) return (nil); | |
61 | ||
62 | if ((typ = TYPE(temp)) == DTPR) | |
63 | return(temp -> cdr); | |
64 | else if(typ==SDOT) { | |
65 | if(temp->CDR==0) return(nil); | |
66 | return(temp->CDR); | |
67 | } else if(Schainp!=nil && typ==ATOM) | |
68 | return(nil); | |
69 | else | |
70 | return(error("BAD ARG TO CDR",FALSE)); | |
71 | } | |
72 | ||
73 | lispval | |
74 | cxxr(as,ds) | |
75 | register int as,ds; | |
76 | { | |
77 | ||
78 | register lispval temp, temp2; | |
79 | int i, typ; | |
80 | lispval errorh(); | |
81 | ||
82 | chkarg(1); | |
83 | temp = lbot->val; | |
84 | ||
85 | for( i=0 ; i<ds ; i++) | |
86 | { | |
87 | if( temp != nil) | |
88 | { | |
89 | if ((typ = TYPE(temp)) == DTPR) | |
90 | temp = temp -> cdr; | |
91 | else if(typ==SDOT) { | |
92 | if(temp->CDR==0) temp = nil; | |
93 | else temp = temp->CDR; | |
94 | } | |
95 | else if(Schainp!=nil && typ==ATOM) | |
96 | return(nil); | |
97 | else | |
98 | return(errorh(Vermisc,"BAD ARG TO CDR",nil,FALSE,5,temp)); | |
99 | } | |
100 | } | |
101 | ||
102 | for( i=0 ; i<as ; i++) | |
103 | { | |
104 | if( temp != nil ) | |
105 | { | |
106 | if ((typ = TYPE(temp)) == DTPR) | |
107 | temp = temp -> car; | |
108 | else if(typ == SDOT) | |
109 | temp2 = inewint(temp->i), temp = temp2; | |
110 | else if(Schainp!=nil && typ==ATOM) | |
111 | return(nil); | |
112 | else | |
113 | return(errorh(Vermisc,"BAD ARG TO CAR",nil,FALSE,5,temp)); | |
114 | } | |
115 | } | |
116 | ||
117 | return(temp); | |
118 | } | |
119 | ||
120 | ||
121 | lispval | |
122 | Lcar() | |
123 | { return(cxxr(1,0)); | |
124 | } | |
125 | ||
126 | lispval | |
127 | Lcdr() | |
128 | { return(cxxr(0,1)); | |
129 | } | |
130 | ||
131 | lispval | |
132 | Lcadr() | |
133 | { return(cxxr(1,1)); | |
134 | } | |
135 | ||
136 | lispval | |
137 | Lcaar() | |
138 | { return(cxxr(2,0)); | |
139 | } | |
140 | ||
141 | lispval | |
142 | Lc02r() | |
143 | { return(cxxr(0,2)); /* cddr */ | |
144 | } | |
145 | ||
146 | lispval | |
147 | Lc12r() | |
148 | { return(cxxr(1,2)); /* caddr */ | |
149 | } | |
150 | ||
151 | lispval | |
152 | Lc03r() | |
153 | { return(cxxr(0,3)); /* cdddr */ | |
154 | } | |
155 | ||
156 | lispval | |
157 | Lc13r() | |
158 | { return(cxxr(1,3)); /* cadddr */ | |
159 | } | |
160 | ||
161 | lispval | |
162 | Lc04r() | |
163 | { return(cxxr(0,4)); /* cddddr */ | |
164 | } | |
165 | ||
166 | lispval | |
167 | Lc14r() | |
168 | { return(cxxr(1,4)); /* caddddr */ | |
169 | } | |
170 | ||
171 | /************************* | |
172 | * | |
173 | * (nthelem num list) | |
174 | * returns the num'th element of the list, by doing a caddddd...ddr | |
175 | * where there are num-1 d's | |
176 | * if num<=0 or greater than the length of the list, we return nil | |
177 | ******************************************************/ | |
178 | ||
179 | lispval | |
180 | Lnthelem() | |
181 | { | |
182 | register lispval temp; | |
183 | register int i; | |
184 | ||
185 | chkarg(2); | |
186 | ||
187 | if( TYPE(temp = lbot->val) != INT) | |
188 | return (error ("First arg to nthelem must be a fixnum",FALSE)); | |
189 | ||
190 | i = temp->i; /* pick up the first arg */ | |
191 | ||
192 | if( i <= 0) return(nil); | |
193 | ||
194 | ++lbot; /* fix lbot for call to cxxr() 'cadddd..r' */ | |
195 | temp = cxxr(1,i-1); | |
196 | --lbot; | |
197 | ||
198 | return(temp); | |
199 | } | |
200 | ||
201 | ||
202 | ||
203 | ||
204 | ||
205 | lispval | |
206 | Lscons() | |
207 | { | |
208 | register struct argent *argp = lbot; | |
209 | register lispval retp, handy; | |
210 | register int typ; | |
211 | ||
212 | chkarg(2); | |
213 | retp = newsdot(); | |
214 | handy = (argp) -> val; | |
215 | if(TYPE(handy)!=INT) | |
216 | error("First arg to scons must be an int.",FALSE); | |
217 | retp->I = handy->i; | |
218 | handy = (argp+1)->val; | |
219 | if(handy==nil) | |
220 | retp->CDR = (lispval) 0; | |
221 | else { | |
222 | if(TYPE(handy)!=SDOT) | |
223 | error("Currently you may only link sdots to sdots.",FALSE); | |
224 | retp->CDR = handy; | |
225 | } | |
226 | return(retp); | |
227 | } | |
228 | lispval | |
229 | Lcons() | |
230 | { register struct argent *argp; | |
231 | lispval retp; | |
232 | ||
233 | chkarg(2); | |
234 | retp = newdot(); | |
235 | retp -> cdr = ((argp = np-1) -> val); | |
236 | retp -> car = (--argp) -> val; | |
237 | return(retp); | |
238 | } | |
239 | #define CA 0 | |
240 | #define CD 1 | |
241 | ||
242 | lispval | |
243 | rpla(what) | |
244 | int what; | |
245 | { register struct argent *argp; | |
246 | register int typ; register lispval first, second; | |
247 | ||
248 | chkarg(2); | |
249 | argp = np-1; | |
250 | first = (argp-1)->val; | |
251 | while(first==nil) | |
252 | first = error("Attempt to rplac[ad] nil.",TRUE); | |
253 | second = argp->val; | |
254 | if (((typ = TYPE(first)) == DTPR) || (typ == ATOM)) { | |
255 | if (what == CA) | |
256 | first->car = second; | |
257 | else | |
258 | first->cdr = second; | |
259 | return(first); | |
260 | } | |
261 | if (typ==SDOT) { | |
262 | if(what == CA) { | |
263 | typ = TYPE(second); | |
264 | if(typ!=INT) error("Rplacca of a bignum will only replace INTS",FALSE); | |
265 | first->i = second->i; | |
266 | } else { | |
267 | if(second==nil) | |
268 | first->CDR = (lispval) 0; | |
269 | else | |
270 | first->CDR = second; | |
271 | } | |
272 | return(first); | |
273 | } | |
274 | return(error("BAD ARG TO RPLA",FALSE)); | |
275 | } | |
276 | lispval | |
277 | Lrplaca() | |
278 | { return(rpla(CA)); } | |
279 | ||
280 | lispval | |
281 | Lrplacd() | |
282 | { return(rpla(CD)); } | |
283 | ||
284 | ||
285 | lispval | |
286 | Leq() | |
287 | { | |
288 | register struct argent *mynp = lbot + AD; | |
289 | int itemp, flag; | |
290 | ||
291 | chkarg(2); | |
292 | if(mynp->val==(mynp+1)->val) return(tatom); | |
293 | return(nil); | |
294 | } | |
295 | ||
296 | ||
297 | ||
298 | lispval | |
299 | Lnull() | |
300 | { chkarg(1); | |
301 | return ((lbot->val == nil) ? tatom : nil); | |
302 | } | |
303 | ||
304 | ||
305 | ||
306 | /* Lreturn **************************************************************/ | |
307 | /* Returns the first argument - which is nill if not specified. */ | |
308 | Lreturn() | |
309 | { | |
310 | chkarg(1); | |
311 | contval = lbot->val; | |
312 | reset(BRRETN); | |
313 | } | |
314 | ||
315 | ||
316 | /* Lretbrk **************************************************************/ | |
317 | /* The first argument must be an integer and must be in the range */ | |
318 | /* -1 .. -depth. */ | |
319 | lispval | |
320 | Lretbrk() | |
321 | { | |
322 | lispval number; | |
323 | register level; | |
324 | ||
325 | ||
326 | chkarg(1); | |
327 | number = lbot->val; | |
328 | if (TYPE(number) != INT) | |
329 | level = -1; | |
330 | else | |
331 | level = number->i; | |
332 | if(level < 0) | |
333 | level += depth; | |
334 | contval = (lispval) level; | |
335 | if (level < depth) | |
336 | reset(BRRETB); | |
337 | return(nil); | |
338 | } | |
339 | ||
340 | ||
341 | ||
342 | lispval | |
343 | Linfile() | |
344 | { | |
345 | FILE *port; | |
346 | register lispval name; | |
347 | snpand(1); | |
348 | ||
349 | chkarg(1); | |
350 | name = lbot->val; | |
351 | while (TYPE(name)!=ATOM) | |
352 | name = error("Please supply atom name for port.",TRUE); | |
353 | /* return nil if file couldnt be opened | |
354 | if ((port = fopen(name->pname,"r")) == NULL) return(nil); */ | |
355 | ||
356 | while ((port = fopen(name->pname,"r")) == NULL) | |
357 | name = errorh(Vermisc,"Unable to open file for reading.",nil,TRUE,31,name); | |
358 | ||
359 | return((lispval)(xports + (port - _iob))); | |
360 | } | |
361 | ||
362 | lispval | |
363 | Loutfile() | |
364 | { | |
365 | FILE *port; register lispval name; | |
366 | ||
367 | chkarg(1); | |
368 | name = lbot->val; | |
369 | while (TYPE(name)!=ATOM) | |
370 | name = error("Please supply atom name for port.",TRUE); | |
371 | while ((port = fopen(name->pname,"w")) == NULL) | |
372 | name = errorh(Vermisc,"Unable to open file for writing.",nil,TRUE,31,name); | |
373 | return((lispval)(xports + (port - _iob))); | |
374 | } | |
375 | lispval | |
376 | Lterpr() | |
377 | { | |
378 | FILE *port; | |
379 | ||
380 | chkarg(1); | |
381 | port = okport(lbot->val,okport(Vpoport->clb,stdout)); | |
382 | putc('\n',port); | |
383 | fflush(port); | |
384 | return(nil); | |
385 | } | |
386 | lispval | |
387 | Lclose() | |
388 | { | |
389 | lispval port; | |
390 | ||
391 | if(lbot==np) | |
392 | port = error("Close requires one argument of type port",TRUE); | |
393 | port = lbot->val; | |
394 | if((TYPE(port))==PORT) fclose(port->p); | |
395 | return(tatom); | |
396 | } | |
397 | ||
398 | lispval | |
399 | Lnwritn() | |
400 | { | |
401 | register FILE *port; | |
402 | register value; | |
403 | ||
404 | chkarg(1); | |
405 | port = okport(lbot->val,okport(Vpoport->clb,stdout)); | |
406 | value = port->_ptr - port->_base; | |
407 | return(inewint(value)); | |
408 | } | |
409 | ||
410 | lispval | |
411 | Ldrain() | |
412 | { | |
413 | register FILE *port; | |
414 | register int iodes; | |
415 | struct sgttyb arg; | |
416 | ||
417 | chkarg(1); | |
418 | port = okport(lbot->val, okport(Vpoport->clb,stdout)); | |
419 | if(port->_flag & _IOWRT) { | |
420 | fflush(port); | |
421 | return(nil); | |
422 | } | |
423 | if(! port->_flag & _IOREAD) return(nil); | |
424 | port->_cnt = 0; | |
425 | port->_ptr = port->_base; | |
426 | iodes = fileno(port); | |
427 | if(gtty(iodes,&arg) != -1) stty(iodes,&arg); | |
428 | return((lispval)(xports + (port - _iob))); | |
429 | } | |
430 | lispval | |
431 | Llist() | |
432 | { | |
433 | /* added for the benefit of mapping functions. */ | |
434 | register struct argent *ulim, *namptr; | |
435 | register lispval temp, result; | |
436 | register struct argent *lbot, *np; | |
437 | ||
438 | ulim = np; | |
439 | namptr = lbot + AD; | |
440 | temp = result = (lispval) np; | |
441 | protect(nil); | |
442 | for(; namptr < ulim;) { | |
443 | temp = temp->l = newdot(); | |
444 | temp->car = (namptr++)->val; | |
445 | } | |
446 | temp->l = nil; | |
447 | return(result->l); | |
448 | } | |
449 | ||
450 | lispval | |
451 | Lnumberp() | |
452 | { | |
453 | chkarg(1); | |
454 | switch(TYPE(lbot->val)) { | |
455 | case INT: case DOUB: case SDOT: | |
456 | return(tatom); | |
457 | } | |
458 | return(nil); | |
459 | } | |
460 | ||
461 | lispval | |
462 | Latom() | |
463 | { | |
464 | chkarg(1); | |
465 | if(TYPE(lbot->val)==DTPR) | |
466 | return(nil); | |
467 | else | |
468 | return(tatom); | |
469 | } | |
470 | lispval | |
471 | Ltype() | |
472 | { | |
473 | chkarg(1); | |
474 | switch(TYPE(lbot->val)) { | |
475 | case INT: | |
476 | return(int_name); | |
477 | case ATOM: | |
478 | return(atom_name); | |
479 | case SDOT: | |
480 | return(sdot_name); | |
481 | case DOUB: | |
482 | return(doub_name); | |
483 | case DTPR: | |
484 | return(dtpr_name); | |
485 | case STRNG: | |
486 | return(str_name); | |
487 | case ARRAY: | |
488 | return(array_name); | |
489 | case BCD: | |
490 | return(funct_name); | |
491 | case VALUE: | |
492 | return(val_name); | |
493 | case PORT: | |
494 | return(matom("port")); /* fix this when name exists */ | |
495 | } | |
496 | return(nil); | |
497 | } | |
498 | ||
499 | lispval | |
500 | Ldtpr() | |
501 | { | |
502 | chkarg(1); | |
503 | return(typred(DTPR,lbot->val)); | |
504 | } | |
505 | ||
506 | lispval | |
507 | Lbcdp() | |
508 | { | |
509 | chkarg(1); | |
510 | return(typred(BCD,lbot->val)); | |
511 | } | |
512 | ||
513 | lispval | |
514 | Lportp() | |
515 | { | |
516 | chkarg(1); | |
517 | return(typred(PORT,lbot->val)); | |
518 | } | |
519 | ||
520 | lispval | |
521 | Larrayp() | |
522 | { | |
523 | chkarg(1); | |
524 | return(typred(ARRAY,lbot->val)); | |
525 | } | |
526 | lispval | |
527 | Lset() | |
528 | { | |
529 | lispval varble; | |
530 | snpand(0); | |
531 | ||
532 | chkarg(2); | |
533 | varble = lbot->val; | |
534 | switch(TYPE(varble)) | |
535 | { | |
536 | case ATOM: return(varble->clb = lbot[1].val); | |
537 | ||
538 | case VALUE: return(varble->l = lbot[1].val); | |
539 | } | |
540 | ||
541 | error("IMPROPER USE OF SET",FALSE); | |
542 | } | |
543 | lispval | |
544 | Lequal() | |
545 | { | |
546 | chkarg(2); | |
547 | ||
548 | if( lbot[1].val == lbot->val ) return(tatom); | |
549 | if(Iequal(lbot[1].val,lbot->val)) return(tatom); else return(nil); | |
550 | } | |
551 | ||
552 | Iequal(first,second) | |
553 | register lispval first, second; | |
554 | { | |
555 | register type1, type2; | |
556 | register struct argent *lbot, *np; | |
557 | lispval Lsub(),Lzerop(); | |
558 | ||
559 | if(first==second) | |
560 | return(1); | |
561 | type1=TYPE(first); | |
562 | type2=TYPE(second); | |
563 | if(type1!=type2) { | |
564 | if((type1==SDOT&&type2==INT)||(type1==INT&&type2==SDOT)) | |
565 | goto dosub; | |
566 | return(0); | |
567 | } | |
568 | switch(type1) { | |
569 | case DTPR: | |
570 | return( | |
571 | Iequal(first->car,second->car) && | |
572 | Iequal(first->cdr,second->cdr) ); | |
573 | case DOUB: | |
574 | return(first->r==second->r); | |
575 | case INT: | |
576 | return( (first->i==second->i)); | |
577 | dosub: | |
578 | case SDOT: | |
579 | lbot = np; | |
580 | np++->val = first; | |
581 | np++->val = second; | |
582 | lbot->val = Lsub(); | |
583 | np = lbot + 1; | |
584 | return(Lzerop()!=nil); | |
585 | case VALUE: | |
586 | return( first->l==second->l ); | |
587 | case STRNG: | |
588 | return(strcmp(first,second)==0); | |
589 | } | |
590 | return(0); | |
591 | } | |
592 | ||
593 | lispval | |
594 | Lprint() | |
595 | { | |
596 | chkarg(2); | |
597 | chkrtab(Vreadtable->clb); | |
598 | printr(lbot->val,okport(lbot[1].val,okport(Vpoport->clb,poport))); | |
599 | return(nil); | |
600 | } | |
601 | ||
602 | FILE * | |
603 | okport(arg,proper) | |
604 | lispval arg; | |
605 | FILE *proper; | |
606 | { | |
607 | if(TYPE(arg)!=PORT) | |
608 | return(proper); | |
609 | else | |
610 | return(arg->p); | |
611 | } | |
612 | lispval | |
613 | Lpatom() | |
614 | { | |
615 | register lispval temp; | |
616 | FILE *port; | |
617 | ||
618 | chkarg(2); | |
619 | temp = Vreadtable->clb; | |
620 | chkrtab(temp); | |
621 | port = okport(lbot[1].val, okport(Vpoport->clb,stdout)); | |
622 | if ((TYPE((temp = (lbot)->val)))!=ATOM) | |
623 | printr(temp, port); | |
624 | else | |
625 | fputs(temp->pname, port); | |
626 | return(temp); | |
627 | } | |
628 | ||
629 | /* | |
630 | * (pntlen thing) returns the length it takes to print out | |
631 | * an atom or number. | |
632 | */ | |
633 | ||
634 | lispval | |
635 | Lpntlen() | |
636 | { | |
637 | register lispval temp; | |
638 | return(inewint(Ipntlen())); | |
639 | } | |
640 | Ipntlen() | |
641 | { | |
642 | register lispval temp; | |
643 | register char *handy; | |
644 | ||
645 | temp = np[-1].val; | |
646 | loop: switch(TYPE(temp)) { | |
647 | ||
648 | case ATOM: | |
649 | handy = temp->pname; | |
650 | break; | |
651 | ||
652 | case INT: | |
653 | sprintf(strbuf,"%d",temp->i); | |
654 | handy =strbuf; | |
655 | break; | |
656 | ||
657 | case DOUB: | |
658 | sprintf(strbuf,"%g",temp->r); | |
659 | handy =strbuf; | |
660 | break; | |
661 | ||
662 | default: | |
663 | temp = error("Non atom or number to pntlen\n",TRUE); | |
664 | goto loop; | |
665 | } | |
666 | ||
667 | return( strlen(handy)); | |
668 | } |