quakeforge/ruamoko/scheme/Compiler.r

#include "Compiler.h"
#include "Instruction.h"
#include "Nil.h"
#include "Void.h"
#include "Boolean.h"
#include "Cons.h"
#include "defs.h"

Symbol *lambdaSym;
Symbol *quoteSym;
Symbol *defineSym;
Symbol *ifSym;
Symbol *letrecSym;
Symbol *beginSym;

@implementation Compiler
+ (void) initialize
{
    lambdaSym = [Symbol forString: "lambda"];
    [lambdaSym retain];
    quoteSym = [Symbol forString: "quote"];
    [quoteSym retain];
    defineSym = [Symbol forString: "define"];
    [defineSym retain];
    ifSym = [Symbol forString: "if"];
    [ifSym retain];
    letrecSym = symbol("letrec");
    [letrecSym retain];
    beginSym = symbol("begin");
    [beginSym retain];
}

+ (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;
    code = [CompiledCode new];
    err = nil;
    return self;
}

- (void) emitBuildEnvironment: (SchemeObject *) arguments
{
    local int count, index;
    local SchemeObject *cur;

    scope = [Scope newWithOuter: scope];
    count = 0;
    for (cur = arguments; [cur isKindOfClass: [Cons class]]; cur = [(Cons*) cur cdr]) {
            count++;
    }
    [code minimumArguments: count];
    if (cur != [Nil nil]) {
            count++;
    }
    [code addInstruction: [Instruction opcode: MAKEENV operand: count]];
    [code addInstruction: [Instruction opcode: LOADENV]];
    cur = arguments;
    for (index = 0; index < count; cur = [(Cons*) cur cdr]) {
            if ([cur isKindOfClass: [Cons class]]) {
                    [scope addName: (Symbol*) [(Cons*) cur car]];
                    [code addInstruction: [Instruction opcode: SET operand: index]];
            } else if ([cur isKindOfClass: [Symbol class]]) {
                    [scope addName: (Symbol*) cur];
                    [code addInstruction:
                              [Instruction opcode: SETREST operand: index]];
                    break;
            } else {
                    err = [Error type: "syntax"
                                 message: "Invalid entry in argument list"
                                 by: arguments];
                    return;
            }
            index++;
    }       
}

- (void) emitSequence: (SchemeObject*) expressions flags: (int) fl
{
    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];
            } else {
                    [self emitExpression: [(Cons*) cur car] flags: fl & ~TAIL];
            }
            if (err) return;
    }
}

- (void) emitVariable: (Symbol*) sym
{
    local int depth = [scope depthOf: sym];
    local int 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) emitDefine: (SchemeObject*) expression
{
    local int index = 0;
    
    if (![expression 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]];
            [self emitLambda: cons(lambdaSym,
                                   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];
            if (err) return;
    } else {
            err = [Error type: "syntax"
                         message: "Malformed define statement"
                         by: expression];
            return;
    }
    [code addInstruction: [Instruction opcode: PUSH]];
    [code addInstruction: [Instruction opcode: LOADLITS]];
    [code addInstruction: [Instruction opcode: GET operand: index]];
    [code addInstruction: [Instruction opcode: SETGLOBAL]];
}

- (void) emitIf: (SchemeObject*) expression flags: (int) fl
{
    local Instruction *falseLabel, *endLabel;
    local int index;
    if (![expression isKindOfClass: [Cons class]] ||
        ![[(Cons*) expression cdr] isKindOfClass: [Cons class]]) {
            err = [Error type: "syntax"
                         message: "Malformed if expression"
                         by: expression];
    }

    falseLabel = [Instruction opcode: LABEL];
    endLabel = [Instruction opcode: LABEL];

    [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];
    if (err) return;
    [code addInstruction: [Instruction opcode: GOTO label: endLabel]];
    [code addInstruction: falseLabel];
    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];
            if (err) return;
    }
    [code addInstruction: endLabel];
}
                
            

    

- (void) emitLetrec: (SchemeObject*) expression flags: (int) fl
{
    local SchemeObject *bindings;
    local int count;

    if (!isList(expression) ||
        !isList([(Cons*) expression car]) ||
        ![[(Cons*) expression cdr] isKindOfClass: [Cons class]]) {
            err = [Error type: "syntax"
                         message: "Malformed letrec expression"
                         by: expression];
    }
    
    scope = [Scope newWithOuter: scope];
    
    count = 0;
    
    for (bindings = [(Cons*) expression car]; bindings != [Nil nil]; bindings = [(Cons*) bindings cdr]) {
            [scope addName: (Symbol*) [(Cons*) [(Cons*) bindings car] car]];
            count++;
    }

    [code addInstruction: [Instruction opcode: MAKEENV operand: count]];

    count = 0;
    
    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];
    [code addInstruction: [Instruction opcode: POPENV]];
    scope = [scope outer];
}

- (void) emitExpression: (SchemeObject*) expression flags: (int) fl
{
    if ([expression isKindOfClass: [Cons class]]) {
            [code source: [expression source]];
            [code line: [expression line]];
            
            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 {
                    [self emitApply: expression flags: fl];
            }
    } 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: [(Cons*) expression cdr]];
            if (err) return;
            [self emitExpression: [(Cons*) expression car] flags: 0];
            if (err) return;
            [code addInstruction: [Instruction opcode: PUSH]];
    }
}

- (void) emitApply: (SchemeObject*) expression flags: (int) fl
{
    local Instruction *label = [Instruction opcode: LABEL];
    if (!(fl & TAIL)) {
            [code addInstruction: [Instruction opcode: MAKECONT label: label]];
    }
    [self emitArguments: [(Cons*) expression cdr]];
    if (err) return;
    [self emitExpression: [(Cons*) expression car] flags: fl & ~TAIL];
    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 int 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 int 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]] ||
        [(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
{
    [self checkLambdaSyntax: sexpr];
    if (err) {
            return err;
    }
    [self emitBuildEnvironment: [(Cons*) [(Cons*) sexpr cdr] car]];
    if (err) {
            return err;
    }
    [self emitSequence: [(Cons*) [(Cons*) sexpr cdr] cdr] flags: TAIL];
    if (err) {
            return err;
    }
    [code addInstruction: [Instruction opcode: RETURN]];
    [code compile];
    return code;
}

- (void) markReachable
{
    [code mark];
    [sexpr mark];
    [scope mark];
}

@end