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" |
#include "stack.h" |
24 |
#include "messages.h" |
#include "messages.h" |
25 |
|
|
32 |
/* Print a newline to a port */ |
/* Print a newline to a port */ |
33 |
extern void nlport(environment *env) |
extern void nlport(environment *env) |
34 |
{ |
{ |
35 |
if(check_args(env, port, empty)) |
if(check_args(env, 1, port)) |
36 |
return printerr(env); |
return printerr(env); |
37 |
|
|
38 |
if(fprintf(CAR(env->head)->content.p, "\n") < 0){ |
if(fprintf(CAR(env->head)->content.p, "\n") < 0) { |
|
perror("nl"); |
|
39 |
env->err= 5; |
env->err= 5; |
40 |
return; |
return printerr(env); |
41 |
} |
} |
42 |
|
|
43 |
toss(env); |
toss(env); |
44 |
} |
} |
45 |
|
|
47 |
extern void type(environment *env) |
extern void type(environment *env) |
48 |
{ |
{ |
49 |
|
|
50 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
51 |
return printerr(env); |
return printerr(env); |
52 |
|
|
53 |
switch(CAR(env->head)->type){ |
switch(CAR(env->head)->type){ |
88 |
extern void print_(environment *env) |
extern void print_(environment *env) |
89 |
{ |
{ |
90 |
|
|
91 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
92 |
return printerr(env); |
return printerr(env); |
93 |
|
|
94 |
print_val(env, CAR(env->head), 0, NULL, stdout); |
print_val(env, CAR(env->head), 0, NULL, stdout); |
109 |
extern void princ_(environment *env) |
extern void princ_(environment *env) |
110 |
{ |
{ |
111 |
|
|
112 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
113 |
return printerr(env); |
return printerr(env); |
114 |
|
|
115 |
print_val(env, CAR(env->head), 1, NULL, stdout); |
print_val(env, CAR(env->head), 1, NULL, stdout); |
127 |
extern void printport_(environment *env) |
extern void printport_(environment *env) |
128 |
{ |
{ |
129 |
|
|
130 |
if(check_args(env, port, unknown, empty)) |
if(check_args(env, 2, port, unknown)) |
131 |
return printerr(env); |
return printerr(env); |
132 |
|
|
133 |
print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p); |
print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p); |
147 |
extern void princport_(environment *env) |
extern void princport_(environment *env) |
148 |
{ |
{ |
149 |
|
|
150 |
if(check_args(env, port, unknown, empty)) |
if(check_args(env, 2, port, unknown)) |
151 |
return printerr(env); |
return printerr(env); |
152 |
|
|
153 |
print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p); |
print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p); |
167 |
{ |
{ |
168 |
value *temp= env->head; |
value *temp= env->head; |
169 |
|
|
170 |
if(check_args(env, unknown, unknown, unknown, empty)) |
if(check_args(env, 3, unknown, unknown, unknown)) |
171 |
return printerr(env); |
return printerr(env); |
172 |
|
|
173 |
env->head= CDR(CDR(env->head)); |
env->head= CDR(CDR(env->head)); |
180 |
{ |
{ |
181 |
value *temp, *new_head; |
value *temp, *new_head; |
182 |
|
|
183 |
if(check_args(env, tcons, empty)) |
if(check_args(env, 1, tcons)) |
184 |
return printerr(env); |
return printerr(env); |
185 |
|
|
186 |
rev(env); |
rev(env); |
215 |
{ |
{ |
216 |
void *left, *right; |
void *left, *right; |
217 |
|
|
218 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, unknown, unknown)) |
219 |
return printerr(env); |
return printerr(env); |
220 |
|
|
221 |
left= CAR(env->head)->content.ptr; |
left= CAR(env->head)->content.ptr; |
230 |
{ |
{ |
231 |
int val; |
int val; |
232 |
|
|
233 |
if(check_args(env, integer, empty)) |
if(check_args(env, 1, integer)) |
234 |
return printerr(env); |
return printerr(env); |
235 |
|
|
236 |
val= CAR(env->head)->content.i; |
val= CAR(env->head)->content.i; |
251 |
symbol *sym; |
symbol *sym; |
252 |
|
|
253 |
/* Needs two values on the stack, the top one must be a symbol */ |
/* Needs two values on the stack, the top one must be a symbol */ |
254 |
if(check_args(env, symb, unknown, empty)) |
if(check_args(env, 2, symb, unknown)) |
255 |
return printerr(env); |
return printerr(env); |
256 |
|
|
257 |
/* long names are a pain */ |
/* long names are a pain */ |
274 |
{ |
{ |
275 |
char* sym_id; |
char* sym_id; |
276 |
|
|
277 |
if(check_args(env, symb, empty)) |
if(check_args(env, 1, symb)) |
278 |
return printerr(env); |
return printerr(env); |
279 |
|
|
280 |
sym_id= CAR(env->head)->content.sym->id; |
sym_id= CAR(env->head)->content.sym->id; |
298 |
char* new_string; |
char* new_string; |
299 |
value *a_val, *b_val; |
value *a_val, *b_val; |
300 |
|
|
301 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, string, string)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, string, string, empty)==0) { |
|
302 |
a_val= CAR(env->head); |
a_val= CAR(env->head); |
303 |
b_val= CAR(CDR(env->head)); |
b_val= CAR(CDR(env->head)); |
304 |
protect(a_val); protect(b_val); |
protect(a_val); protect(b_val); |
316 |
return; |
return; |
317 |
} |
} |
318 |
|
|
319 |
if(check_args(env, integer, integer, empty)==0) { |
if(check_args(env, 2, integer, integer)==0) { |
320 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
321 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
322 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
326 |
return; |
return; |
327 |
} |
} |
328 |
|
|
329 |
if(check_args(env, tfloat, tfloat, empty)==0) { |
if(check_args(env, 2, tfloat, tfloat)==0) { |
330 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
331 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
332 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
336 |
return; |
return; |
337 |
} |
} |
338 |
|
|
339 |
if(check_args(env, tfloat, integer, empty)==0) { |
if(check_args(env, 2, tfloat, integer)==0) { |
340 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
341 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
342 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
346 |
return; |
return; |
347 |
} |
} |
348 |
|
|
349 |
if(check_args(env, integer, tfloat, empty)==0) { |
if(check_args(env, 2, integer, tfloat)==0) { |
350 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
351 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
352 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
365 |
int a, b; |
int a, b; |
366 |
float fa, fb; |
float fa, fb; |
367 |
|
|
368 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, integer, integer)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, integer, integer, empty)==0) { |
|
369 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
370 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
371 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
375 |
return; |
return; |
376 |
} |
} |
377 |
|
|
378 |
if(check_args(env, tfloat, tfloat, empty)==0) { |
if(check_args(env, 2, tfloat, tfloat)==0) { |
379 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
380 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
381 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
385 |
return; |
return; |
386 |
} |
} |
387 |
|
|
388 |
if(check_args(env, tfloat, integer, empty)==0) { |
if(check_args(env, 2, tfloat, integer)==0) { |
389 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
390 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
391 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
395 |
return; |
return; |
396 |
} |
} |
397 |
|
|
398 |
if(check_args(env, integer, tfloat, empty)==0) { |
if(check_args(env, 2, integer, tfloat)==0) { |
399 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
400 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
401 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
414 |
int a, b; |
int a, b; |
415 |
float fa, fb; |
float fa, fb; |
416 |
|
|
417 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, integer, integer)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, integer, integer, empty)==0) { |
|
418 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
419 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
420 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
424 |
return; |
return; |
425 |
} |
} |
426 |
|
|
427 |
if(check_args(env, tfloat, tfloat, empty)==0) { |
if(check_args(env, 2, tfloat, tfloat)==0) { |
428 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
429 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
430 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
434 |
return; |
return; |
435 |
} |
} |
436 |
|
|
437 |
if(check_args(env, tfloat, integer, empty)==0) { |
if(check_args(env, 2, tfloat, integer)==0) { |
438 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
439 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
440 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
444 |
return; |
return; |
445 |
} |
} |
446 |
|
|
447 |
if(check_args(env, integer, tfloat, empty)==0) { |
if(check_args(env, 2, integer, tfloat)==0) { |
448 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
449 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
450 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
481 |
/* "dup"; duplicates an item on the stack */ |
/* "dup"; duplicates an item on the stack */ |
482 |
extern void sx_647570(environment *env) |
extern void sx_647570(environment *env) |
483 |
{ |
{ |
484 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
485 |
return printerr(env); |
return printerr(env); |
486 |
|
|
487 |
push_val(env, copy_val(env, CAR(env->head))); |
push_val(env, copy_val(env, CAR(env->head))); |
492 |
{ |
{ |
493 |
int truth; |
int truth; |
494 |
|
|
495 |
if(check_args(env, unknown, integer, empty)) |
if(check_args(env, 2, unknown, integer)) |
496 |
return printerr(env); |
return printerr(env); |
497 |
|
|
498 |
swap(env); |
swap(env); |
514 |
{ |
{ |
515 |
int truth; |
int truth; |
516 |
|
|
517 |
if(check_args(env, unknown, unknown, integer, empty)) |
if(check_args(env, 3, unknown, unknown, integer)) |
518 |
return printerr(env); |
return printerr(env); |
519 |
|
|
520 |
rot(env); |
rot(env); |
539 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
540 |
{ |
{ |
541 |
|
|
542 |
if(check_args(env, unknown, symb, unknown, symb, integer, empty)) |
if(check_args(env, 5, unknown, symb, unknown, symb, integer)) |
543 |
return printerr(env); |
return printerr(env); |
544 |
|
|
545 |
/// XXX |
/// XXX |
559 |
extern void then(environment *env) |
extern void then(environment *env) |
560 |
{ |
{ |
561 |
|
|
562 |
if(check_args(env, unknown, symb, integer, empty)) |
if(check_args(env, 3, unknown, symb, integer)) |
563 |
return printerr(env); |
return printerr(env); |
564 |
|
|
565 |
/// XXX |
/// XXX |
580 |
int truth; |
int truth; |
581 |
value *loop, *test; |
value *loop, *test; |
582 |
|
|
583 |
if(check_args(env, unknown, integer, empty)) |
if(check_args(env, 2, unknown, integer)) |
584 |
return printerr(env); |
return printerr(env); |
585 |
|
|
586 |
loop= CAR(env->head); |
loop= CAR(env->head); |
624 |
value *loop; |
value *loop; |
625 |
int foo1, foo2; |
int foo1, foo2; |
626 |
|
|
627 |
if(check_args(env, unknown, integer, integer, empty)) |
if(check_args(env, 3, unknown, integer, integer)) |
628 |
return printerr(env); |
return printerr(env); |
629 |
|
|
630 |
loop= CAR(env->head); |
loop= CAR(env->head); |
662 |
value *loop, *foo; |
value *loop, *foo; |
663 |
value *iterator; |
value *iterator; |
664 |
|
|
665 |
if(check_args(env, unknown, tcons, empty)) |
if(check_args(env, 2, unknown, tcons)) |
666 |
return printerr(env); |
return printerr(env); |
667 |
|
|
668 |
loop= CAR(env->head); |
loop= CAR(env->head); |
699 |
int ending, start, i; |
int ending, start, i; |
700 |
value *iterator, *temp, *end; |
value *iterator, *temp, *end; |
701 |
|
|
702 |
if(check_args(env, integer, integer, empty)) |
if(check_args(env, 2, integer, integer)) |
703 |
return printerr(env); |
return printerr(env); |
704 |
|
|
705 |
end= new_val(env); |
end= new_val(env); |
757 |
{ |
{ |
758 |
FILE *stream; |
FILE *stream; |
759 |
|
|
760 |
if(check_args(env, port, empty)) |
if(check_args(env, 1, port)) |
761 |
return printerr(env); |
return printerr(env); |
762 |
|
|
763 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
778 |
{ |
{ |
779 |
FILE *stream; |
FILE *stream; |
780 |
|
|
781 |
if(check_args(env, port, empty)) |
if(check_args(env, 1, port)) |
782 |
return printerr(env); |
return printerr(env); |
783 |
|
|
784 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
793 |
{ |
{ |
794 |
int freq, dur, period, ticks; |
int freq, dur, period, ticks; |
795 |
|
|
796 |
if(check_args(env, integer, integer, empty)) |
if(check_args(env, 2, integer, integer)) |
797 |
return printerr(env); |
return printerr(env); |
798 |
|
|
799 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
814 |
usleep(dur); |
usleep(dur); |
815 |
return; |
return; |
816 |
case -1: |
case -1: |
|
perror("beep"); |
|
817 |
env->err= 5; |
env->err= 5; |
818 |
return; |
return printerr(env); |
819 |
default: |
default: |
820 |
abort(); |
abort(); |
821 |
} |
} |
827 |
{ |
{ |
828 |
int dur; |
int dur; |
829 |
|
|
830 |
if(check_args(env, integer, empty)) |
if(check_args(env, 1, integer)) |
831 |
return printerr(env); |
return printerr(env); |
832 |
|
|
833 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
843 |
int a, b; |
int a, b; |
844 |
float fa, fb; |
float fa, fb; |
845 |
|
|
846 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, integer, integer)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, integer, integer, empty)==0) { |
|
847 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
848 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
849 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
853 |
return; |
return; |
854 |
} |
} |
855 |
|
|
856 |
if(check_args(env, tfloat, tfloat, empty)==0) { |
if(check_args(env, 2, tfloat, tfloat)==0) { |
857 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
858 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
859 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
863 |
return; |
return; |
864 |
} |
} |
865 |
|
|
866 |
if(check_args(env, tfloat, integer, empty)==0) { |
if(check_args(env, 2, tfloat, integer)==0) { |
867 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
868 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
869 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
873 |
return; |
return; |
874 |
} |
} |
875 |
|
|
876 |
if(check_args(env, integer, tfloat, empty)==0) { |
if(check_args(env, 2, integer, tfloat)==0) { |
877 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
878 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
879 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
892 |
int a, b; |
int a, b; |
893 |
float fa, fb; |
float fa, fb; |
894 |
|
|
895 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, integer, integer)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, integer, integer, empty)==0) { |
|
896 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
897 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
898 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
902 |
return; |
return; |
903 |
} |
} |
904 |
|
|
905 |
if(check_args(env, tfloat, tfloat, empty)==0) { |
if(check_args(env, 2, tfloat, tfloat)==0) { |
906 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
907 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
908 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
912 |
return; |
return; |
913 |
} |
} |
914 |
|
|
915 |
if(check_args(env, tfloat, integer, empty)==0) { |
if(check_args(env, 2, tfloat, integer)==0) { |
916 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
917 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
918 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
922 |
return; |
return; |
923 |
} |
} |
924 |
|
|
925 |
if(check_args(env, integer, tfloat, empty)==0) { |
if(check_args(env, 2, integer, tfloat)==0) { |
926 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
927 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
928 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
940 |
{ |
{ |
941 |
int a, b; |
int a, b; |
942 |
|
|
943 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, integer, integer)==0) { |
|
return printerr(env); |
|
|
|
|
|
if(check_args(env, integer, integer, empty)==0) { |
|
944 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
945 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
946 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
959 |
{ |
{ |
960 |
int a, b; |
int a, b; |
961 |
|
|
962 |
if(check_args(env, integer, integer, empty)) |
if(check_args(env, 2, integer, integer)) |
963 |
return printerr(env); |
return printerr(env); |
964 |
|
|
965 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
973 |
extern void setcar(environment *env) |
extern void setcar(environment *env) |
974 |
{ |
{ |
975 |
|
|
976 |
if(check_args(env, tcons, unknown, empty)) |
if(check_args(env, 2, tcons, unknown)) |
977 |
return printerr(env); |
return printerr(env); |
978 |
|
|
979 |
CAR(CAR(CDR(env->head)))=CAR(env->head); |
CAR(CAR(CDR(env->head)))=CAR(env->head); |
983 |
extern void setcdr(environment *env) |
extern void setcdr(environment *env) |
984 |
{ |
{ |
985 |
|
|
986 |
if(check_args(env, tcons, unknown, empty)) |
if(check_args(env, 2, tcons, unknown)) |
987 |
return printerr(env); |
return printerr(env); |
988 |
|
|
989 |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
993 |
extern void car(environment *env) |
extern void car(environment *env) |
994 |
{ |
{ |
995 |
|
|
996 |
if(check_args(env, tcons, empty)) |
if(check_args(env, 1, tcons)) |
997 |
return printerr(env); |
return printerr(env); |
998 |
|
|
999 |
CAR(env->head)=CAR(CAR(env->head)); |
CAR(env->head)=CAR(CAR(env->head)); |
1002 |
extern void cdr(environment *env) |
extern void cdr(environment *env) |
1003 |
{ |
{ |
1004 |
|
|
1005 |
if(check_args(env, tcons, empty)) |
if(check_args(env, 1, tcons)) |
1006 |
return printerr(env); |
return printerr(env); |
1007 |
|
|
1008 |
CAR(env->head)=CDR(CAR(env->head)); |
CAR(env->head)=CDR(CAR(env->head)); |
1012 |
{ |
{ |
1013 |
value *val; |
value *val; |
1014 |
|
|
1015 |
if(check_args(env, unknown, unknown, empty)) |
if(check_args(env, 2, unknown, unknown)) |
1016 |
return printerr(env); |
return printerr(env); |
1017 |
|
|
1018 |
val=new_val(env); |
val=new_val(env); |
1041 |
|
|
1042 |
/* Needs two values on the stack, the top one must be an association |
/* Needs two values on the stack, the top one must be an association |
1043 |
list */ |
list */ |
1044 |
if(check_args(env, tcons, unknown, empty)) |
if(check_args(env, 2, tcons, unknown)) |
1045 |
return printerr(env); |
return printerr(env); |
1046 |
|
|
1047 |
key=CAR(CDR(env->head)); |
key=CAR(CDR(env->head)); |
1058 |
eqfunc((void*)env); if(env->err) return; |
eqfunc((void*)env); if(env->err) return; |
1059 |
|
|
1060 |
/* Check the result of 'eqfunc' */ |
/* Check the result of 'eqfunc' */ |
1061 |
if(check_args(env, integer, empty)) |
if(check_args(env, 1, integer)) |
1062 |
return printerr(env); |
return printerr(env); |
1063 |
|
|
1064 |
if(CAR(env->head)->content.i){ |
if(CAR(env->head)->content.i){ |
1110 |
value *new_port; |
value *new_port; |
1111 |
FILE *stream; |
FILE *stream; |
1112 |
|
|
1113 |
if(check_args(env, string, string, empty)) |
if(check_args(env, 2, string, string)) |
1114 |
return printerr(env); |
return printerr(env); |
1115 |
|
|
1116 |
stream=fopen(CAR(CDR(env->head))->content.ptr, |
stream=fopen(CAR(CDR(env->head))->content.ptr, |
1117 |
CAR(env->head)->content.ptr); |
CAR(env->head)->content.ptr); |
1118 |
|
|
1119 |
if(stream == NULL) { |
if(stream == NULL) { |
|
perror("open"); |
|
1120 |
env->err= 5; |
env->err= 5; |
1121 |
return; |
return printerr(env); |
1122 |
} |
} |
1123 |
|
|
1124 |
new_port=new_val(env); |
new_port=new_val(env); |
1139 |
{ |
{ |
1140 |
int ret; |
int ret; |
1141 |
|
|
1142 |
if(check_args(env, port, empty)) |
if(check_args(env, 1, port)) |
1143 |
return printerr(env); |
return printerr(env); |
1144 |
|
|
1145 |
ret= fclose(CAR(env->head)->content.p); |
ret= fclose(CAR(env->head)->content.p); |
1146 |
|
|
1147 |
if(ret != 0){ |
if(ret != 0){ |
|
perror("close"); |
|
1148 |
env->err= 5; |
env->err= 5; |
1149 |
return; |
return printerr(env); |
1150 |
} |
} |
1151 |
|
|
1152 |
toss(env); |
toss(env); |
1157 |
{ |
{ |
1158 |
char *new_string; |
char *new_string; |
1159 |
|
|
1160 |
if(check_args(env, string, empty)) |
if(check_args(env, 1, string)) |
1161 |
return printerr(env); |
return printerr(env); |
1162 |
|
|
1163 |
new_string= mangle_str(CAR(env->head)->content.string); |
new_string= mangle_str(CAR(env->head)->content.string); |
1178 |
extern void sx_77616974706964(environment *env) |
extern void sx_77616974706964(environment *env) |
1179 |
{ |
{ |
1180 |
|
|
1181 |
if(check_args(env, integer, empty)) |
if(check_args(env, 1, integer)) |
1182 |
return printerr(env); |
return printerr(env); |
1183 |
|
|
1184 |
push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0)); |
push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0)); |
1190 |
extern void toss(environment *env) |
extern void toss(environment *env) |
1191 |
{ |
{ |
1192 |
|
|
1193 |
if(check_args(env, unknown, empty)) |
if(check_args(env, 1, unknown)) |
1194 |
return printerr(env); |
return printerr(env); |
1195 |
|
|
1196 |
env->head= CDR(env->head); /* Remove the top stack item */ |
env->head= CDR(env->head); /* Remove the top stack item */ |
1281 |
{ |
{ |
1282 |
puts(warranty_message); |
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 |
|
} |