|
#include <stdio.h> |
|
1 |
#include "stack.h" |
#include "stack.h" |
2 |
|
#include "messages.h" |
3 |
|
|
4 |
/* Print newline. */ |
/* Print newline. */ |
5 |
extern void nl(environment *env) |
extern void nl(environment *env) |
10 |
/* Print a newline to a port */ |
/* Print a newline to a port */ |
11 |
extern void nlport(environment *env) |
extern void nlport(environment *env) |
12 |
{ |
{ |
13 |
if(env->head->type==empty) { |
switch(check_args(env, port, empty)) { |
14 |
printerr("Too Few Arguments"); |
case 1: |
15 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
16 |
return; |
return; |
17 |
} |
case 2: |
18 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
19 |
return; |
return; |
20 |
|
default: |
21 |
|
break; |
22 |
} |
} |
23 |
|
|
24 |
if(fprintf(CAR(env->head)->content.p, "\n") < 0){ |
if(fprintf(CAR(env->head)->content.p, "\n") < 0){ |
32 |
/* Gets the type of a value */ |
/* Gets the type of a value */ |
33 |
extern void type(environment *env) |
extern void type(environment *env) |
34 |
{ |
{ |
35 |
if(env->head->type==empty) { |
|
36 |
printerr("Too Few Arguments"); |
switch(check_args(env, unknown, empty)) { |
37 |
env->err= 1; |
case 1: |
38 |
|
printerr(env, "Too Few Arguments"); |
39 |
|
return; |
40 |
|
case 2: |
41 |
|
printerr(env, "Bad Argument Type"); |
42 |
return; |
return; |
43 |
|
default: |
44 |
|
break; |
45 |
} |
} |
46 |
|
|
47 |
switch(CAR(env->head)->type){ |
switch(CAR(env->head)->type){ |
48 |
case empty: |
case empty: |
49 |
push_sym(env, "empty"); |
push_sym(env, "empty"); |
50 |
break; |
break; |
51 |
|
case unknown: |
52 |
|
push_sym(env, "unknown"); |
53 |
|
break; |
54 |
case integer: |
case integer: |
55 |
push_sym(env, "integer"); |
push_sym(env, "integer"); |
56 |
break; |
break; |
81 |
/* Print the top element of the stack but don't discard it */ |
/* Print the top element of the stack but don't discard it */ |
82 |
extern void print_(environment *env) |
extern void print_(environment *env) |
83 |
{ |
{ |
84 |
if(env->head->type==empty) { |
|
85 |
printerr("Too Few Arguments"); |
switch(check_args(env, unknown, empty)) { |
86 |
env->err= 1; |
case 1: |
87 |
|
printerr(env, "Too Few Arguments"); |
88 |
|
return; |
89 |
|
case 2: |
90 |
|
printerr(env, "Bad Argument Type"); |
91 |
return; |
return; |
92 |
|
default: |
93 |
|
break; |
94 |
} |
} |
95 |
|
|
96 |
print_val(env, CAR(env->head), 0, NULL, stdout); |
print_val(env, CAR(env->head), 0, NULL, stdout); |
97 |
if(env->err) return; |
if(env->err) return; |
98 |
nl(env); |
nl(env); |
110 |
discard it. */ |
discard it. */ |
111 |
extern void princ_(environment *env) |
extern void princ_(environment *env) |
112 |
{ |
{ |
113 |
if(env->head->type==empty) { |
|
114 |
printerr("Too Few Arguments"); |
switch(check_args(env, unknown, empty)) { |
115 |
env->err= 1; |
case 1: |
116 |
|
printerr(env, "Too Few Arguments"); |
117 |
return; |
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); |
print_val(env, CAR(env->head), 1, NULL, stdout); |
126 |
} |
} |
127 |
|
|
136 |
/* Print a value to a port, but don't discard it */ |
/* Print a value to a port, but don't discard it */ |
137 |
extern void printport_(environment *env) |
extern void printport_(environment *env) |
138 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
139 |
|
|
140 |
if(CAR(env->head)->type!=port) { |
switch(check_args(env, port, unknown, empty)) { |
141 |
printerr("Bad Argument Type"); |
case 1: |
142 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
143 |
return; |
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); |
print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p); |
164 |
/* Print, without quotes, to a port, a value, but don't discard it. */ |
/* Print, without quotes, to a port, a value, but don't discard it. */ |
165 |
extern void princport_(environment *env) |
extern void princport_(environment *env) |
166 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
167 |
|
|
168 |
if(CAR(env->head)->type!=port) { |
switch(check_args(env, port, unknown, empty)) { |
169 |
printerr("Bad Argument Type"); |
case 1: |
170 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
171 |
return; |
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); |
print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p); |
192 |
extern void rot(environment *env) |
extern void rot(environment *env) |
193 |
{ |
{ |
194 |
value *temp= env->head; |
value *temp= env->head; |
195 |
|
|
196 |
if(env->head->type == empty || CDR(env->head)->type == empty |
switch(check_args(env, unknown, unknown, unknown, empty)) { |
197 |
|| CDR(CDR(env->head))->type == empty) { |
case 1: |
198 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
199 |
env->err= 1; |
return; |
200 |
|
case 2: |
201 |
|
printerr(env, "Bad Argument Type"); |
202 |
return; |
return; |
203 |
|
default: |
204 |
|
break; |
205 |
} |
} |
206 |
|
|
207 |
env->head= CDR(CDR(env->head)); |
env->head= CDR(CDR(env->head)); |
214 |
{ |
{ |
215 |
value *temp, *new_head; |
value *temp, *new_head; |
216 |
|
|
217 |
/* Is top element a list? */ |
switch(check_args(env, tcons, empty)) { |
218 |
if(env->head->type==empty) { |
case 1: |
219 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
220 |
return; |
return; |
221 |
} |
case 2: |
222 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=tcons) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
223 |
return; |
return; |
224 |
|
default: |
225 |
|
break; |
226 |
} |
} |
227 |
|
|
228 |
rev(env); |
rev(env); |
235 |
|
|
236 |
toss(env); |
toss(env); |
237 |
|
|
238 |
|
/// XXX |
239 |
/* Find the end of the list */ |
/* Find the end of the list */ |
240 |
while(CDR(temp)->type != empty) { |
while(CDR(temp)->type != empty) { |
241 |
if (CDR(temp)->type == tcons) |
if (CDR(temp)->type == tcons) |
242 |
temp= CDR(temp); |
temp= CDR(temp); |
243 |
else { |
else { |
244 |
printerr("Bad Argument Type"); /* Improper list */ |
printerr(env, "Bad Argument Type"); /* Improper list */ |
245 |
env->err= 2; |
env->err= 2; |
246 |
return; |
return; |
247 |
} |
} |
258 |
{ |
{ |
259 |
void *left, *right; |
void *left, *right; |
260 |
|
|
261 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, unknown, unknown, empty)) { |
262 |
printerr("Too Few Arguments"); |
case 1: |
263 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
264 |
return; |
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; |
left= CAR(env->head)->content.ptr; |
281 |
{ |
{ |
282 |
int val; |
int val; |
283 |
|
|
284 |
if(env->head->type==empty) { |
switch(check_args(env, integer, empty)) { |
285 |
printerr("Too Few Arguments"); |
case 1: |
286 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
287 |
return; |
return; |
288 |
} |
case 2: |
289 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
290 |
return; |
return; |
291 |
|
default: |
292 |
|
break; |
293 |
} |
} |
294 |
|
|
295 |
val= CAR(env->head)->content.i; |
val= CAR(env->head)->content.i; |
310 |
symbol *sym; |
symbol *sym; |
311 |
|
|
312 |
/* 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 */ |
313 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, symb, unknown, empty)) { |
314 |
printerr("Too Few Arguments"); |
case 1: |
315 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
316 |
return; |
return; |
317 |
} |
case 2: |
318 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=symb) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
319 |
return; |
return; |
320 |
|
default: |
321 |
|
break; |
322 |
} |
} |
323 |
|
|
324 |
/* long names are a pain */ |
/* long names are a pain */ |
325 |
sym= CAR(env->head)->content.ptr; |
sym= CAR(env->head)->content.sym; |
326 |
|
|
327 |
/* Bind the symbol to the value */ |
/* Bind the symbol to the value */ |
328 |
sym->val= CAR(CDR(env->head)); |
sym->val= CAR(CDR(env->head)); |
333 |
/* Clear stack */ |
/* Clear stack */ |
334 |
extern void clear(environment *env) |
extern void clear(environment *env) |
335 |
{ |
{ |
336 |
while(env->head->type != empty) |
env->head= new_val(env); |
|
toss(env); |
|
337 |
} |
} |
338 |
|
|
339 |
/* Forgets a symbol (remove it from the hash table) */ |
/* Forgets a symbol (remove it from the hash table) */ |
341 |
{ |
{ |
342 |
char* sym_id; |
char* sym_id; |
343 |
|
|
344 |
if(env->head->type==empty) { |
switch(check_args(env, symb, empty)) { |
345 |
printerr("Too Few Arguments"); |
case 1: |
346 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
347 |
return; |
return; |
348 |
} |
case 2: |
349 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=symb) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
350 |
return; |
return; |
351 |
|
default: |
352 |
|
break; |
353 |
} |
} |
354 |
|
|
355 |
sym_id= CAR(env->head)->content.sym->id; |
sym_id= CAR(env->head)->content.sym->id; |
373 |
char* new_string; |
char* new_string; |
374 |
value *a_val, *b_val; |
value *a_val, *b_val; |
375 |
|
|
376 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
377 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
378 |
return; |
return; |
379 |
} |
} |
380 |
|
|
381 |
if(CAR(env->head)->type==string |
if(check_args(env, string, string, empty)==0) { |
|
&& CAR(CDR(env->head))->type==string) { |
|
382 |
a_val= CAR(env->head); |
a_val= CAR(env->head); |
383 |
b_val= CAR(CDR(env->head)); |
b_val= CAR(CDR(env->head)); |
384 |
protect(a_val); protect(b_val); |
protect(a_val); protect(b_val); |
385 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
386 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
387 |
len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1; |
len= strlen(a_val->content.string)+strlen(b_val->content.string)+1; |
388 |
new_string= malloc(len); |
new_string= malloc(len); |
389 |
assert(new_string != NULL); |
assert(new_string != NULL); |
390 |
strcpy(new_string, b_val->content.ptr); |
strcpy(new_string, b_val->content.string); |
391 |
strcat(new_string, a_val->content.ptr); |
strcat(new_string, a_val->content.string); |
392 |
push_cstring(env, new_string); |
push_cstring(env, new_string); |
393 |
unprotect(a_val); unprotect(b_val); |
unprotect(a_val); unprotect(b_val); |
394 |
free(new_string); |
free(new_string); |
396 |
return; |
return; |
397 |
} |
} |
398 |
|
|
399 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
400 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
401 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
402 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
406 |
return; |
return; |
407 |
} |
} |
408 |
|
|
409 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
410 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
411 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
412 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
416 |
return; |
return; |
417 |
} |
} |
418 |
|
|
419 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
420 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
421 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
422 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
426 |
return; |
return; |
427 |
} |
} |
428 |
|
|
429 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
430 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
431 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
432 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
436 |
return; |
return; |
437 |
} |
} |
438 |
|
|
439 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
440 |
env->err=2; |
env->err=2; |
441 |
} |
} |
442 |
|
|
446 |
int a, b; |
int a, b; |
447 |
float fa, fb; |
float fa, fb; |
448 |
|
|
449 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
450 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err=1; |
|
451 |
return; |
return; |
452 |
} |
} |
453 |
|
|
454 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
455 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
456 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
457 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
461 |
return; |
return; |
462 |
} |
} |
463 |
|
|
464 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
465 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
466 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
467 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
471 |
return; |
return; |
472 |
} |
} |
473 |
|
|
474 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
475 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
476 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
477 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
481 |
return; |
return; |
482 |
} |
} |
483 |
|
|
484 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
485 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
486 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
487 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
491 |
return; |
return; |
492 |
} |
} |
493 |
|
|
494 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
495 |
env->err=2; |
env->err=2; |
496 |
} |
} |
497 |
|
|
501 |
int a, b; |
int a, b; |
502 |
float fa, fb; |
float fa, fb; |
503 |
|
|
504 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
505 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
506 |
return; |
return; |
507 |
} |
} |
508 |
|
|
509 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
510 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
511 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
512 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
516 |
return; |
return; |
517 |
} |
} |
518 |
|
|
519 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
520 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
521 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
522 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
526 |
return; |
return; |
527 |
} |
} |
528 |
|
|
529 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
530 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
531 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
532 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
536 |
return; |
return; |
537 |
} |
} |
538 |
|
|
539 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
540 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
541 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
542 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
546 |
return; |
return; |
547 |
} |
} |
548 |
|
|
549 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
550 |
env->err= 2; |
env->err= 2; |
551 |
} |
} |
552 |
|
|
574 |
/* "dup"; duplicates an item on the stack */ |
/* "dup"; duplicates an item on the stack */ |
575 |
extern void sx_647570(environment *env) |
extern void sx_647570(environment *env) |
576 |
{ |
{ |
577 |
if(env->head->type==empty) { |
switch(check_args(env, unknown, empty)) { |
578 |
printerr("Too Few Arguments"); |
case 1: |
579 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
580 |
|
return; |
581 |
|
case 2: |
582 |
|
printerr(env, "Bad Argument Type"); |
583 |
return; |
return; |
584 |
|
default: |
585 |
|
break; |
586 |
} |
} |
587 |
|
|
588 |
push_val(env, copy_val(env, CAR(env->head))); |
push_val(env, copy_val(env, CAR(env->head))); |
589 |
} |
} |
590 |
|
|
593 |
{ |
{ |
594 |
int truth; |
int truth; |
595 |
|
|
596 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, unknown, integer, empty)) { |
597 |
printerr("Too Few Arguments"); |
case 1: |
598 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
599 |
return; |
return; |
600 |
} |
case 2: |
601 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(CDR(env->head))->type != integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
602 |
return; |
return; |
603 |
|
default: |
604 |
|
break; |
605 |
} |
} |
606 |
|
|
607 |
swap(env); |
swap(env); |
608 |
if(env->err) return; |
if(env->err) return; |
609 |
|
|
623 |
{ |
{ |
624 |
int truth; |
int truth; |
625 |
|
|
626 |
if(env->head->type==empty || CDR(env->head)->type==empty |
switch(check_args(env, unknown, unknown, integer, empty)) { |
627 |
|| CDR(CDR(env->head))->type==empty) { |
case 1: |
628 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
629 |
return; |
return; |
630 |
} |
case 2: |
631 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(CDR(CDR(env->head)))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
632 |
return; |
return; |
633 |
|
default: |
634 |
|
break; |
635 |
} |
} |
636 |
|
|
637 |
rot(env); |
rot(env); |
638 |
if(env->err) return; |
if(env->err) return; |
639 |
|
|
655 |
/* "else" */ |
/* "else" */ |
656 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
657 |
{ |
{ |
658 |
if(env->head->type==empty || CDR(env->head)->type==empty |
|
659 |
|| CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty |
switch(check_args(env, |
660 |
|| CDR(CDR(CDR(CDR(env->head))))->type==empty) { |
unknown, symb, unknown, symb, integer, |
661 |
printerr("Too Few Arguments"); |
empty)) { |
662 |
env->err= 1; |
case 1: |
663 |
|
printerr(env, "Too Few Arguments"); |
664 |
return; |
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 |
if(CAR(CDR(env->head))->type!=symb |
675 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
676 |
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
677 |
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
678 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
679 |
env->err= 2; |
env->err= 2; |
680 |
return; |
return; |
681 |
} |
} |
686 |
|
|
687 |
extern void then(environment *env) |
extern void then(environment *env) |
688 |
{ |
{ |
689 |
if(env->head->type==empty || CDR(env->head)->type==empty |
|
690 |
|| CDR(CDR(env->head))->type==empty) { |
switch(check_args(env, unknown, symb, integer, empty)) { |
691 |
printerr("Too Few Arguments"); |
case 1: |
692 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
693 |
return; |
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 |
if(CAR(CDR(env->head))->type!=symb |
704 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) { |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) { |
705 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
706 |
env->err= 2; |
env->err= 2; |
707 |
return; |
return; |
708 |
} |
} |
717 |
int truth; |
int truth; |
718 |
value *loop, *test; |
value *loop, *test; |
719 |
|
|
720 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, unknown, integer, empty)) { |
721 |
printerr("Too Few Arguments"); |
case 1: |
722 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
723 |
|
return; |
724 |
|
case 2: |
725 |
|
printerr(env, "Bad Argument Type"); |
726 |
return; |
return; |
727 |
|
default: |
728 |
|
break; |
729 |
} |
} |
730 |
|
|
731 |
loop= CAR(env->head); |
loop= CAR(env->head); |
739 |
do { |
do { |
740 |
push_val(env, test); |
push_val(env, test); |
741 |
eval(env); |
eval(env); |
742 |
|
|
743 |
|
/// XXX |
744 |
|
|
745 |
if(CAR(env->head)->type != integer) { |
if(CAR(env->head)->type != integer) { |
746 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
747 |
env->err= 2; |
env->err= 2; |
748 |
return; |
return; |
749 |
} |
} |
770 |
value *loop; |
value *loop; |
771 |
int foo1, foo2; |
int foo1, foo2; |
772 |
|
|
773 |
if(env->head->type==empty || CDR(env->head)->type==empty |
switch(check_args(env, unknown, integer, integer, empty)) { |
774 |
|| CDR(CDR(env->head))->type==empty) { |
case 1: |
775 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
776 |
return; |
return; |
777 |
} |
case 2: |
778 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(CDR(env->head))->type!=integer |
|
|
|| CAR(CDR(CDR(env->head)))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
779 |
return; |
return; |
780 |
|
default: |
781 |
|
break; |
782 |
} |
} |
783 |
|
|
784 |
loop= CAR(env->head); |
loop= CAR(env->head); |
815 |
{ |
{ |
816 |
value *loop, *foo; |
value *loop, *foo; |
817 |
value *iterator; |
value *iterator; |
|
|
|
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
818 |
|
|
819 |
if(CAR(CDR(env->head))->type!=tcons) { |
switch(check_args(env, unknown, tcons, empty)) { |
820 |
printerr("Bad Argument Type"); |
case 1: |
821 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
822 |
return; |
return; |
823 |
|
case 2: |
824 |
|
printerr(env, "Bad Argument Type"); |
825 |
|
return; |
826 |
|
default: |
827 |
|
break; |
828 |
} |
} |
829 |
|
|
830 |
loop= CAR(env->head); |
loop= CAR(env->head); |
831 |
protect(loop); |
protect(loop); |
832 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
841 |
push_val(env, CAR(iterator)); |
push_val(env, CAR(iterator)); |
842 |
push_val(env, loop); |
push_val(env, loop); |
843 |
eval(env); if(env->err) return; |
eval(env); if(env->err) return; |
844 |
|
|
845 |
|
/// XXX |
846 |
if (iterator->type == tcons){ |
if (iterator->type == tcons){ |
847 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
848 |
} else { |
} else { |
849 |
printerr("Bad Argument Type"); /* Improper list */ |
printerr(env, "Bad Argument Type"); /* Improper list */ |
850 |
env->err= 2; |
env->err= 2; |
851 |
break; |
break; |
852 |
} |
} |
860 |
int ending, start, i; |
int ending, start, i; |
861 |
value *iterator, *temp, *end; |
value *iterator, *temp, *end; |
862 |
|
|
863 |
end= new_val(env); |
switch(check_args(env, integer, integer, empty)) { |
864 |
|
case 1: |
865 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
printerr(env, "Too Few Arguments"); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
866 |
return; |
return; |
867 |
} |
case 2: |
868 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=integer |
|
|
|| CAR(CDR(env->head))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
869 |
return; |
return; |
870 |
|
default: |
871 |
|
break; |
872 |
} |
} |
873 |
|
|
874 |
|
end= new_val(env); |
875 |
|
|
876 |
ending= CAR(env->head)->content.i; |
ending= CAR(env->head)->content.i; |
877 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
878 |
start= CAR(env->head)->content.i; |
start= CAR(env->head)->content.i; |
926 |
{ |
{ |
927 |
FILE *stream; |
FILE *stream; |
928 |
|
|
929 |
if(env->head->type==empty) { |
switch(check_args(env, port, empty)) { |
930 |
printerr("Too Few Arguments"); |
case 1: |
931 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
932 |
return; |
return; |
933 |
} |
case 2: |
934 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
935 |
return; |
return; |
936 |
|
default: |
937 |
|
break; |
938 |
} |
} |
939 |
|
|
940 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
955 |
{ |
{ |
956 |
FILE *stream; |
FILE *stream; |
957 |
|
|
958 |
if(env->head->type==empty) { |
switch(check_args(env, port, empty)) { |
959 |
printerr("Too Few Arguments"); |
case 1: |
960 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
961 |
return; |
return; |
962 |
} |
case 2: |
963 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
964 |
return; |
return; |
965 |
|
default: |
966 |
|
break; |
967 |
} |
} |
968 |
|
|
969 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
978 |
{ |
{ |
979 |
int freq, dur, period, ticks; |
int freq, dur, period, ticks; |
980 |
|
|
981 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, integer, integer, empty)) { |
982 |
printerr("Too Few Arguments"); |
case 1: |
983 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
984 |
return; |
return; |
985 |
} |
case 2: |
986 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=integer |
|
|
|| CAR(CDR(env->head))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
987 |
return; |
return; |
988 |
|
default: |
989 |
|
break; |
990 |
} |
} |
991 |
|
|
992 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
1021 |
{ |
{ |
1022 |
int dur; |
int dur; |
1023 |
|
|
1024 |
if(env->head->type==empty) { |
switch(check_args(env, integer, empty)) { |
1025 |
printerr("Too Few Arguments"); |
case 1: |
1026 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
1027 |
return; |
return; |
1028 |
} |
case 2: |
1029 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
1030 |
return; |
return; |
1031 |
|
default: |
1032 |
|
break; |
1033 |
} |
} |
1034 |
|
|
1035 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
1038 |
usleep(dur); |
usleep(dur); |
1039 |
} |
} |
1040 |
|
|
1041 |
|
|
1042 |
/* "*" */ |
/* "*" */ |
1043 |
extern void sx_2a(environment *env) |
extern void sx_2a(environment *env) |
1044 |
{ |
{ |
1045 |
int a, b; |
int a, b; |
1046 |
float fa, fb; |
float fa, fb; |
1047 |
|
|
1048 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
1049 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
1050 |
return; |
return; |
1051 |
} |
} |
1052 |
|
|
1053 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1054 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1055 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1056 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1060 |
return; |
return; |
1061 |
} |
} |
1062 |
|
|
1063 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
1064 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
1065 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1066 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
1070 |
return; |
return; |
1071 |
} |
} |
1072 |
|
|
1073 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1074 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
1075 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1076 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1080 |
return; |
return; |
1081 |
} |
} |
1082 |
|
|
1083 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
1084 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1085 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1086 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
1090 |
return; |
return; |
1091 |
} |
} |
1092 |
|
|
1093 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1094 |
env->err= 2; |
env->err= 2; |
1095 |
} |
} |
1096 |
|
|
1100 |
int a, b; |
int a, b; |
1101 |
float fa, fb; |
float fa, fb; |
1102 |
|
|
1103 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
1104 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
1105 |
return; |
return; |
1106 |
} |
} |
1107 |
|
|
1108 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1109 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1110 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1111 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1115 |
return; |
return; |
1116 |
} |
} |
1117 |
|
|
1118 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
1119 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
1120 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1121 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
1125 |
return; |
return; |
1126 |
} |
} |
1127 |
|
|
1128 |
if(CAR(env->head)->type==tfloat |
if(check_args(env, tfloat, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1129 |
fa= CAR(env->head)->content.f; |
fa= CAR(env->head)->content.f; |
1130 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1131 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1135 |
return; |
return; |
1136 |
} |
} |
1137 |
|
|
1138 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, tfloat, empty)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
1139 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1140 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1141 |
fb= CAR(env->head)->content.f; |
fb= CAR(env->head)->content.f; |
1145 |
return; |
return; |
1146 |
} |
} |
1147 |
|
|
1148 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1149 |
env->err= 2; |
env->err= 2; |
1150 |
} |
} |
1151 |
|
|
1154 |
{ |
{ |
1155 |
int a, b; |
int a, b; |
1156 |
|
|
1157 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
1158 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
1159 |
return; |
return; |
1160 |
} |
} |
1161 |
|
|
1162 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1163 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1164 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1165 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1169 |
return; |
return; |
1170 |
} |
} |
1171 |
|
|
1172 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1173 |
env->err= 2; |
env->err= 2; |
1174 |
} |
} |
1175 |
|
|
1177 |
extern void sx_646976(environment *env) |
extern void sx_646976(environment *env) |
1178 |
{ |
{ |
1179 |
int a, b; |
int a, b; |
1180 |
|
|
1181 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, unknown, unknown, empty)==1) { |
1182 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
|
env->err= 1; |
|
1183 |
return; |
return; |
1184 |
} |
} |
1185 |
|
|
1186 |
if(CAR(env->head)->type==integer |
if(check_args(env, integer, integer, empty)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
1187 |
a= CAR(env->head)->content.i; |
a= CAR(env->head)->content.i; |
1188 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1189 |
b= CAR(env->head)->content.i; |
b= CAR(env->head)->content.i; |
1193 |
return; |
return; |
1194 |
} |
} |
1195 |
|
|
1196 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1197 |
env->err= 2; |
env->err= 2; |
1198 |
} |
} |
1199 |
|
|
1200 |
|
|
1201 |
extern void setcar(environment *env) |
extern void setcar(environment *env) |
1202 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1203 |
|
|
1204 |
if(CDR(env->head)->type!=tcons) { |
switch(check_args(env, tcons, unknown, empty)) { |
1205 |
printerr("Bad Argument Type"); |
case 1: |
1206 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
1207 |
return; |
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); |
CAR(CAR(CDR(env->head)))=CAR(env->head); |
1218 |
|
|
1219 |
extern void setcdr(environment *env) |
extern void setcdr(environment *env) |
1220 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1221 |
|
|
1222 |
if(CDR(env->head)->type!=tcons) { |
switch(check_args(env, tcons, unknown, empty)) { |
1223 |
printerr("Bad Argument Type"); |
case 1: |
1224 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
1225 |
|
return; |
1226 |
|
case 2: |
1227 |
|
printerr(env, "Bad Argument Type"); |
1228 |
return; |
return; |
1229 |
|
default: |
1230 |
|
break; |
1231 |
} |
} |
1232 |
|
|
1233 |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
1236 |
|
|
1237 |
extern void car(environment *env) |
extern void car(environment *env) |
1238 |
{ |
{ |
|
if(env->head->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1239 |
|
|
1240 |
if(CAR(env->head)->type!=tcons) { |
switch(check_args(env, tcons, empty)) { |
1241 |
printerr("Bad Argument Type"); |
case 1: |
1242 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
1243 |
|
return; |
1244 |
|
case 2: |
1245 |
|
printerr(env, "Bad Argument Type"); |
1246 |
return; |
return; |
1247 |
|
default: |
1248 |
|
break; |
1249 |
} |
} |
1250 |
|
|
1251 |
CAR(env->head)=CAR(CAR(env->head)); |
CAR(env->head)=CAR(CAR(env->head)); |
1253 |
|
|
1254 |
extern void cdr(environment *env) |
extern void cdr(environment *env) |
1255 |
{ |
{ |
|
if(env->head->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1256 |
|
|
1257 |
if(CAR(env->head)->type!=tcons) { |
switch(check_args(env, tcons, empty)) { |
1258 |
printerr("Bad Argument Type"); |
case 1: |
1259 |
env->err= 2; |
printerr(env, "Too Few Arguments"); |
1260 |
|
return; |
1261 |
|
case 2: |
1262 |
|
printerr(env, "Bad Argument Type"); |
1263 |
return; |
return; |
1264 |
|
default: |
1265 |
|
break; |
1266 |
} |
} |
1267 |
|
|
1268 |
CAR(env->head)=CDR(CAR(env->head)); |
CAR(env->head)=CDR(CAR(env->head)); |
1272 |
{ |
{ |
1273 |
value *val; |
value *val; |
1274 |
|
|
1275 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, unknown, unknown, empty)) { |
1276 |
printerr("Too Few Arguments"); |
case 1: |
1277 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
1278 |
|
return; |
1279 |
|
case 2: |
1280 |
|
printerr(env, "Bad Argument Type"); |
1281 |
return; |
return; |
1282 |
|
default: |
1283 |
|
break; |
1284 |
} |
} |
1285 |
|
|
1286 |
val=new_val(env); |
val=new_val(env); |
1309 |
|
|
1310 |
/* 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 |
1311 |
list */ |
list */ |
1312 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
switch(check_args(env, tcons, unknown, empty)) { |
1313 |
printerr("Too Few Arguments"); |
case 1: |
1314 |
env->err= 1; |
printerr(env, "Too Few Arguments"); |
1315 |
return; |
return; |
1316 |
} |
case 2: |
1317 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type!=tcons) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
1318 |
return; |
return; |
1319 |
|
default: |
1320 |
|
break; |
1321 |
} |
} |
1322 |
|
|
1323 |
key=CAR(CDR(env->head)); |
key=CAR(CDR(env->head)); |
1325 |
|
|
1326 |
while(item->type == tcons){ |
while(item->type == tcons){ |
1327 |
if(CAR(item)->type != tcons){ |
if(CAR(item)->type != tcons){ |
1328 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1329 |
env->err= 2; |
env->err= 2; |
1330 |
return; |
return; |
1331 |
} |
} |
1335 |
|
|
1336 |
/* Check the result of 'eqfunc' */ |
/* Check the result of 'eqfunc' */ |
1337 |
if(env->head->type==empty) { |
if(env->head->type==empty) { |
1338 |
printerr("Too Few Arguments"); |
printerr(env, "Too Few Arguments"); |
1339 |
env->err= 1; |
env->err= 1; |
1340 |
return; |
return; |
1341 |
} |
} |
1342 |
if(CAR(env->head)->type!=integer) { |
if(CAR(env->head)->type!=integer) { |
1343 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1344 |
env->err= 2; |
env->err= 2; |
1345 |
return; |
return; |
1346 |
} |
} |
1352 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1353 |
|
|
1354 |
if(item->type!=tcons) { |
if(item->type!=tcons) { |
1355 |
printerr("Bad Argument Type"); |
printerr(env, "Bad Argument Type"); |
1356 |
env->err= 2; |
env->err= 2; |
1357 |
return; |
return; |
1358 |
} |
} |
1395 |
value *new_port; |
value *new_port; |
1396 |
FILE *stream; |
FILE *stream; |
1397 |
|
|
1398 |
if(env->head->type == empty || CDR(env->head)->type == empty) { |
switch(check_args(env, string, string, empty)) { |
1399 |
printerr("Too Few Arguments"); |
case 1: |
1400 |
env->err=1; |
printerr(env, "Too Few Arguments"); |
1401 |
return; |
return; |
1402 |
} |
case 2: |
1403 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type != string |
|
|
|| CAR(CDR(env->head))->type != string) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
1404 |
return; |
return; |
1405 |
|
default: |
1406 |
|
break; |
1407 |
} |
} |
1408 |
|
|
1409 |
stream=fopen(CAR(CDR(env->head))->content.ptr, |
stream=fopen(CAR(CDR(env->head))->content.ptr, |
1433 |
{ |
{ |
1434 |
int ret; |
int ret; |
1435 |
|
|
1436 |
if(env->head->type == empty) { |
switch(check_args(env, port, empty)) { |
1437 |
printerr("Too Few Arguments"); |
case 1: |
1438 |
env->err=1; |
printerr(env, "Too Few Arguments"); |
1439 |
return; |
return; |
1440 |
} |
case 2: |
1441 |
|
printerr(env, "Bad Argument Type"); |
|
if(CAR(env->head)->type != port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
1442 |
return; |
return; |
1443 |
|
default: |
1444 |
|
break; |
1445 |
} |
} |
1446 |
|
|
1447 |
ret= fclose(CAR(env->head)->content.p); |
ret= fclose(CAR(env->head)->content.p); |
1454 |
|
|
1455 |
toss(env); |
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 |
|
} |