/[cvs]/stack/symbols.c
ViewVC logotype

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.4 - (hide annotations)
Tue Aug 5 09:09:51 2003 UTC (20 years, 9 months ago) by masse
Branch: MAIN
Changes since 1.3: +25 -0 lines
File MIME type: text/plain 
(mangle) Moved from "stack.c" to "symbols.c".
Makefile: Added tail recursion optimization.
1 masse 1.1 #include "stack.h"
2    
3     /* Print newline. */
4     extern void nl(environment *env)
5     {
6     printf("\n");
7     }
8    
9     /* Print a newline to a port */
10     extern void nlport(environment *env)
11     {
12     if(env->head->type==empty) {
13     printerr("Too Few Arguments");
14     env->err= 1;
15     return;
16     }
17    
18     if(CAR(env->head)->type!=port) {
19     printerr("Bad Argument Type");
20     env->err= 2;
21     return;
22     }
23    
24     if(fprintf(CAR(env->head)->content.p, "\n") < 0){
25     perror("nl");
26     env->err= 5;
27     return;
28     }
29     toss(env);
30     }
31    
32     /* Gets the type of a value */
33     extern void type(environment *env)
34     {
35     if(env->head->type==empty) {
36     printerr("Too Few Arguments");
37     env->err= 1;
38     return;
39     }
40    
41     switch(CAR(env->head)->type){
42     case empty:
43     push_sym(env, "empty");
44     break;
45     case integer:
46     push_sym(env, "integer");
47     break;
48     case tfloat:
49     push_sym(env, "float");
50     break;
51     case string:
52     push_sym(env, "string");
53     break;
54     case symb:
55     push_sym(env, "symbol");
56     break;
57     case func:
58     push_sym(env, "function");
59     break;
60     case tcons:
61     push_sym(env, "pair");
62     break;
63     case port:
64     push_sym(env, "port");
65     break;
66     }
67     swap(env);
68     if (env->err) return;
69     toss(env);
70     }
71    
72     /* Print the top element of the stack but don't discard it */
73     extern void print_(environment *env)
74     {
75     if(env->head->type==empty) {
76     printerr("Too Few Arguments");
77     env->err= 1;
78     return;
79     }
80     print_val(env, CAR(env->head), 0, NULL, stdout);
81     if(env->err) return;
82     nl(env);
83     }
84    
85     /* Prints the top element of the stack */
86     extern void print(environment *env)
87     {
88     print_(env);
89     if(env->err) return;
90     toss(env);
91     }
92    
93     /* Print the top element of the stack without quotes, but don't
94     discard it. */
95     extern void princ_(environment *env)
96     {
97     if(env->head->type==empty) {
98     printerr("Too Few Arguments");
99     env->err= 1;
100     return;
101     }
102     print_val(env, CAR(env->head), 1, NULL, stdout);
103     }
104    
105     /* Prints the top element of the stack without quotes. */
106     extern void princ(environment *env)
107     {
108     princ_(env);
109     if(env->err) return;
110     toss(env);
111     }
112    
113     /* Print a value to a port, but don't discard it */
114     extern void printport_(environment *env)
115     {
116     if(env->head->type==empty || CDR(env->head)->type == empty) {
117     printerr("Too Few Arguments");
118     env->err= 1;
119     return;
120     }
121    
122     if(CAR(env->head)->type!=port) {
123     printerr("Bad Argument Type");
124     env->err= 2;
125     return;
126     }
127    
128     print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
129     if(env->err) return;
130     nlport(env);
131     }
132    
133     /* Print a value to a port */
134     extern void printport(environment *env)
135     {
136     printport_(env);
137     if(env->err) return;
138     toss(env);
139     }
140    
141     /* Print, without quotes, to a port, a value, but don't discard it. */
142     extern void princport_(environment *env)
143     {
144     if(env->head->type==empty || CDR(env->head)->type == empty) {
145     printerr("Too Few Arguments");
146     env->err= 1;
147     return;
148     }
149    
150     if(CAR(env->head)->type!=port) {
151     printerr("Bad Argument Type");
152     env->err= 2;
153     return;
154     }
155    
156     print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
157     toss(env); if(env->err) return;
158     }
159    
160     /* Print, without quotes, to a port, the top element. */
161     extern void princport(environment *env)
162     {
163     princport_(env);
164     if(env->err) return;
165     toss(env);
166     }
167    
168     /* Rotate the first three elements on the stack. */
169     extern void rot(environment *env)
170     {
171     value *temp= env->head;
172    
173     if(env->head->type == empty || CDR(env->head)->type == empty
174     || CDR(CDR(env->head))->type == empty) {
175     printerr("Too Few Arguments");
176     env->err= 1;
177     return;
178     }
179    
180     env->head= CDR(CDR(env->head));
181     CDR(CDR(temp))= CDR(env->head);
182     CDR(env->head)= temp;
183     }
184    
185     /* Relocate elements of the list on the stack. */
186     extern void expand(environment *env)
187     {
188     value *temp, *new_head;
189    
190     /* Is top element a list? */
191     if(env->head->type==empty) {
192     printerr("Too Few Arguments");
193     env->err= 1;
194     return;
195     }
196    
197     if(CAR(env->head)->type!=tcons) {
198     printerr("Bad Argument Type");
199     env->err= 2;
200     return;
201     }
202    
203     rev(env);
204    
205     if(env->err)
206     return;
207    
208     /* The first list element is the new stack head */
209     new_head= temp= CAR(env->head);
210    
211     toss(env);
212    
213     /* Find the end of the list */
214     while(CDR(temp)->type != empty) {
215     if (CDR(temp)->type == tcons)
216     temp= CDR(temp);
217     else {
218     printerr("Bad Argument Type"); /* Improper list */
219     env->err= 2;
220     return;
221     }
222     }
223    
224     /* Connect the tail of the list with the old stack head */
225     CDR(temp)= env->head;
226     env->head= new_head; /* ...and voila! */
227    
228     }
229    
230     /* Compares two elements by reference. */
231     extern void eq(environment *env)
232     {
233     void *left, *right;
234    
235     if(env->head->type==empty || CDR(env->head)->type==empty) {
236     printerr("Too Few Arguments");
237     env->err= 1;
238     return;
239     }
240    
241     left= CAR(env->head)->content.ptr;
242     right= CAR(CDR(env->head))->content.ptr;
243     toss(env); toss(env);
244    
245     push_int(env, left==right);
246     }
247    
248     /* Negates the top element on the stack. */
249     extern void not(environment *env)
250     {
251     int val;
252    
253     if(env->head->type==empty) {
254     printerr("Too Few Arguments");
255     env->err= 1;
256     return;
257     }
258    
259     if(CAR(env->head)->type!=integer) {
260     printerr("Bad Argument Type");
261     env->err= 2;
262     return;
263     }
264    
265     val= CAR(env->head)->content.i;
266     toss(env);
267     push_int(env, !val);
268     }
269    
270     /* Compares the two top elements on the stack and return 0 if they're the
271     same. */
272     extern void neq(environment *env)
273     {
274     eq(env);
275     not(env);
276     }
277    
278     extern void def(environment *env)
279     {
280     symbol *sym;
281    
282     /* Needs two values on the stack, the top one must be a symbol */
283     if(env->head->type==empty || CDR(env->head)->type==empty) {
284     printerr("Too Few Arguments");
285     env->err= 1;
286     return;
287     }
288    
289     if(CAR(env->head)->type!=symb) {
290     printerr("Bad Argument Type");
291     env->err= 2;
292     return;
293     }
294    
295     /* long names are a pain */
296 masse 1.3 sym= CAR(env->head)->content.sym;
297 masse 1.1
298     /* Bind the symbol to the value */
299     sym->val= CAR(CDR(env->head));
300    
301     toss(env); toss(env);
302     }
303    
304     /* Clear stack */
305     extern void clear(environment *env)
306     {
307     while(env->head->type != empty)
308     toss(env);
309     }
310    
311     /* Forgets a symbol (remove it from the hash table) */
312     extern void forget(environment *env)
313     {
314     char* sym_id;
315    
316     if(env->head->type==empty) {
317     printerr("Too Few Arguments");
318     env->err= 1;
319     return;
320     }
321    
322     if(CAR(env->head)->type!=symb) {
323     printerr("Bad Argument Type");
324     env->err= 2;
325     return;
326     }
327    
328     sym_id= CAR(env->head)->content.sym->id;
329     toss(env);
330    
331     return forget_sym(hash(env->symbols, sym_id));
332     }
333    
334     /* Returns the current error number to the stack */
335     extern void errn(environment *env)
336     {
337     push_int(env, env->err);
338     }
339    
340     /* "+" */
341     extern void sx_2b(environment *env)
342     {
343     int a, b;
344     float fa, fb;
345     size_t len;
346     char* new_string;
347     value *a_val, *b_val;
348    
349     if(env->head->type==empty || CDR(env->head)->type==empty) {
350     printerr("Too Few Arguments");
351     env->err= 1;
352     return;
353     }
354    
355     if(CAR(env->head)->type==string
356     && CAR(CDR(env->head))->type==string) {
357     a_val= CAR(env->head);
358     b_val= CAR(CDR(env->head));
359     protect(a_val); protect(b_val);
360     toss(env); if(env->err) return;
361     toss(env); if(env->err) return;
362 masse 1.3 len= strlen(a_val->content.string)+strlen(b_val->content.string)+1;
363 masse 1.1 new_string= malloc(len);
364     assert(new_string != NULL);
365 masse 1.3 strcpy(new_string, b_val->content.string);
366     strcat(new_string, a_val->content.string);
367 masse 1.1 push_cstring(env, new_string);
368     unprotect(a_val); unprotect(b_val);
369     free(new_string);
370    
371     return;
372     }
373    
374     if(CAR(env->head)->type==integer
375     && CAR(CDR(env->head))->type==integer) {
376     a= CAR(env->head)->content.i;
377     toss(env); if(env->err) return;
378     b= CAR(env->head)->content.i;
379     toss(env); if(env->err) return;
380     push_int(env, b+a);
381    
382     return;
383     }
384    
385     if(CAR(env->head)->type==tfloat
386     && CAR(CDR(env->head))->type==tfloat) {
387     fa= CAR(env->head)->content.f;
388     toss(env); if(env->err) return;
389     fb= CAR(env->head)->content.f;
390     toss(env); if(env->err) return;
391     push_float(env, fb+fa);
392    
393     return;
394     }
395    
396     if(CAR(env->head)->type==tfloat
397     && CAR(CDR(env->head))->type==integer) {
398     fa= CAR(env->head)->content.f;
399     toss(env); if(env->err) return;
400     b= CAR(env->head)->content.i;
401     toss(env); if(env->err) return;
402     push_float(env, b+fa);
403    
404     return;
405     }
406    
407     if(CAR(env->head)->type==integer
408     && CAR(CDR(env->head))->type==tfloat) {
409     a= CAR(env->head)->content.i;
410     toss(env); if(env->err) return;
411     fb= CAR(env->head)->content.f;
412     toss(env); if(env->err) return;
413     push_float(env, fb+a);
414    
415     return;
416     }
417    
418     printerr("Bad Argument Type");
419     env->err=2;
420     }
421    
422     /* "-" */
423     extern void sx_2d(environment *env)
424     {
425     int a, b;
426     float fa, fb;
427    
428     if(env->head->type==empty || CDR(env->head)->type==empty) {
429     printerr("Too Few Arguments");
430     env->err=1;
431     return;
432     }
433    
434     if(CAR(env->head)->type==integer
435     && CAR(CDR(env->head))->type==integer) {
436     a= CAR(env->head)->content.i;
437     toss(env); if(env->err) return;
438     b= CAR(env->head)->content.i;
439     toss(env); if(env->err) return;
440     push_int(env, b-a);
441    
442     return;
443     }
444    
445     if(CAR(env->head)->type==tfloat
446     && CAR(CDR(env->head))->type==tfloat) {
447     fa= CAR(env->head)->content.f;
448     toss(env); if(env->err) return;
449     fb= CAR(env->head)->content.f;
450     toss(env); if(env->err) return;
451     push_float(env, fb-fa);
452    
453     return;
454     }
455    
456     if(CAR(env->head)->type==tfloat
457     && CAR(CDR(env->head))->type==integer) {
458     fa= CAR(env->head)->content.f;
459     toss(env); if(env->err) return;
460     b= CAR(env->head)->content.i;
461     toss(env); if(env->err) return;
462     push_float(env, b-fa);
463    
464     return;
465     }
466    
467     if(CAR(env->head)->type==integer
468     && CAR(CDR(env->head))->type==tfloat) {
469     a= CAR(env->head)->content.i;
470     toss(env); if(env->err) return;
471     fb= CAR(env->head)->content.f;
472     toss(env); if(env->err) return;
473     push_float(env, fb-a);
474    
475     return;
476     }
477    
478     printerr("Bad Argument Type");
479     env->err=2;
480     }
481    
482     /* ">" */
483     extern void sx_3e(environment *env)
484     {
485     int a, b;
486     float fa, fb;
487    
488     if(env->head->type==empty || CDR(env->head)->type==empty) {
489     printerr("Too Few Arguments");
490     env->err= 1;
491     return;
492     }
493    
494     if(CAR(env->head)->type==integer
495     && CAR(CDR(env->head))->type==integer) {
496     a= CAR(env->head)->content.i;
497     toss(env); if(env->err) return;
498     b= CAR(env->head)->content.i;
499     toss(env); if(env->err) return;
500     push_int(env, b>a);
501    
502     return;
503     }
504    
505     if(CAR(env->head)->type==tfloat
506     && CAR(CDR(env->head))->type==tfloat) {
507     fa= CAR(env->head)->content.f;
508     toss(env); if(env->err) return;
509     fb= CAR(env->head)->content.f;
510     toss(env); if(env->err) return;
511     push_int(env, fb>fa);
512    
513     return;
514     }
515    
516     if(CAR(env->head)->type==tfloat
517     && CAR(CDR(env->head))->type==integer) {
518     fa= CAR(env->head)->content.f;
519     toss(env); if(env->err) return;
520     b= CAR(env->head)->content.i;
521     toss(env); if(env->err) return;
522     push_int(env, b>fa);
523    
524     return;
525     }
526    
527     if(CAR(env->head)->type==integer
528     && CAR(CDR(env->head))->type==tfloat) {
529     a= CAR(env->head)->content.i;
530     toss(env); if(env->err) return;
531     fb= CAR(env->head)->content.f;
532     toss(env); if(env->err) return;
533     push_int(env, fb>a);
534    
535     return;
536     }
537    
538     printerr("Bad Argument Type");
539     env->err= 2;
540     }
541    
542     /* "<" */
543     extern void sx_3c(environment *env)
544     {
545     swap(env); if(env->err) return;
546     sx_3e(env);
547     }
548    
549     /* "<=" */
550     extern void sx_3c3d(environment *env)
551     {
552     sx_3e(env); if(env->err) return;
553     not(env);
554     }
555    
556     /* ">=" */
557     extern void sx_3e3d(environment *env)
558     {
559     sx_3c(env); if(env->err) return;
560     not(env);
561     }
562    
563     /* "dup"; duplicates an item on the stack */
564     extern void sx_647570(environment *env)
565     {
566     if(env->head->type==empty) {
567     printerr("Too Few Arguments");
568     env->err= 1;
569     return;
570     }
571     push_val(env, copy_val(env, CAR(env->head)));
572     }
573    
574     /* "if", If-Then */
575     extern void sx_6966(environment *env)
576     {
577     int truth;
578    
579     if(env->head->type==empty || CDR(env->head)->type==empty) {
580     printerr("Too Few Arguments");
581     env->err= 1;
582     return;
583     }
584    
585     if(CAR(CDR(env->head))->type != integer) {
586     printerr("Bad Argument Type");
587     env->err= 2;
588     return;
589     }
590    
591     swap(env);
592     if(env->err) return;
593    
594     truth= CAR(env->head)->content.i;
595    
596     toss(env);
597     if(env->err) return;
598    
599     if(truth)
600     eval(env);
601     else
602     toss(env);
603     }
604    
605     /* If-Then-Else */
606     extern void ifelse(environment *env)
607     {
608     int truth;
609    
610     if(env->head->type==empty || CDR(env->head)->type==empty
611     || CDR(CDR(env->head))->type==empty) {
612     printerr("Too Few Arguments");
613     env->err= 1;
614     return;
615     }
616    
617     if(CAR(CDR(CDR(env->head)))->type!=integer) {
618     printerr("Bad Argument Type");
619     env->err= 2;
620     return;
621     }
622    
623     rot(env);
624     if(env->err) return;
625    
626     truth= CAR(env->head)->content.i;
627    
628     toss(env);
629     if(env->err) return;
630    
631     if(!truth)
632     swap(env);
633     if(env->err) return;
634    
635     toss(env);
636     if(env->err) return;
637    
638     eval(env);
639     }
640    
641     /* "else" */
642     extern void sx_656c7365(environment *env)
643     {
644     if(env->head->type==empty || CDR(env->head)->type==empty
645     || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
646     || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
647     printerr("Too Few Arguments");
648     env->err= 1;
649     return;
650     }
651    
652     if(CAR(CDR(env->head))->type!=symb
653     || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
654     || CAR(CDR(CDR(CDR(env->head))))->type!=symb
655     || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
656     printerr("Bad Argument Type");
657     env->err= 2;
658     return;
659     }
660    
661     swap(env); toss(env); rot(env); toss(env);
662     ifelse(env);
663     }
664    
665     extern void then(environment *env)
666     {
667     if(env->head->type==empty || CDR(env->head)->type==empty
668     || CDR(CDR(env->head))->type==empty) {
669     printerr("Too Few Arguments");
670     env->err= 1;
671     return;
672     }
673    
674     if(CAR(CDR(env->head))->type!=symb
675     || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
676     printerr("Bad Argument Type");
677     env->err= 2;
678     return;
679     }
680    
681     swap(env); toss(env);
682     sx_6966(env);
683     }
684    
685     /* "while" */
686     extern void sx_7768696c65(environment *env)
687     {
688     int truth;
689     value *loop, *test;
690    
691     if(env->head->type==empty || CDR(env->head)->type==empty) {
692     printerr("Too Few Arguments");
693     env->err= 1;
694     return;
695     }
696    
697     loop= CAR(env->head);
698     protect(loop);
699     toss(env); if(env->err) return;
700    
701     test= CAR(env->head);
702     protect(test);
703     toss(env); if(env->err) return;
704    
705     do {
706     push_val(env, test);
707     eval(env);
708    
709     if(CAR(env->head)->type != integer) {
710     printerr("Bad Argument Type");
711     env->err= 2;
712     return;
713     }
714    
715     truth= CAR(env->head)->content.i;
716     toss(env); if(env->err) return;
717    
718     if(truth) {
719     push_val(env, loop);
720     eval(env);
721     } else {
722     toss(env);
723     }
724    
725     } while(truth);
726    
727     unprotect(loop); unprotect(test);
728     }
729    
730    
731     /* "for"; for-loop */
732     extern void sx_666f72(environment *env)
733     {
734     value *loop;
735     int foo1, foo2;
736    
737     if(env->head->type==empty || CDR(env->head)->type==empty
738     || CDR(CDR(env->head))->type==empty) {
739     printerr("Too Few Arguments");
740     env->err= 1;
741     return;
742     }
743    
744     if(CAR(CDR(env->head))->type!=integer
745     || CAR(CDR(CDR(env->head)))->type!=integer) {
746     printerr("Bad Argument Type");
747     env->err= 2;
748     return;
749     }
750    
751     loop= CAR(env->head);
752     protect(loop);
753     toss(env); if(env->err) return;
754    
755     foo2= CAR(env->head)->content.i;
756     toss(env); if(env->err) return;
757    
758     foo1= CAR(env->head)->content.i;
759     toss(env); if(env->err) return;
760    
761     if(foo1<=foo2) {
762     while(foo1<=foo2) {
763     push_int(env, foo1);
764     push_val(env, loop);
765     eval(env); if(env->err) return;
766     foo1++;
767     }
768     } else {
769     while(foo1>=foo2) {
770     push_int(env, foo1);
771     push_val(env, loop);
772     eval(env); if(env->err) return;
773     foo1--;
774     }
775     }
776     unprotect(loop);
777     }
778    
779     /* Variant of for-loop
780     Requires a list as first argument */
781     extern void foreach(environment *env)
782     {
783     value *loop, *foo;
784     value *iterator;
785    
786     if(env->head->type==empty || CDR(env->head)->type==empty) {
787     printerr("Too Few Arguments");
788     env->err= 1;
789     return;
790     }
791    
792     if(CAR(CDR(env->head))->type!=tcons) {
793     printerr("Bad Argument Type");
794     env->err= 2;
795     return;
796     }
797    
798     loop= CAR(env->head);
799     protect(loop);
800     toss(env); if(env->err) return;
801    
802     foo= CAR(env->head);
803     protect(foo);
804     toss(env); if(env->err) return;
805    
806     iterator= foo;
807    
808     while(iterator->type!=empty) {
809     push_val(env, CAR(iterator));
810     push_val(env, loop);
811     eval(env); if(env->err) return;
812     if (iterator->type == tcons){
813     iterator= CDR(iterator);
814     } else {
815     printerr("Bad Argument Type"); /* Improper list */
816     env->err= 2;
817     break;
818     }
819     }
820     unprotect(loop); unprotect(foo);
821     }
822    
823     /* "to" */
824     extern void to(environment *env)
825     {
826     int ending, start, i;
827     value *iterator, *temp, *end;
828    
829     end= new_val(env);
830    
831     if(env->head->type==empty || CDR(env->head)->type==empty) {
832     printerr("Too Few Arguments");
833     env->err= 1;
834     return;
835     }
836    
837     if(CAR(env->head)->type!=integer
838     || CAR(CDR(env->head))->type!=integer) {
839     printerr("Bad Argument Type");
840     env->err= 2;
841     return;
842     }
843    
844     ending= CAR(env->head)->content.i;
845     toss(env); if(env->err) return;
846     start= CAR(env->head)->content.i;
847     toss(env); if(env->err) return;
848    
849     push_sym(env, "[");
850    
851     if(ending>=start) {
852     for(i= ending; i>=start; i--)
853     push_int(env, i);
854     } else {
855     for(i= ending; i<=start; i++)
856     push_int(env, i);
857     }
858    
859     iterator= env->head;
860    
861     if(iterator->type==empty
862     || (CAR(iterator)->type==symb
863     && CAR(iterator)->content.sym->id[0]=='[')) {
864     temp= end;
865     toss(env);
866     } else {
867     /* Search for first delimiter */
868     while(CDR(iterator)->type!=empty
869     && (CAR(CDR(iterator))->type!=symb
870     || CAR(CDR(iterator))->content.sym->id[0]!='['))
871     iterator= CDR(iterator);
872    
873     /* Extract list */
874     temp= env->head;
875     env->head= CDR(iterator);
876     CDR(iterator)= end;
877    
878     if(env->head->type!=empty)
879     toss(env);
880     }
881    
882     /* Push list */
883     push_val(env, temp);
884     }
885    
886     /* Read a string */
887     extern void readline(environment *env)
888     {
889     readlinestream(env, env->inputstream);
890     }
891    
892     /* Read a string from a port */
893     extern void readlineport(environment *env)
894     {
895     FILE *stream;
896    
897     if(env->head->type==empty) {
898     printerr("Too Few Arguments");
899     env->err= 1;
900     return;
901     }
902    
903     if(CAR(env->head)->type!=port) {
904     printerr("Bad Argument Type");
905     env->err= 2;
906     return;
907     }
908    
909     stream=CAR(env->head)->content.p;
910     readlinestream(env, stream); if(env->err) return;
911    
912     swap(env); if(env->err) return;
913     toss(env);
914     }
915    
916     /* "read"; Read a value and place on stack */
917     extern void sx_72656164(environment *env)
918     {
919     readstream(env, env->inputstream);
920     }
921    
922     /* "readport"; Read a value from a port and place on stack */
923     extern void readport(environment *env)
924     {
925     FILE *stream;
926    
927     if(env->head->type==empty) {
928     printerr("Too Few Arguments");
929     env->err= 1;
930     return;
931     }
932    
933     if(CAR(env->head)->type!=port) {
934     printerr("Bad Argument Type");
935     env->err= 2;
936     return;
937     }
938    
939     stream=CAR(env->head)->content.p;
940     readstream(env, stream); if(env->err) return;
941    
942     swap(env); if(env->err) return;
943     toss(env);
944     }
945    
946     #ifdef __linux__
947     extern void beep(environment *env)
948     {
949     int freq, dur, period, ticks;
950    
951     if(env->head->type==empty || CDR(env->head)->type==empty) {
952     printerr("Too Few Arguments");
953     env->err= 1;
954     return;
955     }
956    
957     if(CAR(env->head)->type!=integer
958     || CAR(CDR(env->head))->type!=integer) {
959     printerr("Bad Argument Type");
960     env->err= 2;
961     return;
962     }
963    
964     dur= CAR(env->head)->content.i;
965     toss(env);
966     freq= CAR(env->head)->content.i;
967     toss(env);
968    
969     period= 1193180/freq; /* convert freq from Hz to period
970     length */
971     ticks= dur*.001193180; /* convert duration from µseconds to
972     timer ticks */
973    
974     /* ticks=dur/1000; */
975    
976     /* if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
977     switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
978     case 0:
979     usleep(dur);
980     return;
981     case -1:
982     perror("beep");
983     env->err= 5;
984     return;
985     default:
986     abort();
987     }
988     }
989     #endif /* __linux__ */
990    
991     /* "wait" */
992     extern void sx_77616974(environment *env)
993     {
994     int dur;
995    
996     if(env->head->type==empty) {
997     printerr("Too Few Arguments");
998     env->err= 1;
999     return;
1000     }
1001    
1002     if(CAR(env->head)->type!=integer) {
1003     printerr("Bad Argument Type");
1004     env->err= 2;
1005     return;
1006     }
1007    
1008     dur= CAR(env->head)->content.i;
1009     toss(env);
1010    
1011     usleep(dur);
1012     }
1013    
1014     /* "*" */
1015     extern void sx_2a(environment *env)
1016     {
1017     int a, b;
1018     float fa, fb;
1019    
1020     if(env->head->type==empty || CDR(env->head)->type==empty) {
1021     printerr("Too Few Arguments");
1022     env->err= 1;
1023     return;
1024     }
1025    
1026     if(CAR(env->head)->type==integer
1027     && CAR(CDR(env->head))->type==integer) {
1028     a= CAR(env->head)->content.i;
1029     toss(env); if(env->err) return;
1030     b= CAR(env->head)->content.i;
1031     toss(env); if(env->err) return;
1032     push_int(env, b*a);
1033    
1034     return;
1035     }
1036    
1037     if(CAR(env->head)->type==tfloat
1038     && CAR(CDR(env->head))->type==tfloat) {
1039     fa= CAR(env->head)->content.f;
1040     toss(env); if(env->err) return;
1041     fb= CAR(env->head)->content.f;
1042     toss(env); if(env->err) return;
1043     push_float(env, fb*fa);
1044    
1045     return;
1046     }
1047    
1048     if(CAR(env->head)->type==tfloat
1049     && CAR(CDR(env->head))->type==integer) {
1050     fa= CAR(env->head)->content.f;
1051     toss(env); if(env->err) return;
1052     b= CAR(env->head)->content.i;
1053     toss(env); if(env->err) return;
1054     push_float(env, b*fa);
1055    
1056     return;
1057     }
1058    
1059     if(CAR(env->head)->type==integer
1060     && CAR(CDR(env->head))->type==tfloat) {
1061     a= CAR(env->head)->content.i;
1062     toss(env); if(env->err) return;
1063     fb= CAR(env->head)->content.f;
1064     toss(env); if(env->err) return;
1065     push_float(env, fb*a);
1066    
1067     return;
1068     }
1069    
1070     printerr("Bad Argument Type");
1071     env->err= 2;
1072     }
1073    
1074     /* "/" */
1075     extern void sx_2f(environment *env)
1076     {
1077     int a, b;
1078     float fa, fb;
1079    
1080     if(env->head->type==empty || CDR(env->head)->type==empty) {
1081     printerr("Too Few Arguments");
1082     env->err= 1;
1083     return;
1084     }
1085    
1086     if(CAR(env->head)->type==integer
1087     && CAR(CDR(env->head))->type==integer) {
1088     a= CAR(env->head)->content.i;
1089     toss(env); if(env->err) return;
1090     b= CAR(env->head)->content.i;
1091     toss(env); if(env->err) return;
1092     push_float(env, b/a);
1093    
1094     return;
1095     }
1096    
1097     if(CAR(env->head)->type==tfloat
1098     && CAR(CDR(env->head))->type==tfloat) {
1099     fa= CAR(env->head)->content.f;
1100     toss(env); if(env->err) return;
1101     fb= CAR(env->head)->content.f;
1102     toss(env); if(env->err) return;
1103     push_float(env, fb/fa);
1104    
1105     return;
1106     }
1107    
1108     if(CAR(env->head)->type==tfloat
1109     && CAR(CDR(env->head))->type==integer) {
1110     fa= CAR(env->head)->content.f;
1111     toss(env); if(env->err) return;
1112     b= CAR(env->head)->content.i;
1113     toss(env); if(env->err) return;
1114     push_float(env, b/fa);
1115    
1116     return;
1117     }
1118    
1119     if(CAR(env->head)->type==integer
1120     && CAR(CDR(env->head))->type==tfloat) {
1121     a= CAR(env->head)->content.i;
1122     toss(env); if(env->err) return;
1123     fb= CAR(env->head)->content.f;
1124     toss(env); if(env->err) return;
1125     push_float(env, fb/a);
1126    
1127     return;
1128     }
1129    
1130     printerr("Bad Argument Type");
1131     env->err= 2;
1132     }
1133    
1134     /* "mod" */
1135     extern void mod(environment *env)
1136     {
1137     int a, b;
1138    
1139     if(env->head->type==empty || CDR(env->head)->type==empty) {
1140     printerr("Too Few Arguments");
1141     env->err= 1;
1142     return;
1143     }
1144    
1145     if(CAR(env->head)->type==integer
1146     && CAR(CDR(env->head))->type==integer) {
1147     a= CAR(env->head)->content.i;
1148     toss(env); if(env->err) return;
1149     b= CAR(env->head)->content.i;
1150     toss(env); if(env->err) return;
1151     push_int(env, b%a);
1152    
1153     return;
1154     }
1155    
1156     printerr("Bad Argument Type");
1157     env->err= 2;
1158     }
1159    
1160     /* "div" */
1161     extern void sx_646976(environment *env)
1162     {
1163     int a, b;
1164    
1165     if(env->head->type==empty || CDR(env->head)->type==empty) {
1166     printerr("Too Few Arguments");
1167     env->err= 1;
1168     return;
1169     }
1170    
1171     if(CAR(env->head)->type==integer
1172     && CAR(CDR(env->head))->type==integer) {
1173     a= CAR(env->head)->content.i;
1174     toss(env); if(env->err) return;
1175     b= CAR(env->head)->content.i;
1176     toss(env); if(env->err) return;
1177     push_int(env, (int)b/a);
1178    
1179     return;
1180     }
1181    
1182     printerr("Bad Argument Type");
1183     env->err= 2;
1184     }
1185    
1186     extern void setcar(environment *env)
1187     {
1188     if(env->head->type==empty || CDR(env->head)->type==empty) {
1189     printerr("Too Few Arguments");
1190     env->err= 1;
1191     return;
1192     }
1193    
1194     if(CDR(env->head)->type!=tcons) {
1195     printerr("Bad Argument Type");
1196     env->err= 2;
1197     return;
1198     }
1199    
1200     CAR(CAR(CDR(env->head)))=CAR(env->head);
1201     toss(env);
1202     }
1203    
1204     extern void setcdr(environment *env)
1205     {
1206     if(env->head->type==empty || CDR(env->head)->type==empty) {
1207     printerr("Too Few Arguments");
1208     env->err= 1;
1209     return;
1210     }
1211    
1212     if(CDR(env->head)->type!=tcons) {
1213     printerr("Bad Argument Type");
1214     env->err= 2;
1215     return;
1216     }
1217    
1218     CDR(CAR(CDR(env->head)))=CAR(env->head);
1219     toss(env);
1220     }
1221    
1222     extern void car(environment *env)
1223     {
1224     if(env->head->type==empty) {
1225     printerr("Too Few Arguments");
1226     env->err= 1;
1227     return;
1228     }
1229    
1230     if(CAR(env->head)->type!=tcons) {
1231     printerr("Bad Argument Type");
1232     env->err= 2;
1233     return;
1234     }
1235    
1236     CAR(env->head)=CAR(CAR(env->head));
1237     }
1238    
1239     extern void cdr(environment *env)
1240     {
1241     if(env->head->type==empty) {
1242     printerr("Too Few Arguments");
1243     env->err= 1;
1244     return;
1245     }
1246    
1247     if(CAR(env->head)->type!=tcons) {
1248     printerr("Bad Argument Type");
1249     env->err= 2;
1250     return;
1251     }
1252    
1253     CAR(env->head)=CDR(CAR(env->head));
1254     }
1255    
1256     extern void cons(environment *env)
1257     {
1258     value *val;
1259    
1260     if(env->head->type==empty || CDR(env->head)->type==empty) {
1261     printerr("Too Few Arguments");
1262     env->err= 1;
1263     return;
1264     }
1265    
1266     val=new_val(env);
1267     val->content.c= malloc(sizeof(pair));
1268     assert(val->content.c!=NULL);
1269    
1270     env->gc_count += sizeof(pair);
1271     val->type=tcons;
1272    
1273     CAR(val)= CAR(CDR(env->head));
1274     CDR(val)= CAR(env->head);
1275    
1276     push_val(env, val);
1277    
1278     swap(env); if(env->err) return;
1279     toss(env); if(env->err) return;
1280     swap(env); if(env->err) return;
1281     toss(env); if(env->err) return;
1282     }
1283    
1284 masse 1.2
1285     /* General assoc function */
1286     void assocgen(environment *env, funcp eqfunc)
1287     {
1288     value *key, *item;
1289    
1290     /* Needs two values on the stack, the top one must be an association
1291     list */
1292     if(env->head->type==empty || CDR(env->head)->type==empty) {
1293     printerr("Too Few Arguments");
1294     env->err= 1;
1295     return;
1296     }
1297    
1298     if(CAR(env->head)->type!=tcons) {
1299     printerr("Bad Argument Type");
1300     env->err= 2;
1301     return;
1302     }
1303    
1304     key=CAR(CDR(env->head));
1305     item=CAR(env->head);
1306    
1307     while(item->type == tcons){
1308     if(CAR(item)->type != tcons){
1309     printerr("Bad Argument Type");
1310     env->err= 2;
1311     return;
1312     }
1313     push_val(env, key);
1314     push_val(env, CAR(CAR(item)));
1315     eqfunc(env); if(env->err) return;
1316    
1317     /* Check the result of 'eqfunc' */
1318     if(env->head->type==empty) {
1319     printerr("Too Few Arguments");
1320     env->err= 1;
1321     return;
1322     }
1323     if(CAR(env->head)->type!=integer) {
1324     printerr("Bad Argument Type");
1325     env->err= 2;
1326     return;
1327     }
1328    
1329     if(CAR(env->head)->content.i){
1330     toss(env); if(env->err) return;
1331     break;
1332     }
1333     toss(env); if(env->err) return;
1334    
1335     if(item->type!=tcons) {
1336     printerr("Bad Argument Type");
1337     env->err= 2;
1338     return;
1339     }
1340    
1341     item=CDR(item);
1342     }
1343    
1344     if(item->type == tcons){ /* A match was found */
1345     push_val(env, CAR(item));
1346     } else {
1347     push_int(env, 0);
1348     }
1349     swap(env); if(env->err) return;
1350     toss(env); if(env->err) return;
1351     swap(env); if(env->err) return;
1352     toss(env);
1353     }
1354    
1355    
1356 masse 1.1 /* 2: 3 => */
1357     /* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */
1358     extern void assq(environment *env)
1359     {
1360     assocgen(env, eq);
1361     }
1362    
1363    
1364     /* "do" */
1365     extern void sx_646f(environment *env)
1366     {
1367     swap(env); if(env->err) return;
1368     eval(env);
1369     }
1370    
1371     /* "open" */
1372     /* 2: "file" */
1373     /* 1: "r" => 1: #<port 0x47114711> */
1374     extern void sx_6f70656e(environment *env)
1375     {
1376     value *new_port;
1377     FILE *stream;
1378    
1379     if(env->head->type == empty || CDR(env->head)->type == empty) {
1380     printerr("Too Few Arguments");
1381     env->err=1;
1382     return;
1383     }
1384    
1385     if(CAR(env->head)->type != string
1386     || CAR(CDR(env->head))->type != string) {
1387     printerr("Bad Argument Type");
1388     env->err= 2;
1389     return;
1390     }
1391    
1392     stream=fopen(CAR(CDR(env->head))->content.ptr,
1393     CAR(env->head)->content.ptr);
1394    
1395     if(stream == NULL) {
1396     perror("open");
1397     env->err= 5;
1398     return;
1399     }
1400    
1401     new_port=new_val(env);
1402     new_port->type=port;
1403     new_port->content.p=stream;
1404    
1405     push_val(env, new_port);
1406    
1407     swap(env); if(env->err) return;
1408     toss(env); if(env->err) return;
1409     swap(env); if(env->err) return;
1410     toss(env);
1411     }
1412    
1413    
1414     /* "close" */
1415     extern void sx_636c6f7365(environment *env)
1416     {
1417     int ret;
1418    
1419     if(env->head->type == empty) {
1420     printerr("Too Few Arguments");
1421     env->err=1;
1422     return;
1423     }
1424    
1425     if(CAR(env->head)->type != port) {
1426     printerr("Bad Argument Type");
1427     env->err= 2;
1428     return;
1429     }
1430    
1431     ret= fclose(CAR(env->head)->content.p);
1432    
1433     if(ret != 0){
1434     perror("close");
1435     env->err= 5;
1436     return;
1437     }
1438    
1439     toss(env);
1440     }
1441 masse 1.4
1442     extern void mangle(environment *env)
1443     {
1444     char *new_string;
1445    
1446     if(env->head->type==empty) {
1447     printerr("Too Few Arguments");
1448     env->err= 1;
1449     return;
1450     }
1451    
1452     if(CAR(env->head)->type!=string) {
1453     printerr("Bad Argument Type");
1454     env->err= 2;
1455     return;
1456     }
1457    
1458     new_string= mangle_str(CAR(env->head)->content.string);
1459    
1460     toss(env);
1461     if(env->err) return;
1462    
1463     push_cstring(env, new_string);
1464     }
1465    
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26