From d81460ccaecb8f2ae3dc52c140db684b694c7b6f Mon Sep 17 00:00:00 2001 From: Felix Martin Date: Mon, 5 Apr 2021 11:09:03 -0400 Subject: [PATCH] Implement 5.24 --- ex-5_23-xx.scm | 11 +++- misc/sicp-eceval-support.scm | 1 + misc/sicp-eceval.scm | 123 ++++++++++++++++++++++------------- 3 files changed, 88 insertions(+), 47 deletions(-) diff --git a/ex-5_23-xx.scm b/ex-5_23-xx.scm index e3d12b0..7aa8b3a 100644 --- a/ex-5_23-xx.scm +++ b/ex-5_23-xx.scm @@ -27,7 +27,16 @@ (assert (get-register-contents eceval 'val) 9) -(display "\nex-5.24 \n") +(display "\nex-5.24 - cond-special-form\n") + +(set-register-contents! eceval 'exp + '(cond + ((= 2 1) 0) + ((= 2 3) 1) + ((= 0 4) 2) + (else (* 2 5)))) +(start eceval) +(assert (get-register-contents eceval 'val) 10) (display "\nex-5.25\n") diff --git a/misc/sicp-eceval-support.scm b/misc/sicp-eceval-support.scm index be92775..d2616fb 100644 --- a/misc/sicp-eceval-support.scm +++ b/misc/sicp-eceval-support.scm @@ -98,6 +98,7 @@ ;;; cond-support (define (cond? exp) (tagged-list? exp 'cond)) (define (cond-clauses exp) (cdr exp)) +(define (cond-first-clause exp) (car exp)) (define (cond-else-clause? clause) (eq? (cond-predicate clause) 'else)) (define (cond-predicate clause) (car clause)) diff --git a/misc/sicp-eceval.scm b/misc/sicp-eceval.scm index 68aac9c..0a62595 100644 --- a/misc/sicp-eceval.scm +++ b/misc/sicp-eceval.scm @@ -26,64 +26,72 @@ (define eceval-operations (list ;;primitive Scheme operations + (list 'display display) + (list 'newline newline) (list 'read read) ;;operations in syntax.scm - (list 'self-evaluating? self-evaluating?) + (list 'application? application?) + (list 'assignment-value assignment-value) + (list 'assignment-variable assignment-variable) + (list 'assignment? assignment?) + (list 'begin-actions begin-actions) + (list 'begin? begin?) + (list 'definition-value definition-value) + (list 'definition-variable definition-variable) + (list 'definition? definition?) + (list 'first-exp first-exp) + (list 'first-operand first-operand) + (list 'if-alternative if-alternative) + (list 'if-consequent if-consequent) + (list 'if-predicate if-predicate) + (list 'if? if?) + (list 'lambda-body lambda-body) + (list 'lambda-parameters lambda-parameters) + (list 'lambda? lambda?) + (list 'last-exp? last-exp?) + (list 'no-operands? no-operands?) + (list 'operands operands) + (list 'operator operator) (list 'quoted? quoted?) + (list 'rest-exps rest-exps) + (list 'rest-operands rest-operands) + (list 'self-evaluating? self-evaluating?) (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 'make-procedure make-procedure) + (list 'adjoin-arg adjoin-arg) + (list 'announce-output announce-output) + (list 'apply-primitive-procedure apply-primitive-procedure) (list 'compound-procedure? compound-procedure?) - (list 'procedure-parameters procedure-parameters) + (list 'define-variable! define-variable!) + (list 'empty-arglist empty-arglist) + (list 'extend-environment extend-environment) + (list 'get-global-environment get-global-environment)) + (list 'last-operand? last-operand?) + (list 'lookup-variable-value lookup-variable-value) + (list 'make-procedure make-procedure) + (list 'no-more-exps? no-more-exps?) ;for non-tail-recursive machine + (list 'primitive-procedure? primitive-procedure?) (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!) - ;;5.23 - (list 'cond? cond?) - (list 'cond->if cond->if) - (list 'let? let?) - (list 'let->combination let->combination) - (list 'define-variable! define-variable!) - (list 'primitive-procedure? primitive-procedure?) - (list 'apply-primitive-procedure apply-primitive-procedure) + (list 'procedure-parameters procedure-parameters) (list 'prompt-for-input prompt-for-input) - (list 'announce-output announce-output) + (list 'set-variable-value! set-variable-value!) + (list 'true? true?) (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)) + + ;;5.23 + (list 'cond->if cond->if) + (list 'cond-actions cond-actions) + (list 'cond-clauses cond-clauses) + (list 'cond-else-clause? cond-else-clause?) + (list 'cond-first-clause cond-first-clause) + (list 'cond-predicate cond-predicate) + (list 'cond? cond?) + (list 'let->combination let->combination) + (list 'let? let?) ) (define eceval @@ -238,10 +246,33 @@ ev-sequence-last-exp (goto (label eval-dispatch)) ;;; ex-5.23 -ev-cond +ev-cond-transform (assign exp (op cond->if) (reg exp)) (goto (label eval-dispatch)) +;;; ex-5.24 +ev-cond + (save continue) + (assign unev (op cond-clauses) (reg exp)) ; unev contains all clauses +ev-cond-loop + (assign exp (op cond-first-clause) (reg unev)) ; exp contains first clause + (test (op cond-else-clause?) (reg exp)) ; test for else-clause + (branch (label ev-cond-done)) + (assign continue (label ev-cond-decide)) + (save unev) + (assign exp (op cond-predicate) (reg exp)) ; exp contains first predicate + (goto (label eval-dispatch)) ; eval predicate +ev-cond-decide + (restore unev) + (test (op true?) (reg val)) ; test if predicate is true + (branch (label ev-cond-done)) + (assign unev (op cond-clauses) (reg unev)) ; unev contains remainging clauses + (goto (label ev-cond-loop)) +ev-cond-done + (restore continue) + (assign exp (op cond-first-clause) (reg unev)) ; exp contains true clause + (goto (label ev-begin)) + ev-let (assign exp (op let->combination) (reg exp)) (goto (label eval-dispatch))