gscheme/VScheme.m

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

/* #include <sys/time.h>
#include <sys/resource.h>
#include <unistd.h> */

extern id  yyresultform;
extern BOOL yyschemeerrflag;

NSMutableArray *positionStack = nil;


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("VECTOR %s\n", [[VScheme valToString:item] cString]);
    }
    else if([item isKindOfClass:[ByteCodes class]]){
        printf("CODES: %u\n", [item length]);
    }
    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 stringWithFormat:format, c];
    }
    else if(isInt(item)){
        return [NSString stringWithFormat:@"%d", [item intVal]];
    }
    else if(isDouble(item)){
	double v = [item doubleVal];
	NSString *vstr = [[NSNumber numberWithDouble:v] description];
	const char *buf = [vstr cString];
	
	if(*buf && *buf=='-'){
	    buf++;
	}
	while(*buf && isdigit(*buf++));
	if(!(*buf)){
	    vstr = [vstr stringByAppendingString:@".0"];
	}

        return vstr;
    }
    else if(isSymbol(item)){
        return [NSString stringWithFormat:@"%@", [item symVal]];
    }
    else if(isString(item)){
	NSString *str = [item strVal];
	int len = [str length];
	
	const char *src;
	char buf[2*len+1], *dst;
	src = [str cString]; dst = buf;
	while(*src){
	    if(*src=='"'){
		*dst++ = '\\';
	    }
	    *dst++ = *src++;
	}
	*dst = 0;
	
        return [NSString stringWithFormat:@"\"%s\"", buf];
    }
    else if(isClosure(item)){
        return [NSString 
                   stringWithFormat:@"<closure: %@>",
                   [VScheme valToString:[item args] seen:mem]];
    }
    else if(isPrimitive(item)){
        return [NSString
                   stringWithFormat:@"<primitive: %@>",
                   [item primName]];
    }
    else if(isThunk(item)){
        return [NSString
                   stringWithFormat:@"<thunk: %d %d %d>",
                   [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:(ByteCodes *)bc
{
    id *data = [bc codes]; 

    unsigned int pos, len = [bc length];
    for(pos=0; pos<len; pos++){
	[self printInstr:data[pos]];
    }

    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;

    if(errmsg != nil && 
       [errmsg isKindOfClass:[NSConstantString class]]==NO){
	[errmsg release];
    }

    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 appendString:data];
    return self;
}

- (NSString *)output
{
    return output;
}

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

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

    return self;
}


#define FONTSIZE 12.0
- (NSSize)stringAtCurrentFont:(NSString *)str
{
    NSFont *font = 
	(imgFont==nil ? [NSFont systemFontOfSize:FONTSIZE] : imgFont);
    NSDictionary *attr = 
	[NSDictionary dictionaryWithObjectsAndKeys:font, NSFontAttributeName, nil];
    return [str sizeWithAttributes:attr];
}

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

    if(atImgStart==YES && (inst.what==DRAW_MOVE || inst.what==DRAW_LINE)){
        atImgStart = NO;
	imgMin = imgMax = imgCur = inst.data.coord;
    }
    else if(atImgStart==YES && (inst.what==DRAW_CIRCLE || inst.what==FILL_CIRCLE)){
        atImgStart = NO;
        imgMin.x = -inst.data.radius;
	imgMax.x = inst.data.radius;
        imgMin.y = -inst.data.radius;
	imgMax.y = inst.data.radius;
	imgCur = NSMakePoint(0, 0);
    }
    else if(atImgStart==YES && (inst.what==DRAW_RECT || inst.what==FILL_RECT)){
        atImgStart = NO;
        imgMin.x = 0;
	imgMax.x = inst.data.size.width;
        imgMin.y = 0;
	imgMax.y = inst.data.size.height;
	imgCur = NSMakePoint(0, 0);
    }
    else if(atImgStart==YES && inst.what==DRAW_STRING){
	atImgStart = NO;

	imgMin = NSMakePoint(0, 0);

	NSSize result = [self stringAtCurrentFont:inst.data.string];
	imgMax.x = result.width;
	imgMax.y = result.height;

	imgCur = NSMakePoint(result.width, 0);
    }
    else if(inst.what==DRAW_MOVE || inst.what==DRAW_LINE){
        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;
        }

	imgCur = inst.data.coord;
    }
    else if(inst.what==DRAW_CIRCLE || inst.what==FILL_CIRCLE){
	float 
	    minx = imgCur.x-inst.data.radius,
	    miny = imgCur.y-inst.data.radius,
	    maxx = imgCur.x+inst.data.radius,
	    maxy = imgCur.y+inst.data.radius;
	
        if(imgMin.x>minx){
            imgMin.x = minx;
        }
        if(imgMin.y>miny){
            imgMin.y = miny;
        }
        if(imgMax.x<maxx){
            imgMax.x = maxx;
        }
        if(imgMax.y<maxy){
            imgMax.y = maxy;
        }
    }
    else if(inst.what==DRAW_RECT || inst.what==FILL_RECT){
	float 
	    maxx = imgCur.x+inst.data.size.width,
	    maxy = imgCur.y+inst.data.size.height;
	
        if(imgMax.x<maxx){
            imgMax.x = maxx;
        }
        if(imgMax.y<maxy){
            imgMax.y = maxy;
        }
    }
    else if(inst.what==DRAW_STRING){
	NSSize result = [self stringAtCurrentFont:inst.data.string];

	if(imgMax.x<imgCur.x+result.width){
	    imgMax.x = imgCur.x+result.width;
	}
	if(imgMax.y<imgCur.y+result.height){
	    imgMax.y=imgCur.y+result.height;
	}

	imgCur.x += result.width;
    }
    else if(inst.what==DRAW_FONT){
	imgFont = inst.data.font;
    }

    [imgCodes addObject:entry];
}

- clearImage
{
    atImgStart = YES;
    imgFont = nil;

    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];

    [[NSFont systemFontOfSize:FONTSIZE] set];

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

    [[NSColor blackColor] set];
    imgCur = NSMakePoint(0, 0);

    imgFont = nil;

    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);
	    imgCur = inst.data.coord;
        }
        else if(inst.what==DRAW_LINE){
            PSlineto(inst.data.coord.x, inst.data.coord.y);
	    imgCur = inst.data.coord;
        }
	else if(inst.what==DRAW_CIRCLE){
	    PSstroke();
	    PSarc(imgCur.x, imgCur.y, inst.data.radius, 0, 360);
	    PSstroke();
	    PSmoveto(imgCur.x, imgCur.y);
	}
	else if(inst.what==FILL_CIRCLE){
	    PSstroke();
	    PSarc(imgCur.x, imgCur.y, inst.data.radius, 0, 360);
	    PSfill();
	    PSmoveto(imgCur.x, imgCur.y);
	}
	else if(inst.what==DRAW_RECT){
	    PSstroke();
	    NSFrameRect(NSMakeRect(imgCur.x, imgCur.y, 
				   inst.data.size.width, inst.data.size.height));
	    PSmoveto(imgCur.x, imgCur.y);
	}
	else if(inst.what==FILL_RECT){
	    PSstroke();
	    NSRectFill(NSMakeRect(imgCur.x, imgCur.y, 
				  inst.data.size.width, inst.data.size.height));
	    PSmoveto(imgCur.x, imgCur.y);
	}
	else if(inst.what==DRAW_STRING){
	    PSmoveto(imgCur.x, imgCur.y);
	    PSshow([inst.data.string cString]);
	    PSstroke();

	    NSSize result = [self stringAtCurrentFont:inst.data.string];
	    imgCur.x += result.width;
	    PSmoveto(imgCur.x, imgCur.y);

	    [inst.data.string release];
	}
	else if(inst.what==DRAW_FONT){
	    if(imgFont!=nil){
		[imgFont release];
	    }
	    imgFont = inst.data.font;
	    [imgFont set];
	}
        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];

    if(imgFont!=nil){
	[imgFont release];
    }

    [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: NSBackingStoreNonretained 
                               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];

    [delegate imageWindow:window];

    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],
        [PRMRandom 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],
        [PRMDrawCircle class],
        [PRMFillCircle class],
        [PRMDrawRect class],
        [PRMFillRect class],
	[PRMDrawString class],
	[PRMDrawFont class],
        [PRMDrawShow class],
	[PRMExp class],
	[PRMLog class],
        [PRMSin class],
        [PRMASin class],
        [PRMCos class],
        [PRMACos class],
	[PRMTan class],
	[PRMATan class],
        [PRMSqrt class],
        [PRMMakeVector class],
        [PRMVectorPred class],
        [PRMListToVector class],
        [PRMVectorToList class],
        [PRMVectorLength class],
        [PRMVectorRef class],
        [PRMVectorSet class],
        [PRMVectorFill class],
	[PRMSymToStr class],
	[PRMStrToSym class],
	[PRMStringSize class],
	[PRMStringLength class],
	[PRMCharToInt class],
	[PRMIntToChar class],
	[PRMStringRef class],
	[PRMListToStr class],
	[PRMStrToList class],
	[PRMNumberToStr class],
	[PRMStringAppend class],
	[PRMMakeString class],
	[PRMFormat class],
        [PRMEval class],
        [PRMBrowseEnvironment class],
        nil
    }, *current, cl;
    id primitive;
    NSMapTable
        *prim = NSCreateMapTable(NSObjectMapKeyCallBacks,
				 NSNonRetainedObjectMapValueCallBacks, 1),
        *glob = NSCreateMapTable(NSObjectMapKeyCallBacks,
				 NSNonRetainedObjectMapValueCallBacks, 1);

    current = primcls;
    while((cl = *current++) != nil){
        primitive = [[cl alloc] init]; [primitive retain];
	NSMapInsert(prim, [primitive primName], primitive);
    }

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

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

    return self;
}


- (NSMutableArray *)argStack
{
    return argStack;
}

- (NSMutableArray *)envStack
{
    return envStack;
}

- (NSMutableArray *)codeStack
{
    return codeStack;
}


- (BOOL)errflag
{
    return errflag;
}

- (int)errpos
{
    return errpos;
}

- (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;
}

- pushByteCodes:(ByteCodes *)bcodes
{
    if(curpc==curlength){
        [codeStack removeLastObject];
    }
    else{
        [pcStack addObject:[NSNumber numberWithInt:curpc]];
    }
    [codeStack addObject:bcodes];

    curpc = 0; curcodes = [bcodes codes]; curlength = [bcodes length];

    return self;
}

- interrupt:(id)sender
{
    interrupted = YES;
    return self;
}

#define INITIALINT    5
#define INTERVAL      1


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

    if(errmsg != nil && 
       [errmsg isKindOfClass:[NSConstantString class]]==NO){
	[errmsg release];
	errmsg = @"";
    }

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

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

    [codeStack addObject:prog];
    [prog setRoot:YES];

    curcodes = [prog codes];
    curpc = 0; curlength = [prog length];

    NSApplication *app = [NSApplication sharedApplication];
    BOOL inModal = NO;
    NSDate *interruptDate = [NSDate dateWithTimeIntervalSinceNow:INITIALINT];
    NSModalSession interruptSession;
    NSPanel *interruptPanel = [delegate interruptPanel];
    int interruptMask = NSLeftMouseDownMask | NSLeftMouseUpMask |
        NSLeftMouseDraggedMask;

    hadOutput = NO;

    interrupted = NO;
    [interruptDate retain];

    /* struct rusage usg;
    getrusage(RUSAGE_SELF, &usg);
    long start = usg.ru_utime.tv_sec; */

    #define RESFORITER 4000
    unsigned long int iterations = 0;
    while(1){
	iterations++;

	if(!(iterations % RESFORITER) && pmode!=MODE_LOAD && inModal==NO &&
	   [interruptDate timeIntervalSinceNow]<0.0){
	    [interruptPanel center];
	    [interruptPanel orderOut:nil];
	    [interruptPanel flushWindow];

	    interruptSession = [app beginModalSessionForWindow:interruptPanel];
	    inModal = YES;

	    [interruptDate release];
	    interruptDate = [NSDate dateWithTimeIntervalSinceNow:INTERVAL];
	    [interruptDate retain];

	    [[NSCursor arrowCursor] push];
	}	
	else if(!(iterations % RESFORITER) && inModal==YES && 
		[interruptDate timeIntervalSinceNow]<0.0){
	    NSDate *evDate = [NSDate dateWithTimeIntervalSinceNow:0.025];
	    NSEvent *event  = 
		[app nextEventMatchingMask:interruptMask 
		     untilDate:evDate
		     inMode:NSDefaultRunLoopMode
		     dequeue:YES];
	    if([event window]==interruptPanel){
		[app sendEvent:event];
	    }
	    if(interrupted==YES){
		errflag = YES;
		errmsg = @"user abort";

		break;
	    }
	    else{
		[interruptDate release];
		interruptDate = [NSDate dateWithTimeIntervalSinceNow:INTERVAL];
		[interruptDate retain];

		if(output!=nil){
		    if(hadOutput==NO){
			[delegate output:@"\n"];
			hadOutput = YES;
		    }
		    [delegate output:output];
		    [self clearOutput];
		}
	    }
	}

        if(!(curpc<curlength)){
            [codeStack removeLastObject];
            if(![codeStack count]){
                break;
            }

	    ByteCodes *bc = [codeStack lastObject];
            curcodes = [bc codes];
            curpc = [[pcStack lastObject] intValue]; curlength = [bc length];

            [pcStack removeLastObject];
        }

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

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

        switch([instr tag]){
            case IN_TO_ARGS:
                [argStack addObject:[instr arg1]];
                break;    
            case IN_LOOKUP:{
                NSString *sym = [[argStack lastObject] symVal];
                NSMapTable *layer = 
                    [[envStack lastObject] lookup:sym];
                if(layer==NULL){
                    errflag = YES;
                    errmsg = 
                        [[NSString alloc]
                            initWithFormat:@"symbol %@ not bound", sym];
                }
                else{
                    [argStack removeLastObject];
                    [argStack addObject:NSMapGet(layer, 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,
                            NSStringFromClass([item class]),
			    [VScheme valToString:item]];
                }
            } 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 addObject:[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(isEval(op)){
		    if(offs+1!=[argStack count]){
                        errflag = YES;
                        errmsg = @"eval takes one argument";
			break;
		    }

		    NSString *evStr = 
			[VScheme valToString:[argStack objectAtIndex:offs]];
		    [self parse:evStr];

		    if(yyschemeerrflag==YES){
			#define MAXL 40
			char buf[MAXL+1];
			[evStr getCString:buf maxLength:MAXL];

			errflag = YES;
                        errmsg =  [[NSString alloc]
				      initWithFormat:@"parse error in %s%s.", 
				      buf, ([evStr length]>MAXL ? " (...)" : "")];
			break;
		    }

		    [positionStack removeLastObject];
		    
		    id evForms = yyresultform;
		    if(evForms==[NSNull null]){
			res = [NSNull null];
			break;
		    }

                    // [SCMType addToMarkables:evForms];

		    ByteCodes *evCodes = [ByteCodes new];
		    [evCodes setSource:evForms];
		    errflag = [self compile:[evForms arg1] output:evCodes];
		    if(errflag==NO){
                        [evCodes setRoot:YES];
			[self pushByteCodes:evCodes];
		    }
		}
                else if(isPrimitive(op)){
                    if([op evalVM:self Args:argStack offset:offs]==YES){
                        res = [op value];
                    }
                    else{
                        errflag = YES;
                        errmsg = 
			    [[NSString alloc]
				initWithString:[(Primitive *)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] codes];
                }
                else if(isClosure(op)){
		    NSMapTable *layer =
			NSCreateMapTable(NSObjectMapKeyCallBacks,
					 NSNonRetainedObjectMapValueCallBacks, 1);  
                    id argl = [op args];
                    id env;

                    if(isSymbol(argl)){
			id list = [self args2list:offs]; [list retain];
			NSMapInsert(layer, [argl symVal], list);
                    }
                    else{
                        int symc = 0;
                        while(isPair(argl)){
                            symc++;
                            if(symc>argc){
                                errflag = YES;
                                errmsg = 
				    [[NSString alloc]
					initWithFormat:@"not enough arguments to %@",
					[VScheme valToString:op]];
                                break;
                            }
			    id obj = [argStack objectAtIndex:offs++]; [obj retain];
			    NSMapInsert(layer, [[argl car] symVal], obj);
                            argl = [argl cdr];
                        }
                        if(symc<argc && argl==[NSNull null]){
                            errflag = YES;
                            errmsg =
				[[NSString alloc]
				    initWithFormat:@"too many arguments to %@",
				    [VScheme valToString:op]];
                            break;
                        }
                        if(errflag==NO && argl!=[NSNull null]){
			    id list = [self args2list:offs]; [list retain];
			    NSMapInsert(layer, [argl symVal], list);
                        }
                    }

                    env = [Environment newParent:[op env] Data:layer];
                    [envStack addObject:env];
                    [self pushByteCodes:[op body]];
                }

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

                if(res!=nil){
                    [argStack addObject:res];
                }
            } break;    
            case IN_DEFINE:{
                int offs = [argStack count]-2;
                NSMapTable *layer = 
		    [(Environment *)[envStack lastObject] data];

		id obj = [argStack objectAtIndex:(offs+1)]; [obj retain];
		NSMapInsert(layer, [[argStack objectAtIndex:offs] symVal], obj);

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

		id obj = [argStack objectAtIndex:(offs+1)]; [obj retain];
		NSMapInsert(layer, [[argStack objectAtIndex:offs] symVal], obj);

                [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 addObject:closure];
            } break;
            case IN_IF:{
                BOOL isfalse = isFalse([argStack lastObject]);
                [self pushByteCodes:(isfalse==YES ? 
                                     [instr arg2] : [instr arg1])];
                [argStack removeLastObject];
            } break;
            case IN_LAYER:{
                int count = [instr intarg1];
                int offs = [argStack count]-2;
		NSMapTable *layer = 
		    NSCreateMapTable(NSObjectMapKeyCallBacks,
				     NSNonRetainedObjectMapValueCallBacks, 1);
                id env;

                while(count--){
		    id obj = [argStack objectAtIndex:(offs+1)]; [obj retain];
		    NSMapInsert(layer, [[argStack objectAtIndex:offs] symVal], obj);
                    [argStack removeLastObject];
                    [argStack removeLastObject];
                    offs-=2;
                }

                env = [Environment 
                          newParent:[envStack lastObject] Data:layer];
                [envStack addObject: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 addObject:list];
            } break;
            case IN_DUP_ARG: {
                if([argStack count]<1){
                    errflag = YES;
                    errmsg = @"missing item (duplicate)";
                }
                else{
                    [argStack addObject:[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 addObject:item1];
                    [argStack addObject: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 = @"\n%@\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 },
                { [Int class], 0 },
                { [Closure class], 0 },
                { [Vector class], 0 },
                { [Triple class], 0 },
                { [ByteCodes class], 0 },
		{ [interruptDate class], 0 },
                { [NSTableView class], 0 },
                { [NSTableColumn class], 0 },
                { [NSScrollView class], 0 },
                { [SCMTextView class], 0 },
                { [NSWindow class], 0 },
                { nil, 0 }
            };

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

            [SCMType nextMark];
            [SCMType currentMarkForMarkables];

            // [source setMarkToCurrent];

            int codeind, codemx = [codeStack count];
            for(codeind=0; codeind<codemx; codeind++){
                id obj = [codeStack objectAtIndex:codeind];
                if([obj root]==YES){
                    [obj setMarkToCurrent];
                }
            }
            // [prog setMarkToCurrent];

            int argind, 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,
				[[NSDate date] description],
                                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"];
            }
        }
    }

    if(inModal==YES){
        [app endModalSession:interruptSession];
        [interruptPanel close];
        [NSCursor pop];
    }
    [interruptDate release];

    [pool release];

    /* getrusage(RUSAGE_SELF, &usg);
    long end = usg.ru_utime.tv_sec;
    NSLog(@"%u", end-start); */

    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 int yyinputline;
extern int yyinputitem;

- parse:(NSString *)scmText
{
    yyinputline = 0;
    yyinputitem = 0;
    yyschemeerrflag = NO;

    if(positionStack==nil){
	positionStack = [NSMutableArray arrayWithCapacity:1];
	[positionStack retain];
    }
    [positionStack addObject:[NSMutableArray arrayWithCapacity:1]];

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

    return self;
}

#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
{
    [self parse:data];

    id forms;
    int curitem = 0, curpos = 0, nextpos = 0;

    errpos = -1;
    if(yyschemeerrflag==YES){
        errmsg = [[NSString alloc] initWithFormat:PARSE_ERROR,
                           yyinputitem+1, yyinputline+1,
			   (yysofar==[data length]+1 ? @" (at end)" : @"")];
        errflag = YES;
	errpos = yysofar-1;

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


        return NO;
    }

    [SCMType addToMarkables:yyresultform];

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

    char *yyips = yyinputstart;
    id yyrf = yyresultform;
    while(forms!=[NSNull null]){
	yyinputstart = yyips;

        ByteCodes *codes = [ByteCodes new];
        BOOL err = [self compile:[forms arg1] output:codes];
	// [VScheme printCodes: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 = [[[positionStack lastObject] 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(pmode==MODE_EVALUATE){
		[delegate 
		    input:[NSString stringWithCString:second]];
	    }
	    BOOL runResult = [self run:codes mode:pmode];

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

            if(runResult==YES){
                NSString *msg;

                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];
	    [envStack 
		removeObjectsInRange:
		    NSMakeRange(1, [envStack count]-1)];
        }

        free(first);

        forms = [forms arg2];

        if(errflag==YES){
            break;
        }
    }

    [positionStack removeLastObject];
    [SCMType removeFromMarkables:yyrf];

    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];

    return self;
}

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

@end