quakeforge/ruamoko/scheme/Compiler.r
Brian Koropoff 256630c84d Added proper error checking and reporting with line numbers. Next:
Runtime errors and support for line number reporting with the error.
2005-05-02 04:58:22 +00:00

185 lines
5.2 KiB
R

#include "Compiler.h"
#include "Instruction.h"
#include "Nil.h"
#include "Cons.h"
#include "defs.h"
@implementation Compiler
+ (id) newWithLambda: (SchemeObject) xp scope: (Scope) sc
{
return [[self alloc] initWithLambda: xp scope: sc];
}
- (id) initWithLambda: (SchemeObject) xp scope: (Scope) sc
{
self = [super init];
sexpr = xp;
scope = sc;
lambdaSym = [Symbol forString: "lambda"];
quoteSym = [Symbol forString: "quote"];
code = [CompiledCode new];
err = NIL;
return self;
}
// FIXME: handle variable argument lists
- (void) emitBuildEnvironment: (SchemeObject) arguments
{
local integer count, index;
local SchemeObject cur;
scope = [Scope newWithOuter: scope];
count = 0;
for (cur = arguments; cur != [Nil nil]; cur = [cur cdr]) {
count++;
}
[code addInstruction: [Instruction opcode: MAKEENV operand: count]];
[code addInstruction: [Instruction opcode: LOADENV]];
cur = arguments;
for (index = 0; index < count; cur = [cur cdr]) {
[scope addName: (Symbol) [cur car]];
[code addInstruction: [Instruction opcode: SET operand: index]];
index++;
}
}
- (void) emitSequence: (SchemeObject) expressions
{
local SchemeObject cur;
for (cur = expressions; cur != [Nil nil]; cur = [cur cdr]) {
[self emitExpression: [cur car]];
if (err) return;
}
}
- (void) emitVariable: (Symbol) sym
{
local integer depth = [scope depthOf: sym];
local integer index = [scope indexOf: sym];
[code addInstruction: [Instruction opcode: LOADENV]];
if (depth != -1) {
for (; depth; depth--) {
[code addInstruction: [Instruction opcode: GETLINK]];
}
[code addInstruction: [Instruction opcode: GET operand: index]];
} else {
index = [code addConstant: sym];
[code addInstruction: [Instruction opcode: LOADLITS]];
[code addInstruction: [Instruction opcode: GET operand: index]];
[code addInstruction: [Instruction opcode: GETGLOBAL]];
}
}
- (void) emitExpression: (SchemeObject) expression
{
if ([expression isKindOfClass: [Cons class]]) {
if ([expression car] == lambdaSym) {
[self emitLambda: expression];
if (err) return;
} else if ([expression car] == quoteSym) {
[self emitConstant: [[expression cdr] car]];
} else {
[self emitApply: expression];
if (err) return;
}
} else if ([expression isKindOfClass: [Symbol class]]) {
[self emitVariable: (Symbol) expression];
} else {
[self emitConstant: expression];
}
}
- (void) emitArguments: (SchemeObject) expression
{
if (expression == [Nil nil]) {
return;
} else {
[self emitArguments: [expression cdr]];
if (err) return;
[self emitExpression: [expression car]];
if (err) return;
[code addInstruction: [Instruction opcode: PUSH]];
}
}
- (void) emitApply: (SchemeObject) expression
{
local Instruction label = [Instruction opcode: LABEL];
[code addInstruction: [Instruction opcode: MAKECONT label: label]];
[self emitArguments: [expression cdr]];
if (err) return;
[self emitExpression: [expression car]];
if (err) return;
[code addInstruction: [Instruction opcode: CALL]];
[code addInstruction: label];
}
- (void) emitLambda: (SchemeObject) expression
{
local Compiler compiler = [Compiler newWithLambda: expression
scope: scope];
local SchemeObject res;
local integer index;
res = [compiler compile];
if ([res isError]) {
err = (Error) res;
return;
}
index = [code addConstant: res];
[code addInstruction: [Instruction opcode: LOADLITS]];
[code addInstruction: [Instruction opcode: GET operand: index]];
[code addInstruction: [Instruction opcode: MAKECLOSURE]];
}
- (void) emitConstant: (SchemeObject) expression
{
local integer index;
index = [code addConstant: expression];
[code addInstruction: [Instruction opcode: LOADLITS]];
[code addInstruction: [Instruction opcode: GET operand: index]];
}
- (void) checkLambdaSyntax: (SchemeObject) expression
{
if (![expression isKindOfClass: [Cons class]] ||
[expression car] != lambdaSym ||
[expression cdr] == [Nil nil] ||
[[expression cdr] cdr] == [Nil nil]) {
err = [Error type: "syntax"
message: "malformed lambda expression"
by: expression];
}
}
- (SchemeObject) compile
{
[self checkLambdaSyntax: sexpr];
if (err) {
return err;
}
[self emitBuildEnvironment: [[sexpr cdr] car]];
if (err) {
return err;
}
[self emitSequence: [[sexpr cdr] cdr]];
if (err) {
return err;
}
[code addInstruction: [Instruction opcode: RETURN]];
[code compile];
return code;
}
- (void) markReachable
{
[code mark];
[sexpr mark];
[lambdaSym mark];
[quoteSym mark];
[Scope mark];
}
@end