gscheme/testscheme.m

/*
  test scheme parser
  by marko riedel, mriedel@neuearbeit.de
*/

#include <locale.h>
#include <stdio.h>
#include <stdlib.h>

#import "SchemeTypes.h"
#import "VScheme.h"

id yyresult;


static char *forms[] = {
    "top",
    "define1", "define2", "set",
    "lambda1", "lambda2",
    "quote", "binding",
    "let", "let*", "letrec",
    "if1", "if2", 
    "and", "or", 
    "begin", "apply",
    "case", "scond1", "scond2", "scond3", "cond",
    "callcc"
};

void print_tree(id item, int indent)
{
    int pos;

    for(pos=0; pos<indent; pos++){
        putchar(' ');
    }


    if(item==[NSNull null]){
        puts("'()");
    }
    else if([item isKindOfClass:[Boolean class]]){
        printf("BOOL: %s\n", (![item boolVal] ? "NO" : "YES"));
    }
    else if([item isKindOfClass:[Char class]]){
        char c = [item charVal];
        if(c=='\n'){
            printf("CHAR: <\\newline>\n");
        }
        else if(c=='\t'){
            printf("CHAR: <\\tab>\n");
        }
        else if(c==' '){
            printf("CHAR: <\\space>\n");
        }
        else{
            printf("CHAR: <%c>\n", c);
        }
    }
    else if([item isKindOfClass:[Int class]]){
        printf("INT: %ld\n", [item intVal]);
    }
    else if([item isKindOfClass:[Double class]]){
        printf("DOUBLE: %le\n", [item doubleVal]);
    }
    else if([item isKindOfClass:[Symbol class]]){
        printf("SYMBOL: <%s>\n", [[item symVal] cString]);
    }
    else if([item isKindOfClass:[String class]]){
        printf("STRING: <%s>\n", [[item strVal] cString]);
    }
    else if([item isKindOfClass:[Closure class]]){
        printf("CLOSURE %s\n", 
               [[VScheme valToString:[item args]] cString]);
    }
    else if([item isKindOfClass:[Primitive class]]){
        printf("PRIMITIVE\n");
    }
    else if([item isKindOfClass:[Thunk class]]){
        printf("THUNK %d %d %d\n", [item argp], [item envp], [item codep]);
    }
    else if([item isKindOfClass:[Pair class]]){
        printf("PAIR %s\n", [[VScheme valToString:item] cString]);
    }
    else if([item isKindOfClass:[NSMutableArray class]]){
        printf("CODES: %u\n", [item count]);
    }
    else{
        printf("FORM %s\n", forms[[item tag]]);
        if([item arg1]!=nil){
            print_tree([item arg1], indent+1);
        }
        if([item arg2]!=nil){
            print_tree([item arg2], indent+1);
        }
        if([item arg3]!=nil){
            print_tree([item arg3], indent+1);
        }
    }
}

void print_scheme_item(id item)
{
    print_tree(item, 0);
}



yyerror(char *s)  /* Called by yyparse on error */
{
  printf ("%s\n", s);
}

int main(int argc, char **argv)
{
    NSAutoreleasePool *pool = [NSAutoreleasePool new];
    NSApplication     *theApp;
    VScheme *vm;
    id forms, item;

    GSDebugAllocationActive(YES);

    vm = [[VScheme alloc] init];

    theApp = [NSApplication sharedApplication];
    // [theApp run];

    setlocale(LC_NUMERIC, "C");
    printf("locale %s\n", setlocale(LC_NUMERIC, NULL));

    yyparse();
    // print_scheme_item(yyresult);
    [vm setSource:yyresult];

    forms = yyresult;
    while(forms!=[NSNull null]){
        NSMutableArray *codes = [NSMutableArray arrayWithCapacity:1];
        BOOL err = [vm compile:[forms arg1] output:codes];
        print_scheme_item([forms arg1]);
        if(err==NO){
            [VScheme printCodes:codes];
            [vm clearOutput];
            if([vm run:codes]==YES){
                id stack = [vm argStack], envs = [vm envStack],
                    code = [vm codeStack];
                int count = 0;
                while(count<[stack count]){
                    printf("stack %d: ", count);
                    print_scheme_item([stack objectAtIndex:count++]);
                }

                printf("code: %d (%d) pc: %d args: %d (%d) envs: %d (%d):",
                       [code count], [vm maxcode], 
                       [vm maxpc], 
                       [stack count], [vm maxarg], 
                       [envs count], [vm maxenv]);
                
                count=0;
                while(count<[envs count]){
                    id env = [envs objectAtIndex:count++];
                    printf("(%d)", [env chainLength]);
                }
                putchar('\n');

                printf("OUTPUT\n%s\n", [[vm output] cString]);
                
                [vm resetStacks];
            }
            else{
                printf("run time error: %s\n",  [[vm errmsg] cString]);
            }
        }
        else{
            printf("compilation failed: %s\n", [[vm errmsg] cString]);
        }


        [codes removeAllObjects];

        forms = [forms arg2];
    }
    
    // [pool release];
    
    return 0;
}