2101 lines
57 KiB
Objective-C
2101 lines
57 KiB
Objective-C
|
|
#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
|