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

Annotation of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log

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