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

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Thu Feb 19 15:35:38 2004 UTC (20 years, 8 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 masse 1.11 /*
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 masse 1.1 #include "stack.h"
24 masse 1.5 #include "messages.h"
25 masse 1.1
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 masse 1.10 if(check_args(env, 1, port))
36 masse 1.9 return printerr(env);
37 masse 1.1
38 masse 1.10 if(fprintf(CAR(env->head)->content.p, "\n") < 0) {
39 masse 1.1 env->err= 5;
40 masse 1.10 return printerr(env);
41 masse 1.1 }
42 masse 1.10
43 masse 1.1 toss(env);
44     }
45    
46     /* Gets the type of a value */
47     extern void type(environment *env)
48     {
49 masse 1.6
50 masse 1.10 if(check_args(env, 1, unknown))
51 masse 1.9 return printerr(env);
52 masse 1.1
53     switch(CAR(env->head)->type){
54     case empty:
55     push_sym(env, "empty");
56     break;
57 masse 1.6 case unknown:
58     push_sym(env, "unknown");
59     break;
60 masse 1.1 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 masse 1.6
91 masse 1.10 if(check_args(env, 1, unknown))
92 masse 1.9 return printerr(env);
93 masse 1.6
94 masse 1.1 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 masse 1.6
112 masse 1.10 if(check_args(env, 1, unknown))
113 masse 1.9 return printerr(env);
114 masse 1.6
115 masse 1.1 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 masse 1.6
130 masse 1.10 if(check_args(env, 2, port, unknown))
131 masse 1.9 return printerr(env);
132 masse 1.1
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 masse 1.6
150 masse 1.10 if(check_args(env, 2, port, unknown))
151 masse 1.9 return printerr(env);
152 masse 1.1
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 masse 1.6
170 masse 1.10 if(check_args(env, 3, unknown, unknown, unknown))
171 masse 1.9 return printerr(env);
172 masse 1.1
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 masse 1.10 if(check_args(env, 1, tcons))
184 masse 1.9 return printerr(env);
185 masse 1.1
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 masse 1.6 /// XXX
197 masse 1.1 /* 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 masse 1.9 env->err= 2; /* Improper list */
203     return printerr(env);
204 masse 1.1 }
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 masse 1.10 if(check_args(env, 2, unknown, unknown))
219 masse 1.9 return printerr(env);
220 masse 1.1
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 masse 1.10 if(check_args(env, 1, integer))
234 masse 1.9 return printerr(env);
235 masse 1.1
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 masse 1.10 if(check_args(env, 2, symb, unknown))
255 masse 1.9 return printerr(env);
256 masse 1.1
257     /* long names are a pain */
258 masse 1.3 sym= CAR(env->head)->content.sym;
259 masse 1.1
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 masse 1.5 env->head= new_val(env);
270 masse 1.1 }
271    
272     /* Forgets a symbol (remove it from the hash table) */
273     extern void forget(environment *env)
274     {
275     char* sym_id;
276    
277 masse 1.10 if(check_args(env, 1, symb))
278 masse 1.9 return printerr(env);
279 masse 1.1
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 masse 1.10 if(check_args(env, 2, string, string)==0) {
302 masse 1.1 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 masse 1.3 len= strlen(a_val->content.string)+strlen(b_val->content.string)+1;
308 masse 1.1 new_string= malloc(len);
309     assert(new_string != NULL);
310 masse 1.3 strcpy(new_string, b_val->content.string);
311     strcat(new_string, a_val->content.string);
312 masse 1.1 push_cstring(env, new_string);
313     unprotect(a_val); unprotect(b_val);
314     free(new_string);
315    
316     return;
317     }
318    
319 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
320 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, tfloat)==0) {
330 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, integer)==0) {
340 masse 1.1 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 masse 1.10 if(check_args(env, 2, integer, tfloat)==0) {
350 masse 1.1 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 masse 1.9 return printerr(env);
360 masse 1.1 }
361    
362     /* "-" */
363     extern void sx_2d(environment *env)
364     {
365     int a, b;
366     float fa, fb;
367    
368 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
369 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, tfloat)==0) {
379 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, integer)==0) {
389 masse 1.1 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 masse 1.10 if(check_args(env, 2, integer, tfloat)==0) {
399 masse 1.1 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 masse 1.9 return printerr(env);
409 masse 1.1 }
410    
411     /* ">" */
412     extern void sx_3e(environment *env)
413     {
414     int a, b;
415     float fa, fb;
416    
417 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
418 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, tfloat)==0) {
428 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, integer)==0) {
438 masse 1.1 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 masse 1.10 if(check_args(env, 2, integer, tfloat)==0) {
448 masse 1.1 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 masse 1.9 return printerr(env);
458 masse 1.1 }
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 masse 1.10 if(check_args(env, 1, unknown))
485 masse 1.9 return printerr(env);
486 masse 1.6
487 masse 1.1 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 masse 1.10 if(check_args(env, 2, unknown, integer))
496 masse 1.9 return printerr(env);
497 masse 1.1
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 masse 1.10 if(check_args(env, 3, unknown, unknown, integer))
518 masse 1.9 return printerr(env);
519 masse 1.1
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 masse 1.6
542 masse 1.10 if(check_args(env, 5, unknown, symb, unknown, symb, integer))
543 masse 1.9 return printerr(env);
544 masse 1.1
545 masse 1.6 /// XXX
546    
547 masse 1.1 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 masse 1.9 return printerr(env);
553 masse 1.1 }
554    
555     swap(env); toss(env); rot(env); toss(env);
556     ifelse(env);
557     }
558    
559     extern void then(environment *env)
560     {
561 masse 1.6
562 masse 1.10 if(check_args(env, 3, unknown, symb, integer))
563 masse 1.9 return printerr(env);
564 masse 1.1
565 masse 1.6 /// XXX
566    
567 masse 1.1 if(CAR(CDR(env->head))->type!=symb
568     || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
569     env->err= 2;
570 masse 1.9 return printerr(env);
571 masse 1.1 }
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 masse 1.10 if(check_args(env, 2, unknown, integer))
584 masse 1.9 return printerr(env);
585 masse 1.1
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 masse 1.6
598     /// XXX
599 masse 1.1
600     if(CAR(env->head)->type != integer) {
601     env->err= 2;
602 masse 1.9 return printerr(env);
603 masse 1.1 }
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 masse 1.10 if(check_args(env, 3, unknown, integer, integer))
628 masse 1.9 return printerr(env);
629 masse 1.1
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 masse 1.6
665 masse 1.10 if(check_args(env, 2, unknown, tcons))
666 masse 1.9 return printerr(env);
667 masse 1.6
668 masse 1.1 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 masse 1.6
683     /// XXX
684 masse 1.1 if (iterator->type == tcons){
685     iterator= CDR(iterator);
686     } else {
687 masse 1.9 env->err= 2; /* Improper list */
688 masse 1.1 break;
689     }
690     }
691     unprotect(loop); unprotect(foo);
692 masse 1.9
693     return printerr(env);
694 masse 1.1 }
695    
696     /* "to" */
697     extern void to(environment *env)
698     {
699     int ending, start, i;
700     value *iterator, *temp, *end;
701    
702 masse 1.10 if(check_args(env, 2, integer, integer))
703 masse 1.9 return printerr(env);
704 masse 1.1
705 masse 1.6 end= new_val(env);
706 masse 1.1
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 masse 1.10 if(check_args(env, 1, port))
761 masse 1.9 return printerr(env);
762 masse 1.1
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 masse 1.10 if(check_args(env, 1, port))
782 masse 1.9 return printerr(env);
783 masse 1.1
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 masse 1.10 if(check_args(env, 2, integer, integer))
797 masse 1.9 return printerr(env);
798 masse 1.1
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 masse 1.10 return printerr(env);
819 masse 1.1 default:
820     abort();
821     }
822     }
823     #endif /* __linux__ */
824    
825     /* "wait" */
826     extern void sx_77616974(environment *env)
827     {
828     int dur;
829    
830 masse 1.10 if(check_args(env, 1, integer))
831 masse 1.9 return printerr(env);
832 masse 1.1
833     dur= CAR(env->head)->content.i;
834     toss(env);
835    
836     usleep(dur);
837     }
838    
839 masse 1.6
840 masse 1.1 /* "*" */
841     extern void sx_2a(environment *env)
842     {
843     int a, b;
844     float fa, fb;
845    
846 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
847 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, tfloat)==0) {
857 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, integer)==0) {
867 masse 1.1 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 masse 1.10 if(check_args(env, 2, integer, tfloat)==0) {
877 masse 1.1 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 masse 1.9 return printerr(env);
887 masse 1.1 }
888    
889     /* "/" */
890     extern void sx_2f(environment *env)
891     {
892     int a, b;
893     float fa, fb;
894    
895 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
896 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, tfloat)==0) {
906 masse 1.1 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 masse 1.10 if(check_args(env, 2, tfloat, integer)==0) {
916 masse 1.1 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 masse 1.10 if(check_args(env, 2, integer, tfloat)==0) {
926 masse 1.1 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 masse 1.9 return printerr(env);
936 masse 1.1 }
937    
938     /* "mod" */
939     extern void mod(environment *env)
940     {
941     int a, b;
942    
943 masse 1.10 if(check_args(env, 2, integer, integer)==0) {
944 masse 1.1 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 masse 1.9 return printerr(env);
954 masse 1.1 }
955    
956 masse 1.9
957 masse 1.1 /* "div" */
958     extern void sx_646976(environment *env)
959     {
960     int a, b;
961 masse 1.7
962 masse 1.10 if(check_args(env, 2, integer, integer))
963 masse 1.9 return printerr(env);
964 masse 1.7
965 masse 1.9 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 masse 1.1 }
971    
972 masse 1.7
973 masse 1.1 extern void setcar(environment *env)
974     {
975 masse 1.7
976 masse 1.10 if(check_args(env, 2, tcons, unknown))
977 masse 1.9 return printerr(env);
978 masse 1.1
979     CAR(CAR(CDR(env->head)))=CAR(env->head);
980     toss(env);
981     }
982    
983     extern void setcdr(environment *env)
984     {
985 masse 1.7
986 masse 1.10 if(check_args(env, 2, tcons, unknown))
987 masse 1.9 return printerr(env);
988 masse 1.1
989     CDR(CAR(CDR(env->head)))=CAR(env->head);
990     toss(env);
991     }
992    
993     extern void car(environment *env)
994     {
995 masse 1.7
996 masse 1.10 if(check_args(env, 1, tcons))
997 masse 1.9 return printerr(env);
998 masse 1.1
999     CAR(env->head)=CAR(CAR(env->head));
1000     }
1001    
1002     extern void cdr(environment *env)
1003     {
1004 masse 1.7
1005 masse 1.10 if(check_args(env, 1, tcons))
1006 masse 1.9 return printerr(env);
1007 masse 1.1
1008     CAR(env->head)=CDR(CAR(env->head));
1009     }
1010    
1011     extern void cons(environment *env)
1012     {
1013     value *val;
1014    
1015 masse 1.10 if(check_args(env, 2, unknown, unknown))
1016 masse 1.9 return printerr(env);
1017 masse 1.1
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 masse 1.9 toss(env);
1034 masse 1.1 }
1035    
1036 masse 1.2
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 masse 1.10 if(check_args(env, 2, tcons, unknown))
1045 masse 1.9 return printerr(env);
1046 masse 1.2
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 masse 1.9 return printerr(env);
1054 masse 1.2 }
1055 masse 1.9
1056 masse 1.2 push_val(env, key);
1057     push_val(env, CAR(CAR(item)));
1058 masse 1.9 eqfunc((void*)env); if(env->err) return;
1059 masse 1.2
1060     /* Check the result of 'eqfunc' */
1061 masse 1.10 if(check_args(env, 1, integer))
1062 masse 1.9 return printerr(env);
1063 masse 1.2
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 masse 1.9 return printerr(env);
1073 masse 1.2 }
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 masse 1.1 /* 2: 3 => */
1091     /* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */
1092     extern void assq(environment *env)
1093     {
1094 masse 1.9 assocgen(env, (void*)eq);
1095 masse 1.1 }
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 masse 1.10 if(check_args(env, 2, string, string))
1114 masse 1.9 return printerr(env);
1115 masse 1.1
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 masse 1.10 return printerr(env);
1122 masse 1.1 }
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 masse 1.10 if(check_args(env, 1, port))
1143 masse 1.9 return printerr(env);
1144 masse 1.1
1145     ret= fclose(CAR(env->head)->content.p);
1146    
1147     if(ret != 0){
1148     env->err= 5;
1149 masse 1.10 return printerr(env);
1150 masse 1.1 }
1151    
1152     toss(env);
1153     }
1154 masse 1.4
1155 masse 1.7
1156 masse 1.4 extern void mangle(environment *env)
1157     {
1158     char *new_string;
1159    
1160 masse 1.10 if(check_args(env, 1, string))
1161 masse 1.9 return printerr(env);
1162 masse 1.4
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 masse 1.5 /* "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 masse 1.10 if(check_args(env, 1, integer))
1182 masse 1.9 return printerr(env);
1183 masse 1.5
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 masse 1.7
1193 masse 1.10 if(check_args(env, 1, unknown))
1194 masse 1.9 return printerr(env);
1195 masse 1.7
1196 masse 1.5 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 masse 1.8 puts(license_message);
1277 masse 1.5 }
1278    
1279    
1280     extern void warranty(environment *env)
1281     {
1282 masse 1.8 puts(warranty_message);
1283 masse 1.10 }
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 masse 1.5 }

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26