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" |
25 |
|
|
26 |
/* Print newline. */ |
/* Print newline. */ |
27 |
extern void nl(environment *env) |
extern void nl(environment *env) |
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(env->head->type==empty) { |
if(check_args(env, 1, port)) |
36 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
37 |
|
|
38 |
if(CAR(env->head)->type!=port) { |
if(fprintf(CAR(env->head)->content.p, "\n") < 0) { |
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
|
|
|
|
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 |
|
|
46 |
/* Gets the type of a value */ |
/* Gets the type of a value */ |
47 |
extern void type(environment *env) |
extern void type(environment *env) |
48 |
{ |
{ |
49 |
if(env->head->type==empty) { |
|
50 |
printerr("Too Few Arguments"); |
if(check_args(env, 1, unknown)) |
51 |
env->err= 1; |
return printerr(env); |
|
return; |
|
|
} |
|
52 |
|
|
53 |
switch(CAR(env->head)->type){ |
switch(CAR(env->head)->type){ |
54 |
case empty: |
case empty: |
55 |
push_sym(env, "empty"); |
push_sym(env, "empty"); |
56 |
break; |
break; |
57 |
|
case unknown: |
58 |
|
push_sym(env, "unknown"); |
59 |
|
break; |
60 |
case integer: |
case integer: |
61 |
push_sym(env, "integer"); |
push_sym(env, "integer"); |
62 |
break; |
break; |
87 |
/* Print the top element of the stack but don't discard it */ |
/* Print the top element of the stack but don't discard it */ |
88 |
extern void print_(environment *env) |
extern void print_(environment *env) |
89 |
{ |
{ |
90 |
if(env->head->type==empty) { |
|
91 |
printerr("Too Few Arguments"); |
if(check_args(env, 1, unknown)) |
92 |
env->err= 1; |
return printerr(env); |
93 |
return; |
|
|
} |
|
94 |
print_val(env, CAR(env->head), 0, NULL, stdout); |
print_val(env, CAR(env->head), 0, NULL, stdout); |
95 |
if(env->err) return; |
if(env->err) return; |
96 |
nl(env); |
nl(env); |
108 |
discard it. */ |
discard it. */ |
109 |
extern void princ_(environment *env) |
extern void princ_(environment *env) |
110 |
{ |
{ |
111 |
if(env->head->type==empty) { |
|
112 |
printerr("Too Few Arguments"); |
if(check_args(env, 1, unknown)) |
113 |
env->err= 1; |
return printerr(env); |
114 |
return; |
|
|
} |
|
115 |
print_val(env, CAR(env->head), 1, NULL, stdout); |
print_val(env, CAR(env->head), 1, NULL, stdout); |
116 |
} |
} |
117 |
|
|
126 |
/* Print a value to a port, but don't discard it */ |
/* Print a value to a port, but don't discard it */ |
127 |
extern void printport_(environment *env) |
extern void printport_(environment *env) |
128 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
129 |
|
|
130 |
if(CAR(env->head)->type!=port) { |
if(check_args(env, 2, port, unknown)) |
131 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
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); |
134 |
if(env->err) return; |
if(env->err) return; |
146 |
/* 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. */ |
147 |
extern void princport_(environment *env) |
extern void princport_(environment *env) |
148 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type == empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
149 |
|
|
150 |
if(CAR(env->head)->type!=port) { |
if(check_args(env, 2, port, unknown)) |
151 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
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); |
154 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
166 |
extern void rot(environment *env) |
extern void rot(environment *env) |
167 |
{ |
{ |
168 |
value *temp= env->head; |
value *temp= env->head; |
169 |
|
|
170 |
if(env->head->type == empty || CDR(env->head)->type == empty |
if(check_args(env, 3, unknown, unknown, unknown)) |
171 |
|| CDR(CDR(env->head))->type == empty) { |
return printerr(env); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
172 |
|
|
173 |
env->head= CDR(CDR(env->head)); |
env->head= CDR(CDR(env->head)); |
174 |
CDR(CDR(temp))= CDR(env->head); |
CDR(CDR(temp))= CDR(env->head); |
180 |
{ |
{ |
181 |
value *temp, *new_head; |
value *temp, *new_head; |
182 |
|
|
183 |
/* Is top element a list? */ |
if(check_args(env, 1, tcons)) |
184 |
if(env->head->type==empty) { |
return printerr(env); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=tcons) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
185 |
|
|
186 |
rev(env); |
rev(env); |
187 |
|
|
193 |
|
|
194 |
toss(env); |
toss(env); |
195 |
|
|
196 |
|
/// XXX |
197 |
/* Find the end of the list */ |
/* Find the end of the list */ |
198 |
while(CDR(temp)->type != empty) { |
while(CDR(temp)->type != empty) { |
199 |
if (CDR(temp)->type == tcons) |
if (CDR(temp)->type == tcons) |
200 |
temp= CDR(temp); |
temp= CDR(temp); |
201 |
else { |
else { |
202 |
printerr("Bad Argument Type"); /* Improper list */ |
env->err= 2; /* Improper list */ |
203 |
env->err= 2; |
return printerr(env); |
|
return; |
|
204 |
} |
} |
205 |
} |
} |
206 |
|
|
215 |
{ |
{ |
216 |
void *left, *right; |
void *left, *right; |
217 |
|
|
218 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, unknown, unknown)) |
219 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
220 |
|
|
221 |
left= CAR(env->head)->content.ptr; |
left= CAR(env->head)->content.ptr; |
222 |
right= CAR(CDR(env->head))->content.ptr; |
right= CAR(CDR(env->head))->content.ptr; |
230 |
{ |
{ |
231 |
int val; |
int val; |
232 |
|
|
233 |
if(env->head->type==empty) { |
if(check_args(env, 1, integer)) |
234 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
235 |
|
|
236 |
val= CAR(env->head)->content.i; |
val= CAR(env->head)->content.i; |
237 |
toss(env); |
toss(env); |
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(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, symb, unknown)) |
255 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=symb) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
256 |
|
|
257 |
/* long names are a pain */ |
/* long names are a pain */ |
258 |
sym= CAR(env->head)->content.sym; |
sym= CAR(env->head)->content.sym; |
266 |
/* Clear stack */ |
/* Clear stack */ |
267 |
extern void clear(environment *env) |
extern void clear(environment *env) |
268 |
{ |
{ |
269 |
while(env->head->type != empty) |
env->head= new_val(env); |
|
toss(env); |
|
270 |
} |
} |
271 |
|
|
272 |
/* Forgets a symbol (remove it from the hash table) */ |
/* Forgets a symbol (remove it from the hash table) */ |
274 |
{ |
{ |
275 |
char* sym_id; |
char* sym_id; |
276 |
|
|
277 |
if(env->head->type==empty) { |
if(check_args(env, 1, symb)) |
278 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=symb) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
279 |
|
|
280 |
sym_id= CAR(env->head)->content.sym->id; |
sym_id= CAR(env->head)->content.sym->id; |
281 |
toss(env); |
toss(env); |
298 |
char* new_string; |
char* new_string; |
299 |
value *a_val, *b_val; |
value *a_val, *b_val; |
300 |
|
|
301 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, string, string)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==string |
|
|
&& CAR(CDR(env->head))->type==string) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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; |
356 |
return; |
return; |
357 |
} |
} |
358 |
|
|
359 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err=2; |
|
360 |
} |
} |
361 |
|
|
362 |
/* "-" */ |
/* "-" */ |
365 |
int a, b; |
int a, b; |
366 |
float fa, fb; |
float fa, fb; |
367 |
|
|
368 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err=1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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; |
405 |
return; |
return; |
406 |
} |
} |
407 |
|
|
408 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err=2; |
|
409 |
} |
} |
410 |
|
|
411 |
/* ">" */ |
/* ">" */ |
414 |
int a, b; |
int a, b; |
415 |
float fa, fb; |
float fa, fb; |
416 |
|
|
417 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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; |
454 |
return; |
return; |
455 |
} |
} |
456 |
|
|
457 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
458 |
} |
} |
459 |
|
|
460 |
/* "<" */ |
/* "<" */ |
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(env->head->type==empty) { |
if(check_args(env, 1, unknown)) |
485 |
printerr("Too Few Arguments"); |
return printerr(env); |
486 |
env->err= 1; |
|
|
return; |
|
|
} |
|
487 |
push_val(env, copy_val(env, CAR(env->head))); |
push_val(env, copy_val(env, CAR(env->head))); |
488 |
} |
} |
489 |
|
|
492 |
{ |
{ |
493 |
int truth; |
int truth; |
494 |
|
|
495 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, unknown, integer)) |
496 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
497 |
|
|
|
if(CAR(CDR(env->head))->type != integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
|
|
|
498 |
swap(env); |
swap(env); |
499 |
if(env->err) return; |
if(env->err) return; |
500 |
|
|
514 |
{ |
{ |
515 |
int truth; |
int truth; |
516 |
|
|
517 |
if(env->head->type==empty || CDR(env->head)->type==empty |
if(check_args(env, 3, unknown, unknown, integer)) |
518 |
|| CDR(CDR(env->head))->type==empty) { |
return printerr(env); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
519 |
|
|
|
if(CAR(CDR(CDR(env->head)))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
|
|
|
520 |
rot(env); |
rot(env); |
521 |
if(env->err) return; |
if(env->err) return; |
522 |
|
|
538 |
/* "else" */ |
/* "else" */ |
539 |
extern void sx_656c7365(environment *env) |
extern void sx_656c7365(environment *env) |
540 |
{ |
{ |
541 |
if(env->head->type==empty || CDR(env->head)->type==empty |
|
542 |
|| CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty |
if(check_args(env, 5, unknown, symb, unknown, symb, integer)) |
543 |
|| CDR(CDR(CDR(CDR(env->head))))->type==empty) { |
return printerr(env); |
544 |
printerr("Too Few Arguments"); |
|
545 |
env->err= 1; |
/// XXX |
|
return; |
|
|
} |
|
546 |
|
|
547 |
if(CAR(CDR(env->head))->type!=symb |
if(CAR(CDR(env->head))->type!=symb |
548 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0 |
549 |
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
|| CAR(CDR(CDR(CDR(env->head))))->type!=symb |
550 |
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
|| strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) { |
|
printerr("Bad Argument Type"); |
|
551 |
env->err= 2; |
env->err= 2; |
552 |
return; |
return printerr(env); |
553 |
} |
} |
554 |
|
|
555 |
swap(env); toss(env); rot(env); toss(env); |
swap(env); toss(env); rot(env); toss(env); |
558 |
|
|
559 |
extern void then(environment *env) |
extern void then(environment *env) |
560 |
{ |
{ |
561 |
if(env->head->type==empty || CDR(env->head)->type==empty |
|
562 |
|| CDR(CDR(env->head))->type==empty) { |
if(check_args(env, 3, unknown, symb, integer)) |
563 |
printerr("Too Few Arguments"); |
return printerr(env); |
564 |
env->err= 1; |
|
565 |
return; |
/// XXX |
|
} |
|
566 |
|
|
567 |
if(CAR(CDR(env->head))->type!=symb |
if(CAR(CDR(env->head))->type!=symb |
568 |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) { |
|| strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) { |
|
printerr("Bad Argument Type"); |
|
569 |
env->err= 2; |
env->err= 2; |
570 |
return; |
return printerr(env); |
571 |
} |
} |
572 |
|
|
573 |
swap(env); toss(env); |
swap(env); toss(env); |
580 |
int truth; |
int truth; |
581 |
value *loop, *test; |
value *loop, *test; |
582 |
|
|
583 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, unknown, integer)) |
584 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
585 |
|
|
586 |
loop= CAR(env->head); |
loop= CAR(env->head); |
587 |
protect(loop); |
protect(loop); |
594 |
do { |
do { |
595 |
push_val(env, test); |
push_val(env, test); |
596 |
eval(env); |
eval(env); |
597 |
|
|
598 |
|
/// XXX |
599 |
|
|
600 |
if(CAR(env->head)->type != integer) { |
if(CAR(env->head)->type != integer) { |
|
printerr("Bad Argument Type"); |
|
601 |
env->err= 2; |
env->err= 2; |
602 |
return; |
return printerr(env); |
603 |
} |
} |
604 |
|
|
605 |
truth= CAR(env->head)->content.i; |
truth= CAR(env->head)->content.i; |
624 |
value *loop; |
value *loop; |
625 |
int foo1, foo2; |
int foo1, foo2; |
626 |
|
|
627 |
if(env->head->type==empty || CDR(env->head)->type==empty |
if(check_args(env, 3, unknown, integer, integer)) |
628 |
|| CDR(CDR(env->head))->type==empty) { |
return printerr(env); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(CDR(env->head))->type!=integer |
|
|
|| CAR(CDR(CDR(env->head)))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
629 |
|
|
630 |
loop= CAR(env->head); |
loop= CAR(env->head); |
631 |
protect(loop); |
protect(loop); |
661 |
{ |
{ |
662 |
value *loop, *foo; |
value *loop, *foo; |
663 |
value *iterator; |
value *iterator; |
|
|
|
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(CDR(env->head))->type!=tcons) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
664 |
|
|
665 |
|
if(check_args(env, 2, unknown, tcons)) |
666 |
|
return printerr(env); |
667 |
|
|
668 |
loop= CAR(env->head); |
loop= CAR(env->head); |
669 |
protect(loop); |
protect(loop); |
670 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
679 |
push_val(env, CAR(iterator)); |
push_val(env, CAR(iterator)); |
680 |
push_val(env, loop); |
push_val(env, loop); |
681 |
eval(env); if(env->err) return; |
eval(env); if(env->err) return; |
682 |
|
|
683 |
|
/// XXX |
684 |
if (iterator->type == tcons){ |
if (iterator->type == tcons){ |
685 |
iterator= CDR(iterator); |
iterator= CDR(iterator); |
686 |
} else { |
} else { |
687 |
printerr("Bad Argument Type"); /* Improper list */ |
env->err= 2; /* Improper list */ |
|
env->err= 2; |
|
688 |
break; |
break; |
689 |
} |
} |
690 |
} |
} |
691 |
unprotect(loop); unprotect(foo); |
unprotect(loop); unprotect(foo); |
692 |
|
|
693 |
|
return printerr(env); |
694 |
} |
} |
695 |
|
|
696 |
/* "to" */ |
/* "to" */ |
699 |
int ending, start, i; |
int ending, start, i; |
700 |
value *iterator, *temp, *end; |
value *iterator, *temp, *end; |
701 |
|
|
702 |
end= new_val(env); |
if(check_args(env, 2, integer, integer)) |
703 |
|
return printerr(env); |
704 |
|
|
705 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
end= new_val(env); |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=integer |
|
|
|| CAR(CDR(env->head))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
706 |
|
|
707 |
ending= CAR(env->head)->content.i; |
ending= CAR(env->head)->content.i; |
708 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
757 |
{ |
{ |
758 |
FILE *stream; |
FILE *stream; |
759 |
|
|
760 |
if(env->head->type==empty) { |
if(check_args(env, 1, port)) |
761 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
762 |
|
|
763 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
764 |
readlinestream(env, stream); if(env->err) return; |
readlinestream(env, stream); if(env->err) return; |
778 |
{ |
{ |
779 |
FILE *stream; |
FILE *stream; |
780 |
|
|
781 |
if(env->head->type==empty) { |
if(check_args(env, 1, port)) |
782 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=port) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
783 |
|
|
784 |
stream=CAR(env->head)->content.p; |
stream=CAR(env->head)->content.p; |
785 |
readstream(env, stream); if(env->err) return; |
readstream(env, stream); if(env->err) return; |
793 |
{ |
{ |
794 |
int freq, dur, period, ticks; |
int freq, dur, period, ticks; |
795 |
|
|
796 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)) |
797 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=integer |
|
|
|| CAR(CDR(env->head))->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
798 |
|
|
799 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
800 |
toss(env); |
toss(env); |
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(env->head->type==empty) { |
if(check_args(env, 1, integer)) |
831 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
832 |
|
|
833 |
dur= CAR(env->head)->content.i; |
dur= CAR(env->head)->content.i; |
834 |
toss(env); |
toss(env); |
836 |
usleep(dur); |
usleep(dur); |
837 |
} |
} |
838 |
|
|
839 |
|
|
840 |
/* "*" */ |
/* "*" */ |
841 |
extern void sx_2a(environment *env) |
extern void sx_2a(environment *env) |
842 |
{ |
{ |
843 |
int a, b; |
int a, b; |
844 |
float fa, fb; |
float fa, fb; |
845 |
|
|
846 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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; |
883 |
return; |
return; |
884 |
} |
} |
885 |
|
|
886 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
887 |
} |
} |
888 |
|
|
889 |
/* "/" */ |
/* "/" */ |
892 |
int a, b; |
int a, b; |
893 |
float fa, fb; |
float fa, fb; |
894 |
|
|
895 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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(CAR(env->head)->type==tfloat |
if(check_args(env, 2, tfloat, integer)==0) { |
|
&& CAR(CDR(env->head))->type==integer) { |
|
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(CAR(env->head)->type==integer |
if(check_args(env, 2, integer, tfloat)==0) { |
|
&& CAR(CDR(env->head))->type==tfloat) { |
|
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; |
932 |
return; |
return; |
933 |
} |
} |
934 |
|
|
935 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
936 |
} |
} |
937 |
|
|
938 |
/* "mod" */ |
/* "mod" */ |
940 |
{ |
{ |
941 |
int a, b; |
int a, b; |
942 |
|
|
943 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, integer, integer)==0) { |
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
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; |
950 |
return; |
return; |
951 |
} |
} |
952 |
|
|
953 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
954 |
} |
} |
955 |
|
|
956 |
|
|
957 |
/* "div" */ |
/* "div" */ |
958 |
extern void sx_646976(environment *env) |
extern void sx_646976(environment *env) |
959 |
{ |
{ |
960 |
int a, b; |
int a, b; |
|
|
|
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type==integer |
|
|
&& CAR(CDR(env->head))->type==integer) { |
|
|
a= CAR(env->head)->content.i; |
|
|
toss(env); if(env->err) return; |
|
|
b= CAR(env->head)->content.i; |
|
|
toss(env); if(env->err) return; |
|
|
push_int(env, (int)b/a); |
|
|
|
|
|
return; |
|
|
} |
|
961 |
|
|
962 |
printerr("Bad Argument Type"); |
if(check_args(env, 2, integer, integer)) |
963 |
env->err= 2; |
return printerr(env); |
964 |
|
|
965 |
|
a= CAR(env->head)->content.i; |
966 |
|
toss(env); if(env->err) return; |
967 |
|
b= CAR(env->head)->content.i; |
968 |
|
toss(env); if(env->err) return; |
969 |
|
push_int(env, (int)b/a); |
970 |
} |
} |
971 |
|
|
972 |
|
|
973 |
extern void setcar(environment *env) |
extern void setcar(environment *env) |
974 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
975 |
|
|
976 |
if(CDR(env->head)->type!=tcons) { |
if(check_args(env, 2, tcons, unknown)) |
977 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
978 |
|
|
979 |
CAR(CAR(CDR(env->head)))=CAR(env->head); |
CAR(CAR(CDR(env->head)))=CAR(env->head); |
980 |
toss(env); |
toss(env); |
982 |
|
|
983 |
extern void setcdr(environment *env) |
extern void setcdr(environment *env) |
984 |
{ |
{ |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
985 |
|
|
986 |
if(CDR(env->head)->type!=tcons) { |
if(check_args(env, 2, tcons, unknown)) |
987 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
988 |
|
|
989 |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
CDR(CAR(CDR(env->head)))=CAR(env->head); |
990 |
toss(env); |
toss(env); |
992 |
|
|
993 |
extern void car(environment *env) |
extern void car(environment *env) |
994 |
{ |
{ |
|
if(env->head->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
995 |
|
|
996 |
if(CAR(env->head)->type!=tcons) { |
if(check_args(env, 1, tcons)) |
997 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
998 |
|
|
999 |
CAR(env->head)=CAR(CAR(env->head)); |
CAR(env->head)=CAR(CAR(env->head)); |
1000 |
} |
} |
1001 |
|
|
1002 |
extern void cdr(environment *env) |
extern void cdr(environment *env) |
1003 |
{ |
{ |
|
if(env->head->type==empty) { |
|
|
printerr("Too Few Arguments"); |
|
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1004 |
|
|
1005 |
if(CAR(env->head)->type!=tcons) { |
if(check_args(env, 1, tcons)) |
1006 |
printerr("Bad Argument Type"); |
return printerr(env); |
|
env->err= 2; |
|
|
return; |
|
|
} |
|
1007 |
|
|
1008 |
CAR(env->head)=CDR(CAR(env->head)); |
CAR(env->head)=CDR(CAR(env->head)); |
1009 |
} |
} |
1012 |
{ |
{ |
1013 |
value *val; |
value *val; |
1014 |
|
|
1015 |
if(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, unknown, unknown)) |
1016 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
1017 |
|
|
1018 |
val=new_val(env); |
val=new_val(env); |
1019 |
val->content.c= malloc(sizeof(pair)); |
val->content.c= malloc(sizeof(pair)); |
1030 |
swap(env); if(env->err) return; |
swap(env); if(env->err) return; |
1031 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1032 |
swap(env); if(env->err) return; |
swap(env); if(env->err) return; |
1033 |
toss(env); if(env->err) return; |
toss(env); |
1034 |
} |
} |
1035 |
|
|
1036 |
|
|
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(env->head->type==empty || CDR(env->head)->type==empty) { |
if(check_args(env, 2, tcons, unknown)) |
1045 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type!=tcons) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
1046 |
|
|
1047 |
key=CAR(CDR(env->head)); |
key=CAR(CDR(env->head)); |
1048 |
item=CAR(env->head); |
item=CAR(env->head); |
1049 |
|
|
1050 |
while(item->type == tcons){ |
while(item->type == tcons){ |
1051 |
if(CAR(item)->type != tcons){ |
if(CAR(item)->type != tcons){ |
|
printerr("Bad Argument Type"); |
|
1052 |
env->err= 2; |
env->err= 2; |
1053 |
return; |
return printerr(env); |
1054 |
} |
} |
1055 |
|
|
1056 |
push_val(env, key); |
push_val(env, key); |
1057 |
push_val(env, CAR(CAR(item))); |
push_val(env, CAR(CAR(item))); |
1058 |
eqfunc(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(env->head->type==empty) { |
if(check_args(env, 1, integer)) |
1062 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err= 1; |
|
|
return; |
|
|
} |
|
|
if(CAR(env->head)->type!=integer) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
1063 |
|
|
1064 |
if(CAR(env->head)->content.i){ |
if(CAR(env->head)->content.i){ |
1065 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1068 |
toss(env); if(env->err) return; |
toss(env); if(env->err) return; |
1069 |
|
|
1070 |
if(item->type!=tcons) { |
if(item->type!=tcons) { |
|
printerr("Bad Argument Type"); |
|
1071 |
env->err= 2; |
env->err= 2; |
1072 |
return; |
return printerr(env); |
1073 |
} |
} |
1074 |
|
|
1075 |
item=CDR(item); |
item=CDR(item); |
1091 |
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
/* 1: [ [ 1 . 2 ] [ 3 . 4 ] ] => 1: [ 3 . 4 ] */ |
1092 |
extern void assq(environment *env) |
extern void assq(environment *env) |
1093 |
{ |
{ |
1094 |
assocgen(env, eq); |
assocgen(env, (void*)eq); |
1095 |
} |
} |
1096 |
|
|
1097 |
|
|
1110 |
value *new_port; |
value *new_port; |
1111 |
FILE *stream; |
FILE *stream; |
1112 |
|
|
1113 |
if(env->head->type == empty || CDR(env->head)->type == empty) { |
if(check_args(env, 2, string, string)) |
1114 |
printerr("Too Few Arguments"); |
return printerr(env); |
|
env->err=1; |
|
|
return; |
|
|
} |
|
|
|
|
|
if(CAR(env->head)->type != string |
|
|
|| CAR(CDR(env->head))->type != string) { |
|
|
printerr("Bad Argument Type"); |
|
|
env->err= 2; |
|
|
return; |
|
|
} |
|
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, 1, port)) |
1143 |
|
return printerr(env); |
1144 |
|
|
1145 |
|
ret= fclose(CAR(env->head)->content.p); |
1146 |
|
|
1147 |
|
if(ret != 0){ |
1148 |
|
env->err= 5; |
1149 |
|
return printerr(env); |
1150 |
|
} |
1151 |
|
|
1152 |
|
toss(env); |
1153 |
|
} |
1154 |
|
|
1155 |
|
|
1156 |
|
extern void mangle(environment *env) |
1157 |
|
{ |
1158 |
|
char *new_string; |
1159 |
|
|
1160 |
|
if(check_args(env, 1, string)) |
1161 |
|
return printerr(env); |
1162 |
|
|
1163 |
|
new_string= mangle_str(CAR(env->head)->content.string); |
1164 |
|
|
1165 |
|
toss(env); |
1166 |
|
if(env->err) return; |
1167 |
|
|
1168 |
|
push_cstring(env, new_string); |
1169 |
|
} |
1170 |
|
|
1171 |
|
/* "fork" */ |
1172 |
|
extern void sx_666f726b(environment *env) |
1173 |
|
{ |
1174 |
|
push_int(env, fork()); |
1175 |
|
} |
1176 |
|
|
1177 |
|
/* "waitpid" */ |
1178 |
|
extern void sx_77616974706964(environment *env) |
1179 |
|
{ |
1180 |
|
|
1181 |
|
if(check_args(env, 1, integer)) |
1182 |
|
return printerr(env); |
1183 |
|
|
1184 |
|
push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0)); |
1185 |
|
swap(env); toss(env); |
1186 |
|
} |
1187 |
|
|
1188 |
|
|
1189 |
|
/* Discard the top element of the stack. */ |
1190 |
|
extern void toss(environment *env) |
1191 |
|
{ |
1192 |
|
|
1193 |
|
if(check_args(env, 1, unknown)) |
1194 |
|
return printerr(env); |
1195 |
|
|
1196 |
|
env->head= CDR(env->head); /* Remove the top stack item */ |
1197 |
|
} |
1198 |
|
|
1199 |
|
|
1200 |
|
/* Quit stack. */ |
1201 |
|
extern void quit(environment *env) |
1202 |
|
{ |
1203 |
|
int i; |
1204 |
|
|
1205 |
|
env->head= new_val(env); |
1206 |
|
|
1207 |
|
if (env->err) return; |
1208 |
|
for(i= 0; i<HASHTBLSIZE; i++) { |
1209 |
|
while(env->symbols[i]!= NULL) { |
1210 |
|
forget_sym(&(env->symbols[i])); |
1211 |
|
} |
1212 |
|
env->symbols[i]= NULL; |
1213 |
|
} |
1214 |
|
|
1215 |
|
env->gc_limit= 0; |
1216 |
|
gc_maybe(env); |
1217 |
|
|
1218 |
|
words(env); |
1219 |
|
|
1220 |
|
if(env->free_string!=NULL) |
1221 |
|
free(env->free_string); |
1222 |
|
|
1223 |
|
#ifdef __linux__ |
1224 |
|
muntrace(); |
1225 |
|
#endif |
1226 |
|
|
1227 |
|
exit(EXIT_SUCCESS); |
1228 |
|
} |
1229 |
|
|
1230 |
|
|
1231 |
|
/* List all defined words */ |
1232 |
|
extern void words(environment *env) |
1233 |
|
{ |
1234 |
|
symbol *temp; |
1235 |
|
int i; |
1236 |
|
|
1237 |
|
for(i= 0; i<HASHTBLSIZE; i++) { |
1238 |
|
temp= env->symbols[i]; |
1239 |
|
while(temp!=NULL) { |
1240 |
|
#ifdef DEBUG |
1241 |
|
if (temp->val != NULL && temp->val->gc.flag.protect) |
1242 |
|
printf("(protected) "); |
1243 |
|
#endif /* DEBUG */ |
1244 |
|
printf("%s ", temp->id); |
1245 |
|
temp= temp->next; |
1246 |
|
} |
1247 |
|
} |
1248 |
|
} |
1249 |
|
|
1250 |
|
|
1251 |
|
/* Only to be called by itself function printstack. */ |
1252 |
|
void print_st(environment *env, value *stack_head, long counter) |
1253 |
|
{ |
1254 |
|
if(CDR(stack_head)->type != empty) |
1255 |
|
print_st(env, CDR(stack_head), counter+1); |
1256 |
|
printf("%ld: ", counter); |
1257 |
|
print_val(env, CAR(stack_head), 0, NULL, stdout); |
1258 |
|
printf("\n"); |
1259 |
|
} |
1260 |
|
|
1261 |
|
|
1262 |
|
/* Prints the stack. */ |
1263 |
|
extern void printstack(environment *env) |
1264 |
|
{ |
1265 |
if(env->head->type == empty) { |
if(env->head->type == empty) { |
1266 |
printerr("Too Few Arguments"); |
printf("Stack Empty\n"); |
|
env->err=1; |
|
1267 |
return; |
return; |
1268 |
} |
} |
1269 |
|
|
1270 |
if(CAR(env->head)->type != port) { |
print_st(env, env->head, 1); |
1271 |
printerr("Bad Argument Type"); |
} |
1272 |
env->err= 2; |
|
1273 |
|
|
1274 |
|
extern void copying(environment *env) |
1275 |
|
{ |
1276 |
|
puts(license_message); |
1277 |
|
} |
1278 |
|
|
1279 |
|
|
1280 |
|
extern void warranty(environment *env) |
1281 |
|
{ |
1282 |
|
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; |
return; |
1340 |
} |
} |
1341 |
|
|
1342 |
ret= fclose(CAR(env->head)->content.p); |
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 |
|
|
|
if(ret != 0){ |
|
|
perror("close"); |
|
|
env->err= 5; |
|
1385 |
return; |
return; |
1386 |
} |
} |
1387 |
|
|
1388 |
toss(env); |
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 |
} |
} |