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

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

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