#import "VScheme.h"
#import "SchemeDelegate.h"



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:[Vector class]]){
        printf("PAIR %s\n", [[VScheme valToString:item] cString]);
    }
    else if([item isKindOfClass:[ByteCodes class]]){
        printf("CODES: %u\n", [[item codes] 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);
}


@implementation VScheme

static char *codenames[] = {
    "TO_ARGS",
    "LOOKUP",
    "CHECK_PTC",
    "POP_ENV",
    "POP_ARGS",
    "APPLIC",
    "LIST_APPLIC",
    "DEFINE",
    "SET",
    "CLOSURE",
    "IF",
    "LAYER",
    "MEMQ",
    "DUP_ARG",
    "EXCH_ARGS",
    "STATE_TO_THUNK",
    "MARK_THUNK"
};


+ (NSString *)valToString:(id)item seen:(NSMutableSet *)mem
{
    if(item==[NSNull null]){
        return @"()";
    }

    if((isPair(item) || isVector(item)) && 
        [mem containsObject:item]==YES){
        return @"<circular>";
    }

    if(isBoolean(item)){
        return ([item boolVal]==YES ? @"#t" : @"#f");
    }
    else if(isChar(item)){
        NSString *format;
        char c = [item charVal];
        if(c=='\n'){
            format = @"#\\newline";
        }
        else if(c=='\t'){
            format = @"#\\tab";
        }
        else if(c==' '){
            format = @"#\\space";
        }
        else{
            format = @"#\\%c";
        }
        return [[NSString alloc]
                   initWithFormat:format locale: nil, c];
    }
    else if(isInt(item)){
        return [[NSString alloc]
                   initWithFormat:@"%d" locale: nil, [item intVal]];
    }
    else if(isDouble(item)){
        return [[NSString alloc]
                   initWithFormat:@"%le" locale: nil, [item doubleVal]];
    }
    else if(isSymbol(item)){
        return [[NSString alloc]
                   initWithFormat:@"%@" locale: nil, [item symVal]];
    }
    else if(isString(item)){
        return [[NSString alloc]
                   initWithFormat:@"\"%@\"" locale: nil, [item strVal]];
    }
    else if(isClosure(item)){
        return [[NSString alloc]
                   initWithFormat:@"<closure: %@>"
                   locale: nil, 
                   [VScheme valToString:[item args] seen:mem]];
    }
    else if(isPrimitive(item)){
        return [[NSString alloc]
                   initWithFormat:@"<primitive: %@>"
                   locale: nil, [item primName]];
    }
    else if(isThunk(item)){
        return [[NSString alloc]
                   initWithFormat:@"<thunk: %d %d %d>"
                   locale: nil, [item argp], [item envp], [item codep]];
    }
    else if(isPair(item)){
        NSString *str;
        NSMutableSet *local = [NSMutableSet setWithCapacity:1];
        NSEnumerator *en;

        [mem addObject:item]; [local addObject:item];
        str = [VScheme valToString:[item car] seen:mem];

        item = [item cdr];
        while(isPair(item) && [mem containsObject:item]==NO){
            [mem addObject:item]; [local addObject:item];
            str = [str stringByAppendingFormat:@" %@",
                       [VScheme valToString:[item car] seen:mem]];

            item = [item cdr];
        }

        if(isPair(item)){
            str = [str stringByAppendingString:@" <circular>"];
        }
        else if(item!=[NSNull null]){
            str = [str stringByAppendingFormat:@" . %@",
                       [VScheme valToString:item seen:mem]];
        }

        en = [local objectEnumerator];
        while((item = [en nextObject])!=nil){
            [mem removeObject:item];
        }
        
        [local removeAllObjects];
            
        return [NSString stringWithFormat:@"(%@)", str];
    }
    else if(isVector(item)){
        id *entries = [item entries];
        NSString *str;
        int count = [item count], index;

        if(!count){
            return @"#()";
        }

        [mem addObject:item];

        str = [NSString stringWithFormat:@"#(%@",
                        [VScheme valToString:entries[0] seen:mem]];
        for(index=1; index<count; index++){
            str = [str stringByAppendingFormat:@" %@",
                       [VScheme valToString:entries[index] seen:mem]];
        }
        str = [str stringByAppendingString:@")"];

        [mem removeObject:item];

        return str;
    }
    else{
        return [[NSString alloc] initWithFormat:@"%@"
                                 locale: nil, item];
    }
}

+ (NSString *)valToString:(id)item
{
    NSMutableSet *mem = [NSMutableSet setWithCapacity:1];
    return [VScheme valToString:item seen:mem];
}

+ printInstr:(Triple *)instr
{
    int tag;
    tag = [instr tag];
    if(0<= tag && tag<INSTR_COUNT){
        printf("%s\n", codenames[[instr tag]]);
    }
    switch(tag){
        case IN_TO_ARGS:
            print_scheme_item([instr arg1]);
            break;
        case IN_LOOKUP:
        case IN_CHECK_PTC:
        case IN_LIST_APPLIC:
        case IN_DUP_ARG:
        case IN_EXCH_ARGS:
            break;    
        case IN_STATE_TO_THUNK:
        case IN_MARK_THUNK: {
            Thunk *t = [instr arg1];
            printf("%d %d %d", [t argp], [t envp], [t codep]);
        } break;
        case IN_POP_ENV:
        case IN_POP_ARGS:
        case IN_APPLIC:
        case IN_LAYER:
            printf("%d", [instr intarg1]);
            break;    
        case IN_DEFINE:
        case IN_SET:
        case IN_CLOSURE:
        case IN_MEMQ:
            break;
        case IN_IF:
            print_scheme_item([instr arg1]);
            print_scheme_item([instr arg2]);
            break;
        default:
            printf("tag out of range: %d\n", tag);
    }
    putchar('\n');

    return self;
}


+ printCodes:(NSMutableArray *)codes
{
    NSEnumerator *enumerator = [codes objectEnumerator];
    id instr;

    while((instr = [enumerator nextObject])){
        [self printInstr:instr];
    }

    return self;
}

- init
{
    [super init];

    codeStack = nil;
    pcStack = nil;
    argStack  = nil;
    envStack = nil;

    output = nil;

    [self reset:self];
    return self;
}

- delegate
{
    return delegate;
}

- setDelegate:(id)aDelegate
{
    delegate = aDelegate;
    return self;
}


- resetStacks;
{
    if(codeStack!=nil){
        [codeStack release];
        codeStack = nil;
    }
    if(pcStack!=nil){
        [pcStack release];
        pcStack = nil;
    }
    if(argStack!=nil){
        [argStack release];
        argStack = nil;
    }

    maxcode = 0;
    maxpc = 0;
    maxarg = 0;
    maxenv = 0;

    return self;
}

#define LIB @"library.scm"

- reset:(id)sender
{
    NSString *msg = nil;
    NSFileManager *manager = [NSFileManager defaultManager];
    NSString *fileName;


    errflag = NO;
    errmsg = @"";

    [self resetStacks];

    [self clearOutput];
    [self clearImage];

    if(envStack!=nil){
        [envStack release];
        envStack = nil;
    }
    [self makeStartEnvironment];

    fileName = [[[NSBundle mainBundle] bundlePath] 
                   stringByAppendingPathComponent:@"Resources"];
    fileName = [fileName stringByAppendingPathComponent:LIB];


    if([manager fileExistsAtPath:fileName]==NO){
        msg = [NSString 
                  stringWithFormat:@"Library not found: %@",
                  fileName];
    }
    else{
        NSString *str = [NSString stringWithContentsOfFile:fileName];
        if(str==nil){
            msg = [NSString 
                      stringWithFormat:@"Couldn't load library: %@", 
                      fileName];
        }
        if([self processString:str mode:MODE_LOAD]==NO){
            msg = errmsg;
        }
    }

    if(msg!=nil){
        NSRunAlertPanel(@"Error (load library)", msg, @"Ok", nil, nil);
    }

    return self;
}

- appendToOutput:(NSString *)data
{
    output = [output stringByAppendingString:data];
    [output retain];
    return self;
}

- (NSString *)output
{
    return output;
}

- clearOutput
{
    if(output!=nil){
        [output release];
    }

    output = [NSString stringWithCString:""]; // @"";
    [output retain];

    return self;
}

- recordImgInst:(DrawInst)inst
{
    NSValue *entry = 
        [NSValue valueWithBytes:&inst objCType:@encode(DrawInst)];

    if(atImgStart==YES && inst.what!=DRAW_COLOR){
        atImgStart = NO;
        imgMin.x = imgMax.x = inst.data.coord.x;
        imgMin.y = imgMax.y = inst.data.coord.y;
    }
    else if(inst.what!=DRAW_COLOR){
        if(imgMin.x>inst.data.coord.x){
            imgMin.x = inst.data.coord.x;
        }
        if(imgMin.y>inst.data.coord.y){
            imgMin.y = inst.data.coord.y;
        }
        if(imgMax.x<inst.data.coord.x){
            imgMax.x = inst.data.coord.x;
        }
        if(imgMax.y<inst.data.coord.y){
            imgMax.y = inst.data.coord.y;
        }
    }

    [imgCodes addObject:entry];
}

- clearImage
{
    atImgStart = YES;

    if(imgCodes!=nil){
        [imgCodes release];
        imgCodes = nil;
    }
    imgCodes = [NSMutableArray arrayWithCapacity:1];
    [imgCodes retain];
}

#define PAD ((float)10)
static int imgCount = 0;

#define BASEX 200
#define BASEY 200
#define WDELTA 10
#define WREP   12

- produceImage
{
    NSSize imgSize;
    NSRect imgRect;
    NSRect frame;
    int index;
    NSWindow *window;
    NSImageView *view;
    NSImage *img;
    NSColor *col;
    int m = (NSTitledWindowMask |  NSClosableWindowMask | 
             NSMiniaturizableWindowMask);

    imgMin.x -= PAD; imgMin.y -= PAD;
    imgMax.x += PAD; imgMax.y += PAD;

    imgRect.origin.x = 0;
    imgRect.origin.y = 0;

    imgRect.size.width  = imgMax.x-imgMin.x;
    imgRect.size.height = imgMax.y-imgMin.y;

    img = [[NSImage alloc] initWithSize:imgRect.size];
    view  = [[SCMImageView alloc] initWithFrame:imgRect];

    [img lockFocus];

    [[NSColor whiteColor] set];
    PSrectfill(0, 0, imgRect.size.width, imgRect.size.height);
    PStranslate(-imgMin.x, -imgMin.y);

    for(index=0; index<[imgCodes count]; index++){
        NSValue *entry = [imgCodes objectAtIndex:index];
        DrawInst inst;

        [entry getValue:&inst];
        if(inst.what==DRAW_MOVE){
            PSmoveto(inst.data.coord.x, inst.data.coord.y);
        }
        else if(inst.what==DRAW_LINE){
            PSlineto(inst.data.coord.x, inst.data.coord.y);
        }
        else{
            PSstroke();
            col = [NSColor colorWithDeviceRed:inst.data.color[0]
                           green:inst.data.color[1]
                           blue:inst.data.color[2]
                           alpha:1.0];
            [col set];
        }
    }

    PSstroke();
    [img unlockFocus];

    [view setImage:img];

    frame = [NSWindow frameRectForContentRect:[view frame] 
                      styleMask:m];

    frame.origin.x = BASEX + (imgCount%WREP)*WDELTA;
    frame.origin.y = BASEY + (imgCount%WREP)*WDELTA;

    window = [[NSWindow alloc] initWithContentRect:frame 
                               styleMask:m			       
                               backing: NSBackingStoreRetained 
                               defer:YES];
    [window setMinSize:frame.size];
    [window setTitle:
                [NSString
                    stringWithFormat:@"Image #%d", ++imgCount]];

    [window setFrame:frame display:YES];
    [window setMaxSize:frame.size];
    [window setContentView:view];
    [window setReleasedWhenClosed:YES];

    // [window setDelegate:view];

    // RELEASE(view);

    [window orderFront:nil];
    [window display];

    return window;
}



- (int)maxcode
{
    return maxcode;
}

- (int)maxpc
{
    return maxpc;
}

- (int)maxarg
{
    return maxarg;
}

- (int)maxenv
{
    return maxenv;
}


- makeStartEnvironment
{
    Environment *env;
    void *state = NULL;
    Class primcls[] = {
        [PRMPairPred class],
        [PRMNullPred class],
        [PRMZeroPred class],
        [PRMNumberPred class],
        [PRMEqPred class],
        [PRMNot class],
        [PRMNumEqual class],
        [PRMNumLT class],
        [PRMNumGT class],
        [PRMPlus class],
        [PRMTimes class],
        [PRMMinus class],
        [PRMDivide class],
        [PRMQuotient class],
        [PRMRemainder class],
        [PRMList class],
        [PRMCons class],
        [PRMCar class],
        [PRMCdr class],
        [PRMSetCar class],
        [PRMSetCdr class],
        [PRMDisplay class],
        [PRMNewline class],
        [PRMDrawMove class],
        [PRMDrawLine class],
        [PRMDrawColor class],
        [PRMSin class],
        [PRMASin class],
        [PRMCos class],
        [PRMACos class],
        [PRMSqrt class],
        [PRMMakeVector class],
        [PRMVectorPred class],
        [PRMListToVector class],
        [PRMVectorToList class],
        [PRMVectorLength class],
        [PRMVectorRef class],
        [PRMVectorSet class],
        [PRMVectorFill class],
        [PRMBrowseEnvironment class],
        nil
    }, *current, cl;
    id primitive;
    NSMutableDictionary 
        *prim = [NSMutableDictionary dictionaryWithCapacity:1],
        *glob = [NSMutableDictionary dictionaryWithCapacity:1];

    current = primcls;
    while((cl = *current++) != nil){
        primitive = [[cl alloc] init];
        [prim setObjWRP:primitive 
              forKey:[primitive primName]];
    }

    env = [Environment newParent:nil Data:prim];
    env = [Environment newParent:env Data:glob];

    envStack  = [NSMutableArray arrayWithCapacity:1];
    [envStack addObjWRP:env];
    [envStack retain];

    return self;
}


- (NSMutableArray *)argStack
{
    return argStack;
}

- (NSMutableArray *)envStack
{
    return envStack;
}

- (NSMutableArray *)codeStack
{
    return codeStack;
}


- (BOOL)errflag
{
    return errflag;
}

- (NSString *)errmsg
{
    return errmsg;
}

- args2list:(int)lower
{
    int pos = [argStack count]-1;
    id res  = [NSNull null];
    
    while(pos>=lower){
        res = [Pair newCar:[argStack objectAtIndex:pos] 
                    Cdr:res];
        pos--;
    }

    return res;
}

- pushCodes:(NSMutableArray *)newcodes
{
    if(curpc==[[codeStack lastObject] count]){
        [codeStack removeLastObject];
    }
    else{
        [pcStack addObjWRP:[NSNumber numberWithInt:curpc]];
    }
    [codeStack addObjWRP:newcodes];

    curpc = 0; curcodes = newcodes;

    return self;
}

#define MAXREC    1000

- (BOOL)run:(ByteCodes *)prog
{
    NSAutoreleasePool *pool = [NSAutoreleasePool new];
    id instr;

    curRecDepth = 0;
    maxRecDepth = MAXREC;

    codeStack = [NSMutableArray arrayWithCapacity:1];
    pcStack   = [NSMutableArray arrayWithCapacity:1];
    argStack  = [NSMutableArray arrayWithCapacity:1];

    [codeStack retain];
    [pcStack retain];
    [argStack retain];

    [codeStack addObjWRP:[prog codes]];

    curcodes = [prog codes];
    curpc = 0; 

    while(1){
        if(!(curpc<[curcodes count])){
            [codeStack removeLastObject];
            if(![codeStack count]){
                break;
            }

            curcodes = [codeStack lastObject];
            curpc = [[pcStack lastObject] intValue];
            [pcStack removeLastObject];
        }

        // printf("-%d-%d- ", [codeStack count], curpc);

        instr = [curcodes objectAtIndex:curpc++];
        // [VScheme printInstr:instr];


        switch([instr tag]){
            case IN_TO_ARGS:
                [argStack addObjWRP:[instr arg1]];
                break;    
            case IN_LOOKUP:{
                NSString *sym = [[argStack lastObject] symVal];
                NSMutableDictionary *layer = 
                    [[envStack lastObject] lookup:sym];
                if(layer==nil){
                    errflag = YES;
                    errmsg = 
                        [[NSString alloc]
                            initWithFormat:@"symbol %@ not bound" 
                            locale: nil, sym];
                }
                else{
                    [argStack removeLastObject];
                    [argStack addObjWRP:[layer objectForKey:sym]];
                }
            } break;    
            case IN_CHECK_PTC:{
                id item = [argStack lastObject];
                if(!(isPrimitive(item) || isClosure(item) ||
                     isThunk(item))){
                    NSString *format = 
                        @"primitive, thunk or closure required, got %@";
                    errflag = YES;
                    errmsg = 
                        [[NSString alloc]
                            initWithFormat:format 
                            locale: nil, NSStringFromClass([item class])];
                }
            } break;    
            case IN_POP_ENV:{
                int count = [instr intarg1];
                while(count--){
                    [envStack removeLastObject];
                }
            } break;    
            case IN_POP_ARGS:{
                int count = [instr intarg1];
                while(count--){
                    [argStack removeLastObject];
                }
            } break;    
            case IN_LIST_APPLIC:{
                id list = [argStack lastObject];
                int argc = 0;

                [argStack removeLastObject];
                while(isPair(list)){
                    [argStack addObjWRP:[list car]];
                    list = [list cdr];
                    argc++;
                }
                if(list!=[NSNull null]){
                    errflag = YES;
                    errmsg = @"second arg to apply not a proper list";
                    break;
                }
                [instr setIntArg1:argc];
            }
            case IN_APPLIC:{
                int argc = [instr intarg1];
                int offs = [argStack count]-argc;
                id op = [argStack objectAtIndex:(offs-1)];
                id res = nil;

                if(isPrimitive(op)){
                    if([op evalVM:self Args:argStack offset:offs]==YES){
                        res = [op value];
                    }
                    else{
                        errflag = YES;
                        errmsg = [op errmsg];
                        break;
                    }
                }
                else if(isThunk(op)){
                    int 
                        argp = [op argp],
                        envp = [op envp], 
                        codep = [op codep],
                        curargp = [argStack count],
                        curenvp = [envStack count],
                        curcodep = [codeStack count];
                    if(argp<0 || envp<0 || codep<0){
                        errflag = YES;
                        errmsg = @"this thunk has expired";
                        break;
                    }

                    if(argc!=1){
                        errflag = YES;
                        errmsg = @"thunk requires a single argument";
                        break;
                    }
                    
                    res = [argStack lastObject];

                    while(curargp-->argp){
                        [argStack removeLastObject];
                    }
                    while(curenvp-->envp){
                        [envStack removeLastObject];
                    }
                    while(curcodep-->codep){
                        [codeStack removeLastObject];
                        if(curcodep>codep){
                            [pcStack removeLastObject];
                        }
                    }

                    curpc = [[pcStack lastObject] intValue];
                    [pcStack removeLastObject];

                    curcodes = [codeStack lastObject];
                }
                else if(isClosure(op)){
                    NSMutableDictionary *layer = 
                        [NSMutableDictionary dictionaryWithCapacity:1];
                    id argl = [op args];
                    id env;

                    if(isSymbol(argl)){
                        [layer setObjWRP:[self args2list:offs]
                               forKey:[argl symVal]];
                    }
                    else{
                        int symc = 0;
                        while(isPair(argl)){
                            symc++;
                            if(symc>argc){
                                errflag = YES;
                                errmsg = @"not enough arguments";
                                break;
                            }
                            [layer setObjWRP:[argStack objectAtIndex:offs++]
                                   forKey:[[argl car] symVal]];
                            argl = [argl cdr];
                        }
                        if(symc<argc && argl==[NSNull null]){
                            errflag = YES;
                            errmsg = @"too many arguments";
                            break;
                        }
                        if(errflag==NO && argl!=[NSNull null]){
                            [layer setObjWRP:[self args2list:offs]
                                   forKey:[argl symVal]];
                        }
                    }

                    env = [Environment newParent:[op env] Data:layer];
                    [envStack addObjWRP:env];
                    [self pushCodes:[[op body] codes]];

                    curRecDepth++;
                    if(curRecDepth>maxRecDepth){
                        int cont = 
                            NSRunAlertPanel(@"Alert",
                                            @"Deep recursion. Continue?", 
                                            @"Yes", @"No", nil);
                        if(cont==NSAlertAlternateReturn){
                            errflag = YES;
                            errmsg = @"abort on deep recursion";
                        }

                        maxRecDepth *= 4;
                    }
                }

                if(isThunk(op)==NO){
                    while(argc--){
                        [argStack removeLastObject];
                    }
                    [argStack removeLastObject];
                }

                if(res!=nil){
                    [argStack addObjWRP:res];
                }
            } break;    
            case IN_DEFINE:{
                int offs = [argStack count]-2;
                NSMutableDictionary *layer = [[envStack lastObject] data];
                [layer setObjWRP:[argStack objectAtIndex:(offs+1)]
                       forKey:[[argStack objectAtIndex:offs] symVal]];
                [argStack removeLastObject];
            } break;    
            case IN_SET:{
                int offs = [argStack count]-2;
                NSString *sym = [[argStack objectAtIndex:offs] symVal];
                id val = [argStack objectAtIndex:offs+1];
                NSMutableDictionary *layer = 
                    [[envStack lastObject] lookup:sym];
                
                if(layer==nil){
                    NSString *format = 
                        @"symbol %@ not bound; can't assign to it";
                    errflag = YES;
                    errmsg = 
                        [[NSString alloc]
                            initWithFormat:format 
                            locale: nil, sym];
                    break;
                }

                [layer setObjWRP:[argStack objectAtIndex:(offs+1)]
                       forKey:[[argStack objectAtIndex:offs] symVal]];
                [argStack removeObjectAtIndex:offs];
            } break;    
            case IN_CLOSURE:{
                int pos = [argStack count]-2;
                id closure = 
                    [Closure newArgs:[argStack objectAtIndex:pos]
                             Body:[argStack objectAtIndex:(pos+1)]
                             Env:[envStack lastObject]];
                [argStack removeLastObject];
                [argStack removeLastObject];
                [argStack addObjWRP:closure];
            } break;
            case IN_IF:{
                BOOL isfalse = isFalse([argStack lastObject]);
                [self pushCodes:[(isfalse==YES ? 
                                  [instr arg2] : [instr arg1]) codes]];
                [argStack removeLastObject];
            } break;
            case IN_LAYER:{
                int count = [instr intarg1];
                int offs = [argStack count]-2;
                NSMutableDictionary *layer = 
                    [NSMutableDictionary dictionaryWithCapacity:1];
                id env;

                while(count--){
                    [layer setObjWRP:[argStack objectAtIndex:(offs+1)]
                           forKey:[[argStack objectAtIndex:offs] symVal]];
                    [argStack removeLastObject];
                    [argStack removeLastObject];
                    offs-=2;
                }

                env = [Environment 
                          newParent:[envStack lastObject] Data:layer];
                [envStack addObjWRP:env];
            } break;
            case IN_MEMQ:{
                id list = [argStack lastObject];
                id search;

                [argStack removeLastObject];
                search = [argStack lastObject];

                while(isPair(list)){
                    if(isEqual(search, [list car])==YES){
                        break;
                    }
                    list = [list cdr];
                }

                [argStack addObjWRP:list];
            } break;
            case IN_DUP_ARG: {
                if([argStack count]<1){
                    errflag = YES;
                    errmsg = @"missing item (duplicate)";
                }
                else{
                    [argStack addObjWRP:[argStack lastObject]];
                }
            } break;
            case IN_EXCH_ARGS: {
                if([argStack count]<2){
                    errflag = YES;
                    errmsg = @"missing items (exchange)";
                }
                else{
                    id item1, item2;
                    item1 = [argStack lastObject];
                    [argStack removeLastObject];
                    item2 = [argStack lastObject];
                    [argStack removeLastObject];
                    [argStack addObjWRP:item1];
                    [argStack addObjWRP:item2];
                }
            } break;
            case IN_STATE_TO_THUNK:{
                Thunk *t = [instr arg1];
                [t setArgp:[argStack count]];
                [t setEnvp:[envStack count]];
                [t setCodep:[codeStack count]];
            } break;
            case IN_MARK_THUNK:{
                Thunk *t = [instr arg1];
                [t setArgp:-1];
                [t setEnvp:-1];
                [t setCodep:-1];
            } break;
            default:
                errflag = YES;
                errmsg = 
                    [[NSString alloc]
                        initWithFormat:@"instruction unknown (tag %d)" 
                        locale: nil, [instr tag]];
                
        }

        if([codeStack count]>maxcode){
            maxcode = [codeStack count];
        }
        if([pcStack count]>maxpc){
            maxpc = [pcStack count];
        }
        if([argStack count]>maxarg){
            maxarg = [argStack count];
        }
        if([envStack count]>maxenv){
            maxenv = [envStack count];
        }


        if(errflag==YES){
            break;
        }

        if([SCMType totalAllocated]>4*[SCMType allocatedAfterGC]){
            int ptotal = [SCMType totalAllocated];
            NSString *msg, 
                *format = @"\nGC prev: %d now: %d\n",
                *cformat = @"%@ prev: %d now: %d\n";
            struct {
                Class cl;
                int prev;
            } *cent, classes[] = {
                { [Pair class], 0 },
                { [Environment class], 0 },
                { [Closure class], 0 },
                { [Vector class], 0 },
                { [Triple class], 0 },
                { [ByteCodes class], 0 },
                { [NSForm class], 0 },
                { [NSFormCell class], 0 },
                { [NSScrollView class], 0 },
                { [NSWindow class], 0 },
                { nil, 0 }
            };
            int argind, argmx;

            for(cent=classes; cent->cl!=nil; cent++){
                cent->prev = GSDebugAllocationCount(cent->cl);
            }

            [SCMType nextMark];
            [SCMType currentMarkForMarkables];

            // [source setMarkToCurrent];

            [prog setMarkToCurrent];

            argmx = [argStack count];
            for(argind=0; argind<argmx; argind++){
                id obj = [argStack objectAtIndex:argind];
                if(MARKABLE(obj)){
                    [obj setMarkToCurrent];
                }
            }

            [envStack makeObjectsPerformSelector:
                          @selector(setMarkToCurrent)];

            [SCMType runGC];

            [pool release];
            pool = [NSAutoreleasePool new];

            if(delegate!=nil &&
               [delegate respondsToSelector:@selector(statistics:)]){
                msg = [NSString stringWithFormat:format,
                                ptotal, [SCMType totalAllocated]];
                [delegate statistics:msg];

                for(cent=classes; cent->cl!=nil; cent++){
                    msg = [NSString stringWithFormat:cformat,
                                    NSStringFromClass(cent->cl),
                                    cent->prev,
                                    GSDebugAllocationCount(cent->cl)];
                    [delegate statistics:msg];
                }

                [delegate statistics:@"\n"];
            }
        }
    }

    [pool release];

    return (errflag==YES ? NO : YES);
}

- special:(id)data output:(ByteCodes *)codes popenv:(int)ec
{
    int tag = [data tag];

    switch(tag){
        case FORM_DEFINE1:
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]];
            [self compile:[data arg2] output:codes popenv:ec];
            [codes addTriple:[Triple newTag:IN_DEFINE]];
            break;    
        case FORM_DEFINE2: {
            ByteCodes *body = [ByteCodes new];

            [codes addTriple:[Triple newTag:IN_TO_ARGS 
                                     Arg1:[[data arg1] car]]];
            [codes addTriple:[Triple newTag:IN_TO_ARGS 
                                     Arg1:[[data arg1] cdr]]];
            [self sequence:[data arg2] output:body popenv:1];
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:body]];
            [codes addTriple:[Triple newTag:IN_CLOSURE]];

            if(ec>0){
                [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            }
            [codes addTriple:[Triple newTag:IN_DEFINE]];
        } break;    
        case FORM_SET:
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]];
            // [self compile:[data arg2] output:codes popenv:ec];
            [self compile:[data arg2] output:codes popenv:0];
            [codes addTriple:[Triple newTag:IN_SET]];
            [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            break;    
        case FORM_LAMBDA1:
        case FORM_LAMBDA2: {
            ByteCodes *body = [ByteCodes new];

            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]];
            [self sequence:[data arg2] output:body popenv:1];
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:body]];
            [codes addTriple:[Triple newTag:IN_CLOSURE]];

            if(ec>0){
                [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            }
        } break;    
        case FORM_BEGIN:
            [self sequence:[data arg1] output:codes popenv:ec];
            break;
        case FORM_APPLY:
            [self compile:[data arg1] output:codes popenv:0];
            [codes addTriple:[Triple newTag:IN_CHECK_PTC]];
            [self compile:[data arg2] output:codes popenv:ec];
            [codes addTriple:[Triple newTag:IN_LIST_APPLIC]];
            break;
        case FORM_QUOTE:
            if(ec>0){
                [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            }
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:[data arg1]]];
            break;
        case FORM_CALLCC:{
            Thunk *t = [Thunk newArgp:-1 Envp:-1 Codep:-1];

            [codes addTriple:[Triple newTag:IN_STATE_TO_THUNK Arg1:t]];
            [self compile:[data arg1] output:codes popenv:ec];
            [codes addTriple:[Triple newTag:IN_CHECK_PTC]];
            [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:t]];
            [codes addTriple:[Triple newTag:IN_APPLIC IntArg1:1]];
            [codes addTriple:[Triple newTag:IN_MARK_THUNK Arg1:t]];
        } break;
        case FORM_LET:
        case FORM_LETSTAR:
        case FORM_LETREC:{
            int count = 0;
            id bindings = [data arg1];

            if(tag==FORM_LETREC){
                [codes addTriple:[Triple newTag:IN_LAYER IntArg1:0]];
            }
            
            while(isPair(bindings)){
                id binding = [bindings car];

                [codes addTriple:[Triple newTag:IN_TO_ARGS 
                                         Arg1:[binding arg1]]];
                [self compile:[binding arg2] output:codes popenv:0];
                
                if(tag==FORM_LETREC){
                    [codes addTriple:[Triple newTag:IN_DEFINE]];
                    [codes addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]];
                }
                else if(tag==FORM_LETSTAR){
                    [codes addTriple:[Triple newTag:IN_LAYER IntArg1:1]];
                } 

                count++; bindings = [bindings cdr];
            }

            if(tag==FORM_LET){
                [codes addTriple:[Triple newTag:IN_LAYER IntArg1:count]];
            }

            [self sequence:[data arg2] output:codes
                  popenv:ec+(tag==FORM_LETSTAR? count : 1)];
        } break;    
        case FORM_IF1:
        case FORM_IF2: {
            ByteCodes 
                *trueClause  = [ByteCodes new],
                *falseClause = [ByteCodes new];

            [self compile:[data arg1] output:codes popenv:0];
            [self compile:[data arg2] output:trueClause popenv:ec];
            if([data arg3]!=nil){
                [self compile:[data arg3] output:falseClause
                      popenv:ec];
            }
            else{
                if(ec>0){
                    [falseClause 
                        addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
                }
                [falseClause 
                    addTriple:[Triple newTag:IN_TO_ARGS 
                                      Arg1:[NSNull null]]];
            }
            // [trueClause retain]; [falseClause retain];
            [codes addTriple:[Triple newTag:IN_IF 
                                     Arg1:trueClause Arg2:falseClause]];
        } break;
        case FORM_COND: {
            ByteCodes 
                *current, *endClause = [ByteCodes new];
            id args, curcond;

            args = [data arg1]; 
            curcond = [args car];

            if(isPair(curcond)){
                [self sequence:[curcond cdr] output:endClause popenv:ec];
                args = [args cdr];
            }
            else{
                if(ec>0){
                    [endClause 
                        addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
                }
                [endClause 
                    addTriple:[Triple newTag:IN_TO_ARGS 
                                      Arg1:[NSNull null]]];
            }

            current = endClause; // [current retain];
            while(isPair(args)){
                ByteCodes
                    *clause  = [ByteCodes new],
                    *match  = [ByteCodes new];
                int tag;

                curcond = [args car]; tag = [curcond tag];

                [self compile:[curcond arg1] output:clause popenv:0];
                
                if(tag==FORM_SCOND1){
                    [clause addTriple:[Triple newTag:IN_DUP_ARG]];
                    [match addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
                }
                else if(tag==FORM_SCOND2){
                    [self sequence:[curcond arg2] output:match popenv:ec];
                }
                else{
                    [clause addTriple:[Triple newTag:IN_DUP_ARG]];
                    [self compile:[curcond arg2] output:match popenv:ec];
                    [match addTriple:[Triple newTag:IN_CHECK_PTC]];
                    [match addTriple:[Triple newTag:IN_EXCH_ARGS]];
                    [match addTriple:[Triple newTag:IN_APPLIC IntArg1:1]];
                    [current prependTriple:
                                 [Triple newTag:IN_POP_ARGS IntArg1:1]];
                }

                [clause addTriple:
                            [Triple newTag:IN_IF 
                                    Arg1:match Arg2:current]];

                current = clause; // [current retain];
                args = [args cdr];
            }
            [codes appendByteCodes:current];
        } break;
        case FORM_CASE: {
            ByteCodes 
                *endClause = [ByteCodes new];
            id current, args, curcase;

            args = [data arg2]; 
            curcase = [args car];

            [endClause addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]];
            if([curcase car]==[NSNull null]){
                [self sequence:[curcase cdr] output:endClause popenv:ec];
                args = [args cdr];
            }
            else{
                if(ec>0){
                    [endClause 
                        addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
                }
                [endClause 
                    addTriple:[Triple newTag:IN_TO_ARGS 
                                      Arg1:[NSNull null]]];
            }

            [self compile:[data arg1] output:codes popenv:0];
            current = endClause;
            while(isPair(args)){
                ByteCodes
                    *clause  = [ByteCodes new],
                    *match  = [ByteCodes new];

                curcase = [args car];

                [clause 
                    addTriple:[Triple newTag:IN_TO_ARGS 
                                      Arg1:[curcase car]]];
                [clause addTriple:[Triple newTag:IN_MEMQ]];

                [match addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]];
                [self sequence:[curcase cdr] output:match popenv:ec];

                [clause addTriple:
                            [Triple newTag:IN_IF 
                                    Arg1:match Arg2:current]];

                current = clause; // [current retain];
                args = [args cdr];
            }
            [codes appendByteCodes:current];
        } break;
        case FORM_AND:
        case FORM_OR: {
            ByteCodes 
                *trueClause  = [ByteCodes new],
                *falseClause = [ByteCodes new],
                *current;
            id args;
            if(ec>0){
                [trueClause 
                    addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            }
            [trueClause 
                addTriple:[Triple newTag:IN_TO_ARGS 
                                  Arg1:[[Boolean alloc] initSCMBoolean:YES]]];
            if(ec>0){
                [falseClause 
                    addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
            }
            [falseClause 
                addTriple:[Triple newTag:IN_TO_ARGS 
                                  Arg1:[[Boolean alloc] initSCMBoolean:NO]]];
                
            current = (tag == FORM_AND ? trueClause : falseClause);
            args = [data arg1];
            while(isPair(args)){
                ByteCodes
                    *clause  = [ByteCodes new];
                [self compile:[args car] output:clause popenv:0];
                if(tag == FORM_AND){
                    [clause addTriple:
                                [Triple newTag:IN_IF 
                                        Arg1:current Arg2:falseClause]];
                }
                else{
                    [clause addTriple:
                                [Triple newTag:IN_IF 
                                        Arg1:trueClause Arg2:current]];
                }
                current = clause; // [current retain];
                args = [args cdr];
            }
            [codes appendByteCodes:current];
        } break;
        default:
            errflag = YES;
            errmsg = 
                [[NSString alloc]
                    initWithFormat:@"scheme form unknown (tag %d)" 
                    locale: nil, [data tag]];
    }
}

- sequence:(id)data output:(ByteCodes *)codes popenv:(int)ec
{
    while(isPair(data)){
        BOOL beforeLast = isPair([data cdr]);
        [self compile:[data car] output:codes 
              popenv:(beforeLast==YES ? 0 : ec)];
        if(beforeLast==YES){
            [codes addTriple:[Triple newTag:IN_POP_ARGS IntArg1:1]];
        }
        data = [data cdr];
    }
}

- compile:(id)data output:(ByteCodes *)codes popenv:(int)ec
{
    BOOL application = NO;
    int count = 0;
        
    if(isTriple(data)){
        return [self special:data output:codes popenv:ec];
    }
    else if(isPair(data)){
        application = YES;
        while(isPair(data)){
            [self compile:[data car] output:codes popenv:0];
            count++;
            if(count==1){
                [codes addTriple:[Triple newTag:IN_CHECK_PTC]];
            }
            data = [data cdr];
        }
    }
    else if(isSymbol(data)){
        [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:data]];
        [codes addTriple:[Triple newTag:IN_LOOKUP]];
    }
    else{
        [codes addTriple:[Triple newTag:IN_TO_ARGS Arg1:data]];
    }

    if(ec>0){
        [codes addTriple:[Triple newTag:IN_POP_ENV IntArg1:ec]];
    }
    if(application){
        [codes addTriple:[Triple newTag:IN_APPLIC IntArg1:(count-1)]];
    }
}

- (BOOL)compile:(id)data output:(ByteCodes *)codes
{
    errflag = NO;
    errmsg = @"";

    [self compile:data output:codes popenv:0];
    return errflag;
}

void yyrestart(FILE *);

extern char *yyinputstr, *yyinputstart;
extern int yysofar;
extern id yyresult;
extern int yyinputline;
extern int yyinputitem;
extern BOOL yyschemeerrflag;

NSMutableArray *positions = nil;

#define STATS  @"code: %d %d (%d) args: %d (%d) envs: %d (%d)\n"
#define PARSE_ERROR @"Parse error at item %d, line %d.\n"

- (BOOL)processString:(NSString *)data mode:(PROCESS_MODE)pmode
{
    id forms;
    int curitem = 0, curpos = 0, nextpos = 0;

    yyinputline = 0;
    yyinputitem = 0;
    yyschemeerrflag = NO;

    positions = [NSMutableArray arrayWithCapacity:1];

    yyinputstr = yyinputstart = 
        (char *)[[data stringByAppendingString:@"\n"] cString];
    yysofar = 0;
    yyrestart(NULL);
    yyparse();

    if(yyschemeerrflag==YES){
        errmsg = [NSString stringWithFormat:PARSE_ERROR,
                           yyinputitem+1, yyinputline+1];
        errflag = YES;

        if(delegate!=nil && pmode!=MODE_LOAD &&
           [delegate respondsToSelector:@selector(result:)]){
            [delegate result:[NSNull null]];
        }


        return NO;
    }

    [SCMType addToMarkables:yyresult];

    forms = yyresult;
    if(forms==[NSNull null]){
        [delegate result:[NSNull null]];
    }

    while(forms!=[NSNull null]){
        ByteCodes *codes = [ByteCodes new];
        BOOL err = [self compile:[forms arg1] output:codes];
        NSRange range;
        int lower, upper;
        char *first, *fp; int flen;
        
        #define MAXLINE 41
        #define CENTER " ... "
        #define HALF ((MAXLINE-5)/2)
        char second[MAXLINE+1];

        range = [[positions objectAtIndex:curitem] rangeValue];
        nextpos = range.location;

        lower = curpos;
        while(isspace(yyinputstart[lower])){
            lower++;
        }
        upper = nextpos;
        while(isspace(yyinputstart[upper])){
            upper--;
        }

        first = fp = malloc(upper-lower+2);
        while(lower<=upper){
            if(isspace(yyinputstart[lower])){
                BOOL foundRet = NO; int len=0;
                while(isspace(yyinputstart[lower]) && 
                      lower<=upper){
                    if(yyinputstart[lower]=='\n'){
                        foundRet = YES;
                    }
                    lower++; len++;
                }

                if(foundRet==YES){
                    *fp++ = ' ';
                }
                else{
                    strncpy(fp, yyinputstart+lower-len, len);
                    fp += len;
                }
            }
            else{
                *fp++ = yyinputstart[lower];
                lower++;
            }
        }
        *fp = 0;

        if((flen=strlen(first))<=MAXLINE){
            strcpy(second, first);
        }
        else{
            strncpy(second, first, HALF);
            strcpy(second+HALF, CENTER);
            strcpy(second+HALF+5, first+flen-HALF);
        }

        curitem++; curpos = nextpos;

        if(err==NO){
            [self clearOutput];
            [self clearImage];
            if([self run:codes]==YES){
                NSString *msg;

                if(pmode==MODE_EVALUATE){
                    [delegate 
                        input:[NSString stringWithCString:second]];
                }

                if(pmode!=MODE_LOAD){
                    if([output length]>0){
                        [delegate output:@"\n"];
                        [delegate output:output];
                    }
                    if(atImgStart==NO){
                        [delegate imageWindow:[self produceImage]];
                    }
                }

                if(pmode!=MODE_LOAD){
                    [delegate result:[argStack lastObject]];
                }

                if(delegate!=nil &&
                   [delegate respondsToSelector:@selector(statistics:)]){
                    msg = [NSString stringWithFormat:STATS,
                                    [codeStack count], maxpc, maxcode,
                                    [argStack count], maxarg,
                                    [envStack count], maxenv];
                    [delegate statistics:msg];
                }

                [self resetStacks];
            }
        }

        free(first);

        forms = [forms arg2];

        if(errflag==YES){
            break;
        }
    }
    
    [SCMType removeFromMarkables:yyresult];

    if(errflag==YES){
        [delegate result:[NSNull null]];
        [delegate statistics:errmsg];
        [delegate statistics:@"\n"];
    }

    // [positions release];

    return (errflag == YES ? NO : YES);
}

@end

@implementation SCMImageView

- (id)initWithFrame:(NSRect)frameRect
{
    image = nil;
    return [super initWithFrame:frameRect];
}

- (NSImage *)image
{
    return image;
}

- setImage:(NSImage *)anImage
{
    if(image!=nil){
        [image release];
    }
    image = anImage; 
    if(image!=nil){
        [image retain];
    }
    [self setNeedsDisplay:YES];
}

- (void)drawRect:(NSRect)aRect
{
    if(image!=nil){
        [image compositeToPoint:aRect.origin
               fromRect:aRect
               operation:NSCompositeCopy];
    }
}

@end