Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add solutions to 5.5.6

  • Loading branch information...
commit 10ff7da764eba1529b6d4ea5e5c18aa3b65039be 1 parent ef61d3c
@fastred authored
View
19 5_39.scm
@@ -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
20 5_41.scm
@@ -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
50 5_42.scm
@@ -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
59 5_43.scm
@@ -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)
+
View
61 5_44.scm
@@ -0,0 +1,61 @@
+(load "5_43.scm")
+
+; We work with compiler that uses compile time environment, so I've decided
+; to reimplement these procedures from ex. 5.38.
+(define (spread-arguments operands comp-time-env)
+ (let ((op1 (compile (car operands) 'arg1 'next comp-time-env))
+ (op2 (compile (cadr operands) 'arg2 'next comp-time-env)))
+ (list
+ op1
+ op2)))
+
+(define (compile-sel-primitive exp target linkage comp-time-env)
+ (let ((operands-code (spread-arguments (operands exp) comp-time-env))
+ (operator (operator exp))
+ (after-call (make-label 'after-call)))
+ (end-with-linkage linkage
+ (preserving '(continue env)
+ (car operands-code)
+ (preserving '(arg1)
+ (cadr operands-code)
+ (make-instruction-sequence '(arg1 arg2) (list target)
+ `((assign ,target (op ,operator) (reg arg1) (reg arg2)))))))))
+
+(define (primitive-overwritten? operator comp-time-env)
+ (not (eq? (find-variable operator comp-time-env) 'not-found)))
+
+(define (selected-primitive? exp comp-time-env)
+ (let ((operator (car exp)))
+ (and (pair? exp) (memq operator '(+ - * /))
+ (not (primitive-overwritten? operator comp-time-env)))))
+
+(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))
+ ((selected-primitive? exp comp-time-env)
+ (compile-sel-primitive exp target linkage comp-time-env))
+ ((application? exp)
+ (compile-application exp target linkage comp-time-env))
+ (else
+ (error "Unknown expression type -- COMPILE" exp))))
+
+;(define code '((lambda (+ a b) (+ a b)) * 3 3))
+;(show-formatted (compile code
+ ;'val
+ ;'next
+ ;empty-comp-time-env))
+;(compile-and-go code)
View
314 ch5-eceval-compiler-lexical.scm
@@ -0,0 +1,314 @@
+(define eceval-operations
+ (list
+ ;;primitive Scheme operations
+ (list 'read read) ;used by eceval
+
+ ;;used by compiled code
+ (list 'list list)
+ (list 'cons cons)
+
+ ;;operations in syntax.scm
+ (list 'self-evaluating? self-evaluating?)
+ (list 'quoted? quoted?)
+ (list 'text-of-quotation text-of-quotation)
+ (list 'variable? variable?)
+ (list 'assignment? assignment?)
+ (list 'assignment-variable assignment-variable)
+ (list 'assignment-value assignment-value)
+ (list 'definition? definition?)
+ (list 'definition-variable definition-variable)
+ (list 'definition-value definition-value)
+ (list 'lambda? lambda?)
+ (list 'lambda-parameters lambda-parameters)
+ (list 'lambda-body lambda-body)
+ (list 'if? if?)
+ (list 'if-predicate if-predicate)
+ (list 'if-consequent if-consequent)
+ (list 'if-alternative if-alternative)
+ (list 'begin? begin?)
+ (list 'begin-actions begin-actions)
+ (list 'last-exp? last-exp?)
+ (list 'first-exp first-exp)
+ (list 'rest-exps rest-exps)
+ (list 'application? application?)
+ (list 'operator operator)
+ (list 'operands operands)
+ (list 'no-operands? no-operands?)
+ (list 'first-operand first-operand)
+ (list 'rest-operands rest-operands)
+
+ ;;operations in eceval-support.scm
+ (list 'true? true?)
+ (list 'false? false?) ;for compiled code
+ (list 'make-procedure make-procedure)
+ (list 'compound-procedure? compound-procedure?)
+ (list 'procedure-parameters procedure-parameters)
+ (list 'procedure-body procedure-body)
+ (list 'procedure-environment procedure-environment)
+ (list 'extend-environment extend-environment)
+ (list 'lookup-variable-value lookup-variable-value)
+ (list 'set-variable-value! set-variable-value!)
+ (list 'define-variable! define-variable!)
+ (list 'primitive-procedure? primitive-procedure?)
+ (list 'apply-primitive-procedure apply-primitive-procedure)
+ (list 'prompt-for-input prompt-for-input)
+ (list 'announce-output announce-output)
+ (list 'user-print user-print)
+ (list 'empty-arglist empty-arglist)
+ (list 'adjoin-arg adjoin-arg)
+ (list 'last-operand? last-operand?)
+ (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine
+ (list 'get-global-environment get-global-environment)
+
+ ;;for compiled code (also in eceval-support.scm)
+ (list 'make-compiled-procedure make-compiled-procedure)
+ (list 'compiled-procedure? compiled-procedure?)
+ (list 'compiled-procedure-entry compiled-procedure-entry)
+ (list 'compiled-procedure-env compiled-procedure-env)
+
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'lexical-address-lookup lexical-address-lookup)
+ (list 'lexical-address-set! lexical-address-set!)
+
+ ))
+
+(define eceval
+ (make-machine
+ '(exp env val proc argl continue unev arg1 arg2
+ compapp ;*for compiled to call interpreted
+ )
+ eceval-operations
+ '(
+;;SECTION 5.4.4, as modified in 5.5.7
+;;*for compiled to call interpreted (from exercise 5.47)
+ (assign compapp (label compound-apply))
+;;*next instruction supports entry from compiler (from section 5.5.7)
+ (branch (label external-entry))
+read-eval-print-loop
+ (perform (op initialize-stack))
+ (perform
+ (op prompt-for-input) (const ";;; EC-Eval input:"))
+ (assign exp (op read))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (label eval-dispatch))
+print-result
+;;**following instruction optional -- if use it, need monitored stack
+ (perform (op print-stack-statistics))
+ (perform
+ (op announce-output) (const ";;; EC-Eval value:"))
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+;;*support for entry from compiler (from section 5.5.7)
+external-entry
+ (perform (op initialize-stack))
+ (assign env (op get-global-environment))
+ (assign continue (label print-result))
+ (goto (reg val))
+
+unknown-expression-type
+ (assign val (const unknown-expression-type-error))
+ (goto (label signal-error))
+
+unknown-procedure-type
+ (restore continue)
+ (assign val (const unknown-procedure-type-error))
+ (goto (label signal-error))
+
+signal-error
+ (perform (op user-print) (reg val))
+ (goto (label read-eval-print-loop))
+
+;;SECTION 5.4.1
+eval-dispatch
+ (test (op self-evaluating?) (reg exp))
+ (branch (label ev-self-eval))
+ (test (op variable?) (reg exp))
+ (branch (label ev-variable))
+ (test (op quoted?) (reg exp))
+ (branch (label ev-quoted))
+ (test (op assignment?) (reg exp))
+ (branch (label ev-assignment))
+ (test (op definition?) (reg exp))
+ (branch (label ev-definition))
+ (test (op if?) (reg exp))
+ (branch (label ev-if))
+ (test (op lambda?) (reg exp))
+ (branch (label ev-lambda))
+ (test (op begin?) (reg exp))
+ (branch (label ev-begin))
+ (test (op application?) (reg exp))
+ (branch (label ev-application))
+ (goto (label unknown-expression-type))
+
+ev-self-eval
+ (assign val (reg exp))
+ (goto (reg continue))
+ev-variable
+ (assign val (op lookup-variable-value) (reg exp) (reg env))
+ (goto (reg continue))
+ev-quoted
+ (assign val (op text-of-quotation) (reg exp))
+ (goto (reg continue))
+ev-lambda
+ (assign unev (op lambda-parameters) (reg exp))
+ (assign exp (op lambda-body) (reg exp))
+ (assign val (op make-procedure)
+ (reg unev) (reg exp) (reg env))
+ (goto (reg continue))
+
+ev-application
+ (save continue)
+ (save env)
+ (assign unev (op operands) (reg exp))
+ (save unev)
+ (assign exp (op operator) (reg exp))
+ (assign continue (label ev-appl-did-operator))
+ (goto (label eval-dispatch))
+ev-appl-did-operator
+ (restore unev)
+ (restore env)
+ (assign argl (op empty-arglist))
+ (assign proc (reg val))
+ (test (op no-operands?) (reg unev))
+ (branch (label apply-dispatch))
+ (save proc)
+ev-appl-operand-loop
+ (save argl)
+ (assign exp (op first-operand) (reg unev))
+ (test (op last-operand?) (reg unev))
+ (branch (label ev-appl-last-arg))
+ (save env)
+ (save unev)
+ (assign continue (label ev-appl-accumulate-arg))
+ (goto (label eval-dispatch))
+ev-appl-accumulate-arg
+ (restore unev)
+ (restore env)
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (assign unev (op rest-operands) (reg unev))
+ (goto (label ev-appl-operand-loop))
+ev-appl-last-arg
+ (assign continue (label ev-appl-accum-last-arg))
+ (goto (label eval-dispatch))
+ev-appl-accum-last-arg
+ (restore argl)
+ (assign argl (op adjoin-arg) (reg val) (reg argl))
+ (restore proc)
+ (goto (label apply-dispatch))
+apply-dispatch
+ (test (op primitive-procedure?) (reg proc))
+ (branch (label primitive-apply))
+ (test (op compound-procedure?) (reg proc))
+ (branch (label compound-apply))
+;;*next added to call compiled code from evaluator (section 5.5.7)
+ (test (op compiled-procedure?) (reg proc))
+ (branch (label compiled-apply))
+ (goto (label unknown-procedure-type))
+
+;;*next added to call compiled code from evaluator (section 5.5.7)
+compiled-apply
+ (restore continue)
+ (assign val (op compiled-procedure-entry) (reg proc))
+ (goto (reg val))
+
+primitive-apply
+ (assign val (op apply-primitive-procedure)
+ (reg proc)
+ (reg argl))
+ (restore continue)
+ (goto (reg continue))
+
+compound-apply
+ (assign unev (op procedure-parameters) (reg proc))
+ (assign env (op procedure-environment) (reg proc))
+ (assign env (op extend-environment)
+ (reg unev) (reg argl) (reg env))
+ (assign unev (op procedure-body) (reg proc))
+ (goto (label ev-sequence))
+
+;;;SECTION 5.4.2
+ev-begin
+ (assign unev (op begin-actions) (reg exp))
+ (save continue)
+ (goto (label ev-sequence))
+
+ev-sequence
+ (assign exp (op first-exp) (reg unev))
+ (test (op last-exp?) (reg unev))
+ (branch (label ev-sequence-last-exp))
+ (save unev)
+ (save env)
+ (assign continue (label ev-sequence-continue))
+ (goto (label eval-dispatch))
+ev-sequence-continue
+ (restore env)
+ (restore unev)
+ (assign unev (op rest-exps) (reg unev))
+ (goto (label ev-sequence))
+ev-sequence-last-exp
+ (restore continue)
+ (goto (label eval-dispatch))
+
+;;;SECTION 5.4.3
+
+ev-if
+ (save exp)
+ (save env)
+ (save continue)
+ (assign continue (label ev-if-decide))
+ (assign exp (op if-predicate) (reg exp))
+ (goto (label eval-dispatch))
+ev-if-decide
+ (restore continue)
+ (restore env)
+ (restore exp)
+ (test (op true?) (reg val))
+ (branch (label ev-if-consequent))
+ev-if-alternative
+ (assign exp (op if-alternative) (reg exp))
+ (goto (label eval-dispatch))
+ev-if-consequent
+ (assign exp (op if-consequent) (reg exp))
+ (goto (label eval-dispatch))
+
+ev-assignment
+ (assign unev (op assignment-variable) (reg exp))
+ (save unev)
+ (assign exp (op assignment-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-assignment-1))
+ (goto (label eval-dispatch))
+ev-assignment-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op set-variable-value!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+
+ev-definition
+ (assign unev (op definition-variable) (reg exp))
+ (save unev)
+ (assign exp (op definition-value) (reg exp))
+ (save env)
+ (save continue)
+ (assign continue (label ev-definition-1))
+ (goto (label eval-dispatch))
+ev-definition-1
+ (restore continue)
+ (restore env)
+ (restore unev)
+ (perform
+ (op define-variable!) (reg unev) (reg val) (reg env))
+ (assign val (const ok))
+ (goto (reg continue))
+ )))
+
Please sign in to comment.
Something went wrong with that request. Please try again.