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

Contents of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

Revision 1.5 - (show annotations)
Fri Aug 8 14:20:49 2003 UTC (20 years, 9 months ago) by masse
Branch: MAIN
Changes since 1.4: +126 -2 lines
File MIME type: text/plain 
stack.c: Trying to clean up. Moving big text mass to separate file.
Eliminating the use of function toss.
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 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.sym;
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 env->head= new_val(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 }
1441
1442 extern void mangle(environment *env)
1443 {
1444 char *new_string;
1445
1446 if(env->head->type==empty) {
1447 printerr("Too Few Arguments");
1448 env->err= 1;
1449 return;
1450 }
1451
1452 if(CAR(env->head)->type!=string) {
1453 printerr("Bad Argument Type");
1454 env->err= 2;
1455 return;
1456 }
1457
1458 new_string= mangle_str(CAR(env->head)->content.string);
1459
1460 toss(env);
1461 if(env->err) return;
1462
1463 push_cstring(env, new_string);
1464 }
1465
1466 /* "fork" */
1467 extern void sx_666f726b(environment *env)
1468 {
1469 push_int(env, fork());
1470 }
1471
1472 /* "waitpid" */
1473 extern void sx_77616974706964(environment *env)
1474 {
1475
1476 if(env->head->type==empty) {
1477 printerr("Too Few Arguments");
1478 env->err= 1;
1479 return;
1480 }
1481
1482 if(CAR(env->head)->type!=integer) {
1483 printerr("Bad Argument Type");
1484 env->err= 2;
1485 return;
1486 }
1487
1488 push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
1489 swap(env); toss(env);
1490 }
1491
1492
1493 /* Discard the top element of the stack. */
1494 extern void toss(environment *env)
1495 {
1496 if(env->head->type==empty) {
1497 printerr("Too Few Arguments");
1498 env->err= 1;
1499 return;
1500 }
1501
1502 env->head= CDR(env->head); /* Remove the top stack item */
1503 }
1504
1505
1506 /* Quit stack. */
1507 extern void quit(environment *env)
1508 {
1509 int i;
1510
1511 env->head= new_val(env);
1512
1513 if (env->err) return;
1514 for(i= 0; i<HASHTBLSIZE; i++) {
1515 while(env->symbols[i]!= NULL) {
1516 forget_sym(&(env->symbols[i]));
1517 }
1518 env->symbols[i]= NULL;
1519 }
1520
1521 env->gc_limit= 0;
1522 gc_maybe(env);
1523
1524 words(env);
1525
1526 if(env->free_string!=NULL)
1527 free(env->free_string);
1528
1529 #ifdef __linux__
1530 muntrace();
1531 #endif
1532
1533 exit(EXIT_SUCCESS);
1534 }
1535
1536
1537 /* List all defined words */
1538 extern void words(environment *env)
1539 {
1540 symbol *temp;
1541 int i;
1542
1543 for(i= 0; i<HASHTBLSIZE; i++) {
1544 temp= env->symbols[i];
1545 while(temp!=NULL) {
1546 #ifdef DEBUG
1547 if (temp->val != NULL && temp->val->gc.flag.protect)
1548 printf("(protected) ");
1549 #endif /* DEBUG */
1550 printf("%s ", temp->id);
1551 temp= temp->next;
1552 }
1553 }
1554 }
1555
1556
1557 /* Only to be called by itself function printstack. */
1558 void print_st(environment *env, value *stack_head, long counter)
1559 {
1560 if(CDR(stack_head)->type != empty)
1561 print_st(env, CDR(stack_head), counter+1);
1562 printf("%ld: ", counter);
1563 print_val(env, CAR(stack_head), 0, NULL, stdout);
1564 printf("\n");
1565 }
1566
1567
1568 /* Prints the stack. */
1569 extern void printstack(environment *env)
1570 {
1571 if(env->head->type == empty) {
1572 printf("Stack Empty\n");
1573 return;
1574 }
1575
1576 print_st(env, env->head, 1);
1577 }
1578
1579
1580 extern void copying(environment *env)
1581 {
1582 printf(license_message);
1583 }
1584
1585
1586 extern void warranty(environment *env)
1587 {
1588 printf(warranty_message);
1589 }
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26