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

Contents of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

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