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

Contents of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

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