conservatory
/
gscheme
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
gscheme/Primitive.m

2498 lines
48 KiB
Objective-C
Raw Permalink Blame History

#import "Primitive.h"
#import "VScheme.h"
#import "SchemeDelegate.h"
inline BOOL isBoolean(id item)
{
return [item isKindOfClass:[Boolean class]];
}
inline BOOL isChar(id item)
{
return [item isKindOfClass:[Char class]];
}
inline BOOL isInt(id item)
{
return [item isKindOfClass:[Int class]];
}
inline BOOL isDouble(id item)
{
return [item isKindOfClass:[Double class]];
}
inline BOOL isSymbol(id item)
{
return [item isKindOfClass:[Symbol class]];
}
inline BOOL isString(id item)
{
return [item isKindOfClass:[String class]];
}
inline BOOL isPair(id item)
{
return [item isKindOfClass:[Pair class]];
}
inline BOOL isVector(id item)
{
return [item isKindOfClass:[Vector class]];
}
inline BOOL isTriple(id item)
{
return [item isKindOfClass:[Triple class]];
}
inline BOOL isPrimitive(id item)
{
return [item isKindOfClass:[Primitive class]];
}
inline BOOL isEval(id item)
{
return [item isKindOfClass:[PRMEval class]];
}
inline BOOL isClosure(id item)
{
return [item isKindOfClass:[Closure class]];
}
inline BOOL isThunk(id item)
{
return [item isKindOfClass:[Thunk class]];
}
BOOL isFalse(id item)
{
if(item==[NSNull null]){
return YES;
}
if([item isKindOfClass:[Boolean class]]){
return ([item boolVal]==YES ? NO : YES);
}
return NO;
}
BOOL isEqual(id itema, id itemb)
{
if([itema class]!=[itemb class]){
return NO;
}
if(isChar(itema)){
return ([itema charVal]==[itemb charVal] ? YES : NO);
}
else if(isInt(itema)){
return ([itema intVal]==[itemb intVal] ? YES : NO);
}
else if(isDouble(itema)){
return ([itema doubleVal]==[itemb doubleVal] ? YES : NO);
}
else if(isBoolean(itema)){
return ([itema boolVal]==[itemb boolVal] ? YES : NO);
}
else if(isString(itema)){
return [[itema strVal] isEqual:[itemb strVal]];
}
else if(isSymbol(itema)){
return [[itema symVal] isEqual:[itemb symVal]];
}
return (itema==itemb ? YES : NO);
}
@implementation Primitive
- init
{
[super init];
value = [NSNull null];
errmsg = nil;
return self;
}
- (NUMTYPE)checkArgsNumeric:(NSMutableArray *)args offset:(int)offs
{
int pos;
NUMTYPE res = NT_INTEGERS;
for(pos=offs; pos<[args count]; pos++){
id arg = [args objectAtIndex:pos];
if(isInt(arg)==NO){
if(isDouble(arg)==NO){
return NT_OTHER;
}
res = NT_DOUBLE;
}
}
return res;
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
[self notImplemented: _cmd];
return NO;
}
- (NSString *)primName
{
[self notImplemented: _cmd];
return @"_not_implemented";
}
- value
{
return value;
}
- errmsg
{
if([errmsg isKindOfClass:[NSConstantString class]]==NO){
[errmsg autorelease];
}
return errmsg;
}
@end
@implementation PRMVectorPred
- (NSString *)primName
{
return @"vector?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"vector? takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
value = [[Boolean alloc] initSCMBoolean:isVector(item)];
return YES;
}
@end
@implementation PRMPairPred
- (NSString *)primName
{
return @"pair?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"pair? takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
value = [[Boolean alloc] initSCMBoolean:isPair(item)];
return YES;
}
@end
@implementation PRMNullPred
- (NSString *)primName
{
return @"null?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"null? takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
value = [[Boolean alloc]
initSCMBoolean:(item==[NSNull null] ? YES : NO)];
return YES;
}
@end
@implementation PRMZeroPred
- (NSString *)primName
{
return @"zero?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
id item;
BOOL res = NO;
if(offs+1!=[args count]){
errmsg = @"zero? takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
if(nt==NT_OTHER){
errmsg = @"Argument to zero? must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
if(![item intVal]){
res = YES;
}
}
else{
if([item doubleVal]==(double)0.0){
res = YES;
}
}
value = [[Boolean alloc] initSCMBoolean:res];
return YES;
}
@end
@implementation PRMNumberPred
- (NSString *)primName
{
return @"number?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
id item;
BOOL res = NO;
if(offs+1!=[args count]){
errmsg = @"number? takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
res = (nt!=NT_OTHER ? YES : NO);
value = [[Boolean alloc] initSCMBoolean:res];
return YES;
}
@end
@implementation PRMEqPred
- (NSString *)primName
{
return @"eq?";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id itema, itemb;
BOOL res = NO;
if(offs+2!=[args count]){
errmsg = @"eq? takes two arguments";
return NO;
}
itema = [args objectAtIndex:offs];
itemb = [args objectAtIndex:offs+1];
value = [[Boolean alloc] initSCMBoolean:isEqual(itema, itemb)];
return YES;
}
@end
@implementation PRMNot
- (NSString *)primName
{
return @"not";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"not takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
value = [[Boolean alloc] initSCMBoolean:isFalse(item)];
return YES;
}
@end
@implementation PRMNumEqual
- (NSString *)primName
{
return @"=";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int icur, ires = 0; double dcur, dres = 0;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
BOOL res = YES;
if(nt==NT_OTHER){
errmsg = @"Arguments to = must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
ires = [[args objectAtIndex:offs] intVal];
for(pos=offs+1; pos<[args count]; pos++){
icur = [[args objectAtIndex:pos] intVal];
if(!(ires==icur)){
res = NO;
break;
}
ires = icur;
}
}
else{
dres = [[args objectAtIndex:offs] doubleVal];
for(pos=offs+1; pos<[args count]; pos++){
dcur = [[args objectAtIndex:pos] doubleVal];
if(!(dres==dcur)){
res = NO;
break;
}
dres = dcur;
}
}
value = [[Boolean alloc] initSCMBoolean:res];
return YES;
}
@end
@implementation PRMNumLT
- (NSString *)primName
{
return @"<";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int icur, ires = 0; double dcur, dres = 0;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
BOOL res = YES;
if(nt==NT_OTHER){
errmsg = @"Arguments to < must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
ires = [[args objectAtIndex:offs] intVal];
for(pos=offs+1; pos<[args count]; pos++){
icur = [[args objectAtIndex:pos] intVal];
if(!(ires<icur)){
res = NO;
break;
}
ires = icur;
}
}
else{
dres = [[args objectAtIndex:offs] doubleVal];
for(pos=offs+1; pos<[args count]; pos++){
dcur = [[args objectAtIndex:pos] doubleVal];
if(!(dres<dcur)){
res = NO;
break;
}
dres = dcur;
}
}
value = [[Boolean alloc] initSCMBoolean:res];
return YES;
}
@end
@implementation PRMNumGT
- (NSString *)primName
{
return @">";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int icur, ires = 0; double dcur, dres = 0;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
BOOL res = YES;
if(nt==NT_OTHER){
errmsg = @"Arguments to > must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
ires = [[args objectAtIndex:offs] intVal];
for(pos=offs+1; pos<[args count]; pos++){
icur = [[args objectAtIndex:pos] intVal];
if(!(ires>icur)){
res = NO;
break;
}
ires = icur;
}
}
else{
dres = [[args objectAtIndex:offs] doubleVal];
for(pos=offs+1; pos<[args count]; pos++){
dcur = [[args objectAtIndex:pos] doubleVal];
if(!(dres>dcur)){
res = NO;
break;
}
dres = dcur;
}
}
value = [[Boolean alloc] initSCMBoolean:res];
return YES;
}
@end
@implementation PRMPlus
- (NSString *)primName
{
return @"+";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int ires = 0; double dres = 0;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
if(nt==NT_OTHER){
errmsg = @"Arguments to + must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
for(pos=offs; pos<[args count]; pos++){
ires += [[args objectAtIndex:pos] intVal];
}
value = [[Int alloc] initSCMInt:ires];
return YES;
}
for(pos=offs; pos<[args count]; pos++){
dres += [[args objectAtIndex:pos] doubleVal];
}
value = [[Double alloc] initSCMDouble:dres];
return YES;
}
@end
@implementation PRMTimes
- (NSString *)primName
{
return @"*";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int ires = 1; double dres = 1;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
if(nt==NT_OTHER){
errmsg = @"Arguments to * must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
for(pos=offs; pos<[args count]; pos++){
ires *= [[args objectAtIndex:pos] intVal];
}
value = [[Int alloc] initSCMInt:ires];
return YES;
}
for(pos=offs; pos<[args count]; pos++){
dres *= [[args objectAtIndex:pos] doubleVal];
}
value = [[Double alloc] initSCMDouble:dres];
return YES;
}
@end
@implementation PRMMinus
- (NSString *)primName
{
return @"-";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int ires = 1; double dres = 1;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
if(offs==[args count]){
errmsg = @"- needs at least one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to - must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
ires = [[args objectAtIndex:offs] intVal];
if(offs+1==[args count]){
ires = -ires;
}
else{
for(pos=offs+1; pos<[args count]; pos++){
ires -= [[args objectAtIndex:pos] intVal];
}
}
value = [[Int alloc] initSCMInt:ires];
return YES;
}
dres = [[args objectAtIndex:offs] doubleVal];
if(offs+1==[args count]){
dres = -dres;
}
else{
for(pos=offs+1; pos<[args count]; pos++){
dres -= [[args objectAtIndex:pos] doubleVal];
}
}
value = [[Double alloc] initSCMDouble:dres];
return YES;
}
@end
@implementation PRMDivide
- (NSString *)primName
{
return @"/";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
int ires = 1; double dres = 1;
int pos = offs;
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
if(offs==[args count]){
errmsg = @"/ needs at least one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to / must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
ires = [[args objectAtIndex:offs] intVal];
if(offs+1==[args count]){
if(ires!=1){
errmsg = @"no integer fractions";
return NO;
}
}
else{
for(pos=offs+1; pos<[args count]; pos++){
ires /= [[args objectAtIndex:pos] intVal];
}
}
value = [[Int alloc] initSCMInt:ires];
return YES;
}
dres = [[args objectAtIndex:offs] doubleVal];
if(offs+1==[args count]){
dres = ((double)1.0)/dres;
}
else{
for(pos=offs+1; pos<[args count]; pos++){
dres /= [[args objectAtIndex:pos] doubleVal];
}
}
value = [[Double alloc] initSCMDouble:dres];
return YES;
}
@end
@implementation PRMRandom
- (NSString *)primName
{
return @"random";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
if(offs+1!=[args count]){
errmsg = @"random takes exactly one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"argument to random must be numeric";
return NO;
}
if(nt==NT_INTEGERS){
int v = [[args objectAtIndex:offs] intVal];
value = [[Int alloc] initSCMInt:(lrand48() % v)];
}
else{
double v = [[args objectAtIndex:offs] doubleVal];
value = [[Double alloc] initSCMDouble:(drand48() * v)];
}
return YES;
}
@end
@implementation PRMQuotient
- (NSString *)primName
{
return @"quotient";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
int a, b;
if(offs+2!=[args count]){
errmsg = @"quotient takes exactly two arguments";
return NO;
}
if(nt!=NT_INTEGERS){
errmsg = @"Arguments to quotient must be integers";
return NO;
}
a = [[args objectAtIndex:offs] intVal];
b = [[args objectAtIndex:offs+1] intVal];
if(!b){
errmsg = @"divide by zero error in quotient";
return NO;
}
value = [[Int alloc] initSCMInt:(a/b)];
return YES;
}
@end
@implementation PRMRemainder
- (NSString *)primName
{
return @"remainder";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
int a, b;
if(offs+2!=[args count]){
errmsg = @"remainder takes exactly two arguments";
return NO;
}
if(nt!=NT_INTEGERS){
errmsg = @"Arguments to remainder must be integers";
return NO;
}
a = [[args objectAtIndex:offs] intVal];
b = [[args objectAtIndex:offs+1] intVal];
if(!b){
errmsg = @"divide by zero error in remainder";
return NO;
}
value = [[Int alloc] initSCMInt:(a%b)];
return YES;
}
@end
@implementation PRMList
- (NSString *)primName
{
return @"list";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id res = [NSNull null];
int pos;
for(pos=[args count]-1; pos>=offs; pos--){
res = [Pair newCar:[args objectAtIndex:pos] Cdr:res];
}
value = res;
return YES;
}
@end
@implementation PRMCons
- (NSString *)primName
{
return @"cons";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+2!=[args count]){
errmsg = @"cons takes exactly two arguments";
return NO;
}
value = [Pair
newCar:[args objectAtIndex:offs]
Cdr:[args objectAtIndex:offs+1]];
return YES;
}
@end
@implementation PRMCar
- (NSString *)primName
{
return @"car";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"car takes exactly one argument";
return NO;
}
item = [args objectAtIndex:offs];
if(isPair(item)==NO){
errmsg = @"argument to car must be a pair";
return NO;
}
value = [item car];
return YES;
}
@end
@implementation PRMCdr
- (NSString *)primName
{
return @"cdr";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+1!=[args count]){
errmsg = @"cdr takes exactly one argument";
return NO;
}
item = [args objectAtIndex:offs];
if(isPair(item)==NO){
errmsg = @"argument to cdr must be a pair";
return NO;
}
value = [item cdr];
return YES;
}
@end
@implementation PRMSetCar
- (NSString *)primName
{
return @"set-car!";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+2!=[args count]){
errmsg = @"set-car! takes two arguments";
return NO;
}
item = [args objectAtIndex:offs];
if(isPair(item)==NO){
errmsg = @"argument to set-car! must be a pair";
return NO;
}
[item setcar:[args objectAtIndex:(offs+1)]];
value = [item car];
return YES;
}
@end
@implementation PRMSetCdr
- (NSString *)primName
{
return @"set-cdr!";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs+2!=[args count]){
errmsg = @"set-cdr! takes two arguments";
return NO;
}
item = [args objectAtIndex:offs];
if(isPair(item)==NO){
errmsg = @"argument to set-cdr! must be a pair";
return NO;
}
[item setcdr:[args objectAtIndex:(offs+1)]];
value = [item cdr];
return YES;
}
@end
@implementation PRMDisplay
- (NSString *)primName
{
return @"display";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
NSString *res;
if(offs+1!=[args count]){
errmsg = @"display takes one argument";
return NO;
}
item = [args objectAtIndex:offs];
if(isString(item)){
res = [NSString
stringWithFormat:@"%@", [item strVal]];
}
else if(isChar(item)){
res = [NSString
stringWithFormat:@"%c", [item charVal]];
}
else{
res = [VScheme valToString:item];
}
[vm appendToOutput:res];
value = [NSNull null];
return YES;
}
@end
@implementation PRMNewline
- (NSString *)primName
{
return @"newline";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id item;
if(offs!=[args count]){
errmsg = @"newline takes no arguments";
return NO;
}
[vm appendToOutput:@"\n"];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawMove
- (NSString *)primName
{
return @"draw-move";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+2!=[args count]){
errmsg = @"draw-move takes two arguments";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to draw-move must be numeric";
return NO;
}
inst.what = DRAW_MOVE;
inst.data.coord.x = [[args objectAtIndex:offs] doubleVal];
inst.data.coord.y = [[args objectAtIndex:offs+1] doubleVal];
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawLine
- (NSString *)primName
{
return @"draw-line";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+2!=[args count]){
errmsg = @"draw-line takes two arguments";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to draw-line must be numeric";
return NO;
}
inst.what = DRAW_LINE;
inst.data.coord.x = [[args objectAtIndex:offs] doubleVal];
inst.data.coord.y = [[args objectAtIndex:offs+1] doubleVal];
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawColor
- (NSString *)primName
{
return @"draw-color";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+3!=[args count]){
errmsg = @"draw-color takes three arguments";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to draw-color must be numeric";
return NO;
}
inst.what = DRAW_COLOR;
inst.data.color[0] = [[args objectAtIndex:offs] doubleVal];
inst.data.color[1] = [[args objectAtIndex:offs+1] doubleVal];
inst.data.color[2] = [[args objectAtIndex:offs+2] doubleVal];
if(inst.data.color[0]<(float)0 ||
inst.data.color[0]>(float)255){
errmsg = @"red color component out of range (0..255)";
return NO;
}
if(inst.data.color[1]<(float)0 ||
inst.data.color[1]>(float)255){
errmsg = @"green color component out of range (0..255)";
return NO;
}
if(inst.data.color[2]<(float)0 ||
inst.data.color[2]>(float)255){
errmsg = @"blue color component out of range (0..255)";
return NO;
}
inst.data.color[0]/=(float)255;
inst.data.color[1]/=(float)255;
inst.data.color[2]/=(float)255;
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawCircle
- (NSString *)primName
{
return @"draw-circle";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+1!=[args count]){
errmsg = @"draw-circle takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to draw-circle must be numeric";
return NO;
}
inst.what = DRAW_CIRCLE;
inst.data.radius = [[args objectAtIndex:offs] doubleVal];
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMFillCircle
- (NSString *)primName
{
return @"fill-circle";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+1!=[args count]){
errmsg = @"fill-circle takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to fill-circle must be numeric";
return NO;
}
inst.what = FILL_CIRCLE;
inst.data.radius = [[args objectAtIndex:offs] doubleVal];
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawRect
- (NSString *)primName
{
return @"draw-rect";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+2!=[args count]){
errmsg = @"draw-rect takes two arguments";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Arguments to draw-rect must be numeric";
return NO;
}
inst.what = DRAW_RECT;
inst.data.size =
NSMakeSize([[args objectAtIndex:offs] doubleVal],
[[args objectAtIndex:offs+1] doubleVal]);
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMFillRect
- (NSString *)primName
{
return @"fill-rect";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
DrawInst inst;
if(offs+2!=[args count]){
errmsg = @"fill-rect takes two arguments";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to fill-rect must be numeric";
return NO;
}
inst.what = FILL_RECT;
inst.data.size =
NSMakeSize([[args objectAtIndex:offs] doubleVal],
[[args objectAtIndex:offs+1] doubleVal]);
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawFont
- (NSString *)primName
{
return @"draw-font";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
DrawInst inst;
if(offs+2!=[args count]){
errmsg = @"draw-font takes two arguments";
return NO;
}
String *fontName = [args objectAtIndex:offs];
if(isString(fontName)==NO){
errmsg = @"draw-font: font name must be a string";
return NO;
}
NSString *fontNameStr = [fontName strVal];
if([[[NSFontManager sharedFontManager]
availableFonts] containsObject:fontNameStr]==NO){
errmsg =
[[NSString alloc]
initWithFormat:@"draw-font: no such font (%@)", fontNameStr];
return NO;
}
id size = [args objectAtIndex:offs+1];
if(isInt(size)==NO && isDouble(size)==NO){
errmsg = @"draw-font: size must be a number";
return NO;
}
float sizeVal = (float)[size doubleVal];
NSFont *font = [NSFont fontWithName:fontNameStr size:sizeVal];
[font retain];
inst.what = DRAW_FONT;
inst.data.font = font;
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawString
- (NSString *)primName
{
return @"draw-string";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
DrawInst inst;
if(offs+1!=[args count]){
errmsg = @"draw-string takes one argument";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"draw-string: string required";
return NO;
}
NSString *string = [NSString stringWithString:[str strVal]];
[string retain];
inst.what = DRAW_STRING;
inst.data.string = string;
[vm recordImgInst:inst];
value = [NSNull null];
return YES;
}
@end
@implementation PRMDrawShow
- (NSString *)primName
{
return @"draw-show";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs!=[args count]){
errmsg = @"draw-show takes no argument";
return NO;
}
[vm produceImage];
[vm clearImage];
value = [NSNull null];
return YES;
}
@end
@implementation PRMSin
- (NSString *)primName
{
return @"sin";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res;
if(offs+1!=[args count]){
errmsg = @"sin takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to sin must be numeric";
return NO;
}
res = sin([[args objectAtIndex:offs] doubleVal]);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMCos
- (NSString *)primName
{
return @"cos";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res;
if(offs+1!=[args count]){
errmsg = @"cos takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to cos must be numeric";
return NO;
}
res = cos([[args objectAtIndex:offs] doubleVal]);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMTan
- (NSString *)primName
{
return @"tan";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res;
if(offs+1!=[args count]){
errmsg = @"tan takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to tan must be numeric";
return NO;
}
res = tan([[args objectAtIndex:offs] doubleVal]);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMExp
- (NSString *)primName
{
return @"exp";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res;
if(offs+1!=[args count]){
errmsg = @"exp takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to exp must be numeric";
return NO;
}
res = exp([[args objectAtIndex:offs] doubleVal]);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMLog
- (NSString *)primName
{
return @"log";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double v, res;
if(offs+1!=[args count]){
errmsg = @"log takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to log must be numeric";
return NO;
}
v = [[args objectAtIndex:offs] doubleVal];
if(v<=0.0){
errmsg = @"Argument to log must be positive";
return NO;
}
res = log(v);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMATan
- (NSString *)primName
{
return @"atan";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res, v;
if(offs+1!=[args count]){
errmsg = @"atan takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to atan must be numeric";
return NO;
}
v = [[args objectAtIndex:offs] doubleVal];
res = atan(v);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMASin
- (NSString *)primName
{
return @"asin";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res, v;
if(offs+1!=[args count]){
errmsg = @"asin takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to asin must be numeric";
return NO;
}
v = [[args objectAtIndex:offs] doubleVal];
if(v<(double)-1.0 || (double)1.0<v){
errmsg = @"Argument to asin out of range";
return NO;
}
res = asin(v);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMACos
- (NSString *)primName
{
return @"acos";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double res, v;
if(offs+1!=[args count]){
errmsg = @"acos takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to acos must be numeric";
return NO;
}
v = [[args objectAtIndex:offs] doubleVal];
if(v<(double)-1.0 || (double)1.0<v){
errmsg = @"Argument to acos out of range";
return NO;
}
res = acos(v);
value = [[Double alloc] initSCMDouble:res];
return YES;
}
@end
@implementation PRMSqrt
- (NSString *)primName
{
return @"sqrt";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NUMTYPE nt = [self checkArgsNumeric:args offset:offs];
double v, res; int ires;
id item;
if(offs+1!=[args count]){
errmsg = @"sqrt takes one argument";
return NO;
}
if(nt==NT_OTHER){
errmsg = @"Argument to sqrt must be numeric";
return NO;
}
item = [args objectAtIndex:offs]; v = [item doubleVal];
if(v<0){
errmsg = @"Argument to sqrt must not be negative";
return NO;
}
res = sqrt([item doubleVal]);
ires = (int)res;
if(nt==NT_INTEGERS && ires*ires==[item intVal]){
value = [[Int alloc] initSCMInt:ires];
}
else{
value = [[Double alloc] initSCMDouble:res];
}
return YES;
}
@end
@implementation PRMMakeVector
- (NSString *)primName
{
return @"make-vector";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id filler;
id count;
int cval;
if(offs+1==[args count]){
filler = [NSNull null];
}
else if(offs+2==[args count]){
filler = [args objectAtIndex:offs+1];
}
else{
errmsg = @"make-vector takes one or two arguments";
return NO;
}
count = [args objectAtIndex:offs];
if(isInt(count)==NO){
errmsg = @"make-vector: integer required";
return NO;
}
cval = [count intVal];
if(cval<0){
errmsg = @"make-vector: non-negative integer required";
return NO;
}
value = [Vector newWithItem:filler count:cval];
return YES;
}
@end
@implementation PRMListToVector
- (NSString *)primName
{
return @"list->vector";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id list;
if(offs+1!=[args count]){
errmsg = @"list->vector takes one argument";
return NO;
}
list = [args objectAtIndex:offs];
if(isPair(list)==NO && list!=[NSNull null]){
errmsg = @"list->vector: list required";
return NO;
}
value = [Vector newFromList:list];
return YES;
}
@end
@implementation PRMVectorToList
- (NSString *)primName
{
return @"vector->list";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
Vector *vect;
Pair *result;
id *data;
int index;
if(offs+1!=[args count]){
errmsg = @"vector->list takes one argument";
return NO;
}
vect = [args objectAtIndex:offs];
if(isVector(vect)==NO){
errmsg = @"vector->list: vector required";
return NO;
}
data = [vect entries];
for(index=[vect count]-1, result=(Pair *)[NSNull null];
index>=0; index--){
result =
[Pair newCar:data[index] Cdr:result];
}
value = result;
return YES;
}
@end
@implementation PRMVectorLength
- (NSString *)primName
{
return @"vector-length";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
Vector *vect;
if(offs+1!=[args count]){
errmsg = @"vector-length takes one argument";
return NO;
}
vect = [args objectAtIndex:offs];
if(isVector(vect)==NO){
errmsg = @"vector-length: vector required";
return NO;
}
value = [[Int alloc] initSCMInt:[vect count]];
return YES;
}
@end
@implementation PRMVectorRef
- (NSString *)primName
{
return @"vector-ref";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id *data;
Vector *vect;
int count, index;
Int *ind;
if(offs+2!=[args count]){
errmsg = @"vector-ref takes two arguments";
return NO;
}
vect = [args objectAtIndex:offs];
if(isVector(vect)==NO){
errmsg = @"vector-ref: vector required";
return NO;
}
data = [vect entries]; count = [vect count];
ind = [args objectAtIndex:offs+1];
if(isInt(ind)==NO){
errmsg = @"vector-ref: integer required";
return NO;
}
index = [ind intVal];
if(index<0 || index>=count){
errmsg = @"vector-ref: index out of bounds";
return NO;
}
value = data[index];
return YES;
}
@end
@implementation PRMVectorSet
- (NSString *)primName
{
return @"vector-set!";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id *data;
Vector *vect;
int count, index;
Int *ind;
id obj;
if(offs+3!=[args count]){
errmsg = @"vector-set! takes three arguments";
return NO;
}
vect = [args objectAtIndex:offs];
if(isVector(vect)==NO){
errmsg = @"vector-set!: vector required";
return NO;
}
data = [vect entries]; count = [vect count];
ind = [args objectAtIndex:offs+1];
if(isInt(ind)==NO){
errmsg = @"vector-set!: integer required";
return NO;
}
index = [ind intVal];
if(index<0 || index>=count){
errmsg = @"vector-set!: index out of bounds";
return NO;
}
obj = [args objectAtIndex:offs+2];
data[index] = obj; [obj retain];
value = obj;
return YES;
}
@end
@implementation PRMVectorFill
- (NSString *)primName
{
return @"vector-fill!";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id *data;
Vector *vect;
int count, index;
id obj;
if(offs+2!=[args count]){
errmsg = @"vector-fill! takes two arguments";
return NO;
}
vect = [args objectAtIndex:offs];
if(isVector(vect)==NO){
errmsg = @"vector-fill!: vector required";
return NO;
}
data = [vect entries]; count = [vect count];
obj = [args objectAtIndex:offs+1];
for(index=0; index<count; index++){
data[index] = obj; [obj retain];
}
value = obj;
return YES;
}
@end
@implementation PRMSymToStr
- (NSString *)primName
{
return @"symbol->string";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"symbol->string takes one argument";
return NO;
}
Symbol *sym = [args objectAtIndex:offs];
if(isSymbol(sym)==NO){
errmsg = @"symbol->string: symbol required";
return NO;
}
value = [[String alloc]
initSCMString:(char *)[[sym symVal] cString]];
return YES;
}
@end
@implementation PRMStrToSym
- (NSString *)primName
{
return @"string->symbol";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"string->symbol takes one argument";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"string->symbol: string required";
return NO;
}
value = [[Symbol alloc]
initSCMSymbol:(char *)[[str strVal] cString]];
return YES;
}
@end
@implementation PRMStringSize
- (NSString *)primName
{
return @"string-size";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+3!=[args count]){
errmsg = @"string-size takes three arguments";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"string-size: string required";
return NO;
}
String *fontName = [args objectAtIndex:offs+1];
if(isString(fontName)==NO){
errmsg = @"string-size: font name must be a string";
return NO;
}
NSString *fontNameStr = [fontName strVal];
if([[[NSFontManager sharedFontManager]
availableFonts] containsObject:fontNameStr]==NO){
errmsg =
[[NSString alloc]
initWithFormat:@"string-size: no such font (%@)", fontNameStr];
return NO;
}
id size = [args objectAtIndex:offs+2];
if(isInt(size)==NO && isDouble(size)==NO){
errmsg = @"string-size: size must be a number";
return NO;
}
float sizeVal = (float)[size doubleVal];
NSFont *font = [NSFont fontWithName:fontNameStr size:sizeVal];
NSDictionary *attr =
[NSDictionary dictionaryWithObjectsAndKeys:font, NSFontAttributeName, nil];
NSSize result = [[str strVal] sizeWithAttributes:attr];
value =
[Pair
newCar:[[Double alloc] initSCMDouble:result.width]
Cdr:[[Double alloc] initSCMDouble:result.height]];
return YES;
}
@end
@implementation PRMStringLength
- (NSString *)primName
{
return @"string-length";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"string-length takes three arguments";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"string-length: string required";
return NO;
}
value = [[Int alloc] initSCMInt:[[str strVal] length]];
return YES;
}
@end
@implementation PRMCharToInt
- (NSString *)primName
{
return @"char->integer";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"char->integer takes one argument";
return NO;
}
Char *ch = [args objectAtIndex:offs];
if(isChar(ch)==NO){
errmsg = @"char->integer: character required";
return NO;
}
value = [[Int alloc]
initSCMInt:(long int)[ch charVal]];
return YES;
}
@end
@implementation PRMIntToChar
- (NSString *)primName
{
return @"integer->char";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"integer->char takes one argument";
return NO;
}
Int *i = [args objectAtIndex:offs];
if(isInt(i)==NO){
errmsg = @"integer->char: character required";
return NO;
}
value = [[Char alloc]
initSCMChar:(char)[i intVal]];
return YES;
}
@end
@implementation PRMStringRef
- (NSString *)primName
{
return @"string-ref";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+2!=[args count]){
errmsg = @"string-ref takes two argument";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"string-ref: string required";
return NO;
}
Int *i = [args objectAtIndex:offs+1];
if(isInt(i)==NO){
errmsg = @"string-ref: integer position required";
return NO;
}
int pos = [i intVal];
NSString *theStr = [str strVal];
if(pos>=[theStr length]){
errmsg = @"string-ref: index out of range";
return NO;
}
value = [[Char alloc] initSCMChar:[theStr characterAtIndex:pos]];
return YES;
}
@end
@implementation PRMListToStr
- (NSString *)primName
{
return @"list->string";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"list->string takes one argument";
return NO;
}
Pair *p = [args objectAtIndex:offs];
if(isPair(p)==NO && [NSNull null]!=(id)p){
errmsg = @"list->string: pair required";
return NO;
}
int cpos = 0, cmax = 0;
while(isPair(p)){
if(isChar([p car])==NO){
errmsg = @"list->string: character required";
return NO;
}
p = [p cdr];
cmax++;
}
char buf[cmax+1];
p = [args objectAtIndex:offs];
while(isPair(p)){
Char *ch = [p car];
buf[cpos++] = [ch charVal];
p = [p cdr];
}
buf[cpos] = 0;
value = [[String alloc] initSCMString:buf];
return YES;
}
@end
@implementation PRMStrToList
- (NSString *)primName
{
return @"string->list";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count]){
errmsg = @"string->list takes one argument";
return NO;
}
String *str = [args objectAtIndex:offs];
if(isString(str)==NO){
errmsg = @"string->list: string required";
return NO;
}
NSString *theStr = [str strVal];
id result = [NSNull null];
int cmax = [theStr length], cpos;
cpos = cmax-1;
while(cpos>=0){
char c = [theStr characterAtIndex:cpos];
result =
[Pair
newCar:[[Char alloc] initSCMChar:c]
Cdr:result];
cpos--;
}
value = result;
return YES;
}
@end
@implementation PRMStringAppend
- (NSString *)primName
{
return @"string-append";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
NSString *result = @"";
int cpos = offs, cmax = [args count];
while(cpos<cmax){
String *str = [args objectAtIndex:cpos];
if(isString(str)==NO){
errmsg = @"string-append: string required";
return NO;
}
result = [result stringByAppendingString:[str strVal]];
cpos++;
}
value = [[String alloc] initSCMString:(char *)[result cString]];
return YES;
}
@end
@implementation PRMMakeString
- (NSString *)primName
{
return @"make-string";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count] && offs+2!=[args count]){
errmsg = @"make-string takes one or two arguments";
return NO;
}
Int *i = [args objectAtIndex:offs];
if(isInt(i)==NO){
errmsg = @"make-string: integer required";
return NO;
}
int pos = 0, count = [i intVal];
char fill = ' ';
if(offs+2==[args count]){
Char *ch = [args objectAtIndex:offs+1];
if(isChar(ch)==NO){
errmsg = @"make-string: character required";
return NO;
}
fill = [ch charVal];
}
char buf[count+1];
while(pos<count){
buf[pos++] = fill;
}
buf[pos] = 0;
value = [[String alloc] initSCMString:buf];
return YES;
}
@end
@implementation PRMNumberToStr
- (NSString *)primName
{
return @"number->string";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs+1!=[args count] && offs+2!=[args count]){
errmsg = @"number->string takes one or two arguments";
return NO;
}
id n = [args objectAtIndex:offs];
if(isInt(n)==NO && isDouble(n)==NO){
errmsg = @"number->string: int or double required";
return NO;
}
if(isDouble(n)){
NSNumber *num = [NSNumber numberWithDouble:[n doubleVal]];
value = [[String alloc] initSCMString:(char *)[[num description] cString]];
return YES;
}
int radix = 10;
if(offs+2==[args count]){
Int *r = [args objectAtIndex:offs+1];
if(isInt(r)==NO){
errmsg = @"number->string: radix must be an integer";
return NO;
}
radix = [r intVal];
if(radix<2 || radix>36){
errmsg = @"number->string: radix must be >= 2 and <= 36";
return NO;
}
}
int number = [n intVal];
if(radix==10 || !number){
NSNumber *num = [NSNumber numberWithInt:number];
value = [[String alloc] initSCMString:(char *)[[num description] cString]];
return YES;
}
int sign = 1;
if(number<0){
sign = -1;
number = -number;
}
NSString *result = @"";
while(number>0){
int digit = number % radix;
result =
[[NSString stringWithFormat:@"%c",
(digit<10 ? '0' + digit : 'A' + digit-10)]
stringByAppendingString:result];
number /= radix;
}
if(sign==-1){
result = [NSString stringWithFormat:@"-%@", result];
}
value = [[String alloc] initSCMString:(char *)[result cString]];
return YES;
}
@end
@implementation PRMFormat
- (NSString *)primName
{
return @"format";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
if(offs==[args count]){
errmsg = @"format needs at least one argument";
return NO;
}
String *fmt = [args objectAtIndex:offs++];
if(isString(fmt)==NO){
errmsg = @"format: string required";
return NO;
}
const char *fmtStr = [[fmt strVal] cString];
NSString *result = @"";
while(*fmtStr){
NSString *item;
if(fmtStr[0]=='~'){
if(fmtStr[1]){
switch(fmtStr[1]){
case 'a':
case 's':
if(offs==[args count]){
errmsg = @"format: ran out of arguments";
return NO;
}
id cur = [args objectAtIndex:offs++];
if(isString(cur)){
item = [NSString stringWithFormat:@"%@", [cur strVal]];
}
else if(isChar(cur)){
item = [NSString stringWithFormat:@"%c", [cur charVal]];
}
else{
item = [VScheme valToString:cur];
}
break;
case '%':
item = @"\n";
break;
case '~':
item = @"~";
}
fmtStr++;
}
}
else{
item = [NSString stringWithCString:fmtStr length:1];
}
result = [result stringByAppendingString:item];
fmtStr++;
}
value = [[String alloc] initSCMString:(char *)[result cString]];
return YES;
}
@end
@implementation PRMBrowseEnvironment
- (NSString *)primName
{
return @"browse-environment";
}
- (BOOL)evalVM:(id)vm Args:(NSMutableArray *)args offset:(int)offs
{
id win;
if(offs!=[args count]){
errmsg = @"browse-environment takes no arguments";
return NO;
}
win = [[EnvWindow alloc] initWithEnv:[[vm envStack] lastObject]];
[[vm delegate] envWindow:win];
value = [NSNull null];
return YES;
}
@end
@implementation PRMEval
- (NSString *)primName
{
return @"eval";
}
@end
Reference in New Issue View Git Blame Copy Permalink