計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著)ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著)Julie Sussman (原著)
Gerald Jay Sussman (原著)和田 英一 (翻訳)
開発環境
- OS X Yosemite - Apple (OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- Gauche (処理系)
計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の5(レジスタ計算機での計算)、5.4(積極制御評価器)、5.4.4(評価の実行)、評価器の性能監視、問題 5.30-b.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
- Scheme手習い
問題 5.30-b.
コード(BBEdit, Emacs)
eceval30_b.scm
#!/usr/bin/env gosh ;; -*- coding: utf-8 -*- (load "./simulator.scm") (load "./operations30_b.scm") (define (initialize-stack) (eceval 'initialize-stack)) (define eceval-operations (list (list 'self-evaluating? self-evaluating?) (list 'initialize-stack initialize-stack) (list 'prompt-for-input prompt-for-input) (list 'read read) (list 'get-global-environment get-global-environment) (list 'announce-output announce-output) (list 'user-print user-print) (list 'variable? variable?) (list 'quoted? quoted?) (list 'assignment? assignment?) (list 'assignment-value assignment-value) (list 'definition? definition?) (list 'if? if?) (list 'lambda? lambda?) (list 'begin? begin?) (list 'cond? cond?) (list 'let? let?) (list 'application? application?) (list 'lookup-variable-value lookup-variable-value) (list 'text-of-quotation text-of-quotation) (list 'lambda-parameters lambda-parameters) (list 'lambda-body lambda-body) (list 'make-procedure make-procedure) (list 'operands operands) (list 'operator operator) (list 'empty-arglist empty-arglist) (list 'no-operands? no-operands?) (list 'first-operand first-operand) (list 'last-operand? last-operand?) (list 'adjoin-arg adjoin-arg) (list 'rest-operands rest-operands) (list 'primitive-procedure? primitive-procedure?) (list 'compound-procedure? compound-procedure?) (list 'apply-primitive-procedure apply-primitive-procedure) (list 'procedure-parameters procedure-parameters) (list 'procedure-environment procedure-environment) (list 'extend-environment extend-environment) (list 'procedure-body procedure-body) (list 'begin-actions begin-actions) (list 'first-exp first-exp) (list 'last-exp? last-exp?) (list 'rest-exps rest-exps) (list 'if-predicate if-predicate) (list 'true? true?) (list 'if-alternative if-alternative) (list 'if-consequent if-consequent) (list 'assignment-variable assignment-variable) (list 'set-variable-value! set-variable-value!) (list 'definition-variable definition-variable) (list 'definition-value definition-value) (list 'define-variable! define-variable!) (list 'cond->if cond->if) (list 'let->combination let->combination) (list 'unbound-variable? unbound-variable?) (list 'check-arguments check-arguments) )) (define eceval (make-machine eceval-operations '(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 (perform (op print-stack-statisstics)) ; 性能監視 (perform (op announce-output) (const ";;; EC-Eval value:")) (perform (op user-print) (reg val)) (goto (label read-eval-print-loop)) 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)) arguments-error (assign val (const arguments-error)) (goto (label signal-error)) unbound-variable (restore continue) (assign val (const unbound-variable)) (goto (label signal-error)) signal-error (perform (op user-print) (reg val)) (goto (label read-eval-print-loop)) 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 cond?) (reg exp)) (branch (label ev-cond)) (test (op let?) (reg exp)) (branch (label ev-let)) (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)) (test (op unbound-variable?) (reg val)) (branch (label unbound-variable)) (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)) (goto (label unknown-procedure-type)) primitive-apply (test (op check-arguments) (reg proc) (reg argl)) (branch (label arguments-error)) (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)) 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)) 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)) ev-cond (assign exp (op cond->if) (reg exp)) (goto (label eval-dispatch)) ev-let (assign exp (op let->combination) (reg exp)) (goto (label eval-dispatch)) ))) (define the-global-environment (setup-environment)) (start eceval)
simulator.scm
;; -*- coding: utf-8 -*- (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) #f)) (define (make-machine ops controller-text) (let ((machine (make-new-machine))) ((machine 'install-operations) ops) ((machine 'install-instruction-sequence) (assemble controller-text machine)) machine)) (define (make-register name) (let ((contents '*unassigned*) (trace #f)) (define (dispatch message) (cond ((eq? message 'get) contents) ((eq? message 'set) (lambda (value) (set! contents value))) ((eq? message 'trace-on) (set! trace #t)) ((eq? message 'trace-off) (set! trace #f)) ((eq? message 'trace?) trace) (else (error "Unknown request -- REGISTER" message)))) dispatch)) (define (get-contents register) (register 'get)) (define (set-contents! register value) ((register 'set) value)) (define (make-stack) (let ((s '()) (number-pushes 0) (max-depth 0) (current-depth 0)) (define (push x) (set! s (cons x s)) (set! number-pushes (+ 1 number-pushes)) (set! current-depth (+ 1 current-depth)) (set! max-depth (max current-depth max-depth))) (define (pop) (if (null? s) (error "Empty stack -- POP") (let ((top (car s))) (set! s (cdr s)) (set! current-depth (- current-depth 1)) top))) (define (initialize) (set! s '()) (set! number-pushes 0) (set! max-depth 0) (set! current-depth 0)) (define (print-statistics) (print (list 'total-pushes '= number-pushes 'maximum-depth '= max-depth))) (define (dispatch message) (cond ((eq? message 'push) push) ((eq? message 'pop) (pop)) ((eq? message 'initialize) (initialize)) ((eq? message 'print-statistics) (print-statistics)) (else (error "Unknown request -- STACK" message)))) dispatch)) (define (pop stack) (stack 'pop)) (define (push stack value) ((stack 'push) value)) (define (print-statistics machine) ((machine 'stack) 'print-statistics)) (define (make-new-machine) (let ((pc (make-register 'pc)) (flag (make-register 'flag)) (stack (make-stack)) (the-instruction-sequence '()) (instruction-counting 0) (trace-flag #f) (label '()) (breakpoints '()) (current-n -1)) (let ((the-ops (list (list 'initialize-stack (lambda () (stack 'initialize))) (list 'print-stack-statisstics (lambda () (stack 'print-statistics))))) (register-table (list (list 'pc pc) (list 'flag flag)))) (define (allocate-register name) (if (assoc name register-table) (error "Multiply defined register: " name) (set! register-table (cons (list name (make-register name)) register-table))) 'register-allocated) (define (lookup-register name) (let ((val (assoc name register-table))) (if val (cadr val) (begin (allocate-register name) (lookup-register name))))) (define (execute) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (if (eq? (caaar insts) 'label) (begin (set! label (cadr (caar insts))) (set! current-n 0)) (set! instruction-counting (+ instruction-counting 1))) (if trace-flag (print "label: " label ", trace: " (caar insts))) (let ((val (assoc label breakpoints))) (if (and val (memq current-n (cdr val))) (print "break label:" label " offset:" current-n) (begin ((instruction-execution-proc (car insts))) (set! current-n (+ current-n 1)) (execute)))))))) (define (set-breakpoint label n) (let ((val (assoc label breakpoints))) (if val (set-cdr! val (cons n (cdr val))) (set! breakpoints (cons (cons label (list n)) breakpoints)))) 'done) (define (proceed-machine) (let ((insts (get-contents pc))) (if (null? insts) 'done (begin (if (eq? (caaar insts) 'label) (begin (set! label (cadr (caar insts))) (set! current-n 0)) (set! instruction-counting (+ instruction-counting 1))) (if trace-flag (print "label: " label ", trace: " (caar insts))) (begin ((instruction-execution-proc (car insts))) (set! current-n (+ current-n 1)) (execute)))))) (define (cancel-breakpoint label n) (let ((val (assoc label breakpoints))) (if val (set-cdr! val (filter (lambda (i) (not (= i n))) (cdr val)))))) (define (dispatch message) (cond ((eq? message 'start) (set-contents! pc the-instruction-sequence) (execute)) ((eq? message 'install-instruction-sequence) (lambda (seq) (set! the-instruction-sequence seq))) ((eq? message 'allocate-register) allocate-register) ((eq? message 'get-register) lookup-register) ((eq? message 'install-operations) (lambda (ops) (set! the-ops (append the-ops ops)))) ((eq? message 'stack) stack) ((eq? message 'operations) the-ops) ((eq? message 'print-instruction-counting) (print "(instruction-counting = " instruction-counting ")")) ((eq? message 'initialize-instruction-counting) (set! instruction-counting 0) 'done) ((eq? message 'trace-on) (set! trace-flag #t)) ((eq? message 'trace-off) (set! trace-flag #f)) ((eq? message 'trace-register-on) (lambda (reg-name) (let ((val (lookup-register reg-name))) (if val (val 'trace-on) (error "Unknown register:" reg-name))))) ((eq? message 'trace-register-off) (lambda (reg-name) (let ((val (lookup-register reg-name))) (if val (val 'trace-off) (error "Unknown register:" reg-name))))) ((eq? message 'set-breakpoint) set-breakpoint) ((eq? message 'proceed-machine) proceed-machine) ((eq? message 'cancel-breakpoint) cancel-breakpoint) ((eq? message 'cancel-all-breakpoints) (set! breakpoints '())) ((eq? message initialize-stack) (stack 'initialize)) (else (error "Unknown request -- MACHINE" message)))) dispatch))) (define (start machine) (machine 'start)) (define (get-register-contents machine register-name) (get-contents (get-register machine register-name))) (define (set-register-contents! machine register-name value) (set-contents! (get-register machine register-name) value) 'done) (define (get-register machine reg-name) ((machine 'get-register) reg-name)) (define (print-instruction-counting machine) (machine 'print-instruction-counting)) (define (initialize-instruction-counting machine) (machine 'initialize-instruction-counting)) (define (trace-register-on machine register-name) ((machine 'trace-register-on) register-name)) (define (trace-register-off machine register-name) ((machine 'trace-register-off) register-name)) (define (trace-on machine) (machine 'trace-on)) (define (trace-off machine) (machine 'trace-off)) (define (set-breakpoint machine label n) ((machine 'set-breakpoint) label n)) (define (proceed-machine machine) ((machine 'proceed-machine))) (define (cancel-breakpoint machine label n) ((machine 'cancel-breakpoint) label n)) (define (cancel-all-breakpoints machine) (machine 'cancel-all-breakpoints)) (define (assemble controller-text machine) (extract-labels controller-text (lambda (insts labels) (update-insts! insts labels machine) insts))) (define (extract-labels text receive) (if (null? text) (receive '() '()) (extract-labels (cdr text) (lambda (insts labels) (let ((next-inst (car text))) (if (symbol? next-inst) (if (assoc next-inst labels) (error "Multiply defined label:" next-inst) (begin (set! insts (cons (list (list 'label next-inst)) insts)) (receive insts (cons (make-label-entry next-inst insts) labels)))) (receive (cons (make-instruction next-inst) insts) labels))))))) (define (update-insts! insts labels machine) (let ((pc (get-register machine 'pc)) (flag (get-register machine 'flag)) (stack (machine 'stack)) (ops (machine 'operations))) (for-each (lambda (inst) (set-instruction-execution-proc! inst (make-execution-procedure (instruction-text inst) labels machine pc flag stack ops))) insts))) (define (make-instruction text) (cons text '())) (define (instruction-text inst) (car inst)) (define (instruction-execution-proc inst) (cdr inst)) (define (set-instruction-execution-proc! inst proc) (set-cdr! inst proc)) (define (make-label-entry label-name insts) (cons label-name insts)) (define (lookup-label labels label-name) (let ((val (assoc label-name labels))) (if val (cdr val) (error "Undefined label -- ASSEMBLE" label-name)))) (define (make-execution-procedure inst labels machine pc flag stack ops) (cond ((eq? (car inst) 'assign) (make-assign inst machine labels ops pc)) ((eq? (car inst) 'test) (make-test inst machine labels ops flag pc)) ((eq? (car inst) 'branch) (make-branch inst machine labels flag pc)) ((eq? (car inst) 'goto) (make-goto inst machine labels pc)) ((eq? (car inst) 'save) (make-save inst machine stack pc)) ((eq? (car inst) 'restore) (make-restore inst machine stack pc)) ((eq? (car inst) 'perform) (make-perform inst machine labels ops pc)) ((eq? (car inst) 'del) ((make-del inst machine pc))) ((eq? (car inst) 'label) (lambda () (advance-pc pc))) (else (error "Unknown instruction type -- ASSEMBLE" inst)))) (define (make-assign inst machine labels operations pc) (let ((target (get-register machine (assign-reg-name inst))) (value-exp (assign-value-exp inst))) (let ((value-proc (if (operation-exp? value-exp) (make-operation-exp value-exp machine labels operations) (make-primitive-exp (car value-exp) machine labels)))) (lambda () (if (target 'trace?) (print "register-name:" (assign-reg-name inst) " old:" (get-contents target) " new:" (value-proc))) (set-contents! target (value-proc)) (advance-pc pc))))) (define (assign-reg-name assign-instruction) (cadr assign-instruction)) (define (assign-value-exp assign-instruction) (cddr assign-instruction)) (define (advance-pc pc) (set-contents! pc (cdr (get-contents pc)))) (define (make-test inst machine labels operations flag pc) (let ((condition (test-condition inst))) (if (operation-exp? condition) (let ((condition-proc (make-operation-exp condition machine labels operations))) (lambda () (set-contents! flag (condition-proc)) (advance-pc pc))) (error "Bad TEST instruction -- ASSEMBLE" inst)))) (define (test-condition test-instruction) (cdr test-instruction)) (define (make-branch inst machine labels flag pc) (let ((dest (branch-dest inst))) (if (label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (if (get-contents flag) (set-contents! pc insts) (advance-pc pc)))) (error "Bad BRANCH instruction -- ASSEMBLE" inst)))) (define (branch-dest branch-instruction) (cadr branch-instruction)) (define (make-goto inst machine labels pc) (let ((dest (goto-dest inst))) (cond ((label-exp? dest) (let ((insts (lookup-label labels (label-exp-label dest)))) (lambda () (set-contents! pc insts)))) ((register-exp? dest) (let ((reg (get-register machine (register-exp-reg dest)))) (lambda () (set-contents! pc (get-contents reg))))) (else (error "Bad GOTO instruction -- ASSEMBLE" inst))))) (define (goto-dest goto-instruction) (cadr goto-instruction)) (define (make-save inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (push stack (get-contents reg)) (advance-pc pc)))) (define (make-restore inst machine stack pc) (let ((reg (get-register machine (stack-inst-reg-name inst)))) (lambda () (set-contents! reg (pop stack)) (advance-pc pc)))) (define (stack-inst-reg-name stack-instruction) (cadr stack-instruction)) (define (make-perform inst machine labels operations pc) (let ((action (perform-action inst))) (if (operation-exp? action) (let ((action-proc (make-operation-exp action machine labels operations))) (lambda () (action-proc) (advance-pc pc))) (error "Bad PERFORM instruction -- ASSEMBLE" inst)))) (define (perform-action inst) (cdr inst)) (define (make-primitive-exp exp machine labels) (cond ((constant-exp? exp) (let ((c (constant-exp-value exp))) (lambda () c))) ((label-exp? exp) (let ((insts (lookup-label labels (label-exp-label exp)))) (lambda () insts))) ((register-exp? exp) (let ((r (get-register machine (register-exp-reg exp)))) (lambda () (get-contents r)))) (else (error "Unknown expression type -- ASSEMBLE" exp)))) (define (register-exp? exp) (tagged-list? exp 'reg)) (define (register-exp-reg exp) (cadr exp)) (define (constant-exp? exp) (tagged-list? exp 'const)) (define (constant-exp-value exp) (cadr exp)) (define (label-exp? exp) (tagged-list? exp 'label)) (define (label-exp-label exp) (cadr exp)) (define (make-operation-exp exp machine labels operations) (let ((op (lookup-prim (operation-exp-op exp) operations)) (aprocs (map (lambda (e) (if (label-exp? e) (error "Bad OPERANDS instruction -- ASSEMBLE" e) (make-primitive-exp e machine labels))) (operation-exp-operands exp)))) (lambda () (apply op (map (lambda (p) (p)) aprocs))))) (define (operation-exp? exp) (and (pair? exp) (tagged-list? (car exp) 'op))) (define (operation-exp-op operation-exp) (cadr (car operation-exp))) (define (operation-exp-operands operation-exp) (cdr operation-exp)) (define (lookup-prim symbol operations) (let ((val (assoc symbol operations))) (if val (cadr val) (error "Unknown operation -- ASSEMBLE" symbol)))) (define (make-del inst machine pc) (let ((target (get-register machine (del-reg-name inst)))) (lambda () (set-contents! target '*unassigned*) (advance-pc pc)))) (define (del-reg-name delete-instruction) (cadr delete-instruction))
operations30_b.scm
;; -*- coding: utf-8 -*- (load "./environment30_b.scm") (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (get-global-environment) the-global-environment) (define (announce-output string) (newline) (display string) (newline)) (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '<procedure-env>)) (display object))) (define (self-evaluating? exp) (cond ((number? exp) #t) ((string? exp) #t) (else #f))) (define (variable? exp) (symbol? exp)) (define (unbound-variable? var) (eq? var '*unbound-variable*)) (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) #f)) (define (quoted? exp) (tagged-list? exp 'quote)) (define (assignment? exp) (tagged-list? exp 'set!)) (define (definition? exp) (tagged-list? exp 'define)) (define (if? exp) (tagged-list? exp 'if)) (define (lambda? exp) (tagged-list? exp 'lambda)) (define (begin? exp) (tagged-list? exp 'begin)) (define (cond? exp) (tagged-list? exp 'cond)) (define (let? exp) (tagged-list? exp 'let)) (define (application? exp) (pair? exp)) (define (text-of-quotation exp) (cadr exp)) (define (lambda-parameters exp) (cadr exp)) (define (lambda-body exp) (cddr exp)) (define (make-procedure parameters body env) (list 'procedure parameters body env)) (define (operands exp) (cdr exp)) (define (operator exp) (car exp)) (define (no-operands? ops) (null? ops)) (define (first-operand ops) (car ops)) (define (empty-arglist) '()) (define (last-operand? ops) (null? (cdr ops))) (define (adjoin-arg arg arglist) (append arglist (list arg))) (define (rest-operands ops) (cdr ops)) (define (primitive-procedure? proc) (tagged-list? proc 'primitive)) (define (compound-procedure? p) (tagged-list? p 'procedure)) (define (primitive-implementation proc) (cadr proc)) (define apply-in-underlying-scheme apply) (define (apply-primitive-procedure proc args) (apply-in-underlying-scheme (primitive-implementation proc) args)) (define (procedure-parameters p) (cadr p)) (define (procedure-environment p) (cadddr p)) (define (procedure-body p) (caddr p)) (define (check-arguments proc argl) (if (or (and (eq? (cadr proc) car) (not (pair? (car argl)))) (and (eq? (cadr proc) /) (= (cadr argl) 0))) #t #f)) (define (begin-actions exp) (cdr exp)) (define (first-exp seq) (car seq)) (define (last-exp? seq) (null? (cdr seq))) (define (rest-exps seq) (cdr seq)) (define (if-predicate exp) (cadr exp)) (define (true? x) (not (eq? x #f))) (define (if-alternative exp) (if (not (null? (cdddr exp))) (cadddr exp) 'false)) (define (if-consequent exp) (caddr exp)) (define (assignment-variable exp) (cadr exp)) (define (assignment-value exp) (caddr exp)) (define (definition-variable exp) (if (symbol? (cadr exp)) (cadr exp) (caadr exp))) (define (make-lambda parameters body) (cons 'lambda (cons parameters body))) (define (definition-value exp) (if (symbol? (cadr exp)) (caddr exp) (make-lambda (cdadr exp) (cddr exp)))) (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 (expand-clauses clauses) (if (null? clauses) 'false (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)))))) (define (cond->if exp) (expand-clauses (cond-clauses exp))) (define (let-vars exp) (map car (cadr exp))) (define (let-exps exp) (map cadr (cadr exp))) (define (let-body exp) (cddr exp)) (define (let->combination exp) (cons (make-lambda (let-vars exp) (let-boy exp)) (let-exps exp))) (define primitive-procedures (list (list 'car car) (list 'cdr cdr) (list 'cons cons) (list 'null? null?) (list 'list list) (list 'symbol? symbol?) (list 'exit exit) (list '= =) (list '+ +) (list '- -) (list '* *) (list '/ /) (list '> >) (list '< <) (list 'not not) )) (define (primitive-procedure-names) (map car primitive-procedures)) (define (primitive-procedure-objects) (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures)) (define (setup-environment) (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment))) (define-variable! 'true #t initial-env) (define-variable! 'false #f initial-env) initial-env))
environment30_b.scm
;; -*- coding: utf-8 -*- (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment '()) (define (make-frame variables values) (cons variables values)) (define (frame-variables frame) (car frame)) (define (frame-values frame) (cdr frame)) (define (add-binding-to-frame! var val frame) (set-car! frame (cons var (car frame))) (set-cdr! frame (cons val (cdr frame)))) (define (extend-environment vars vals base-env) (if (= (length vars) (length vals)) (cons (make-frame vars vals) base-env) (if (< (length vars) (length vals)) (error "Too many arguments supplied" vars vals) (error "Too few arguments supplied" vars vals)))) (define (lookup-variable-value var env) (define (env-loop env) (define (scan vars vals) (cond ((null? vars) (env-loop (enclosing-environment env))) ((eq? var (car vars)) (car vals)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) '*unbound-variable* (let ((frame (first-frame env))) (scan (frame-variables frame) (frame-values frame))))) (env-loop env)) (define (set-variable-value! var val env) (define (env-loop env) (define (scan vars vals) (cond ((null? vars) (env-loop (enclosing-environment env))) ((eq? var (car vars)) (set-car! vals val)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) (error "Unbound variable -- SET!" var) (let ((frame (first-frame env))) (scan (frame-variables frame) (frame-values frame))))) (env-loop env)) (define (define-variable! var val env) (let ((frame (first-frame env))) (define (scan vars vals) (cond ((null? vars) (add-binding-to-frame! var val frame)) ((eq? var (car vars)) (set-car! vals val)) (else (scan (cdr vars) (cdr vals))))) (scan (frame-variables frame) (frame-values frame))))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./eceval30_b.scm ;;; EC-Eval input: (car (cons 1 2)) (total-pushes = 13 maximum-depth = 8) ;;; EC-Eval value: 1 ;;; EC-Eval input: (car 1) arguments-error ;;; EC-Eval input: (/ 1 2) (total-pushes = 8 maximum-depth = 5) ;;; EC-Eval value: 1/2 ;;; EC-Eval input: (/ 1 0) arguments-error ;;; EC-Eval input: (exit) $
0 コメント:
コメントを投稿