1723 lines
49 KiB
Mathematica
1723 lines
49 KiB
Mathematica
|
|
||
|
#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
|