qf/quakeforge
0
0
Fork 0
mirror of https://git.code.sf.net/p/quake/quakeforge synced 2024-11-22 04:21:51 +00:00
Code Issues Projects Releases Packages Wiki Activity

Syntax fixes for ruamoko/scheme.

Browse source
This commit is contained in:
Bill Currie 2011-02-14 22:39:43 +09:00
parent da3ac388fe
commit 6af747705c
41 changed files with 362 additions and 361 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
ruamoko/scheme/BaseContinuation.r
View file

@ -2,7 +2,7 @@
#include "Cons.h"
instruction_t returninst;
BaseContinuation []base;
BaseContinuation *base;
@implementation BaseContinuation
+ (void) initialize
@ -15,14 +15,14 @@ BaseContinuation []base;
return base;
}
- (void) restoreOnMachine: (Machine []) m
- (void) restoreOnMachine: (Machine *) m
{
[m state].program = &returninst;
}
- (void) invokeOnMachine: (Machine []) m
- (void) invokeOnMachine: (Machine *) m
{
[m value: [(Cons []) [m stack] car]];
[m value: [(Cons *) [m stack] car]];
[m state].program = &returninst;
}

4
ruamoko/scheme/Boolean.r
View file

@ -1,7 +1,7 @@
#include "Boolean.h"
Boolean []trueConstant;
Boolean []falseConstant;
Boolean *trueConstant;
Boolean *falseConstant;
@implementation Boolean

22
ruamoko/scheme/CompiledCode.h
View file

@ -8,26 +8,26 @@
struct lineinfo_s {
integer linenumber;
String []sourcefile;
String *sourcefile;
};
typedef struct lineinfo_s lineinfo_t;
@interface CompiledCode: SchemeObject
{
Frame []literals;
Array []instructions;
Array []constants;
instruction_t [] code;
lineinfo_t [] lineinfo;
Frame *literals;
Array *instructions;
Array *constants;
instruction_t *code;
lineinfo_t *lineinfo;
integer minargs, size;
}
- (void) addInstruction: (Instruction []) inst;
- (integer) addConstant: (SchemeObject []) c;
- (void) addInstruction: (Instruction *) inst;
- (integer) addConstant: (SchemeObject *) c;
- (void) compile;
- (instruction_t []) code;
- (lineinfo_t []) lineinfo;
- (Frame []) literals;
- (instruction_t *) code;
- (lineinfo_t *) lineinfo;
- (Frame *) literals;
- (integer) minimumArguments;
- (void) minimumArguments: (integer) min;

16
ruamoko/scheme/CompiledCode.r
View file

@ -22,7 +22,7 @@
[instructions makeObjectsPerformSelector: @selector(mark)];
}
- (void) addInstruction: (Instruction []) inst
- (void) addInstruction: (Instruction *) inst
{
[inst line: [self line]];
[inst source: [self source]];
@ -32,7 +32,7 @@
}
}
- (integer) addConstant: (SchemeObject []) c
- (integer) addConstant: (SchemeObject *) c
{
local integer number = [constants count];
[constants addObject: c];
@ -42,12 +42,12 @@
- (void) compile
{
local integer index;
local Instruction []inst;
local Instruction *inst;
literals = [Frame newWithSize: [constants count] link: nil];
code = obj_malloc (@sizeof(instruction_t) * [instructions count]);
lineinfo = obj_malloc(@sizeof(lineinfo_t) * [instructions count]);
for (index = 0; index < [constants count]; index++) {
[literals set: index to: (SchemeObject[]) [constants objectAtIndex: index]];
[literals set: index to: (SchemeObject*) [constants objectAtIndex: index]];
}
for (index = 0; index < [instructions count]; index++) {
inst = [instructions objectAtIndex: index];
@ -62,24 +62,24 @@
instructions = constants = nil;
}
- (instruction_t []) code
- (instruction_t *) code
{
return code;
}
- (lineinfo_t []) lineinfo
- (lineinfo_t *) lineinfo
{
return lineinfo;
}
- (Frame[]) literals
- (Frame*) literals
{
return literals;
}
- (void) dealloc
{
local Array []temp;
local Array *temp;
if (instructions) {
temp = instructions;

22
ruamoko/scheme/Compiler.h
View file

@ -10,20 +10,20 @@
@interface Compiler: SchemeObject
{
CompiledCode []code;
SchemeObject []sexpr;
Scope []scope;
Error []err;
CompiledCode *code;
SchemeObject *sexpr;
Scope *scope;
Error *err;
}
+ (id) newWithLambda: (SchemeObject []) xp scope: (Scope []) sc;
- (id) initWithLambda: (SchemeObject []) xp scope: (Scope []) sc;
- (SchemeObject[]) compile;
+ (id) newWithLambda: (SchemeObject *) xp scope: (Scope *) sc;
- (id) initWithLambda: (SchemeObject *) xp scope: (Scope *) sc;
- (SchemeObject*) compile;
- (void) emitExpression: (SchemeObject []) expression flags: (integer) fl;
- (void) emitLambda: (SchemeObject []) expression;
- (void) emitConstant: (SchemeObject []) expression;
- (void) emitApply: (SchemeObject []) expression flags: (integer) fl;
- (void) emitExpression: (SchemeObject *) expression flags: (integer) fl;
- (void) emitLambda: (SchemeObject *) expression;
- (void) emitConstant: (SchemeObject *) expression;
- (void) emitApply: (SchemeObject *) expression flags: (integer) fl;
@end
#endif //__Compiler_h

156
ruamoko/scheme/Compiler.r
View file

@ -6,12 +6,12 @@
#include "Cons.h"
#include "defs.h"
Symbol []lambdaSym;
Symbol []quoteSym;
Symbol []defineSym;
Symbol []ifSym;
Symbol []letrecSym;
Symbol []beginSym;
Symbol *lambdaSym;
Symbol *quoteSym;
Symbol *defineSym;
Symbol *ifSym;
Symbol *letrecSym;
Symbol *beginSym;
@implementation Compiler
+ (void) initialize
@ -30,12 +30,12 @@ Symbol []beginSym;
[beginSym retain];
}
+ (id) newWithLambda: (SchemeObject[]) xp scope: (Scope[]) sc
+ (id) newWithLambda: (SchemeObject*) xp scope: (Scope*) sc
{
return [[self alloc] initWithLambda: xp scope: sc];
}
- (id) initWithLambda: (SchemeObject[]) xp scope: (Scope[]) sc
- (id) initWithLambda: (SchemeObject*) xp scope: (Scope*) sc
{
self = [super init];
sexpr = xp;
@ -45,14 +45,14 @@ Symbol []beginSym;
return self;
}
- (void) emitBuildEnvironment: (SchemeObject []) arguments
- (void) emitBuildEnvironment: (SchemeObject *) arguments
{
local integer count, index;
local SchemeObject []cur;
local SchemeObject *cur;
scope = [Scope newWithOuter: scope];
count = 0;
for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [(Cons[]) cur cdr]) {
for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [(Cons*) cur cdr]) {
count++;
}
[code minimumArguments: count];
@ -62,12 +62,12 @@ Symbol []beginSym;
[code addInstruction: [Instruction opcode: MAKEENV operand: count]];
[code addInstruction: [Instruction opcode: LOADENV]];
cur = arguments;
for (index = 0; index < count; cur = [(Cons[]) cur cdr]) {
for (index = 0; index < count; cur = [(Cons*) cur cdr]) {
if ([cur isKindOfClass: [Cons class]]) {
[scope addName: (Symbol[]) [(Cons[]) cur car]];
[scope addName: (Symbol*) [(Cons*) cur car]];
[code addInstruction: [Instruction opcode: SET operand: index]];
} else if ([cur isKindOfClass: [Symbol class]]) {
[scope addName: (Symbol[]) cur];
[scope addName: (Symbol*) cur];
[code addInstruction:
[Instruction opcode: SETREST operand: index]];
break;
@ -81,21 +81,21 @@ Symbol []beginSym;
}
}
- (void) emitSequence: (SchemeObject[]) expressions flags: (integer) fl
- (void) emitSequence: (SchemeObject*) expressions flags: (integer) fl
{
local SchemeObject []cur;
local SchemeObject *cur;
for (cur = expressions; cur != [Nil nil]; cur = [(Cons[]) cur cdr]) {
if ([(Cons[]) cur cdr] == [Nil nil] && (fl & TAIL)) {
[self emitExpression: [(Cons[]) cur car] flags: fl];
for (cur = expressions; cur != [Nil nil]; cur = [(Cons*) cur cdr]) {
if ([(Cons*) cur cdr] == [Nil nil] && (fl & TAIL)) {
[self emitExpression: [(Cons*) cur car] flags: fl];
} else {
[self emitExpression: [(Cons[]) cur car] flags: fl & ~TAIL];
[self emitExpression: [(Cons*) cur car] flags: fl & ~TAIL];
}
if (err) return;
}
}
- (void) emitVariable: (Symbol[]) sym
- (void) emitVariable: (Symbol*) sym
{
local integer depth = [scope depthOf: sym];
local integer index = [scope indexOf: sym];
@ -114,27 +114,27 @@ Symbol []beginSym;
}
}
- (void) emitDefine: (SchemeObject[]) expression
- (void) emitDefine: (SchemeObject*) expression
{
local integer index = 0;
if (![expression isKindOfClass: [Cons class]] ||
![[(Cons[]) expression cdr] isKindOfClass: [Cons class]]) {
![[(Cons*) expression cdr] isKindOfClass: [Cons class]]) {
err = [Error type: "syntax"
message: "Malformed define statement"
by: expression];
return;
}
if ([[(Cons[]) expression car] isKindOfClass: [Cons class]]) {
index = [code addConstant: [(Cons[]) [(Cons[]) expression car] car]];
if ([[(Cons*) expression car] isKindOfClass: [Cons class]]) {
index = [code addConstant: [(Cons*) [(Cons*) expression car] car]];
[self emitLambda: cons(lambdaSym,
cons([(Cons[]) [(Cons[]) expression car] cdr],
[(Cons[]) expression cdr]))];
cons([(Cons*) [(Cons*) expression car] cdr],
[(Cons*) expression cdr]))];
if (err) return;
} else if ([[(Cons[]) expression car] isKindOfClass: [Symbol class]]) {
index = [code addConstant: [(Cons[]) expression car]];
[self emitExpression: [(Cons[]) [(Cons[]) expression cdr] car] flags: 0];
} else if ([[(Cons*) expression car] isKindOfClass: [Symbol class]]) {
index = [code addConstant: [(Cons*) expression car]];
[self emitExpression: [(Cons*) [(Cons*) expression cdr] car] flags: 0];
if (err) return;
} else {
err = [Error type: "syntax"
@ -148,12 +148,12 @@ Symbol []beginSym;
[code addInstruction: [Instruction opcode: SETGLOBAL]];
}
- (void) emitIf: (SchemeObject[]) expression flags: (integer) fl
- (void) emitIf: (SchemeObject*) expression flags: (integer) fl
{
local Instruction []falseLabel, endLabel;
local Instruction *falseLabel, *endLabel;
local integer index;
if (![expression isKindOfClass: [Cons class]] ||
![[(Cons[]) expression cdr] isKindOfClass: [Cons class]]) {
![[(Cons*) expression cdr] isKindOfClass: [Cons class]]) {
err = [Error type: "syntax"
message: "Malformed if expression"
by: expression];
@ -162,19 +162,19 @@ Symbol []beginSym;
falseLabel = [Instruction opcode: LABEL];
endLabel = [Instruction opcode: LABEL];
[self emitExpression: [(Cons[]) expression car] flags: fl & ~TAIL];
[self emitExpression: [(Cons*) expression car] flags: fl & ~TAIL];
if (err) return;
[code addInstruction: [Instruction opcode: IFFALSE label: falseLabel]];
[self emitExpression: [(Cons[]) [(Cons[]) expression cdr] car] flags: fl];
[self emitExpression: [(Cons*) [(Cons*) expression cdr] car] flags: fl];
if (err) return;
[code addInstruction: [Instruction opcode: GOTO label: endLabel]];
[code addInstruction: falseLabel];
if ([(Cons[]) [(Cons[]) expression cdr] cdr] == [Nil nil]) {
if ([(Cons*) [(Cons*) expression cdr] cdr] == [Nil nil]) {
index = [code addConstant: [Void voidConstant]];
[code addInstruction: [Instruction opcode: LOADLITS]];
[code addInstruction: [Instruction opcode: GET operand: index]];
} else {
[self emitExpression: [(Cons[]) [(Cons[]) [(Cons[]) expression cdr] cdr] car] flags: fl];
[self emitExpression: [(Cons*) [(Cons*) [(Cons*) expression cdr] cdr] car] flags: fl];
if (err) return;
}
[code addInstruction: endLabel];
@ -184,14 +184,14 @@ Symbol []beginSym;
- (void) emitLetrec: (SchemeObject[]) expression flags: (integer) fl
- (void) emitLetrec: (SchemeObject*) expression flags: (integer) fl
{
local SchemeObject []bindings;
local SchemeObject *bindings;
local integer count;
if (!isList(expression) ||
!isList([(Cons[]) expression car]) ||
![[(Cons[]) expression cdr] isKindOfClass: [Cons class]]) {
!isList([(Cons*) expression car]) ||
![[(Cons*) expression cdr] isKindOfClass: [Cons class]]) {
err = [Error type: "syntax"
message: "Malformed letrec expression"
by: expression];
@ -201,8 +201,8 @@ Symbol []beginSym;
count = 0;
for (bindings = [(Cons[]) expression car]; bindings != [Nil nil]; bindings = [(Cons[]) bindings cdr]) {
[scope addName: (Symbol[]) [(Cons[]) [(Cons[]) bindings car] car]];
for (bindings = [(Cons*) expression car]; bindings != [Nil nil]; bindings = [(Cons*) bindings cdr]) {
[scope addName: (Symbol*) [(Cons*) [(Cons*) bindings car] car]];
count++;
}
@ -210,84 +210,84 @@ Symbol []beginSym;
count = 0;
for (bindings = [(Cons[]) expression car]; bindings != [Nil nil]; bindings = [(Cons[]) bindings cdr]) {
[self emitSequence: [(Cons[]) [(Cons[]) bindings car] cdr] flags: fl & ~TAIL];
for (bindings = [(Cons*) expression car]; bindings != [Nil nil]; bindings = [(Cons*) bindings cdr]) {
[self emitSequence: [(Cons*) [(Cons*) bindings car] cdr] flags: fl & ~TAIL];
[code addInstruction: [Instruction opcode: PUSH]];
[code addInstruction: [Instruction opcode: LOADENV]];
[code addInstruction: [Instruction opcode: SET operand: count]];
count++;
}
[self emitSequence: [(Cons[]) expression cdr] flags: fl];
[self emitSequence: [(Cons*) expression cdr] flags: fl];
[code addInstruction: [Instruction opcode: POPENV]];
scope = [scope outer];
}
- (void) emitExpression: (SchemeObject[]) expression flags: (integer) fl
- (void) emitExpression: (SchemeObject*) expression flags: (integer) fl
{
if ([expression isKindOfClass: [Cons class]]) {
[code source: [expression source]];
[code line: [expression line]];
if ([(Cons[]) expression car] == lambdaSym) {
if ([(Cons*) expression car] == lambdaSym) {
[self emitLambda: expression];
} else if ([(Cons[]) expression car] == quoteSym) {
[self emitConstant: [(Cons[]) [(Cons[]) expression cdr] car]];
} else if ([(Cons[]) expression car] == defineSym) {
[self emitDefine: [(Cons[]) expression cdr]];
} else if ([(Cons[]) expression car] == ifSym) {
[self emitIf: [(Cons[]) expression cdr] flags: fl];
} else if ([(Cons[]) expression car] == letrecSym) {
[self emitLetrec: [(Cons[]) expression cdr] flags: fl];
} else if ([(Cons[]) expression car] == beginSym) {
[self emitSequence: [(Cons[]) expression cdr] flags: fl];
} else if ([(Cons*) expression car] == quoteSym) {
[self emitConstant: [(Cons*) [(Cons*) expression cdr] car]];
} else if ([(Cons*) expression car] == defineSym) {
[self emitDefine: [(Cons*) expression cdr]];
} else if ([(Cons*) expression car] == ifSym) {
[self emitIf: [(Cons*) expression cdr] flags: fl];
} else if ([(Cons*) expression car] == letrecSym) {
[self emitLetrec: [(Cons*) expression cdr] flags: fl];
} else if ([(Cons*) expression car] == beginSym) {
[self emitSequence: [(Cons*) expression cdr] flags: fl];
} else {
[self emitApply: expression flags: fl];
}
} else if ([expression isKindOfClass: [Symbol class]]) {
[self emitVariable: (Symbol[]) expression];
[self emitVariable: (Symbol*) expression];
} else {
[self emitConstant: expression];
}
}
- (void) emitArguments: (SchemeObject[]) expression
- (void) emitArguments: (SchemeObject*) expression
{
if (expression == [Nil nil]) {
return;
} else {
[self emitArguments: [(Cons[]) expression cdr]];
[self emitArguments: [(Cons*) expression cdr]];
if (err) return;
[self emitExpression: [(Cons[]) expression car] flags: 0];
[self emitExpression: [(Cons*) expression car] flags: 0];
if (err) return;
[code addInstruction: [Instruction opcode: PUSH]];
}
}
- (void) emitApply: (SchemeObject[]) expression flags: (integer) fl
- (void) emitApply: (SchemeObject*) expression flags: (integer) fl
{
local Instruction []label = [Instruction opcode: LABEL];
local Instruction *label = [Instruction opcode: LABEL];
if (!(fl & TAIL)) {
[code addInstruction: [Instruction opcode: MAKECONT label: label]];
}
[self emitArguments: [(Cons[]) expression cdr]];
[self emitArguments: [(Cons*) expression cdr]];
if (err) return;
[self emitExpression: [(Cons[]) expression car] flags: fl & ~TAIL];
[self emitExpression: [(Cons*) expression car] flags: fl & ~TAIL];
if (err) return;
[code addInstruction: [Instruction opcode: CALL]];
[code addInstruction: label];
}
- (void) emitLambda: (SchemeObject[]) expression
- (void) emitLambda: (SchemeObject*) expression
{
local Compiler []compiler = [Compiler newWithLambda: expression
local Compiler *compiler = [Compiler newWithLambda: expression
scope: scope];
local SchemeObject []res;
local SchemeObject *res;
local integer index;
res = [compiler compile];
if ([res isError]) {
err = (Error []) res;
err = (Error *) res;
return;
}
index = [code addConstant: res];
@ -296,7 +296,7 @@ Symbol []beginSym;
[code addInstruction: [Instruction opcode: MAKECLOSURE]];
}
- (void) emitConstant: (SchemeObject[]) expression
- (void) emitConstant: (SchemeObject*) expression
{
local integer index;
index = [code addConstant: expression];
@ -304,29 +304,29 @@ Symbol []beginSym;
[code addInstruction: [Instruction opcode: GET operand: index]];
}
- (void) checkLambdaSyntax: (SchemeObject[]) expression
- (void) checkLambdaSyntax: (SchemeObject*) expression
{
if (![expression isKindOfClass: [Cons class]] ||
[(Cons[]) expression car] != lambdaSym ||
[(Cons[]) expression cdr] == [Nil nil] ||
[(Cons[]) [(Cons[]) expression cdr] cdr] == [Nil nil]) {
[(Cons*) expression car] != lambdaSym ||
[(Cons*) expression cdr] == [Nil nil] ||
[(Cons*) [(Cons*) expression cdr] cdr] == [Nil nil]) {
err = [Error type: "syntax"
message: "malformed lambda expression"
by: expression];
}
}
- (SchemeObject[]) compile
- (SchemeObject*) compile
{
[self checkLambdaSyntax: sexpr];
if (err) {
return err;
}
[self emitBuildEnvironment: [(Cons[]) [(Cons[]) sexpr cdr] car]];
[self emitBuildEnvironment: [(Cons*) [(Cons*) sexpr cdr] car]];
if (err) {
return err;
}
[self emitSequence: [(Cons[]) [(Cons[]) sexpr cdr] cdr] flags: TAIL];
[self emitSequence: [(Cons*) [(Cons*) sexpr cdr] cdr] flags: TAIL];
if (err) {
return err;
}

20
ruamoko/scheme/Cons.h
View file

@ -4,18 +4,18 @@
@interface Cons: SchemeObject
{
SchemeObject []car, cdr;
SchemeObject *car, *cdr;
}
+ (id) newWithCar: (SchemeObject []) a cdr: (SchemeObject []) d;
- (id) initWithCar: (SchemeObject []) a cdr: (SchemeObject []) d;
- (SchemeObject []) car;
- (void) car: (SchemeObject []) a;
- (SchemeObject []) cdr;
- (void) cdr: (SchemeObject []) d;
+ (id) newWithCar: (SchemeObject *) a cdr: (SchemeObject *) d;
- (id) initWithCar: (SchemeObject *) a cdr: (SchemeObject *) d;
- (SchemeObject *) car;
- (void) car: (SchemeObject *) a;
- (SchemeObject *) cdr;
- (void) cdr: (SchemeObject *) d;
@end
@extern Cons []cons (SchemeObject []car, SchemeObject []cdr);
@extern BOOL isList (SchemeObject []ls);
@extern integer length (SchemeObject []foo);
@extern Cons *cons (SchemeObject *car, SchemeObject *cdr);
@extern BOOL isList (SchemeObject *ls);
@extern integer length (SchemeObject *foo);
#endif //__Cons_h

22
ruamoko/scheme/Cons.r
View file

@ -4,37 +4,37 @@
#include "defs.h"
#include "SchemeString.h"
Cons []cons (SchemeObject []car, SchemeObject []cdr)
Cons *cons (SchemeObject *car, SchemeObject *cdr)
{
return [Cons newWithCar: car cdr: cdr];
}
integer length (SchemeObject []foo)
integer length (SchemeObject *foo)
{
local integer len;
for (len = 0; [foo isKindOfClass: [Cons class]]; foo = [(Cons []) foo cdr]) {
for (len = 0; [foo isKindOfClass: [Cons class]]; foo = [(Cons *) foo cdr]) {
len++;
}
return len;
}
BOOL isList (SchemeObject []ls)
BOOL isList (SchemeObject *ls)
{
return ls == [Nil nil] ||
([ls isKindOfClass: [Cons class]] &&
isList([(Cons[]) ls cdr]));
isList([(Cons*) ls cdr]));
}
@implementation Cons
+ (id) newWithCar: (SchemeObject []) a cdr: (SchemeObject []) d
+ (id) newWithCar: (SchemeObject *) a cdr: (SchemeObject *) d
{
return [[self alloc] initWithCar: a cdr: d];
}
- (id) initWithCar: (SchemeObject []) a cdr: (SchemeObject []) d
- (id) initWithCar: (SchemeObject *) a cdr: (SchemeObject *) d
{
car = a;
cdr = d;
@ -48,22 +48,22 @@ BOOL isList (SchemeObject []ls)
return [super init];
}
- (SchemeObject []) car
- (SchemeObject *) car
{
return car;
}
- (void) car: (SchemeObject []) a
- (void) car: (SchemeObject *) a
{
car = a;
}
- (SchemeObject []) cdr
- (SchemeObject *) cdr
{
return cdr;
}
- (void) cdr: (SchemeObject []) d
- (void) cdr: (SchemeObject *) d
{
cdr = d;
}

6
ruamoko/scheme/Continuation.h
View file

@ -8,9 +8,9 @@
{
state_t state;
}
+ (id) newWithState: (state_t []) st pc: (integer) p;
- (id) initWithState: (state_t []) st pc: (integer) p;
- (void) restoreOnMachine: (Machine []) m;
+ (id) newWithState: (state_t *) st pc: (integer) p;
- (id) initWithState: (state_t *) st pc: (integer) p;
- (void) restoreOnMachine: (Machine *) m;
@end

10
ruamoko/scheme/Continuation.r
View file

@ -4,11 +4,11 @@
#include "defs.h"
@implementation Continuation
+ (id) newWithState: (state_t []) st pc: (integer) p
+ (id) newWithState: (state_t *) st pc: (integer) p
{
return [[self alloc] initWithState: st pc: p];
}
- (id) initWithState: (state_t []) st pc: (integer) p
- (id) initWithState: (state_t *) st pc: (integer) p
{
self = [self init];
state.program = st.program;
@ -22,15 +22,15 @@
return self;
}
- (void) restoreOnMachine: (Machine []) m
- (void) restoreOnMachine: (Machine *) m
{
[m state: &state];
return;
}
- (void) invokeOnMachine: (Machine []) m
- (void) invokeOnMachine: (Machine *) m
{
[m value: [(Cons []) [m stack] car]];
[m value: [(Cons *) [m stack] car]];
[m state: &state];
return;
}

4
ruamoko/scheme/Error.h
View file

@ -6,9 +6,9 @@
{
string type, message;
}
+ (id) type: (string) t message: (string) m by: (SchemeObject []) o;
+ (id) type: (string) t message: (string) m by: (SchemeObject *) o;
+ (id) type: (string) t message: (string) m;
- (id) initWithType: (string) t message: (string) m by: (SchemeObject []) o;
- (id) initWithType: (string) t message: (string) m by: (SchemeObject *) o;
- (string) type;
- (string) message;

4
ruamoko/scheme/Error.r
View file

@ -2,7 +2,7 @@
#include "string.h"
@implementation Error
+ (id) type: (string) t message: (string) m by: (SchemeObject []) o
+ (id) type: (string) t message: (string) m by: (SchemeObject *) o
{
return [[self alloc] initWithType: t message: m by: o];
}
@ -12,7 +12,7 @@
return [[self alloc] initWithType: t message: m by: nil];
}
- (id) initWithType: (string) t message: (string) m by: (SchemeObject []) o
- (id) initWithType: (string) t message: (string) m by: (SchemeObject *) o
{
self = [super init];
type = str_new();

14
ruamoko/scheme/Frame.h
View file

@ -4,15 +4,15 @@
@interface Frame: SchemeObject
{
SchemeObject[][] array;
SchemeObject**array;
integer size;
Frame []link;
Frame *link;
}
+ (id) newWithSize: (integer) sz link: (Frame []) l;
- (id) initWithSize: (integer) sz link: (Frame []) l;
- (void) set: (integer) index to: (SchemeObject []) o;
- (SchemeObject []) get: (integer) index;
- (Frame []) getLink;
+ (id) newWithSize: (integer) sz link: (Frame *) l;
- (id) initWithSize: (integer) sz link: (Frame *) l;
- (void) set: (integer) index to: (SchemeObject *) o;
- (SchemeObject *) get: (integer) index;
- (Frame *) getLink;
@end
#endif //__FOO_h

10
ruamoko/scheme/Frame.r
View file

@ -1,12 +1,12 @@
#include "Frame.h"
@implementation Frame
+ (id) newWithSize: (integer) sz link: (Frame []) l
+ (id) newWithSize: (integer) sz link: (Frame *) l
{
return [[self alloc] initWithSize: sz link: l];
}
- (id) initWithSize: (integer) sz link: (Frame []) l
- (id) initWithSize: (integer) sz link: (Frame *) l
{
self = [super init];
size = sz;
@ -15,17 +15,17 @@
return self;
}
- (void) set: (integer) index to: (SchemeObject []) o
- (void) set: (integer) index to: (SchemeObject *) o
{
array[index] = o;
}
- (SchemeObject []) get: (integer) index
- (SchemeObject *) get: (integer) index
{
return array[index];
}
- (Frame []) getLink
- (Frame *) getLink
{
return link;
}

8
ruamoko/scheme/Instruction.h
View file

@ -36,16 +36,16 @@ typedef struct instruction_s instruction_t;
{
opcode_e opcode;
integer operand, offset;
Instruction []label;
Instruction *label;
}
+ (id) opcode: (opcode_e) oc;
+ (id) opcode: (opcode_e) oc operand: (integer) op;
+ (id) opcode: (opcode_e) oc label: (Instruction []) l;
- (id) initWithOpcode: (opcode_e) oc operand: (integer) op label: (Instruction []) l;
+ (id) opcode: (opcode_e) oc label: (Instruction *) l;
- (id) initWithOpcode: (opcode_e) oc operand: (integer) op label: (Instruction *) l;
- (void) offset: (integer) ofs;
- (integer) offset;
- (opcode_e) opcode;
- (void) emitStruct: (instruction_t []) program;
- (void) emitStruct: (instruction_t *) program;
@end

6
ruamoko/scheme/Instruction.r
View file

@ -12,12 +12,12 @@
return [[self alloc] initWithOpcode: oc operand: op label: nil];
}
+ (id) opcode: (opcode_e) oc label: (Instruction []) l
+ (id) opcode: (opcode_e) oc label: (Instruction *) l
{
return [[self alloc] initWithOpcode: oc operand: 0 label: l];
}
- (id) initWithOpcode: (opcode_e) oc operand: (integer) op label: (Instruction []) l
- (id) initWithOpcode: (opcode_e) oc operand: (integer) op label: (Instruction *) l
{
self = [super init];
opcode = oc;
@ -41,7 +41,7 @@
return opcode;
}
- (void) emitStruct: (instruction_t []) program
- (void) emitStruct: (instruction_t *) program
{
program[offset].opcode = opcode;
if (label) {

8
ruamoko/scheme/Lambda.h
View file

@ -7,11 +7,11 @@
@interface Lambda: Procedure
{
Frame []env;
CompiledCode []code;
Frame *env;
CompiledCode *code;
}
+ (id) newWithCode: (CompiledCode []) c environment: (Frame []) e;
- (id) initWithCode: (CompiledCode []) c environment: (Frame []) e;
+ (id) newWithCode: (CompiledCode *) c environment: (Frame *) e;
- (id) initWithCode: (CompiledCode *) c environment: (Frame *) e;
@end
#endif //__Lambda_h

6
ruamoko/scheme/Lambda.r
View file

@ -8,12 +8,12 @@
#include "Machine.h"
@implementation Lambda
+ (id) newWithCode: (CompiledCode []) c environment: (Frame []) e
+ (id) newWithCode: (CompiledCode *) c environment: (Frame *) e
{
return [[self alloc] initWithCode: c environment: e];
}
- (id) initWithCode: (CompiledCode []) c environment: (Frame []) e
- (id) initWithCode: (CompiledCode *) c environment: (Frame *) e
{
self = [super init];
code = c;
@ -21,7 +21,7 @@
return self;
}
- (void) invokeOnMachine: (Machine []) m
- (void) invokeOnMachine: (Machine *) m
{
[super invokeOnMachine: m];
if (length([m stack]) < [code minimumArguments]) {

2
ruamoko/scheme/Lexer.h
View file

@ -11,7 +11,7 @@
}
+ (id) newFromSource: (string) s file: (string) f;
- (id) initWithSource: (string) s file: (string) f;
- (SchemeObject []) nextToken;
- (SchemeObject *) nextToken;
- (integer) lineNumber;
@end

10
ruamoko/scheme/Lexer.r
View file

@ -44,13 +44,13 @@ BOOL issymbol (string x)
return self;
}
- (SchemeObject[]) nextToken
- (SchemeObject*) nextToken
{
local integer len;
local Number []num;
local Symbol []sym;
local String []str;
local Boolean []bl;
local Number *num;
local Symbol *sym;
local String *str;
local Boolean *bl;
for (len = 0; isjunk(str_mid(source, len, len+1)); len++) {
if (str_mid(source, len, len+1) == ";") {

28
ruamoko/scheme/Machine.h
View file

@ -10,23 +10,23 @@
@interface Machine: SchemeObject
{
state_t state;
SchemeObject []value;
SchemeObject *value;
hashtab_t globals;
SchemeObject []all_globals;
SchemeObject *all_globals;
}
- (void) loadCode: (CompiledCode []) code;
- (SchemeObject []) run;
- (void) addGlobal: (Symbol []) sym value: (SchemeObject []) val;
- (void) environment: (Frame []) e;
- (void) continuation: (Continuation []) c;
- (Continuation []) continuation;
- (void) value: (SchemeObject []) o;
- (SchemeObject []) stack;
- (void) stack: (SchemeObject []) o;
- (state_t []) state;
- (void) state: (state_t []) st;
- (void) loadCode: (CompiledCode *) code;
- (SchemeObject *) run;
- (void) addGlobal: (Symbol *) sym value: (SchemeObject *) val;
- (void) environment: (Frame *) e;
- (void) continuation: (Continuation *) c;
- (Continuation *) continuation;
- (void) value: (SchemeObject *) o;
- (SchemeObject *) stack;
- (void) stack: (SchemeObject *) o;
- (state_t *) state;
- (void) state: (state_t *) st;
- (void) reset;
- (void) procedure: (Procedure []) pr;
- (void) procedure: (Procedure *) pr;
@end
#endif //__Machine_h

62
ruamoko/scheme/Machine.r
View file

@ -8,12 +8,12 @@
#include "Error.h"
//#include "debug.h"
string GlobalGetKey (void []ele, void []data)
string GlobalGetKey (void *ele, void *data)
{
return [[((Cons[]) ele) car] printForm];
return [[((Cons*) ele) car] printForm];
}
void GlobalFree (void []ele, void []data)
void GlobalFree (void *ele, void *data)
{
return;
}
@ -37,14 +37,14 @@ void GlobalFree (void []ele, void []data)
return self;
}
- (void) addGlobal: (Symbol[]) sym value: (SchemeObject[]) val
- (void) addGlobal: (Symbol*) sym value: (SchemeObject*) val
{
local Cons []c = cons(sym, val);
local Cons *c = cons(sym, val);
Hash_Add(globals, c);
all_globals = cons(c, all_globals);
}
- (void) loadCode: (CompiledCode[]) code
- (void) loadCode: (CompiledCode*) code
{
state.program = [code code];
state.literals = [code literals];
@ -52,47 +52,47 @@ void GlobalFree (void []ele, void []data)
state.pc = 0;
}
- (void) environment: (Frame[]) e
- (void) environment: (Frame*) e
{
state.env = e;
}
- (void) continuation: (Continuation[]) c
- (void) continuation: (Continuation*) c
{
state.cont = c;
}
- (void) value: (SchemeObject[]) v
- (void) value: (SchemeObject*) v
{
value = v;
}
- (SchemeObject[]) value
- (SchemeObject*) value
{
return value;
}
- (Continuation[]) continuation
- (Continuation*) continuation
{
return state.cont;
}
- (SchemeObject[]) stack
- (SchemeObject*) stack
{
return state.stack;
}
- (void) stack: (SchemeObject[]) o
- (void) stack: (SchemeObject*) o
{
state.stack = o;
}
- (state_t []) state
- (state_t *) state
{
return &state;
}
- (void) state: (state_t []) st
- (void) state: (state_t *) st
{
state.program = st.program;
state.pc = st.pc;
@ -104,16 +104,16 @@ void GlobalFree (void []ele, void []data)
state.lineinfo = st.lineinfo;
}
- (void) procedure: (Procedure[]) pr
- (void) procedure: (Procedure*) pr
{
state.proc = pr;
}
- (SchemeObject[]) run
- (SchemeObject*) run
{
local integer opcode;
local integer operand;
local SchemeObject []res;
local SchemeObject *res;
while (1) {
if (value && [value isError]) {
dprintf("Error: %s[%s]\n", [value description], [value printForm]);
@ -134,17 +134,17 @@ void GlobalFree (void []ele, void []data)
state.stack = cons(value, state.stack);
break;
case POP:
value = [(Cons[]) state.stack car];
value = [(Cons*) state.stack car];
if (value) {
dprintf("Pop: %s\n", [value printForm]);
} else {
dprintf("Pop: NULL!!!!\n");
}
state.stack = [(Cons[]) state.stack cdr];
state.stack = [(Cons*) state.stack cdr];
break;
case MAKECLOSURE:
dprintf("Makeclosure\n");
value = [Lambda newWithCode: (CompiledCode[]) value
value = [Lambda newWithCode: (CompiledCode*) value
environment: state.env];
break;
case MAKECONT:
@ -169,16 +169,16 @@ void GlobalFree (void []ele, void []data)
dprintf("Popenv\n");
state.env = [state.env getLink];
case GET:
value = [(Frame[]) value get: operand];
value = [(Frame*) value get: operand];
dprintf("Get: %i --> %s\n", operand, [value printForm]);
break;
case SET:
[(Frame[]) value set: operand to: [(Cons[]) state.stack car]];
dprintf("Set: %i --> %s\n", operand, [[(Cons[]) state.stack car] printForm]);
state.stack = [(Cons[]) state.stack cdr];
[(Frame*) value set: operand to: [(Cons*) state.stack car]];
dprintf("Set: %i --> %s\n", operand, [[(Cons*) state.stack car] printForm]);
state.stack = [(Cons*) state.stack cdr];
break;
case SETREST:
[(Frame[]) value set: operand to: state.stack];
[(Frame*) value set: operand to: state.stack];
dprintf("Setrest: %i --> %s\n", operand, [state.stack printForm]);
state.stack = [Nil nil];
break;
@ -188,11 +188,11 @@ void GlobalFree (void []ele, void []data)
break;
case GETLINK:
dprintf("Getlink\n");
value = [(Frame[]) value getLink];
value = [(Frame*) value getLink];
break;
case GETGLOBAL:
dprintf("Getglobal: %s\n", [value printForm]);
res = [((Cons[]) Hash_Find(globals, [value printForm])) cdr];
res = [((Cons*) Hash_Find(globals, [value printForm])) cdr];
if (!res) {
return [Error type: "binding"
message: sprintf("Undefined binding: %s",
@ -204,8 +204,8 @@ void GlobalFree (void []ele, void []data)
break;
case SETGLOBAL:
dprintf("Setglobal: %s\n", [value printForm]);
[self addGlobal: (Symbol[]) value value: [(Cons[]) state.stack car]];
state.stack = [(Cons[]) state.stack cdr];
[self addGlobal: (Symbol*) value value: [(Cons*) state.stack car]];
state.stack = [(Cons*) state.stack cdr];
break;
case CALL:
dprintf("Call\n");
@ -217,7 +217,7 @@ void GlobalFree (void []ele, void []data)
[value printForm], [state.stack printForm])
by: self];
}
[(Procedure[]) value invokeOnMachine: self];
[(Procedure*) value invokeOnMachine: self];
break;
case RETURN:
dprintf("Return: %s\n", [value printForm]);

2
ruamoko/scheme/Nil.r
View file

@ -1,7 +1,7 @@
#include "Nil.h"
#include "defs.h"
Nil []one_nil_to_rule_them_all;
Nil *one_nil_to_rule_them_all;
@implementation Nil

6
ruamoko/scheme/Parser.h
View file

@ -4,13 +4,13 @@
@interface Parser: SchemeObject
{
Lexer []lexer;
Lexer *lexer;
string file;
}
+ (id) newFromSource: (string) s file: (string) f;
- (id) initWithSource: (string) s file: (string) f;
- (SchemeObject []) readAtomic;
- (SchemeObject []) read;
- (SchemeObject *) readAtomic;
- (SchemeObject *) read;
@end
#endif //__Parser_h

16
ruamoko/scheme/Parser.r
View file

@ -19,11 +19,11 @@
return self;
}
- (SchemeObject[]) readList
- (SchemeObject*) readList
{
local SchemeObject []token, res;
local SchemeObject *token, *res;
local integer line;
local Error []err;
local Error *err;
line = [lexer lineNumber];
token = [self readAtomic];
@ -60,9 +60,9 @@
}
}
- (SchemeObject[]) readAtomic
- (SchemeObject*) readAtomic
{
local SchemeObject []token, list, res;
local SchemeObject *token, *list, *res;
local integer line;
line = [lexer lineNumber];
@ -93,10 +93,10 @@
} else return token;
}
- (SchemeObject[]) read
- (SchemeObject*) read
{
local SchemeObject []token;
local Error []err;
local SchemeObject *token;
local Error *err;
token = [self readAtomic];
if (token == [Symbol rightParen]) {

2
ruamoko/scheme/Primitive.h
View file

@ -3,7 +3,7 @@
#include "Procedure.h"
#include "Machine.h"
typedef SchemeObject [](SchemeObject []args, Machine []m) primfunc_t;
typedef SchemeObject *primfunc_t (SchemeObject *args, Machine *m);
@interface Primitive: Procedure
{

5
ruamoko/scheme/Primitive.r
View file

@ -13,14 +13,15 @@
func = f;
return self;
}
- (SchemeObject[]) invokeOnMachine: (Machine[]) m
- (SchemeObject*) invokeOnMachine: (Machine*) m
{
local SchemeObject []value = func ([m stack], m);
local SchemeObject *value = func ([m stack], m);
[super invokeOnMachine: m];
if (value) {
[m value: value];
[[m continuation] restoreOnMachine: m];
}
return value;
}
- (string) printForm

2
ruamoko/scheme/Procedure.h
View file

@ -5,7 +5,7 @@
@class Machine;
@interface Procedure: SchemeObject
- (void) invokeOnMachine: (Machine []) m;
- (void) invokeOnMachine: (Machine *) m;
@end
#endif //__Procedure_h

2
ruamoko/scheme/Procedure.r
View file

@ -2,7 +2,7 @@
#include "Machine.h"
@implementation Procedure
- (void) invokeOnMachine: (Machine []) m
- (void) invokeOnMachine: (Machine *) m
{
[m procedure: self];
return;

2
ruamoko/scheme/SchemeObject.h
View file

@ -9,7 +9,7 @@
@interface SchemeObject: Object
{
@public SchemeObject []prev, next;
@public SchemeObject *prev, *next;
BOOL marked, root;
integer line;
string source;

4
ruamoko/scheme/SchemeObject.r
View file

@ -2,7 +2,7 @@
#include "defs.h"
//#include "debug.h"
SchemeObject []maybe_garbage, not_garbage, not_garbage_end, wait_list, roots, queue_pos;
SchemeObject *maybe_garbage, *not_garbage, *not_garbage_end, *wait_list, *roots, *queue_pos;
BOOL markstate;
typedef enum {
@ -42,7 +42,7 @@ integer checkpoint;
+ (void) collect
{
local SchemeObject []cur;
local SchemeObject *cur;
local integer amount;
switch (gc_state) {

16
ruamoko/scheme/Scope.h
View file

@ -6,15 +6,15 @@
@interface Scope: SchemeObject
{
Scope []outerScope;
Array []names;
Scope *outerScope;
Array *names;
}
+ (id) newWithOuter: (Scope []) o;
- (id) initWithOuter: (Scope []) o;
- (integer) depthOf: (Symbol []) sym;
- (integer) indexOf: (Symbol []) sym;
- (void) addName: (Symbol []) sym;
- (Scope []) outer;
+ (id) newWithOuter: (Scope *) o;
- (id) initWithOuter: (Scope *) o;
- (integer) depthOf: (Symbol *) sym;
- (integer) indexOf: (Symbol *) sym;
- (void) addName: (Symbol *) sym;
- (Scope *) outer;
@end
#endif //__Scope_h

14
ruamoko/scheme/Scope.r
View file

@ -3,12 +3,12 @@
@implementation Scope
+ (id) newWithOuter: (Scope []) o
+ (id) newWithOuter: (Scope *) o
{
return [[self alloc] initWithOuter: o];
}
- (id) initWithOuter: (Scope []) o
- (id) initWithOuter: (Scope *) o
{
self = [super init];
outerScope = o;
@ -16,7 +16,7 @@
return self;
}
- (integer) indexLocal: (Symbol []) sym
- (integer) indexLocal: (Symbol *) sym
{
local integer index;
@ -28,7 +28,7 @@
return -1;
}
- (integer) indexOf: (Symbol []) sym
- (integer) indexOf: (Symbol *) sym
{
local integer index;
@ -41,7 +41,7 @@
}
}
- (integer) depthOf: (Symbol []) sym
- (integer) depthOf: (Symbol *) sym
{
local integer index;
local integer res;
@ -64,7 +64,7 @@
}
}
- (void) addName: (Symbol []) sym
- (void) addName: (Symbol *) sym
{
[names addObject: sym];
}
@ -84,7 +84,7 @@
[outerScope mark];
}
- (Scope []) outer
- (Scope *) outer
{
return outerScope;
}

12
ruamoko/scheme/Symbol.h
View file

@ -6,13 +6,13 @@
{
}
+ (void) initialize;
+ (Symbol []) leftParen;
+ (Symbol []) rightParen;
+ (Symbol []) dot;
+ (Symbol []) forString: (string) s;
+ (Symbol []) quote;
+ (Symbol *) leftParen;
+ (Symbol *) rightParen;
+ (Symbol *) dot;
+ (Symbol *) forString: (string) s;
+ (Symbol *) quote;
@end
@extern Symbol []symbol (string str);
@extern Symbol *symbol (string str);
#endif //__Symbol_h

32
ruamoko/scheme/Symbol.r
View file

@ -2,27 +2,27 @@
#include "hash.h"
#include "defs.h"
string SymbolGetKey (void [] ele, void [] data)
string SymbolGetKey (void *ele, void *data)
{
local Symbol []s = (Symbol[]) ele;
local Symbol *s = (Symbol*) ele;
return [s stringValue];
}
void SymbolFree (void [] ele, void [] data)
void SymbolFree (void *ele, void *data)
{
local Symbol []s = (Symbol[]) ele;
local Symbol *s = (Symbol*) ele;
[s release];
}
hashtab_t symbols;
Symbol []lparen;
Symbol []rparen;
Symbol []quote;
Symbol []dot;
Symbol *lparen;
Symbol *rparen;
Symbol *quote;
Symbol *dot;
Symbol []symbol (string str)
Symbol *symbol (string str)
{
return [Symbol forString: str];
}
@ -41,35 +41,35 @@ Symbol []symbol (string str)
[dot retain];
}
+ (Symbol[]) forString: (string) s
+ (Symbol*) forString: (string) s
{
local Symbol []res;
local Symbol *res;
if ((res = Hash_Find (symbols, s))) {
return res;
} else {
res = (Symbol[]) [self newFromString: s];
res = (Symbol*) [self newFromString: s];
Hash_Add (symbols, res);
return res;
}
}
+ (Symbol[]) leftParen
+ (Symbol*) leftParen
{
return lparen;
}
+ (Symbol[]) rightParen
+ (Symbol*) rightParen
{
return rparen;
}
+ (Symbol[]) quote
+ (Symbol*) quote
{
return quote;
}
+ (Symbol[]) dot
+ (Symbol*) dot
{
return dot;
}

2
ruamoko/scheme/Void.h
View file

@ -8,6 +8,6 @@
+ (id) voidConstant;
@end
@extern Void []voidConstant;
@extern Void *voidConstant;
#endif //__Void_h

2
ruamoko/scheme/Void.r
View file

@ -1,6 +1,6 @@
#include "Void.h"
Void []voidConstant;
Void *voidConstant;
@implementation Void

2
ruamoko/scheme/builtins.h
View file

@ -1,3 +1,3 @@
#include "Primitive.h"
@extern void builtin_addtomachine (Machine []m);
@extern void builtin_addtomachine (Machine *m);

140
ruamoko/scheme/builtins.r
View file

@ -10,26 +10,26 @@
#include "Boolean.h"
#include "Error.h"
BOOL num_args (SchemeObject []list, integer num)
BOOL num_args (SchemeObject *list, integer num)
{
for (; [list isKindOfClass: [Cons class]]; list = [(Cons[]) list cdr]) {
for (; [list isKindOfClass: [Cons class]]; list = [(Cons*) list cdr]) {
num--;
}
return num == 0;
}
SchemeObject []bi_display (SchemeObject []args, Machine []m)
SchemeObject *bi_display (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "display"
message: "expected 1 argument"
by: m];
}
print([[(Cons[]) args car] printForm]);
print([[(Cons*) args car] printForm]);
return [Void voidConstant];
}
SchemeObject []bi_newline (SchemeObject []args, Machine []m)
SchemeObject *bi_newline (SchemeObject *args, Machine *m)
{
if (!num_args(args, 0)) {
return [Error type: "newline"
@ -40,28 +40,28 @@ SchemeObject []bi_newline (SchemeObject []args, Machine []m)
return [Void voidConstant];
}
SchemeObject []bi_add (SchemeObject []args, Machine []m)
SchemeObject *bi_add (SchemeObject *args, Machine *m)
{
local integer sum = 0;
local SchemeObject []cur;
local SchemeObject *cur;
for (cur = args; cur != [Nil nil]; cur = [(Cons[]) cur cdr]) {
if (![[(Cons[]) cur car] isKindOfClass: [Number class]]) {
for (cur = args; cur != [Nil nil]; cur = [(Cons*) cur cdr]) {
if (![[(Cons*) cur car] isKindOfClass: [Number class]]) {
return [Error type: "+"
message: sprintf("non-number argument: %s\n",
[[(Cons[]) cur car] printForm])
[[(Cons*) cur car] printForm])
by: m];
}
sum += [(Number[]) [(Cons[]) cur car] intValue];
sum += [(Number*) [(Cons*) cur car] intValue];
}
return [Number newFromInt: sum];
}
SchemeObject []bi_sub (SchemeObject []args, Machine []m)
SchemeObject *bi_sub (SchemeObject *args, Machine *m)
{
local integer diff = 0;
local SchemeObject []cur;
local SchemeObject *cur;
if (args == [Nil nil]) {
return [Error type: "-"
@ -69,7 +69,7 @@ SchemeObject []bi_sub (SchemeObject []args, Machine []m)
by: m];
}
cur = [(Cons[]) args car];
cur = [(Cons*) args car];
if (![cur isKindOfClass: [Number class]]) {
return [Error type: "-"
@ -78,47 +78,47 @@ SchemeObject []bi_sub (SchemeObject []args, Machine []m)
by: m];
}
diff = [(Number[]) cur intValue];
diff = [(Number*) cur intValue];
if ([(Cons[]) args cdr] == [Nil nil]) {
if ([(Cons*) args cdr] == [Nil nil]) {
return [Number newFromInt: -diff];
}
for (cur = [(Cons[]) args cdr]; cur != [Nil nil]; cur = [(Cons[]) cur cdr]) {
if (![[(Cons[]) cur car] isKindOfClass: [Number class]]) {
for (cur = [(Cons*) args cdr]; cur != [Nil nil]; cur = [(Cons*) cur cdr]) {
if (![[(Cons*) cur car] isKindOfClass: [Number class]]) {
return [Error type: "-"
message: sprintf("non-number argument: %s\n",
[[(Cons[]) cur car] printForm])
[[(Cons*) cur car] printForm])
by: m];
}
diff -= [(Number[]) [(Cons[]) cur car] intValue];
diff -= [(Number*) [(Cons*) cur car] intValue];
}
return [Number newFromInt: diff];
}
SchemeObject []bi_mult (SchemeObject []args, Machine []m)
SchemeObject *bi_mult (SchemeObject *args, Machine *m)
{
local integer prod = 1;
local SchemeObject []cur;
local SchemeObject *cur;
for (cur = args; cur != [Nil nil]; cur = [(Cons[]) cur cdr]) {
if (![[(Cons[]) cur car] isKindOfClass: [Number class]]) {
for (cur = args; cur != [Nil nil]; cur = [(Cons*) cur cdr]) {
if (![[(Cons*) cur car] isKindOfClass: [Number class]]) {
return [Error type: "*"
message: sprintf("non-number argument: %s\n",
[[(Cons[]) cur car] printForm])
[[(Cons*) cur car] printForm])
by: m];
}
prod *= [(Number[]) [(Cons[]) cur car] intValue];
prod *= [(Number*) [(Cons*) cur car] intValue];
}
return [Number newFromInt: prod];
}
SchemeObject []bi_div (SchemeObject []args, Machine []m)
SchemeObject *bi_div (SchemeObject *args, Machine *m)
{
local integer frac = 0;
local SchemeObject []cur;
local SchemeObject *cur;
if (args == [Nil nil]) {
return [Error type: "/"
@ -126,7 +126,7 @@ SchemeObject []bi_div (SchemeObject []args, Machine []m)
by: m];
}
cur = [(Cons[]) args car];
cur = [(Cons*) args car];
if (![cur isKindOfClass: [Number class]]) {
return [Error type: "/"
@ -135,123 +135,123 @@ SchemeObject []bi_div (SchemeObject []args, Machine []m)
by: m];
}
frac = [(Number[]) cur intValue];
frac = [(Number*) cur intValue];
if ([(Cons[]) args cdr] == [Nil nil]) {
if ([(Cons*) args cdr] == [Nil nil]) {
return [Number newFromInt: 1/frac];
}
for (cur = [(Cons[]) args cdr]; cur != [Nil nil]; cur = [(Cons[]) cur cdr]) {
if (![[(Cons[]) cur car] isKindOfClass: [Number class]]) {
for (cur = [(Cons*) args cdr]; cur != [Nil nil]; cur = [(Cons*) cur cdr]) {
if (![[(Cons*) cur car] isKindOfClass: [Number class]]) {
return [Error type: "/"
message: sprintf("non-number argument: %s\n",
[[(Cons[]) cur car] printForm])
[[(Cons*) cur car] printForm])
by: m];
}
frac /= [(Number[]) [(Cons[]) cur car] intValue];
frac /= [(Number*) [(Cons*) cur car] intValue];
}
return [Number newFromInt: frac];
}
SchemeObject []bi_cons (SchemeObject []args, Machine []m)
SchemeObject *bi_cons (SchemeObject *args, Machine *m)
{
if (!num_args(args, 2)) {
return [Error type: "cons"
message: "expected 2 arguments"
by: m];
}
[(Cons[]) args cdr: [(Cons[]) [(Cons[]) args cdr] car]];
[(Cons*) args cdr: [(Cons*) [(Cons*) args cdr] car]];
return args;
}
SchemeObject []bi_null (SchemeObject []args, Machine []m)
SchemeObject *bi_null (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "null?"
message: "expected 1 argument"
by: m];
}
return [(Cons[]) args car] == [Nil nil]
return [(Cons*) args car] == [Nil nil]
?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject []bi_car (SchemeObject []args, Machine []m)
SchemeObject *bi_car (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "car"
message: "expected 1 argument"
by: m];
}
if (![[(Cons[]) args car] isKindOfClass: [Cons class]]) {
if (![[(Cons*) args car] isKindOfClass: [Cons class]]) {
return [Error type: "car"
message: sprintf("expected pair, got: %s",
[[(Cons[]) args car] printForm])
[[(Cons*) args car] printForm])
by: m];
}
return [(Cons[]) [(Cons[]) args car] car];
return [(Cons*) [(Cons*) args car] car];
}
SchemeObject []bi_cdr (SchemeObject []args, Machine []m)
SchemeObject *bi_cdr (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "cdr"
message: "expected 1 argument"
by: m];
}
if (![[(Cons[]) args car] isKindOfClass: [Cons class]]) {
if (![[(Cons*) args car] isKindOfClass: [Cons class]]) {
return [Error type: "cdr"
message: sprintf("expected pair, got: %s",
[[(Cons[]) args car] printForm])
[[(Cons*) args car] printForm])
by: m];
}
return [(Cons[]) [(Cons[]) args car] cdr];
return [(Cons*) [(Cons*) args car] cdr];
}
SchemeObject []bi_apply (SchemeObject []args, Machine []m)
SchemeObject *bi_apply (SchemeObject *args, Machine *m)
{
local SchemeObject []cur, prev;
local SchemeObject *cur, *prev;
if (args == [Nil nil]) {
return [Error type: "apply"
message: "expected at least 1 argument"
by: m];
} else if (![[(Cons[]) args car] isKindOfClass: [Procedure class]]) {
} else if (![[(Cons*) args car] isKindOfClass: [Procedure class]]) {
return [Error type: "apply"
message:
sprintf("expected procedure as 1st argument, got: %s",
[[(Cons[]) args car] printForm])
[[(Cons*) args car] printForm])
by: m];
}
prev = nil;
for (cur = args; [(Cons[]) cur cdr] != [Nil nil]; cur = [(Cons[]) cur cdr]) {
for (cur = args; [(Cons*) cur cdr] != [Nil nil]; cur = [(Cons*) cur cdr]) {
prev = cur;
}
if (prev) {
[(Cons[]) prev cdr: [(Cons[]) cur car]];
[(Cons*) prev cdr: [(Cons*) cur car]];
}
[m stack: [(Cons[]) args cdr]];
[(Procedure[]) [(Cons[]) args car] invokeOnMachine: m];
[m stack: [(Cons*) args cdr]];
[(Procedure*) [(Cons*) args car] invokeOnMachine: m];
return nil;
}
SchemeObject []bi_callcc (SchemeObject []args, Machine []m)
SchemeObject *bi_callcc (SchemeObject *args, Machine *m)
{
if (args == [Nil nil]) {
return [Error type: "call-with-current-continuation"
message: "expected at least 1 argument"
by: m];
} else if (![[(Cons[]) args car] isKindOfClass: [Procedure class]]) {
} else if (![[(Cons*) args car] isKindOfClass: [Procedure class]]) {
return [Error type: "call-with-current-continuation"
message:
sprintf("expected procedure as 1st argument, got: %s",
[[(Cons[]) args car] printForm])
[[(Cons*) args car] printForm])
by: m];
}
if ([m continuation]) {
@ -260,11 +260,11 @@ SchemeObject []bi_callcc (SchemeObject []args, Machine []m)
[m stack: cons([BaseContinuation baseContinuation],
[Nil nil])];
}
[(Procedure[]) [(Cons[]) args car] invokeOnMachine: m];
[(Procedure*) [(Cons*) args car] invokeOnMachine: m];
return nil;
}
SchemeObject []bi_eq (SchemeObject []args, Machine []m)
SchemeObject *bi_eq (SchemeObject *args, Machine *m)
{
if (!num_args(args, 2)) {
return [Error type: "eq?"
@ -272,21 +272,21 @@ SchemeObject []bi_eq (SchemeObject []args, Machine []m)
by: m];
}
return
[(Cons[]) args car] == [(Cons[]) [(Cons[]) args cdr] car] ?
[(Cons*) args car] == [(Cons*) [(Cons*) args cdr] car] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject []bi_numeq (SchemeObject []args, Machine []m)
SchemeObject *bi_numeq (SchemeObject *args, Machine *m)
{
local SchemeObject []num1, num2;
local SchemeObject *num1, *num2;
if (!num_args(args, 2)) {
return [Error type: "="
message: "expected 2 arguments"
by: m];
}
num1 = [(Cons[]) args car];
num2 = [(Cons[]) [(Cons[]) args cdr] car];
num1 = [(Cons*) args car];
num2 = [(Cons*) [(Cons*) args cdr] car];
if (![num1 isKindOfClass: [Number class]]) {
return [Error type: "="
message: sprintf("expected number argument, got: %s",
@ -300,12 +300,12 @@ SchemeObject []bi_numeq (SchemeObject []args, Machine []m)
}
return
[(Number[]) num1 intValue] == [(Number[]) num2 intValue] ?
[(Number*) num1 intValue] == [(Number*) num2 intValue] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
SchemeObject []bi_islist (SchemeObject []args, Machine []m)
SchemeObject *bi_islist (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "list?"
@ -319,7 +319,7 @@ SchemeObject []bi_islist (SchemeObject []args, Machine []m)
[Boolean falseConstant];
}
SchemeObject []bi_ispair (SchemeObject []args, Machine []m)
SchemeObject *bi_ispair (SchemeObject *args, Machine *m)
{
if (!num_args(args, 1)) {
return [Error type: "pair?"
@ -328,14 +328,14 @@ SchemeObject []bi_ispair (SchemeObject []args, Machine []m)
}
return
[[(Cons[]) args car] isKindOfClass: [Cons class]] ?
[[(Cons*) args car] isKindOfClass: [Cons class]] ?
[Boolean trueConstant] :
[Boolean falseConstant];
}
#define builtin(name, func) [m addGlobal: symbol(#name) value: [Primitive newFromFunc: (func)]]
void builtin_addtomachine (Machine []m)
void builtin_addtomachine (Machine *m)
{
builtin(display, bi_display);
builtin(newline, bi_newline);

2
ruamoko/scheme/defs.h
View file

@ -3,7 +3,7 @@
@extern string (integer err) strerror = #0;
@extern integer (...) open = #0; // string path, float flags[, float mode]
@extern integer (integer handle) close = #0;
@extern string (integer handle, integer count, integer []result) read = #0;
@extern string read (integer handle, integer count, integer *result) = #0;
@extern integer (integer handle, string buffer, integer count) write = #0;
@extern integer (integer handle, integer pos, integer whence) seek = #0;

12
ruamoko/scheme/state.h
View file

@ -8,13 +8,13 @@
@class Continuation;
struct state_s {
instruction_t [] program;
lineinfo_t [] lineinfo;
instruction_t *program;
lineinfo_t *lineinfo;
integer pc;
Frame []literals, env;
SchemeObject []stack;
Continuation []cont;
Procedure []proc;
Frame *literals, *env;
SchemeObject *stack;
Continuation *cont;
Procedure *proc;
};
typedef struct state_s state_t;