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

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

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