diff --git a/ex-5_31-xx.scm b/ex-5_31-xx.scm new file mode 100644 index 0000000..af0e8bb --- /dev/null +++ b/ex-5_31-xx.scm @@ -0,0 +1,34 @@ +(load "util.scm") + +(display "\nex-5.31\n") + +; 1. save and restore env around operator +; 2. save and restore env around each operand (except last) +; 3. save and restore argl around each operand +; 4. save and restore proc around operand sequence + +; (f 'x 'y) +; 1-4 are superfluous + +; ((f) 'x 'y) +; 1-4 are superfluous +; no need to save env because compound-apply without args does +; not change env + +; (f (g 'x) y) +; 1 is superfluous +; we need 2 because (g 'x) changes the env for y +; we need 3 because (g 'x) changes argl +; we need 4 because (g 'x) changes proc + +; (f (g 'x) 'y) ; 1 is superfluous +; 1-2 are superfluous +; (g 'x) changes the env but we don't need it later (better save it anyway) +; 3-4 are still needed + +(display "[answered]\n") + +(display "\nex-5.32\n") + +(display "\nex-5.33\n") + diff --git a/misc/ch5-compiler.scm b/misc/ch5-compiler.scm new file mode 100644 index 0000000..c295770 --- /dev/null +++ b/misc/ch5-compiler.scm @@ -0,0 +1,380 @@ +;;;;COMPILER FROM SECTION 5.5 OF +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS + +;;;;Matches code in ch5.scm + +;;;;This file can be loaded into Scheme as a whole. +;;;;**NOTE**This file loads the metacircular evaluator's syntax procedures +;;;; from section 4.1.2 +;;;; You may need to change the (load ...) expression to work in your +;;;; version of Scheme. + +;;;;Then you can compile Scheme programs as shown in section 5.5.5 + +;;**implementation-dependent loading of syntax procedures +(load "ch5-syntax.scm") ;section 4.1.2 syntax procedures + + +;;;SECTION 5.5.1 + +(define (compile exp target linkage) + (cond ((self-evaluating? exp) + (compile-self-evaluating exp target linkage)) + ((quoted? exp) (compile-quoted exp target linkage)) + ((variable? exp) + (compile-variable exp target linkage)) + ((assignment? exp) + (compile-assignment exp target linkage)) + ((definition? exp) + (compile-definition exp target linkage)) + ((if? exp) (compile-if exp target linkage)) + ((lambda? exp) (compile-lambda exp target linkage)) + ((begin? exp) + (compile-sequence (begin-actions exp) + target + linkage)) + ((cond? exp) (compile (cond->if exp) target linkage)) + ((application? exp) + (compile-application exp target linkage)) + (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 '() '() '())) + + +;;;SECTION 5.5.2 + +;;;linkage code + +(define (compile-linkage linkage) + (cond ((eq? linkage 'return) + (make-instruction-sequence '(continue) '() + '((goto (reg continue))))) + ((eq? linkage 'next) + (empty-instruction-sequence)) + (else + (make-instruction-sequence '() '() + `((goto (label ,linkage))))))) + +(define (end-with-linkage linkage instruction-sequence) + (preserving '(continue) + instruction-sequence + (compile-linkage linkage))) + + +;;;simple expressions + +(define (compile-self-evaluating exp target linkage) + (end-with-linkage linkage + (make-instruction-sequence '() (list target) + `((assign ,target (const ,exp)))))) + +(define (compile-quoted exp target linkage) + (end-with-linkage linkage + (make-instruction-sequence '() (list target) + `((assign ,target (const ,(text-of-quotation exp))))))) + +(define (compile-variable exp target linkage) + (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) + (let ((var (assignment-variable exp)) + (get-value-code + (compile (assignment-value exp) 'val 'next))) + (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) + (let ((var (definition-variable exp)) + (get-value-code + (compile (definition-value exp) 'val 'next))) + (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)))))))) + + +;;;conditional expressions + +;;;labels (from footnote) +(define label-counter 0) + +(define (new-label-number) + (set! label-counter (+ 1 label-counter)) + label-counter) + +(define (make-label name) + (string->symbol + (string-append (symbol->string name) + (number->string (new-label-number))))) +;; end of footnote + +(define (compile-if exp target linkage) + (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)) + (c-code + (compile + (if-consequent exp) target consequent-linkage)) + (a-code + (compile (if-alternative exp) target linkage))) + (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)))))) + +;;; sequences + +(define (compile-sequence seq target linkage) + (if (last-exp? seq) + (compile (first-exp seq) target linkage) + (preserving '(env continue) + (compile (first-exp seq) target 'next) + (compile-sequence (rest-exps seq) target linkage)))) + +;;;lambda expressions + +(define (compile-lambda exp target linkage) + (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)) + after-lambda)))) + +(define (compile-lambda-body exp proc-entry) + (let ((formals (lambda-parameters exp))) + (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)))) + + +;;;SECTION 5.5.3 + +;;;combinations + +(define (compile-application exp target linkage) + (let ((proc-code (compile (operator exp) 'proc 'next)) + (operand-codes + (map (lambda (operand) (compile operand 'val 'next)) + (operands exp)))) + (preserving '(env continue) + proc-code + (preserving '(proc continue) + (construct-arglist operand-codes) + (compile-procedure-call target linkage))))) + +(define (construct-arglist operand-codes) + (let ((operand-codes (reverse operand-codes))) + (if (null? operand-codes) + (make-instruction-sequence '() '(argl) + '((assign argl (const ())))) + (let ((code-to-get-last-arg + (append-instruction-sequences + (car operand-codes) + (make-instruction-sequence '(val) '(argl) + '((assign argl (op list) (reg val))))))) + (if (null? (cdr operand-codes)) + code-to-get-last-arg + (preserving '(env) + code-to-get-last-arg + (code-to-get-rest-args + (cdr operand-codes)))))))) + +(define (code-to-get-rest-args operand-codes) + (let ((code-for-next-arg + (preserving '(argl) + (car operand-codes) + (make-instruction-sequence '(val argl) '(argl) + '((assign argl + (op cons) (reg val) (reg argl))))))) + (if (null? (cdr operand-codes)) + code-for-next-arg + (preserving '(env) + code-for-next-arg + (code-to-get-rest-args (cdr operand-codes)))))) + +;;;applying procedures + +(define (compile-procedure-call target linkage) + (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)) + (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)))) + +;;;applying compiled procedures + +(define (compile-proc-appl target linkage) + (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)))) + +;; footnote +(define all-regs '(env proc val argl continue)) + + +;;;SECTION 5.5.4 + +(define (registers-needed s) + (if (symbol? s) '() (car s))) + +(define (registers-modified s) + (if (symbol? s) '() (cadr s))) + +(define (statements s) + (if (symbol? s) (list s) (caddr s))) + +(define (needs-register? seq reg) + (memq reg (registers-needed seq))) + +(define (modifies-register? seq reg) + (memq reg (registers-modified seq))) + + +(define (append-instruction-sequences . seqs) + (define (append-2-sequences seq1 seq2) + (make-instruction-sequence + (list-union (registers-needed seq1) + (list-difference (registers-needed seq2) + (registers-modified seq1))) + (list-union (registers-modified seq1) + (registers-modified seq2)) + (append (statements seq1) (statements seq2)))) + (define (append-seq-list seqs) + (if (null? seqs) + (empty-instruction-sequence) + (append-2-sequences (car seqs) + (append-seq-list (cdr seqs))))) + (append-seq-list seqs)) + +(define (list-union s1 s2) + (cond ((null? s1) s2) + ((memq (car s1) s2) (list-union (cdr s1) s2)) + (else (cons (car s1) (list-union (cdr s1) s2))))) + +(define (list-difference s1 s2) + (cond ((null? s1) '()) + ((memq (car s1) s2) (list-difference (cdr s1) s2)) + (else (cons (car s1) + (list-difference (cdr s1) s2))))) + +(define (preserving regs seq1 seq2) + (if (null? regs) + (append-instruction-sequences seq1 seq2) + (let ((first-reg (car regs))) + (if (and (needs-register? seq2 first-reg) + (modifies-register? seq1 first-reg)) + (preserving (cdr regs) + (make-instruction-sequence + (list-union (list first-reg) + (registers-needed seq1)) + (list-difference (registers-modified seq1) + (list first-reg)) + (append `((save ,first-reg)) + (statements seq1) + `((restore ,first-reg)))) + seq2) + (preserving (cdr regs) seq1 seq2))))) + +(define (tack-on-instruction-sequence seq body-seq) + (make-instruction-sequence + (registers-needed seq) + (registers-modified seq) + (append (statements seq) (statements body-seq)))) + +(define (parallel-instruction-sequences seq1 seq2) + (make-instruction-sequence + (list-union (registers-needed seq1) + (registers-needed seq2)) + (list-union (registers-modified seq1) + (registers-modified seq2)) + (append (statements seq1) (statements seq2)))) + +'(COMPILER LOADED) diff --git a/misc/ch5-eceval-compiler.scm b/misc/ch5-eceval-compiler.scm new file mode 100644 index 0000000..d97eb2b --- /dev/null +++ b/misc/ch5-eceval-compiler.scm @@ -0,0 +1,370 @@ +;;;;EXPLICIT-CONTROL EVALUATOR FROM SECTION 5.4 OF +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS +;;;; MODIFIED TO SUPPORT COMPILED CODE (AS IN SECTION 5.5.7) + +;;;;Changes to basic evaluator machine are +;;;; (1) some new eceval controller code for the driver and apply-dispatch; +;;;; (2) some additional machine operations from; +;;;; (3) support for compiled code to call interpreted code (exercise 5.47) -- +;;;; (new register and 1 new instruction at start) +;;;; (4) new startup aid start-eceval + +;; Explicit-control evaluator. +;; To use it, load "load-eceval-compiler.scm", which loads this file and the +;; support it needs (including the register-machine simulator) + +;; To start, can use compile-and-go as in section 5.5.7 +;; or start-eceval as in the section 5.5.7 footnote. + +;; To resume the machine without reinitializing the global environment +;; if you have somehow interrupted out of the machine back to Scheme, do + +;: (set-register-contents! eceval 'flag false) +;: (start eceval) + +;;;;;;;; + +;; any old value to create the variable so that +;; compile-and-go and/or start-eceval can set! it. +(define the-global-environment '()) + +;;; Interfacing compiled code with eceval machine +;;; From section 5.5.7 +(define (start-eceval) + (set! the-global-environment (setup-environment)) + (set-register-contents! eceval 'flag false) + (start eceval)) + +;; Modification of section 4.1.4 procedure +;; **replaces version in syntax file +(define (user-print object) + (cond ((compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + '))) + ((compiled-procedure? object) + (display ')) + (else (display object)))) + +(define (compile-and-go expression) + (let ((instructions + (assemble (statements + (compile expression 'val 'return)) + eceval))) + (set! the-global-environment (setup-environment)) + (set-register-contents! eceval 'val instructions) + (set-register-contents! eceval 'flag true) + (start eceval))) + +;;**NB. To [not] monitor stack operations, comment in/[out] the line after +;; print-result in the machine controller below +;;**Also choose the desired make-stack version in regsim.scm + +(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) + )) + +(define eceval + (make-machine + '(exp env val proc argl continue unev + 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)) + ))) + +'(EXPLICIT CONTROL EVALUATOR FOR COMPILER LOADED) \ No newline at end of file diff --git a/misc/ch5-syntax.scm b/misc/ch5-syntax.scm new file mode 100644 index 0000000..30618ab --- /dev/null +++ b/misc/ch5-syntax.scm @@ -0,0 +1,120 @@ +;;;;SCHEME SYNTAX FROM SECTION 4.1.2 OF STRUCTURE AND INTERPRETATION OF +;;; COMPUTER PROGRAMS, TO SUPPORT CHAPTER 5 +;;;;Loaded by compiler.scm (for use by compiler), and by eceval-support.scm +;;;; (for simulation of eceval machine operations) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + + +(define (variable? exp) (symbol? exp)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (assignment-value exp) (caddr exp)) + + +(define (definition? exp) + (tagged-list? exp 'define)) + +(define (definition-variable exp) + (if (symbol? (cadr exp)) + (cadr exp) + (caadr exp))) + +(define (definition-value exp) + (if (symbol? (cadr exp)) + (caddr exp) + (make-lambda (cdadr exp) + (cddr exp)))) + +(define (lambda? exp) (tagged-list? exp 'lambda)) + +(define (lambda-parameters exp) (cadr exp)) +(define (lambda-body exp) (cddr exp)) + +(define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + +(define (if? exp) (tagged-list? exp 'if)) + +(define (if-predicate exp) (cadr exp)) + +(define (if-consequent exp) (caddr exp)) + +(define (if-alternative exp) + (if (not (null? (cdddr exp))) + (cadddr exp) + 'false)) + + +(define (begin? exp) (tagged-list? exp 'begin)) +(define (begin-actions exp) (cdr exp)) + +(define (last-exp? seq) (null? (cdr seq))) +(define (first-exp seq) (car seq)) +(define (rest-exps seq) (cdr seq)) + +(define (application? exp) (pair? exp)) +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) + +(define (no-operands? ops) (null? ops)) +(define (first-operand ops) (car ops)) +(define (rest-operands ops) (cdr ops)) + +;;;**following needed only to implement COND as derived expression, +;;; not needed by eceval machine in text. But used by compiler + +;; from 4.1.2 +(define (make-if predicate consequent alternative) + (list 'if predicate consequent alternative)) + + +(define (sequence->exp seq) + (cond ((null? seq) seq) + ((last-exp? seq) (first-exp seq)) + (else (make-begin seq)))) + +(define (make-begin seq) (cons 'begin seq)) + +(define (cond? exp) (tagged-list? exp 'cond)) +(define (cond-clauses exp) (cdr exp)) +(define (cond-else-clause? clause) + (eq? (cond-predicate clause) 'else)) +(define (cond-predicate clause) (car clause)) +(define (cond-actions clause) (cdr clause)) + +(define (cond->if exp) + (expand-clauses (cond-clauses exp))) + +(define (expand-clauses clauses) + (if (null? clauses) + 'false ; no else clause + (let ((first (car clauses)) + (rest (cdr clauses))) + (if (cond-else-clause? first) + (if (null? rest) + (sequence->exp (cond-actions first)) + (error "ELSE clause isn't last -- COND->IF" + clauses)) + (make-if (cond-predicate first) + (sequence->exp (cond-actions first)) + (expand-clauses rest)))))) +;; end of Cond support