20 |
Teddy Hogeborn <teddy@fukt.bth.se> |
Teddy Hogeborn <teddy@fukt.bth.se> |
21 |
*/ |
*/ |
22 |
|
|
23 |
#define CAR(X) X->content.c->car |
#define CAR(X) (X->content.c->car) |
24 |
#define CDR(X) X->content.c->cdr |
#define CDR(X) (X->content.c->cdr) |
25 |
|
|
26 |
/* printf, sscanf, fgets, fprintf, fopen, perror */ |
/* printf, sscanf, fgets, fprintf, fopen, perror */ |
27 |
#include <stdio.h> |
#include <stdio.h> |
233 |
/* Keep values */ |
/* Keep values */ |
234 |
env->gc_count += sizeof(value); |
env->gc_count += sizeof(value); |
235 |
if(env->gc_ref->item->type==string) |
if(env->gc_ref->item->type==string) |
236 |
env->gc_count += strlen(env->gc_ref->item->content.ptr); |
env->gc_count += strlen(env->gc_ref->item->content.ptr)+1; |
237 |
|
|
238 |
titem= env->gc_ref->next; |
titem= env->gc_ref->next; |
239 |
env->gc_ref->next= new_head; |
env->gc_ref->next= new_head; |
450 |
/* Gets the type of a value */ |
/* Gets the type of a value */ |
451 |
extern void type(environment *env) |
extern void type(environment *env) |
452 |
{ |
{ |
|
int typenum; |
|
|
|
|
453 |
if(env->head->type==empty) { |
if(env->head->type==empty) { |
454 |
printerr("Too Few Arguments"); |
printerr("Too Few Arguments"); |
455 |
env->err= 1; |
env->err= 1; |
456 |
return; |
return; |
457 |
} |
} |
458 |
|
|
459 |
typenum= CAR(env->head)->type; |
switch(CAR(env->head)->type){ |
460 |
toss(env); |
case empty: |
461 |
switch(typenum){ |
push_sym(env, "empty"); |
462 |
|
break; |
463 |
case integer: |
case integer: |
464 |
push_sym(env, "integer"); |
push_sym(env, "integer"); |
465 |
break; |
break; |
476 |
push_sym(env, "function"); |
push_sym(env, "function"); |
477 |
break; |
break; |
478 |
case tcons: |
case tcons: |
479 |
push_sym(env, "list"); |
push_sym(env, "pair"); |
480 |
break; |
break; |
481 |
} |
} |
482 |
|
swap(env); |
483 |
|
if (env->err) return; |
484 |
|
toss(env); |
485 |
} |
} |
486 |
|
|
487 |
/* Prints the top element of the stack. */ |
/* Print a value */ |
488 |
void print_h(value *stack_head, int noquote) |
void print_val(value *val, int noquote) |
489 |
{ |
{ |
490 |
switch(CAR(stack_head)->type) { |
switch(val->type) { |
491 |
|
case empty: |
492 |
|
printf("[]"); |
493 |
|
break; |
494 |
case integer: |
case integer: |
495 |
printf("%d", CAR(stack_head)->content.i); |
printf("%d", val->content.i); |
496 |
break; |
break; |
497 |
case tfloat: |
case tfloat: |
498 |
printf("%f", CAR(stack_head)->content.f); |
printf("%f", val->content.f); |
499 |
break; |
break; |
500 |
case string: |
case string: |
501 |
if(noquote) |
if(noquote) |
502 |
printf("%s", (char*)CAR(stack_head)->content.ptr); |
printf("%s", (char*)(val->content.ptr)); |
503 |
else |
else |
504 |
printf("\"%s\"", (char*)CAR(stack_head)->content.ptr); |
printf("\"%s\"", (char*)(val->content.ptr)); |
505 |
break; |
break; |
506 |
case symb: |
case symb: |
507 |
printf("%s", CAR(stack_head)->content.sym->id); |
printf("%s", val->content.sym->id); |
508 |
break; |
break; |
509 |
case func: |
case func: |
510 |
printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr)); |
printf("#<function %p>", (funcp)(val->content.ptr)); |
511 |
break; |
break; |
512 |
case tcons: |
case tcons: |
|
/* A list is just a stack, so make stack_head point to it */ |
|
|
stack_head= CAR(stack_head); |
|
513 |
printf("[ "); |
printf("[ "); |
514 |
while(CAR(stack_head)->type != empty) { |
do { |
515 |
print_h(stack_head, noquote); |
print_val(CAR(val), noquote); |
516 |
if(CDR(stack_head)->type==tcons) |
val= CDR(val); |
517 |
|
switch(val->type){ |
518 |
|
case empty: |
519 |
|
break; |
520 |
|
case tcons: |
521 |
printf(" "); |
printf(" "); |
522 |
else |
break; |
523 |
|
default: |
524 |
printf(" . "); /* Improper list */ |
printf(" . "); /* Improper list */ |
525 |
stack_head= CDR(stack_head); |
print_val(val, noquote); |
526 |
} |
} |
527 |
|
} while(val->type == tcons); |
528 |
printf(" ]"); |
printf(" ]"); |
529 |
break; |
break; |
530 |
} |
} |
537 |
env->err= 1; |
env->err= 1; |
538 |
return; |
return; |
539 |
} |
} |
540 |
print_h(env->head, 0); |
print_val(CAR(env->head), 0); |
541 |
nl(); |
nl(); |
542 |
} |
} |
543 |
|
|
556 |
env->err= 1; |
env->err= 1; |
557 |
return; |
return; |
558 |
} |
} |
559 |
print_h(env->head, 1); |
print_val(CAR(env->head), 1); |
560 |
} |
} |
561 |
|
|
562 |
/* Prints the top element of the stack and then discards it. */ |
/* Prints the top element of the stack and then discards it. */ |
573 |
if(CDR(stack_head)->type != empty) |
if(CDR(stack_head)->type != empty) |
574 |
print_st(CDR(stack_head), counter+1); |
print_st(CDR(stack_head), counter+1); |
575 |
printf("%ld: ", counter); |
printf("%ld: ", counter); |
576 |
print_h(stack_head, 0); |
print_val(CAR(stack_head), 0); |
577 |
nl(); |
nl(); |
578 |
} |
} |
579 |
|
|
1725 |
} else { |
} else { |
1726 |
push_float(env, ftemp); |
push_float(env, ftemp); |
1727 |
} |
} |
1728 |
|
} else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF |
1729 |
|
&& readlength != -1) { |
1730 |
|
push_cstring(env, ""); |
1731 |
} else if(sscanf(env->in_string, strform, match, &readlength) != EOF |
} else if(sscanf(env->in_string, strform, match, &readlength) != EOF |
1732 |
&& readlength != -1) { |
&& readlength != -1) { |
1733 |
push_cstring(env, match); |
push_cstring(env, match); |
2283 |
printerr("Bad Argument Type"); |
printerr("Bad Argument Type"); |
2284 |
env->err= 2; |
env->err= 2; |
2285 |
} |
} |
2286 |
|
|
2287 |
|
extern void setcar(environment *env) |
2288 |
|
{ |
2289 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2290 |
|
printerr("Too Few Arguments"); |
2291 |
|
env->err= 1; |
2292 |
|
return; |
2293 |
|
} |
2294 |
|
|
2295 |
|
if(CDR(env->head)->type!=tcons) { |
2296 |
|
printerr("Bad Argument Type"); |
2297 |
|
env->err= 2; |
2298 |
|
return; |
2299 |
|
} |
2300 |
|
|
2301 |
|
CAR(CAR(CDR(env->head)))=CAR(env->head); |
2302 |
|
toss(env); |
2303 |
|
} |
2304 |
|
|
2305 |
|
extern void setcdr(environment *env) |
2306 |
|
{ |
2307 |
|
if(env->head->type==empty || CDR(env->head)->type==empty) { |
2308 |
|
printerr("Too Few Arguments"); |
2309 |
|
env->err= 1; |
2310 |
|
return; |
2311 |
|
} |
2312 |
|
|
2313 |
|
if(CDR(env->head)->type!=tcons) { |
2314 |
|
printerr("Bad Argument Type"); |
2315 |
|
env->err= 2; |
2316 |
|
return; |
2317 |
|
} |
2318 |
|
|
2319 |
|
CDR(CAR(CDR(env->head)))=CAR(env->head); |
2320 |
|
toss(env); |
2321 |
|
} |
2322 |
|
|
2323 |
|
extern void car(environment *env) |
2324 |
|
{ |
2325 |
|
if(env->head->type==empty) { |
2326 |
|
printerr("Too Few Arguments"); |
2327 |
|
env->err= 1; |
2328 |
|
return; |
2329 |
|
} |
2330 |
|
|
2331 |
|
if(CAR(env->head)->type!=tcons) { |
2332 |
|
printerr("Bad Argument Type"); |
2333 |
|
env->err= 2; |
2334 |
|
return; |
2335 |
|
} |
2336 |
|
|
2337 |
|
CAR(env->head)=CAR(CAR(env->head)); |
2338 |
|
} |
2339 |
|
|
2340 |
|
extern void cdr(environment *env) |
2341 |
|
{ |
2342 |
|
if(env->head->type==empty) { |
2343 |
|
printerr("Too Few Arguments"); |
2344 |
|
env->err= 1; |
2345 |
|
return; |
2346 |
|
} |
2347 |
|
|
2348 |
|
if(CAR(env->head)->type!=tcons) { |
2349 |
|
printerr("Bad Argument Type"); |
2350 |
|
env->err= 2; |
2351 |
|
return; |
2352 |
|
} |
2353 |
|
|
2354 |
|
CAR(env->head)=CDR(CAR(env->head)); |
2355 |
|
} |