SICP問題4.22
式と環境をとるevalを分けた超循環評価器。
手続き analyze は式だけを取る。これは構文解析を実施し、解析された式を実行する
教科書の定義に加えてletを組み込む。
;; 4.1.7 - 以降 ;; 評価器実行用に超循環のapplyを定義する前に定義しておく (define apply-in-underlying-scheme apply) (define true #t) (define false #f) ;; 式の表現 (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) false)) ;; 自己評価式は数と文字列だけである (define (self-evaluating? exp) (cond ((number? exp) true) ((string? exp) true) (else false))) ;; クォート式は(quote <text-of-quotation>)の形である('aも(quote a)に見える) (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)) ;; 代入は(set! <var> <value>)の形である (define (assignment? exp) (tagged-list? exp 'set!)) (define (assignment-variable exp) (cadr exp)) (define (assignment-value exp) (caddr exp)) ;; 定義は ;; (define <var> <value>) ;; または ;; (define (<var> <parameter1> ... <parametern>) ;; <body>) ;; の形である。後の形(標準手続き定義)は ;; (define <var> ;; (lambda (<parameter1> ... <parametern>) ;; <body>) ;; の構文シュガーである。 (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) ; formal parameters (cddr exp)))) ; body ;; 条件はifで始まり、述語と帰結部(場合により)代替部を持つ。式に代替部がなければ、代替部としてfalseを置く。 (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)) 'false)) ;; lambda式は記号lambdaで始まるリストである (define (lambda? exp) (tagged-list? exp 'lambda)) (define (lambda-parameters exp) (cadr exp)) (define (lambda-body exp) (cddr exp)) ;; 上のdefienition-valueが使うlambda式の構成子 (define (make-lambda parameters body) (cons 'lambda (cons parameters body))) ;; begin式は式の並びを単一の式に包み込む。begin式から実際の並びが取れるようにbegin式の構文演算と、並びの最初の式と残りの式を返す選択子を用意する (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)) ;; 導出された式。特殊形式のあるものは直接実装するのでなはなく、他の特殊形式を使った式の形で定義できる。その一例がcondで、if式の入れ子として実装できる。condの評価をこのように実装すると評価プロセスに明確に規定しなければならない特殊形式の数が減るので評価器が単純になる ;; cond式の要素を取り出す構文手続きとcond式をif式に変換する手続きcond->ifを用意する。場合分けはcondで始まり、述語と行動の節のリストを持つ。述語が記号elseの時、節はelse節である。 ;; 拡張構文を追加したcond (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 (extended-cond? clause) (if (cond-else-clause? clause) false (eq? (cadr clause) '=>))) ;; 拡張構文のtest (define (extended-cond-test clause) (car clause)) ;; 拡張構文のrecipient (define (extended-cond-recipient clause) (caddr clause)) ;; (define (cond-actinos clause) (cdr clause)) ;; cond-actions を修正 (define (cond-actions clause) (if (extended-cond? clause) (list (extended-cond-recipient clause) (extended-cond-test clause)) (cdr clause))) (define (cond->if exp) (expand-clauses (cond-clauses exp))) (define (expand-clauses clauses) (if (null? clauses) ;; false ; else節なし 'false ; else節なし (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)))))) ;; (cond->ifが使う)構成子sequence->exp (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)) ;; let (define (let? exp) (tagged-list? exp 'let)) (define (named-let? exp) (and (let? exp) (not (pair? (cadr exp))))) (define (let-parameters exp) (if (named-let? exp) (caddr exp) (cadr exp))) (define (let-body exp) (if (named-let? exp) (cdddr exp) (cddr exp))) (define (let-variables exp) (map car (let-parameters exp))) (define (let-expressions exp) (map cadr (let-parameters exp))) (define (let-name exp) (cadr exp)) (define (make-definition variable body) (list 'define variable body)) (define (let->combination exp) (if (named-let? exp) (if (null? (let-parameters exp)) '() (make-begin (list (make-definition (let-name exp) (make-lambda (let-variables exp) (let-body exp))) (cons (let-name exp) (let-expressions exp))))) (if (null? (let-parameters exp)) '() (cons (make-lambda (let-variables exp) (let-body exp)) (let-expressions exp))))) ;; 手続き作用。上の式の形のいずれでもない任意の合成式。式のcarが演算子,cdrが被演算子のリスト (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)) ;; 式と環境をとるevalを分ける ;; 手続き analyze は式だけを取る。これは構文解析を実施し、解析された式を実行する時になすべき仕事をカプセル化した新しい手続き、実行手続き(execution procedure)を返す ;; 実行手続きは引数として環境をとり、評価を完成する (define (eval exp env) ((analyze exp) env)) (define (analyze exp) (cond ((self-evaluating? exp) (analyze-self-evaluating exp)) ((quoted? exp) (analyze-quoted exp)) ((variable? exp) (analyze-variable exp)) ((assignment? exp) (analyze-assignment exp)) ((definition? exp) (analyze-definition exp)) ((if? exp) (analyze-if exp)) ((lambda? exp) (analyze-lambda exp)) ((let? exp) (analyze (let->combination exp))) ((begin? exp) (analyze-sequence (begin-actions exp))) ((cond? exp) (analyze (cond->if exp))) ((application? exp) (analyze-application exp)) (else (error "Unknown expression type -- ANALYZE" exp)))) ;; 自己評価式を扱う最も単純な構文解析手続き。環境引数を無視し、式を返す実行手続きを返す (define (analyze-self-evaluating exp) (lambda (env) exp)) ;; クォート式では実行フェーズでなく、解析フェーズでクォート引用の本文を一回取り出すだけで、多少の効率を得る (define (analyze-quoted exp) (let ((qval (text-of-quotation exp))) (lambda (env) qval))) ;; 変数の値の探索は、環境を知ることに依存するので、実行フェーズで行わなければならない (define (analyze-variable exp) (lambda (env) (lookup-variable-value exp env))) ;; analyze-assignmentもまた変数の実際の設定を、環境が用意される実行まで延期する。 ;; しかしassignment-value式が解析時に(再帰的に)解析出来るという事実は、assignment-value式は一回だけ解析されるので、効率に大きく貢献する。 ;; 同じことは定義でも成り立つ。 (define (analyze-assignment exp) (let ((var (assignment-variable exp)) (vproc (analyze (assignment-value exp)))) (lambda (env) (set-variable-value! var (vproc env) env) 'ok))) (define (analyze-definition exp) (let ((var (definition-variable exp)) (vproc (analyze (definition-value exp)))) (lambda (env) (define-variable! var (vproc env) env) 'ok))) ;; if式は解析時に述語, 帰結部および代替部を取り出し解析する (define (analyze-if exp) (let ((pproc (analyze (if-predicate exp))) (cproc (analyze (if-consequent exp))) (aproc (analyze (if-alternative exp)))) (lambda (env) (if (true? (pproc env)) (cproc env) (aproc env))))) ;; lambda式の解析は、効率に大きな利益をもたらす:lambdaの評価の結果の手続きが多数回使用されようともlambda本体は一回だけ解析される (define (analyze-lambda exp) (let ((vars (lambda-parameters exp)) (bproc (analyze-sequence (lambda-body exp)))) (lambda (env) (make-procedure vars bproc env)))) ;; (beginやlambda式の本体のような)式の並びの解析はずっと複雑である。並びの中のそれぞれの式を解析し、実行手続きを作り出す。これらの実行手続きを組み合わせ、環境を引数としてとり、個々の実行手続きを環境を引数として順に呼び出す一個の実行手続きを作る (define (analyze-sequence exps) (define (sequentially proc1 proc2) (lambda (env) (proc1 env) (proc2 env))) (define (loop first-proc rest-procs) (if (null? rest-procs) first-proc (loop (sequentially first-proc (car rest-procs)) (cdr rest-procs)))) (let ((procs (map analyze exps))) (if (null? procs) (error "Empty sequence -- ANALYZE")) (loop (car procs) (cdr procs)))) ;; 手続き作用を解析するためには ;; 演算子と被演算子を解析し、演算子の実行手続きと、被演算子の実行手続きを呼び出す実行手続きを構成する。 ;; 演算子の実行手続き => 実際に作用させる手続きを得るため ;; 非演算子の実行手続き => 実際に作用させる引数を得るため ;; 次にこれを execute-applicationへ渡す。applyとexecute-applicationは合成手続きの手続き本体はすでに解析してあるので、更に解析する必要がないという点だけが異なる。解析はせずに本体の実行手続きを拡張された環境に対して呼び出すだけである。 (define (analyze-application exp) (let ((pproc (analyze (operator exp))) (aprocs (map analyze (operands exp)))) (lambda (env) (execute-application (pproc env) (map (lambda (aproc) (aproc env)) aprocs))))) (define (execute-application proc args) (cond ((primitive-procedure? proc) (apply-primitive-procedure proc args)) ((compound-procedure? proc) ((procedure-body proc) (extend-environment (procedure-parameters proc) args (procedure-environment proc)))) (else (error "Unknown procedure type -- EXECUTE-APPLICATION" proc)))) ;; ------------------------------------------------- ;; --------------------------------------------- ;; 述語のテスト ;; --------------------------------------------- (define (true? x) (not (eq? x false))) (define (false? x) (eq? x false)) ;; --------------------------------------------- ;; 手続きの表現 ;; --------------------------------------------- ;; 基本手続き ;; (apply-primitive-procedure <proc> <args>) ;; (primitive-procedure? <proc>) ;; 合成手続き (define (make-procedure parameters body env) (list 'procedure parameters body env)) (define (compound-procedure? p) (tagged-list? p 'procedure)) (define (procedure-parameters p) (cadr p)) (define (procedure-body p) (caddr p)) (define (procedure-environment p) (cadddr p)) ;; --------------------------------------------- ;; 環境に対する操作 ;; --------------------------------------------- ;; 環境をフレームのリストとして表現する。ある環境の外側の環境はリストのcdrである ;; 空の環境は単に環境のリストである (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) (error "Unbound variable" var) (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)))) ;; unbind! (define (unbind-variable! var env) (let ((frame (first-frame env))) (define (scan vars vals) (cond ((null? vars) (error "Unbound variable -- UNBIND!" var)) ((eq? var (car vars)) (begin (set-car! vars (cdr vars)) (set-car! vals (cdr vals)))) (else (scan (cdr vars) (cdr vals))))) (scan (frame-variables frame) (frame-values frame)))) ;; --------------------------------------------- ;; 評価器の実行 ;; --------------------------------------------- ;; 必要なものは基本手続きの作用をモデル化するために、基盤になるLispシステムを呼び出す機構を作ること ;; 一義的なオブジェクトを評価しようとしている式に現れ得る基本手続きの名前に対応付ける大域環境を設定する。大域環境にはまだ評価する式で変数として扱えるように記号trueとfalseの束縛もある (define (setup-environment) (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment))) (define-variable! 'true true initial-env) (define-variable! 'false false initial-env) initial-env)) ;; 基本手続き (define (primitive-procedure? proc) (tagged-list? proc 'primitive)) (define (primitive-implementation proc) (cadr proc)) ;; 基本手続きの名前と実装手続きのリスト (define primitive-procedures (list (list 'car car) (list 'cdr cdr) (list 'cons cons) (list 'null? null?) (list '= =) (list '+ +) (list '- -) (list '* *) ;; (list 'map map) ;; <基本手続きが続く> )) (define (primitive-procedure-names) (map car primitive-procedures)) (define (primitive-procedure-objects) (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures)) ;; 基本手続きを作用させる (define (apply-primitive-procedure proc args) (apply-in-underlying-scheme (primitive-implementation proc) args)) ;; 超循環評価器を走らせるのを便利にするため、基盤Lispシステムの読込み-評価-印字ループをモデル化する駆動ループ(driver loop)を用意する。これは促進記号(prompt)を印字し、入力式を読み込み、この式を大域環境で評価し、結果を印字する。印字された結果の前に出力記号(output prompt)をつけ、式の値を他の印字された出力から区別できるようにする (define input-prompt ";;; M-Eval input:") (define output-prompt ";;; M-Eval value:") (define (driver-loop) (prompt-for-input input-prompt) (let ((input (read))) (let ((output (eval input the-global-environment))) (announce-output output-prompt) (user-print output))) (driver-loop)) (define (prompt-for-input string) (newline) (newline) (display string) (newline)) (define (announce-output string) (newline) (display string) (newline)) ;; 非常に長くなりそうな(または循環するかも知れない)合成手続きの環境部分を避けるため、特別な印字手続きuser-printを使う (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '<procedure-env>)) (display object))) ;; 評価器を走らせるための駆動ループの起動 ;; (define the-global-environment (setup-environment)) ;; (driver-loop)
