評価器写経終了

書き写した。なんとかうごいた。
mitscheme(edwin)とgoshではなんとかうごくらしい。mzschemeはconsがアレという致命傷なので調伏できなかった。。。(drscheme上は..しらね。)
(define (add1 n) (+ 1 n))ぐらいしかテストしてないです。

;;とりあえずtrue/falseはエイリアスつけておくべし
(define true #t)
(define false #f)
;mzで動かすぜ！とおもったけど↓だけではどうにも動かないのであった。
;;consが＊＊＊＊などと怒られてどうにもならない。
;;set-car! set-cdr! cons
;(begin
;(define cons mcons)
;(define set-car! set-mcar!)
;(define set-cdr! set-mcdr!))

;;mit-scheme(edwin)でうごかした。
;;(load "hoge")したらとりあえず後は(driver-loop)だけでムフフとなるが
;;現状はtrace的なものを埋め込みすぎたのでうっとうしい。
;;写経のみなので。。。ごめんなさいって誰に謝っているのやら？
;;(動かないので)traceで追っかけまくっているうちになんとなく分かってきたきもするし、
;;apply.*をmapply.*,eval.*をmeval.*にして元々の実装の関数からはずらした(つもり)

(define (meval exp env) 
  (cond ((self-mevaluating? exp) (trace "self-meval")exp)
        ((variable? exp) (trace "variable")(lookup-variable-value exp env))
        ((quoted? exp) (trace "quoted") (text-of-quotation exp))
        ((assignment? exp) (trace "assign") (meval-assignment exp env))
        ((definition? exp) (trace "define")(meval-definition exp env))
        ((if? exp) (trace "if") (meval-if exp env))
        ((lambda? exp) (trace "lambda")
         (make-procedure (lambda-parameters exp)
                         (lambda-body exp)
                         env))
        ((begin? exp) (trace "begin")
         (meval-sequence (begin-actions exp) env))
        ((cond? exp) (trace "cond")(meval (cond->if exp) env))
        ((application? exp) (trace "appli")
         (mapply (meval (operator exp) env)
                (list-of-values (operands exp) env))) 
        (else
         (error "Unknown expression type -- MEVAL" exp))))
(define (mapply procedure arguments)
  (cond ((primitive-procedure? procedure)
         (mapply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (meval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters procedure)
             arguments
             (procedure-environment procedure))))
        (else
         (error
          "Unknown procedure type -- MAPPLY" procedure))))
(define (meval-sequence exps env)
  (cond ((last-exp? exps) (meval (first-exp exps) env))
        (else (meval (first-exp exps) env) 
              (meval-sequence (rest-exps exps) env)))) 
;;2
(define (list-of-values exps env)
  (if (no-operands? exps)
      '()
      (cons (meval (first-operand exps) env)
            (list-of-values (rest-operands exps) env)
            )))

;;3
(define (meval-if exp env)
  (if (true? (meval (if-predicate exp) env))
      (meval (if-consequent exp) env)
      (meval (if-alternative exp) env)))

;;
(define (meval-assignment exp env)
  (set-variable-value! (assignment-variable exp)
                       (meval (assignment-value exp) env)
                       env)
  'ok)

;;
(define (meval-definition exp env)
  (define-variable! (definition-variable exp)
                    (meval (definition-value exp) env)
                    env)
  'ok)

;;
(define (self-mevaluating? exp)
  (cond ((number? exp) true)
        ((string? exp) true)
        (else (display "not self-meval") false)))

;;
(define (variable? exp) (symbol? exp))

;;
(define (quoted? exp)
  (tagged-list? exp 'quote))
(define (text-of-quotation exp) (cadr exp))

;;tagged-list
(define (tagged-list? exp tag)
  (if (pair? exp) (eq? (car exp) tag) false))

;;
(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)   ; formal parameters
                   (cddr exp)))) ; body

;;lambda
(define (lambda? exp) (tagged-list? exp 'lambda))
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
;;lambda
(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))
;;cond->if
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))
;;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
(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 (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))

;;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 (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))))))

;;
(define (ture? x)
  (not (eq? x false)))
(define (false? x)
  (eq? x false))

;;
(define mapply-in-underlying-scheme apply)
(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))

;;
(define (enclosing-environment env) (trace "enclosing-environment") 
;  (trace (cdr env))
  (cdr env))
(define (first-frame env)
;  (display env)
  (if (null? env)
      (begin (display "first-env-null") '())
      (begin (trace "env is not null")(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)
  (trace "extend-environment")
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals) #f));;;my:#f
  )

;;
(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)) (display "found! :") (trace var) (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))
        )))
  (trace "lookup-variable-value") (trace var)
  (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)))))
  (trace "set-variable-value!") (trace var)
  (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)))))
    (trace "define-variable-value!")
    (scan (frame-variables frame)
          (frame-values frame))
    ))

(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)
    (display "set up complete.")
    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 'eq? eq?)
   (list 'null? null?)
   (list '+ +)
   (list '- -)
   (list '* *)
   (list '/ /)
   (list 'ma +)
   (list 'load load)
;   (list 'car car)
;   (list 'car car)
   ))
;;primitive
(define (primitive-procedure-names) (map car primitive-procedures))
(define (primitive-procedure-objects) (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures))
(define (mapply-primitive-procedure proc args)
  (mapply-in-underlying-scheme (primitive-implementation proc) args))

;;
(define input-prompt  "scheme::MyInterpreter::input>>")
(define output-prompt "scheme::MyInterpreter::outpt>>")
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (trace input)
    (let ((output (meval input the-global-environment)))
      (announce-output output-prompt)
      (user-print output)))
      (driver-loop))
(define (prompt-for-input string)
  (newline) (display string) (newline))
(define (announce-output string)
  (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 (trace string) (display "trace:") (display string) (newline))

(define the-global-environment (setup-environment))
;(driver-loop)

追記 mzschemeでも動かした

mzschemeでも動かした。goshでも動かせるようにした。
;;inputはconsでくるのでpair?をつかっているところは部分的にmzscheme/goshで
;;処理を別ける必要がある
;;変更したところ

;;tagged-list
(define mod-pair? pair?)
(define (tagged-list? exp tag)
;;  (if (pair? exp) (eq? (car exp) tag) false))
  (if (mod-pair? exp) ;;mzschemeのみpair?=>mpair?
      (begin (display "in the tagged:") (display exp)(newline)
             (eq? (car exp) tag))
      (begin (display "tag is not pair") (display exp)(newline)
             false)))
             
;;inputまわりはconsでくるのでcar/cdr=>ecar/ecdrとエイリアスをつけて使う
;;(define (operator exp) (car exp))
(define (operator exp) (ecar exp))
;;(define (operands exp) (cdr exp))
(define (operands exp) (ecdr exp))
(define (no-operands? ops) (null? ops))
;;(define (first-operand ops) (car ops))
(define (first-operand ops) (ecar ops))
;;(define (rest-operands ops) (cdr ops))
(define (rest-operands ops) (ecdr ops))

動かしかたはキモいことになった。
mzschemeなら以下を読み込む

;;;mzscheme用
(begin
(require scheme/mpair)
(define cons mcons)
(define set-car! set-mcar!)
(define set-cdr! set-mcdr!)
(define ecar car)
(define ecdr cdr)
(define car mcar)
(define cdr mcdr)
(define list mlist)
;;(define pair? mpair?) ;;この評価器ではinput=>exp=>pair?なのでmconsを経由しない
(define length mlength)
(define map mmap)
(define (cadr c) (mcar (mcdr c)))
(define (cddr c) (mcdr (mcdr c)))
(define (caddr c) (mcar (mcdr (mcdr c))))
(define (cdddr c) (mcdr (mcdr (mcdr c))))
'1)
;;ここで評価器を読み込む
(load "im2.scm")
(begin
  (define mod-pair? mpair?)
  (define (setapply mls) (mlist->list mls))
  (define the-global-environment (setup-environment))
  (driver-loop)
'3)

goshなら以下を読み込む

;;;gosh用
(begin
  (define ecar car)
  (define ecdr cdr)
  (load "/cygdrive/c/home/sicp/im2.scm")
  (define the-global-environment (setup-environment))
  (driver-loop)
)

「inputはcons」、「評価器の中のデータ構造はmcons」なのでもう少しすっきりした切り替えができるはず。
いまは入力側と出力側をとりあえず動くようにerror表示を元に切り替えている感覚なので
とても気持ち悪いその場しのぎですね。が、ねむくなってしまった。

評価器を動かしてみた感想

評価器は、"primitive"まで分解していって実装の機構にスイッチして戻りをもらうと言うのがしくみなのだろうという自分なりの理解をした。言葉では理解していたけど体感した。

今回は+,-,*/などを"primitive"に設定した。
なにも評価器を書くのに(その言語で)特殊な関数は必要なくて、評価器の中で基本的なものとして使っているeq? null? if consに変わるものがあれば(この非常に低機能な)評価器は書けてしまう。
もし書くならschemeならではの()入れ子な構文解析を挟めば良くて、それにはschemeのinputがどういうものをeval以下に渡しているのかをもっと詳しく確かめる所から始めればよい。構文解析は評価器を作る言語の便利機能を使えばよいし...、ぐらいまでは見通しがたった。(たとえばjavascriptなどで)評価器が実装できたりするのだろう。構文解析がschemeでschemeの評価器を作った今回は簡素化されている、ということだった。まぁ、実際にやるとなったら構文解析はしんどそうではあるけれども。

評価器なんて作れる人は雲の上の人だなぁ、とか思っていたけど、手が届く世界なのかもしれない、と想像ができる世界に思えるようになったのはきっとものすごい収穫なのだろうとおもってニヤニヤしながら眠ることにします。

アッ！偉そうに言ってるけど結局コピペしただけだった。orz...
まだ、問題解いてないですし。

評価器にpromptで入力をせっつかれるとすごく萌えます。
schemeさわってるとコンピューターが生きてるんじゃないか、という錯覚に陥るんだな。