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