#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 integer 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: (integer) 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 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) emitDefine: (SchemeObject[]) expression { local integer 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: (integer) fl { local Instruction []falseLabel, endLabel; local integer 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: (integer) fl { local SchemeObject []bindings; local integer 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: (integer) 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: (integer) 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 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]] || [(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