Permalink
Browse files

Add solutions to 5.5.6

  • Loading branch information...
1 parent ef61d3c commit 10ff7da764eba1529b6d4ea5e5c18aa3b65039be @fastred committed Jan 19, 2013
Showing with 757 additions and 0 deletions.
  1. +19 −0 5_39.scm
  2. +234 −0 5_40.scm
  3. +20 −0 5_41.scm
  4. +50 −0 5_42.scm
  5. +59 −0 5_43.scm
  6. +61 −0 5_44.scm
  7. +314 −0 ch5-eceval-compiler-lexical.scm
View
@@ -0,0 +1,19 @@
+(define frame-num car)
+(define displacement-num cdr)
+
+(define (lexical-address-lookup addr env)
+ (let* ((frame (list-ref env (frame-num addr)))
+ (value (list-ref (frame-values frame) (displacement-num addr))))
+ (if (eq? value '*unassigned*)
+ (error "Variable is unassigned -- lexical-address-lookup" addr)
+ value)))
+
+(define (lexical-address-set! addr env new-value)
+ (let* ((frame (list-ref env (frame-num addr))))
+ (define (set-value! frame-values displacement-num)
+ (if (= displacement-num 0)
+ (set-car! frame-values new-value)
+ (set-value! (cdr frame-values) (- displacement-num 1))))
+ (set-value! (frame-values frame) (displacement-num addr))
+ 'ok))
+
View
234 5_40.scm
@@ -0,0 +1,234 @@
+(load "5_33.scm")
+(load "5_39.scm")
+(load "5_41.scm") ; In my opinion exercises 5.40 & 5.41 are in the wrong order,
+; that's why I'm loading it in here
+(load "load-eceval-compiler.scm")
+(load "ch5-eceval-compiler-lexical")
+
+(define (compile exp target linkage comp-time-env)
+ (cond ((self-evaluating? exp)
+ (compile-self-evaluating exp target linkage comp-time-env))
+ ((quoted? exp) (compile-quoted exp target linkage comp-time-env))
+ ((variable? exp)
+ (compile-variable exp target linkage comp-time-env))
+ ((assignment? exp)
+ (compile-assignment exp target linkage comp-time-env))
+ ((definition? exp)
+ (compile-definition exp target linkage comp-time-env))
+ ((if? exp) (compile-if exp target linkage comp-time-env))
+ ((lambda? exp) (compile-lambda exp target linkage comp-time-env))
+ ((begin? exp)
+ (compile-sequence (begin-actions exp)
+ target
+ linkage comp-time-env))
+ ((cond? exp) (compile (cond->if exp) target linkage comp-time-env))
+ ((application? exp)
+ (compile-application exp target linkage comp-time-env))
+ (else
+ (error "Unknown expression type -- COMPILE" exp))))
+
+(define (make-instruction-sequence needs modifies statements)
+ (list needs modifies statements))
+
+(define (empty-instruction-sequence)
+ (make-instruction-sequence '() '() '()))
+
+(define (compile-self-evaluating exp target linkage comp-time-env)
+ (end-with-linkage linkage
+ (make-instruction-sequence '() (list target)
+ `((assign ,target (const ,exp))))))
+
+(define (compile-quoted exp target linkage comp-time-env)
+ (end-with-linkage linkage
+ (make-instruction-sequence '() (list target)
+ `((assign ,target (const ,(text-of-quotation exp)))))))
+
+(define (compile-variable exp target linkage comp-time-env)
+ (end-with-linkage linkage
+ (make-instruction-sequence '(env) (list target)
+ `((assign ,target
+ (op lookup-variable-value)
+ (const ,exp)
+ (reg env))))))
+
+(define (compile-assignment exp target linkage comp-time-env)
+ (let ((var (assignment-variable exp))
+ (get-value-code
+ (compile (assignment-value exp) 'val 'next comp-time-env)))
+ (end-with-linkage linkage
+ (preserving '(env)
+ get-value-code
+ (make-instruction-sequence '(env val) (list target)
+ `((perform (op set-variable-value!)
+ (const ,var)
+ (reg val)
+ (reg env))
+ (assign ,target (const ok))))))))
+
+(define (compile-definition exp target linkage comp-time-env)
+ (let ((var (definition-variable exp))
+ (get-value-code
+ (compile (definition-value exp) 'val 'next comp-time-env)))
+ (end-with-linkage linkage
+ (preserving '(env)
+ get-value-code
+ (make-instruction-sequence '(env val) (list target)
+ `((perform (op define-variable!)
+ (const ,var)
+ (reg val)
+ (reg env))
+ (assign ,target (const ok))))))))
+
+(define (compile-if exp target linkage comp-time-env)
+ (let ((t-branch (make-label 'true-branch))
+ (f-branch (make-label 'false-branch))
+ (after-if (make-label 'after-if)))
+ (let ((consequent-linkage
+ (if (eq? linkage 'next) after-if linkage)))
+ (let ((p-code (compile (if-predicate exp) 'val 'next comp-time-env))
+ (c-code
+ (compile
+ (if-consequent exp) target consequent-linkage comp-time-env))
+ (a-code
+ (compile (if-alternative exp) target linkage comp-time-env)))
+ (preserving '(env continue)
+ p-code
+ (append-instruction-sequences
+ (make-instruction-sequence '(val) '()
+ `((test (op false?) (reg val))
+ (branch (label ,f-branch))))
+ (parallel-instruction-sequences
+ (append-instruction-sequences t-branch c-code)
+ (append-instruction-sequences f-branch a-code))
+ after-if))))))
+
+(define (compile-sequence seq target linkage comp-time-env)
+ (if (last-exp? seq)
+ (compile (first-exp seq) target linkage comp-time-env)
+ (preserving '(env continue)
+ (compile (first-exp seq) target 'next comp-time-env)
+ (compile-sequence (rest-exps seq) target linkage comp-time-env))))
+
+(define (compile-lambda exp target linkage comp-time-env)
+ (let ((proc-entry (make-label 'entry))
+ (after-lambda (make-label 'after-lambda)))
+ (let ((lambda-linkage
+ (if (eq? linkage 'next) after-lambda linkage)))
+ (append-instruction-sequences
+ (tack-on-instruction-sequence
+ (end-with-linkage lambda-linkage
+ (make-instruction-sequence '(env) (list target)
+ `((assign ,target
+ (op make-compiled-procedure)
+ (label ,proc-entry)
+ (reg env)))))
+ (compile-lambda-body exp proc-entry comp-time-env))
+ after-lambda))))
+
+(define (compile-lambda-body exp proc-entry comp-time-env)
+ (let ((formals (lambda-parameters exp)))
+ (let ((new-comp-time-env (extend-comp-time-env formals comp-time-env)))
+ (append-instruction-sequences
+ (make-instruction-sequence '(env proc argl) '(env)
+ `(,proc-entry
+ (assign env (op compiled-procedure-env) (reg proc))
+ (assign env
+ (op extend-environment)
+ (const ,formals)
+ (reg argl)
+ (reg env))))
+ (compile-sequence (lambda-body exp) 'val 'return new-comp-time-env)))))
+
+(define (compile-application exp target linkage comp-time-env)
+ (let ((proc-code (compile (operator exp) 'proc 'next comp-time-env))
+ (operand-codes
+ (map (lambda (operand) (compile operand 'val 'next comp-time-env))
+ (operands exp))))
+ (preserving '(env continue)
+ proc-code
+ (preserving '(proc continue)
+ (construct-arglist operand-codes)
+ (compile-procedure-call target linkage comp-time-env)))))
+
+(define (compile-procedure-call target linkage comp-time-env)
+ (let ((primitive-branch (make-label 'primitive-branch))
+ (compiled-branch (make-label 'compiled-branch))
+ (after-call (make-label 'after-call)))
+ (let ((compiled-linkage
+ (if (eq? linkage 'next) after-call linkage)))
+ (append-instruction-sequences
+ (make-instruction-sequence '(proc) '()
+ `((test (op primitive-procedure?) (reg proc))
+ (branch (label ,primitive-branch))))
+ (parallel-instruction-sequences
+ (append-instruction-sequences
+ compiled-branch
+ (compile-proc-appl target compiled-linkage comp-time-env))
+ (append-instruction-sequences
+ primitive-branch
+ (end-with-linkage linkage
+ (make-instruction-sequence '(proc argl)
+ (list target)
+ `((assign ,target
+ (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl)))))))
+ after-call))))
+
+(define (compile-proc-appl target linkage comp-time-env)
+ (cond ((and (eq? target 'val) (not (eq? linkage 'return)))
+ (make-instruction-sequence '(proc) all-regs
+ `((assign continue (label ,linkage))
+ (assign val (op compiled-procedure-entry)
+ (reg proc))
+ (goto (reg val)))))
+ ((and (not (eq? target 'val))
+ (not (eq? linkage 'return)))
+ (let ((proc-return (make-label 'proc-return)))
+ (make-instruction-sequence '(proc) all-regs
+ `((assign continue (label ,proc-return))
+ (assign val (op compiled-procedure-entry)
+ (reg proc))
+ (goto (reg val))
+ ,proc-return
+ (assign ,target (reg val))
+ (goto (label ,linkage))))))
+ ((and (eq? target 'val) (eq? linkage 'return))
+ (make-instruction-sequence '(proc continue) all-regs
+ '((assign val (op compiled-procedure-entry)
+ (reg proc))
+ (goto (reg val)))))
+ ((and (not (eq? target 'val)) (eq? linkage 'return))
+ (error "return linkage, target not val -- COMPILE"
+ target))))
+
+(define (extend-comp-time-env formals comp-time-env)
+ (cons formals comp-time-env))
+
+(define empty-comp-time-env '())
+
+(define (compile-and-go expression)
+ (let ((instructions
+ (assemble (statements
+ (compile expression 'val 'return empty-comp-time-env))
+ eceval)))
+ (set! the-global-environment (setup-environment))
+ (set-register-contents! eceval 'val instructions)
+ (set-register-contents! eceval 'flag true)
+ (start eceval)))
+
+;(define code
+ ;'(define (factorial n)
+ ;(if (= n 1)
+ ;1
+ ;(* (factorial (- n 1)) n))))
+;(compile-and-go code)
+
+;(compile-and-go '((lambda (x y)
+ ;(lambda (a b c d e)
+ ;((lambda (y z) (* x y z))
+ ;(* a b x)
+ ;(+ c d x))))
+ ;3
+ ;4))
+
View
@@ -0,0 +1,20 @@
+; returns element position in the list
+; if element is not found returns -1
+(define (find-element-pos list el)
+ (define (find-acc list pos)
+ (if (null? list)
+ -1
+ (if (eq? (car list) el)
+ pos
+ (find-acc (cdr list) (+ pos 1)))))
+ (find-acc list 0))
+
+(define (find-variable var-name env)
+ (define (find-rec env frame-num)
+ (if (null? env)
+ 'not-found
+ (let ((disp-num (find-element-pos (car env) var-name)))
+ (if (= disp-num -1)
+ (find-rec (cdr env) (+ frame-num 1))
+ (cons frame-num disp-num)))))
+ (find-rec env 0))
View
@@ -0,0 +1,50 @@
+(load "5_40.scm")
+(define (compile-variable exp target linkage comp-time-env)
+ (end-with-linkage linkage
+ (make-instruction-sequence '(env) (list target)
+ (let ((addr (find-variable exp comp-time-env)))
+ (if (eq? addr 'not-found)
+ `((assign ,target
+ (op lookup-variable-value)
+ (const ,exp)
+ (reg env)))
+ `((assign ,target
+ (op lexical-address-lookup)
+ (const ,addr)
+ (reg env))))))))
+
+
+(define (compile-assignment exp target linkage comp-time-env)
+ (let ((var (assignment-variable exp))
+ (get-value-code
+ (compile (assignment-value exp) 'val 'next comp-time-env)))
+ (end-with-linkage linkage
+ (preserving '(env)
+ get-value-code
+ (make-instruction-sequence '(env val) (list target)
+ (let ((addr (find-variable var comp-time-env)))
+ (if (eq? addr 'not-found)
+ `((perform (op set-variable-value!)
+ (const ,var)
+ (reg val)
+ (reg env))
+ (assign ,target (const ok)))
+ `((perform (op lexical-address-set!)
+ (const ,addr)
+ (reg env)
+ (reg val))
+ (assign ,target (const ok)))
+ )))))))
+
+;(define code '(((lambda (x y)
+ ;(lambda (a b c d e)
+ ;((lambda (y z) (* x y z))
+ ;(* a b x)
+ ;(+ c d x))))
+ ;3 4) 5 6 7 8 9))
+;(show-formatted (compile code
+ ;'val
+ ;'next
+ ;empty-comp-time-env))
+;(compile-and-go code)
+
View
@@ -0,0 +1,59 @@
+(load "5_42.scm")
+
+(define (make-let-unassigned definition)
+ (list (definition-variable definition) ''*unassigned*))
+
+(define (make-let-set! definition)
+ (list 'set! (definition-variable definition) (definition-value definition)))
+
+(define (scan-out-defines body)
+ (let ((definitions (filter definition? body))
+ (rest-of-body (filter (lambda (a) (not (definition? a))) body)))
+ (if (null? definitions)
+ body
+ (list (cons 'let (cons (map make-let-unassigned definitions)
+ (append (map make-let-set! definitions)
+ rest-of-body)))))))
+
+(define (let-bindings exp)
+ (cadr exp))
+(define (let-body exp)
+ (cddr exp))
+(define (let->combination exp)
+ (expand-let (let-bindings exp) (let-body exp)))
+(define (let-vars bindings)
+ (map car bindings))
+(define (let-values bindings)
+ (map cadr bindings))
+(define (expand-let bindings body)
+ (append (list (make-lambda (let-vars bindings) body))
+ (let-values bindings)))
+
+(define (compile-lambda-body exp proc-entry comp-time-env)
+ (define scanned-out (car (scan-out-defines (lambda-body exp))))
+ (define body
+ (if (tagged-list? scanned-out 'let) ; transform only when lambda body contains definitions
+ (let->combination scanned-out)
+ (lambda-body exp)))
+ (let ((formals (lambda-parameters exp)))
+ (let ((new-comp-time-env (extend-comp-time-env formals comp-time-env)))
+ (append-instruction-sequences
+ (make-instruction-sequence '(env proc argl) '(env)
+ `(,proc-entry
+ (assign env (op compiled-procedure-env) (reg proc))
+ (assign env
+ (op extend-environment)
+ (const ,formals)
+ (reg argl)
+ (reg env))))
+ (if (tagged-list? scanned-out 'let)
+ (compile body 'val 'return new-comp-time-env)
+ (compile-sequence body 'val 'return new-comp-time-env))))))
+
+;(define code '(define (test x) (define y 1) (define z 2) (+ x y z)))
+;(show-formatted (compile code
+ ;'val
+ ;'next
+ ;empty-comp-time-env))
+;(compile-and-go code)
+
Oops, something went wrong.

0 comments on commit 10ff7da

Please sign in to comment.