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

Contents of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.7 - (show annotations)
Tue Aug 12 07:15:29 2003 UTC (20 years, 9 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 #include "stack.h"
2 #include "messages.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 switch(check_args(env, port, empty)) {
14 case 1:
15 printerr(env, "Too Few Arguments");
16 return;
17 case 2:
18 printerr(env, "Bad Argument Type");
19 return;
20 default:
21 break;
22 }
23
24 if(fprintf(CAR(env->head)->content.p, "\n") < 0){
25 perror("nl");
26 env->err= 5;
27 return;
28 }
29 toss(env);
30 }
31
32 /* Gets the type of a value */
33 extern void type(environment *env)
34 {
35
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 return;
43 default:
44 break;
45 }
46
47 switch(CAR(env->head)->type){
48 case empty:
49 push_sym(env, "empty");
50 break;
51 case unknown:
52 push_sym(env, "unknown");
53 break;
54 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
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 return;
92 default:
93 break;
94 }
95
96 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
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 return;
121 default:
122 break;
123 }
124
125 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
140 switch(check_args(env, port, unknown, empty)) {
141 case 1:
142 printerr(env, "Too Few Arguments");
143 return;
144 case 2:
145 printerr(env, "Bad Argument Type");
146 return;
147 default:
148 break;
149 }
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
168 switch(check_args(env, port, unknown, empty)) {
169 case 1:
170 printerr(env, "Too Few Arguments");
171 return;
172 case 2:
173 printerr(env, "Bad Argument Type");
174 return;
175 default:
176 break;
177 }
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
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 return;
203 default:
204 break;
205 }
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 switch(check_args(env, tcons, empty)) {
218 case 1:
219 printerr(env, "Too Few Arguments");
220 return;
221 case 2:
222 printerr(env, "Bad Argument Type");
223 return;
224 default:
225 break;
226 }
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 /// XXX
239 /* 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 printerr(env, "Bad Argument Type"); /* Improper list */
245 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 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 return;
268 default:
269 break;
270 }
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 switch(check_args(env, integer, empty)) {
285 case 1:
286 printerr(env, "Too Few Arguments");
287 return;
288 case 2:
289 printerr(env, "Bad Argument Type");
290 return;
291 default:
292 break;
293 }
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 switch(check_args(env, symb, unknown, empty)) {
314 case 1:
315 printerr(env, "Too Few Arguments");
316 return;
317 case 2:
318 printerr(env, "Bad Argument Type");
319 return;
320 default:
321 break;
322 }
323
324 /* long names are a pain */
325 sym= CAR(env->head)->content.sym;
326
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 env->head= new_val(env);
337 }
338
339 /* Forgets a symbol (remove it from the hash table) */
340 extern void forget(environment *env)
341 {
342 char* sym_id;
343
344 switch(check_args(env, symb, empty)) {
345 case 1:
346 printerr(env, "Too Few Arguments");
347 return;
348 case 2:
349 printerr(env, "Bad Argument Type");
350 return;
351 default:
352 break;
353 }
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 if(check_args(env, unknown, unknown, empty)==1) {
377 printerr(env, "Too Few Arguments");
378 return;
379 }
380
381 if(check_args(env, string, string, empty)==0) {
382 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 len= strlen(a_val->content.string)+strlen(b_val->content.string)+1;
388 new_string= malloc(len);
389 assert(new_string != NULL);
390 strcpy(new_string, b_val->content.string);
391 strcat(new_string, a_val->content.string);
392 push_cstring(env, new_string);
393 unprotect(a_val); unprotect(b_val);
394 free(new_string);
395
396 return;
397 }
398
399 if(check_args(env, integer, integer, empty)==0) {
400 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 if(check_args(env, tfloat, tfloat, empty)==0) {
410 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 if(check_args(env, tfloat, integer, empty)==0) {
420 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 if(check_args(env, integer, tfloat, empty)==0) {
430 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 printerr(env, "Bad Argument Type");
440 env->err=2;
441 }
442
443 /* "-" */
444 extern void sx_2d(environment *env)
445 {
446 int a, b;
447 float fa, fb;
448
449 if(check_args(env, unknown, unknown, empty)==1) {
450 printerr(env, "Too Few Arguments");
451 return;
452 }
453
454 if(check_args(env, integer, integer, empty)==0) {
455 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 if(check_args(env, tfloat, tfloat, empty)==0) {
465 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 if(check_args(env, tfloat, integer, empty)==0) {
475 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 if(check_args(env, integer, tfloat, empty)==0) {
485 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 printerr(env, "Bad Argument Type");
495 env->err=2;
496 }
497
498 /* ">" */
499 extern void sx_3e(environment *env)
500 {
501 int a, b;
502 float fa, fb;
503
504 if(check_args(env, unknown, unknown, empty)==1) {
505 printerr(env, "Too Few Arguments");
506 return;
507 }
508
509 if(check_args(env, integer, integer, empty)==0) {
510 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 if(check_args(env, tfloat, tfloat, empty)==0) {
520 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 if(check_args(env, tfloat, integer, empty)==0) {
530 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 if(check_args(env, integer, tfloat, empty)==0) {
540 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 printerr(env, "Bad Argument Type");
550 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 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 return;
584 default:
585 break;
586 }
587
588 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 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 return;
603 default:
604 break;
605 }
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 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 return;
633 default:
634 break;
635 }
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
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 return;
668 default:
669 break;
670 }
671
672 /// XXX
673
674 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 printerr(env, "Bad Argument Type");
679 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
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 return;
697 default:
698 break;
699 }
700
701 /// XXX
702
703 if(CAR(CDR(env->head))->type!=symb
704 || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
705 printerr(env, "Bad Argument Type");
706 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 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 return;
727 default:
728 break;
729 }
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
743 /// XXX
744
745 if(CAR(env->head)->type != integer) {
746 printerr(env, "Bad Argument Type");
747 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 switch(check_args(env, unknown, integer, integer, empty)) {
774 case 1:
775 printerr(env, "Too Few Arguments");
776 return;
777 case 2:
778 printerr(env, "Bad Argument Type");
779 return;
780 default:
781 break;
782 }
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
819 switch(check_args(env, unknown, tcons, empty)) {
820 case 1:
821 printerr(env, "Too Few Arguments");
822 return;
823 case 2:
824 printerr(env, "Bad Argument Type");
825 return;
826 default:
827 break;
828 }
829
830 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
845 /// XXX
846 if (iterator->type == tcons){
847 iterator= CDR(iterator);
848 } else {
849 printerr(env, "Bad Argument Type"); /* Improper list */
850 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 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 return;
870 default:
871 break;
872 }
873
874 end= new_val(env);
875
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 switch(check_args(env, port, empty)) {
930 case 1:
931 printerr(env, "Too Few Arguments");
932 return;
933 case 2:
934 printerr(env, "Bad Argument Type");
935 return;
936 default:
937 break;
938 }
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 switch(check_args(env, port, empty)) {
959 case 1:
960 printerr(env, "Too Few Arguments");
961 return;
962 case 2:
963 printerr(env, "Bad Argument Type");
964 return;
965 default:
966 break;
967 }
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 switch(check_args(env, integer, integer, empty)) {
982 case 1:
983 printerr(env, "Too Few Arguments");
984 return;
985 case 2:
986 printerr(env, "Bad Argument Type");
987 return;
988 default:
989 break;
990 }
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 switch(check_args(env, integer, empty)) {
1025 case 1:
1026 printerr(env, "Too Few Arguments");
1027 return;
1028 case 2:
1029 printerr(env, "Bad Argument Type");
1030 return;
1031 default:
1032 break;
1033 }
1034
1035 dur= CAR(env->head)->content.i;
1036 toss(env);
1037
1038 usleep(dur);
1039 }
1040
1041
1042 /* "*" */
1043 extern void sx_2a(environment *env)
1044 {
1045 int a, b;
1046 float fa, fb;
1047
1048 if(check_args(env, unknown, unknown, empty)==1) {
1049 printerr(env, "Too Few Arguments");
1050 return;
1051 }
1052
1053 if(check_args(env, integer, integer, empty)==0) {
1054 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 if(check_args(env, tfloat, tfloat, empty)==0) {
1064 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 if(check_args(env, tfloat, integer, empty)==0) {
1074 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 if(check_args(env, integer, tfloat, empty)==0) {
1084 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 printerr(env, "Bad Argument Type");
1094 env->err= 2;
1095 }
1096
1097 /* "/" */
1098 extern void sx_2f(environment *env)
1099 {
1100 int a, b;
1101 float fa, fb;
1102
1103 if(check_args(env, unknown, unknown, empty)==1) {
1104 printerr(env, "Too Few Arguments");
1105 return;
1106 }
1107
1108 if(check_args(env, integer, integer, empty)==0) {
1109 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 if(check_args(env, tfloat, tfloat, empty)==0) {
1119 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 if(check_args(env, tfloat, integer, empty)==0) {
1129 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 if(check_args(env, integer, tfloat, empty)==0) {
1139 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 printerr(env, "Bad Argument Type");
1149 env->err= 2;
1150 }
1151
1152 /* "mod" */
1153 extern void mod(environment *env)
1154 {
1155 int a, b;
1156
1157 if(check_args(env, unknown, unknown, empty)==1) {
1158 printerr(env, "Too Few Arguments");
1159 return;
1160 }
1161
1162 if(check_args(env, integer, integer, empty)==0) {
1163 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 printerr(env, "Bad Argument Type");
1173 env->err= 2;
1174 }
1175
1176 /* "div" */
1177 extern void sx_646976(environment *env)
1178 {
1179 int a, b;
1180
1181 if(check_args(env, unknown, unknown, empty)==1) {
1182 printerr(env, "Too Few Arguments");
1183 return;
1184 }
1185
1186 if(check_args(env, integer, integer, empty)==0) {
1187 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 printerr(env, "Bad Argument Type");
1197 env->err= 2;
1198 }
1199
1200
1201 extern void setcar(environment *env)
1202 {
1203
1204 switch(check_args(env, tcons, unknown, empty)) {
1205 case 1:
1206 printerr(env, "Too Few Arguments");
1207 return;
1208 case 2:
1209 printerr(env, "Bad Argument Type");
1210 return;
1211 default:
1212 break;
1213 }
1214
1215 CAR(CAR(CDR(env->head)))=CAR(env->head);
1216 toss(env);
1217 }
1218
1219 extern void setcdr(environment *env)
1220 {
1221
1222 switch(check_args(env, tcons, unknown, empty)) {
1223 case 1:
1224 printerr(env, "Too Few Arguments");
1225 return;
1226 case 2:
1227 printerr(env, "Bad Argument Type");
1228 return;
1229 default:
1230 break;
1231 }
1232
1233 CDR(CAR(CDR(env->head)))=CAR(env->head);
1234 toss(env);
1235 }
1236
1237 extern void car(environment *env)
1238 {
1239
1240 switch(check_args(env, tcons, empty)) {
1241 case 1:
1242 printerr(env, "Too Few Arguments");
1243 return;
1244 case 2:
1245 printerr(env, "Bad Argument Type");
1246 return;
1247 default:
1248 break;
1249 }
1250
1251 CAR(env->head)=CAR(CAR(env->head));
1252 }
1253
1254 extern void cdr(environment *env)
1255 {
1256
1257 switch(check_args(env, tcons, empty)) {
1258 case 1:
1259 printerr(env, "Too Few Arguments");
1260 return;
1261 case 2:
1262 printerr(env, "Bad Argument Type");
1263 return;
1264 default:
1265 break;
1266 }
1267
1268 CAR(env->head)=CDR(CAR(env->head));
1269 }
1270
1271 extern void cons(environment *env)
1272 {
1273 value *val;
1274
1275 switch(check_args(env, unknown, unknown, empty)) {
1276 case 1:
1277 printerr(env, "Too Few Arguments");
1278 return;
1279 case 2:
1280 printerr(env, "Bad Argument Type");
1281 return;
1282 default:
1283 break;
1284 }
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
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 switch(check_args(env, tcons, unknown, empty)) {
1313 case 1:
1314 printerr(env, "Too Few Arguments");
1315 return;
1316 case 2:
1317 printerr(env, "Bad Argument Type");
1318 return;
1319 default:
1320 break;
1321 }
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 printerr(env, "Bad Argument Type");
1329 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 printerr(env, "Too Few Arguments");
1339 env->err= 1;
1340 return;
1341 }
1342 if(CAR(env->head)->type!=integer) {
1343 printerr(env, "Bad Argument Type");
1344 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 printerr(env, "Bad Argument Type");
1356 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 /* 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 switch(check_args(env, string, string, empty)) {
1399 case 1:
1400 printerr(env, "Too Few Arguments");
1401 return;
1402 case 2:
1403 printerr(env, "Bad Argument Type");
1404 return;
1405 default:
1406 break;
1407 }
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 switch(check_args(env, port, empty)) {
1437 case 1:
1438 printerr(env, "Too Few Arguments");
1439 return;
1440 case 2:
1441 printerr(env, "Bad Argument Type");
1442 return;
1443 default:
1444 break;
1445 }
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
1458
1459 extern void mangle(environment *env)
1460 {
1461 char *new_string;
1462
1463 switch(check_args(env, string, empty)) {
1464 case 1:
1465 printerr(env, "Too Few Arguments");
1466 return;
1467 case 2:
1468 printerr(env, "Bad Argument Type");
1469 return;
1470 default:
1471 break;
1472 }
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 /* "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 switch(check_args(env, integer, empty)) {
1493 case 1:
1494 printerr(env, "Too Few Arguments");
1495 return;
1496 case 2:
1497 printerr(env, "Bad Argument Type");
1498 return;
1499 default:
1500 break;
1501 }
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
1512 switch(check_args(env, unknown, empty)) {
1513 case 1:
1514 printerr(env, "Too Few Arguments");
1515 return;
1516 case 2:
1517 printerr(env, "Bad Argument Type");
1518 return;
1519 default:
1520 break;
1521 }
1522
1523 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