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

Contents of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Thu Feb 19 15:35:38 2004 UTC (20 years, 3 months ago) by masse
Branch: MAIN
CVS Tags: HEAD
Changes since 1.10: +22 -0 lines
File MIME type: text/plain
Extracted garbage collector to gc.c

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

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26