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

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.7 - (hide annotations)
Tue Aug 12 07:15:29 2003 UTC (21 years, 2 months ago) by masse
Branch: MAIN
Changes since 1.6: +86 -95 lines
File MIME type: text/plain 
(check_args) Rewrote some functions to use check_args.
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
1042 masse 1.1 /* "*" */
1043     extern void sx_2a(environment *env)
1044     {
1045     int a, b;
1046     float fa, fb;
1047    
1048 masse 1.7 if(check_args(env, unknown, unknown, empty)==1) {
1049 masse 1.6 printerr(env, "Too Few Arguments");
1050 masse 1.1 return;
1051     }
1052 masse 1.7
1053     if(check_args(env, integer, integer, empty)==0) {
1054 masse 1.1 a= CAR(env->head)->content.i;
1055     toss(env); if(env->err) return;
1056     b= CAR(env->head)->content.i;
1057     toss(env); if(env->err) return;
1058     push_int(env, b*a);
1059    
1060     return;
1061     }
1062    
1063 masse 1.7 if(check_args(env, tfloat, tfloat, empty)==0) {
1064 masse 1.1 fa= CAR(env->head)->content.f;
1065     toss(env); if(env->err) return;
1066     fb= CAR(env->head)->content.f;
1067     toss(env); if(env->err) return;
1068     push_float(env, fb*fa);
1069    
1070     return;
1071     }
1072    
1073 masse 1.7 if(check_args(env, tfloat, integer, empty)==0) {
1074 masse 1.1 fa= CAR(env->head)->content.f;
1075     toss(env); if(env->err) return;
1076     b= CAR(env->head)->content.i;
1077     toss(env); if(env->err) return;
1078     push_float(env, b*fa);
1079    
1080     return;
1081     }
1082    
1083 masse 1.7 if(check_args(env, integer, tfloat, empty)==0) {
1084 masse 1.1 a= CAR(env->head)->content.i;
1085     toss(env); if(env->err) return;
1086     fb= CAR(env->head)->content.f;
1087     toss(env); if(env->err) return;
1088     push_float(env, fb*a);
1089    
1090     return;
1091     }
1092    
1093 masse 1.6 printerr(env, "Bad Argument Type");
1094 masse 1.1 env->err= 2;
1095     }
1096    
1097     /* "/" */
1098     extern void sx_2f(environment *env)
1099     {
1100     int a, b;
1101     float fa, fb;
1102    
1103 masse 1.7 if(check_args(env, unknown, unknown, empty)==1) {
1104 masse 1.6 printerr(env, "Too Few Arguments");
1105 masse 1.1 return;
1106     }
1107 masse 1.7
1108     if(check_args(env, integer, integer, empty)==0) {
1109 masse 1.1 a= CAR(env->head)->content.i;
1110     toss(env); if(env->err) return;
1111     b= CAR(env->head)->content.i;
1112     toss(env); if(env->err) return;
1113     push_float(env, b/a);
1114    
1115     return;
1116     }
1117    
1118 masse 1.7 if(check_args(env, tfloat, tfloat, empty)==0) {
1119 masse 1.1 fa= CAR(env->head)->content.f;
1120     toss(env); if(env->err) return;
1121     fb= CAR(env->head)->content.f;
1122     toss(env); if(env->err) return;
1123     push_float(env, fb/fa);
1124    
1125     return;
1126     }
1127    
1128 masse 1.7 if(check_args(env, tfloat, integer, empty)==0) {
1129 masse 1.1 fa= CAR(env->head)->content.f;
1130     toss(env); if(env->err) return;
1131     b= CAR(env->head)->content.i;
1132     toss(env); if(env->err) return;
1133     push_float(env, b/fa);
1134    
1135     return;
1136     }
1137    
1138 masse 1.7 if(check_args(env, integer, tfloat, empty)==0) {
1139 masse 1.1 a= CAR(env->head)->content.i;
1140     toss(env); if(env->err) return;
1141     fb= CAR(env->head)->content.f;
1142     toss(env); if(env->err) return;
1143     push_float(env, fb/a);
1144    
1145     return;
1146     }
1147    
1148 masse 1.6 printerr(env, "Bad Argument Type");
1149 masse 1.1 env->err= 2;
1150     }
1151    
1152     /* "mod" */
1153     extern void mod(environment *env)
1154     {
1155     int a, b;
1156    
1157 masse 1.7 if(check_args(env, unknown, unknown, empty)==1) {
1158 masse 1.6 printerr(env, "Too Few Arguments");
1159 masse 1.1 return;
1160     }
1161 masse 1.7
1162     if(check_args(env, integer, integer, empty)==0) {
1163 masse 1.1 a= CAR(env->head)->content.i;
1164     toss(env); if(env->err) return;
1165     b= CAR(env->head)->content.i;
1166     toss(env); if(env->err) return;
1167     push_int(env, b%a);
1168    
1169     return;
1170     }
1171    
1172 masse 1.6 printerr(env, "Bad Argument Type");
1173 masse 1.1 env->err= 2;
1174     }
1175    
1176     /* "div" */
1177     extern void sx_646976(environment *env)
1178     {
1179     int a, b;
1180 masse 1.7
1181     if(check_args(env, unknown, unknown, empty)==1) {
1182 masse 1.6 printerr(env, "Too Few Arguments");
1183 masse 1.1 return;
1184     }
1185 masse 1.7
1186     if(check_args(env, integer, integer, empty)==0) {
1187 masse 1.1 a= CAR(env->head)->content.i;
1188     toss(env); if(env->err) return;
1189     b= CAR(env->head)->content.i;
1190     toss(env); if(env->err) return;
1191     push_int(env, (int)b/a);
1192    
1193     return;
1194     }
1195    
1196 masse 1.6 printerr(env, "Bad Argument Type");
1197 masse 1.1 env->err= 2;
1198     }
1199    
1200 masse 1.7
1201 masse 1.1 extern void setcar(environment *env)
1202     {
1203 masse 1.7
1204     switch(check_args(env, tcons, unknown, empty)) {
1205     case 1:
1206 masse 1.6 printerr(env, "Too Few Arguments");
1207 masse 1.1 return;
1208 masse 1.7 case 2:
1209 masse 1.6 printerr(env, "Bad Argument Type");
1210 masse 1.1 return;
1211 masse 1.7 default:
1212     break;
1213 masse 1.1 }
1214    
1215     CAR(CAR(CDR(env->head)))=CAR(env->head);
1216     toss(env);
1217     }
1218    
1219     extern void setcdr(environment *env)
1220     {
1221 masse 1.7
1222     switch(check_args(env, tcons, unknown, empty)) {
1223     case 1:
1224 masse 1.6 printerr(env, "Too Few Arguments");
1225 masse 1.1 return;
1226 masse 1.7 case 2:
1227 masse 1.6 printerr(env, "Bad Argument Type");
1228 masse 1.1 return;
1229 masse 1.7 default:
1230     break;
1231 masse 1.1 }
1232    
1233     CDR(CAR(CDR(env->head)))=CAR(env->head);
1234     toss(env);
1235     }
1236    
1237     extern void car(environment *env)
1238     {
1239 masse 1.7
1240     switch(check_args(env, tcons, empty)) {
1241     case 1:
1242 masse 1.6 printerr(env, "Too Few Arguments");
1243 masse 1.1 return;
1244 masse 1.7 case 2:
1245 masse 1.6 printerr(env, "Bad Argument Type");
1246 masse 1.1 return;
1247 masse 1.7 default:
1248     break;
1249 masse 1.1 }
1250    
1251     CAR(env->head)=CAR(CAR(env->head));
1252     }
1253    
1254     extern void cdr(environment *env)
1255     {
1256 masse 1.7
1257     switch(check_args(env, tcons, empty)) {
1258     case 1:
1259 masse 1.6 printerr(env, "Too Few Arguments");
1260 masse 1.1 return;
1261 masse 1.7 case 2:
1262 masse 1.6 printerr(env, "Bad Argument Type");
1263 masse 1.1 return;
1264 masse 1.7 default:
1265     break;
1266 masse 1.1 }
1267    
1268     CAR(env->head)=CDR(CAR(env->head));
1269     }
1270    
1271     extern void cons(environment *env)
1272     {
1273     value *val;
1274    
1275 masse 1.7 switch(check_args(env, unknown, unknown, empty)) {
1276     case 1:
1277 masse 1.6 printerr(env, "Too Few Arguments");
1278 masse 1.1 return;
1279 masse 1.7 case 2:
1280     printerr(env, "Bad Argument Type");
1281     return;
1282     default:
1283     break;
1284 masse 1.1 }
1285    
1286     val=new_val(env);
1287     val->content.c= malloc(sizeof(pair));
1288     assert(val->content.c!=NULL);
1289    
1290     env->gc_count += sizeof(pair);
1291     val->type=tcons;
1292    
1293     CAR(val)= CAR(CDR(env->head));
1294     CDR(val)= CAR(env->head);
1295    
1296     push_val(env, val);
1297    
1298     swap(env); if(env->err) return;
1299     toss(env); if(env->err) return;
1300     swap(env); if(env->err) return;
1301     toss(env); if(env->err) return;
1302     }
1303    
1304 masse 1.2
1305     /* General assoc function */
1306     void assocgen(environment *env, funcp eqfunc)
1307     {
1308     value *key, *item;
1309    
1310     /* Needs two values on the stack, the top one must be an association
1311     list */
1312 masse 1.7 switch(check_args(env, tcons, unknown, empty)) {
1313     case 1:
1314 masse 1.6 printerr(env, "Too Few Arguments");
1315 masse 1.2 return;
1316 masse 1.7 case 2:
1317 masse 1.6 printerr(env, "Bad Argument Type");
1318 masse 1.2 return;
1319 masse 1.7 default:
1320     break;
1321 masse 1.2 }
1322    
1323     key=CAR(CDR(env->head));
1324     item=CAR(env->head);
1325    
1326     while(item->type == tcons){
1327     if(CAR(item)->type != tcons){
1328 masse 1.6 printerr(env, "Bad Argument Type");
1329 masse 1.2 env->err= 2;
1330     return;
1331     }
1332     push_val(env, key);
1333     push_val(env, CAR(CAR(item)));
1334     eqfunc(env); if(env->err) return;
1335    
1336     /* Check the result of 'eqfunc' */
1337     if(env->head->type==empty) {
1338 masse 1.6 printerr(env, "Too Few Arguments");
1339 masse 1.2 env->err= 1;
1340     return;
1341     }
1342     if(CAR(env->head)->type!=integer) {
1343 masse 1.6 printerr(env, "Bad Argument Type");
1344 masse 1.2 env->err= 2;
1345     return;
1346     }
1347    
1348     if(CAR(env->head)->content.i){
1349     toss(env); if(env->err) return;
1350     break;
1351     }
1352     toss(env); if(env->err) return;
1353    
1354     if(item->type!=tcons) {
1355 masse 1.6 printerr(env, "Bad Argument Type");
1356 masse 1.2 env->err= 2;
1357     return;
1358     }
1359    
1360     item=CDR(item);
1361     }
1362    
1363     if(item->type == tcons){ /* A match was found */
1364     push_val(env, CAR(item));
1365     } else {
1366     push_int(env, 0);
1367     }
1368     swap(env); if(env->err) return;
1369     toss(env); if(env->err) return;
1370     swap(env); if(env->err) return;
1371     toss(env);
1372     }
1373    
1374    
1375 masse 1.1 /* 2: 3 => */
1376     /* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */
1377     extern void assq(environment *env)
1378     {
1379     assocgen(env, eq);
1380     }
1381    
1382    
1383     /* "do" */
1384     extern void sx_646f(environment *env)
1385     {
1386     swap(env); if(env->err) return;
1387     eval(env);
1388     }
1389    
1390     /* "open" */
1391     /* 2: "file" */
1392     /* 1: "r" => 1: #<port 0x47114711> */
1393     extern void sx_6f70656e(environment *env)
1394     {
1395     value *new_port;
1396     FILE *stream;
1397    
1398 masse 1.7 switch(check_args(env, string, string, empty)) {
1399     case 1:
1400 masse 1.6 printerr(env, "Too Few Arguments");
1401 masse 1.1 return;
1402 masse 1.7 case 2:
1403 masse 1.6 printerr(env, "Bad Argument Type");
1404 masse 1.1 return;
1405 masse 1.7 default:
1406     break;
1407 masse 1.1 }
1408    
1409     stream=fopen(CAR(CDR(env->head))->content.ptr,
1410     CAR(env->head)->content.ptr);
1411    
1412     if(stream == NULL) {
1413     perror("open");
1414     env->err= 5;
1415     return;
1416     }
1417    
1418     new_port=new_val(env);
1419     new_port->type=port;
1420     new_port->content.p=stream;
1421    
1422     push_val(env, new_port);
1423    
1424     swap(env); if(env->err) return;
1425     toss(env); if(env->err) return;
1426     swap(env); if(env->err) return;
1427     toss(env);
1428     }
1429    
1430    
1431     /* "close" */
1432     extern void sx_636c6f7365(environment *env)
1433     {
1434     int ret;
1435    
1436 masse 1.7 switch(check_args(env, port, empty)) {
1437     case 1:
1438 masse 1.6 printerr(env, "Too Few Arguments");
1439 masse 1.1 return;
1440 masse 1.7 case 2:
1441 masse 1.6 printerr(env, "Bad Argument Type");
1442 masse 1.1 return;
1443 masse 1.7 default:
1444     break;
1445 masse 1.1 }
1446    
1447     ret= fclose(CAR(env->head)->content.p);
1448    
1449     if(ret != 0){
1450     perror("close");
1451     env->err= 5;
1452     return;
1453     }
1454    
1455     toss(env);
1456     }
1457 masse 1.4
1458 masse 1.7
1459 masse 1.4 extern void mangle(environment *env)
1460     {
1461     char *new_string;
1462    
1463 masse 1.7 switch(check_args(env, string, empty)) {
1464     case 1:
1465 masse 1.6 printerr(env, "Too Few Arguments");
1466 masse 1.4 return;
1467 masse 1.7 case 2:
1468 masse 1.6 printerr(env, "Bad Argument Type");
1469 masse 1.4 return;
1470 masse 1.7 default:
1471     break;
1472 masse 1.4 }
1473    
1474     new_string= mangle_str(CAR(env->head)->content.string);
1475    
1476     toss(env);
1477     if(env->err) return;
1478    
1479     push_cstring(env, new_string);
1480     }
1481    
1482 masse 1.5 /* "fork" */
1483     extern void sx_666f726b(environment *env)
1484     {
1485     push_int(env, fork());
1486     }
1487    
1488     /* "waitpid" */
1489     extern void sx_77616974706964(environment *env)
1490     {
1491    
1492 masse 1.7 switch(check_args(env, integer, empty)) {
1493     case 1:
1494 masse 1.6 printerr(env, "Too Few Arguments");
1495 masse 1.5 return;
1496 masse 1.7 case 2:
1497 masse 1.6 printerr(env, "Bad Argument Type");
1498 masse 1.5 return;
1499 masse 1.7 default:
1500     break;
1501 masse 1.5 }
1502    
1503     push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
1504     swap(env); toss(env);
1505     }
1506    
1507    
1508     /* Discard the top element of the stack. */
1509     extern void toss(environment *env)
1510     {
1511 masse 1.7
1512     switch(check_args(env, unknown, empty)) {
1513     case 1:
1514 masse 1.6 printerr(env, "Too Few Arguments");
1515 masse 1.5 return;
1516 masse 1.7 case 2:
1517     printerr(env, "Bad Argument Type");
1518     return;
1519     default:
1520     break;
1521 masse 1.5 }
1522 masse 1.7
1523 masse 1.5 env->head= CDR(env->head); /* Remove the top stack item */
1524     }
1525    
1526    
1527     /* Quit stack. */
1528     extern void quit(environment *env)
1529     {
1530     int i;
1531    
1532     env->head= new_val(env);
1533    
1534     if (env->err) return;
1535     for(i= 0; i<HASHTBLSIZE; i++) {
1536     while(env->symbols[i]!= NULL) {
1537     forget_sym(&(env->symbols[i]));
1538     }
1539     env->symbols[i]= NULL;
1540     }
1541    
1542     env->gc_limit= 0;
1543     gc_maybe(env);
1544    
1545     words(env);
1546    
1547     if(env->free_string!=NULL)
1548     free(env->free_string);
1549    
1550     #ifdef __linux__
1551     muntrace();
1552     #endif
1553    
1554     exit(EXIT_SUCCESS);
1555     }
1556    
1557    
1558     /* List all defined words */
1559     extern void words(environment *env)
1560     {
1561     symbol *temp;
1562     int i;
1563    
1564     for(i= 0; i<HASHTBLSIZE; i++) {
1565     temp= env->symbols[i];
1566     while(temp!=NULL) {
1567     #ifdef DEBUG
1568     if (temp->val != NULL && temp->val->gc.flag.protect)
1569     printf("(protected) ");
1570     #endif /* DEBUG */
1571     printf("%s ", temp->id);
1572     temp= temp->next;
1573     }
1574     }
1575     }
1576    
1577    
1578     /* Only to be called by itself function printstack. */
1579     void print_st(environment *env, value *stack_head, long counter)
1580     {
1581     if(CDR(stack_head)->type != empty)
1582     print_st(env, CDR(stack_head), counter+1);
1583     printf("%ld: ", counter);
1584     print_val(env, CAR(stack_head), 0, NULL, stdout);
1585     printf("\n");
1586     }
1587    
1588    
1589     /* Prints the stack. */
1590     extern void printstack(environment *env)
1591     {
1592     if(env->head->type == empty) {
1593     printf("Stack Empty\n");
1594     return;
1595     }
1596    
1597     print_st(env, env->head, 1);
1598     }
1599    
1600    
1601     extern void copying(environment *env)
1602     {
1603     printf(license_message);
1604     }
1605    
1606    
1607     extern void warranty(environment *env)
1608     {
1609     printf(warranty_message);
1610     }
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26