読者です 読者をやめる 読者になる 読者になる

レガシーコード生産ガイド

私に教えられることなら

Common Lispでコンピュテーションをアンダースタンディングする 2

変数、何もしない文、代入文まで。

前回

変数

環境は、Lisp処理系では単純にalistを使っているけど、せっかくなのでハッシュを使ってみる。

後で変更するかもしれないので、環境作成と値の追加・取り出しは関数にしておく。

;; 環境
(defun make-environment ()
  (make-hash-table :test #'equal))

(defun get-variable-value (var env)
  (gethash var env))

(defun push-variable (var value env)
  (setf (gethash var env) value))

reduce、vmのそれぞれで、環境を渡していくように定義し直す。

(defun s-inspect (expr env)
  (funcall (inspect-function (s-type expr)) expr env))

(defun s-reduce (expr env)
  (funcall (type-function (s-type expr)) expr env))

(defun s-reduce-1 (expr env)
  (cond
    ((reducible? (s-left expr))  (s-replaced-left  expr (s-reduce-1 (s-left  expr) env)))
    ((reducible? (s-right expr)) (s-replaced-right expr (s-reduce-1 (s-right expr) env)))
    (t (s-reduce expr env))))

(defun vm-run (expr &optional (env (make-environment)))
  (format t "~A~%" (s-inspect expr env))
  (if (reducible? expr) (vm-run (s-reduce-1 expr env) env) expr))

併せてマクロも編集する。

  (defun declare-destructed-arg (arg)
    (case arg
      (($env)   '($env env))
      (($type)  '($type  (s-type expr)))
      (($value) '($value (s-value expr)))
      (($left)  '($left  (s-left expr)))
      (($right) '($right (s-right expr)))
      (($reducible) '($reducible (reducible? expr)))))

  (defun make-expr-fn (args &rest body)
    `(lambda (expr env)
       (declare (ignorable env))
       (let ,(declares-destructed-args args) ,@(car body))))

一貫性を持たせるため、環境を扱うための$envを追加する。本当なら変数の衝突を避けるためにexpr、envはgensymで変数名を作ってそれを渡すべきなのかな。

二項演算子用のマクロも定義し直す。

(defmacro regist-binop (type result-type fn)
  (let ((format (concatenate 'string "~A " (symbol-name fn) " ~A")))
    `(regist-type ,type
                  (($left $right $env)
                   (format nil ,format (s-inspect $left $env) (s-inspect $right $env)))
                  (($left $right $env)
                   (make-value ',result-type 
                               (,fn 
                                (s-reduce-1 $left  $env) 
                                (s-reduce-1 $right $env)))))))

変数を追加する。タイプは演算子ではなく値で、reducibleをtにする。 値を変数名として、簡約するときにget-variable-valueで変数の値を取得する。

(regist-type variable
             (($value) (format nil "~A" $value))
             (($value $env) (get-variable-value $value $env)))

試してみる。ハッシュテーブルで環境を作り、vm-runに渡す。

CL-USER> (defvar *test-env* (make-hash-table))
*TEST-ENV*
CL-USER> (push-variable 'x (make-value 'number 3) *test-env*)
(NUMBER 3 NIL NIL NIL)
CL-USER> (vm-run (make-value 'variable 'x t) *test-env*)
X
3
(NUMBER 3 NIL NIL NIL)
CL-USER> (vm-run (make-op 'add (make-value 'number 4) (make-value 'variable 'x t)) *test-env*)
4 + X
4 + 3
7
(NUMBER 7 NIL NIL NIL)

変数Xが簡約される様子がわかる。昨日は勘違いしていたけど、こうやって簡約による最小の変化によって定義するのがスモールステップ意味論なのかな?

環境で変数名と結びついているのは、LISPでの数字ではなく、SIMPLEでの数字の表現ということを見落としてちょっとハマった。

まずは何もしない文を作る。データ構造はとりあえず値・演算子と同じものを使う。文はそれぞれでデータ構造が大きく異なりそうなので、make-statementではなくmake-do-nothingなどそれぞれを生成する関数を作っておく。

(defun make-do-nothing () '(do-nothing nil nil nil nil))

(regist-type do-nothing
             (() (format nil "DO-NOTHING"))
             (() nil))

そのまま代入文に取り掛かる。簡約した文と、代入した結果が反映された新しい環境を返さないといけない。

変数名を扱う為に、簡約されるとシンボルを返すsymbol値を作る。

(regist-type symbol
             (($value) (format nil "~A" $value))
             (($value) $value))

代入文はASTの左に変数名を、右に式を持つ。式が簡約可能なら簡約し続け、値になったらそれを代入する。

本では代入が反映された新しい環境を作り、それを返す設計だけど、とりあえず破壊的に変更してみる。

(regist-type assign
             (($left $right $env)  
              (format nil "~A = ~A" 
                      (s-inspect $left $env)
                      (s-inspect $right $env)))
             (($env $left $right)
              (if (reducible? $right) 
                  (make-assign $left (s-reduce-1 $right $env))
                  (progn
                   (push-variable $left $right $env)
                   (make-do-nothing)))))

環境がどう変化したかを見たいので、逆引きCommon Lispを参考にして、環境をalistに変換し、値と一緒に表示させる。

(defun env-to-alist (env)
  (let ((alist () ))
    (maphash (lambda (key val) 
               (push (cons (s-value key) (s-value val)) alist)) env)
    alist))

(defun vm-run (expr &optional (env (make-environment)))
  (format t "~A : ~A ~%" (s-inspect expr env) (env-to-alist env))
  (if (reducible? expr) (vm-run (s-reduce-1 expr env) env) expr))

試してみる。

CL-USER> (vm-run (make-assign (make-value 'symbol 'hoge) (make-op 'add (make-value 'number 3) (make-value 'number 4))))
HOGE = 3 + 4 : NIL 
HOGE = 7 : NIL 
DO-NOTHING : ((HOGE . 7)) 
(DO-NOTHING NIL NIL NIL NIL)

ちゃんとhogeに代入されている。

DO-NOTHING文を「返す」ぐらいなら、全部式でいいんじゃないのかなと思うんだけど、文と分けたほうがいい理由があるんだろうか?式は純粋で、文は純粋では無い、はわかったんだけど、関数内で文を使えたら一緒なような。

長くなったのでこの記事はここまで。

感想

全コード

(defun make-value (type value &optional (reducible nil)) (list type value nil nil reducible))
(defun make-op    (type left right &optional (reducible t)) (list type nil left right reducible))

(defun make-do-nothing () '(do-nothing nil nil nil nil))
(defun make-assign (var expr) `(assign nil ,var ,expr t))

(defun s-type  (node) (first  node))
(defun s-value (node) (second node))
(defun s-left  (node) (third  node))
(defun s-right (node) (fourth node))
(defun reducible? (node) (fifth node))

;; 環境
(defun make-environment ()
  (make-hash-table :test #'equal))

(defun get-variable-value (var env)
  (gethash var env))

(defun push-variable (var value env)
  (setf (gethash var env) value))


(defun s-replaced-left (expr node)
  (list (s-type expr) (s-value expr) node (s-right expr) (reducible? expr)))

(defun s-replaced-right (expr node)
  (list (s-type expr) (s-value expr) (s-left expr) node (reducible? expr)))

(defvar *inspect-function-table* '())
(defun inspect-function (type)
  (cdr (assoc type *inspect-function-table*)))

(defun s-inspect (expr env)
  (funcall (inspect-function (s-type expr)) expr env))

(defvar *type-function-table* '())
(defun type-function (type)
  (cdr (assoc type *type-function-table*)))

(defun s-reduce (expr env)
  (funcall (type-function (s-type expr)) expr env))

(defun s-reduce-1 (expr env)
  (cond
    ((reducible? (s-left expr))  (s-replaced-left  expr (s-reduce-1 (s-left  expr) env)))
    ((reducible? (s-right expr)) (s-replaced-right expr (s-reduce-1 (s-right expr) env)))
    (t (s-reduce expr env))))

(defun env-to-alist (env)
  (let ((alist () ))
    (maphash (lambda (key val) 
               (push (cons (s-value key) (s-value val)) alist)) env)
    alist))

(defun vm-run (expr &optional (env (make-environment)))
  (format t "~A : ~A ~%" (s-inspect expr env) (env-to-alist env))
  (if (reducible? expr) (vm-run (s-reduce-1 expr env) env) expr))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun declare-destructed-arg (arg)
    (case arg
      (($env)   '($env env))
      (($type)  '($type  (s-type expr)))
      (($value) '($value (s-value expr)))
      (($left)  '($left  (s-left expr)))
      (($right) '($right (s-right expr)))
      (($reducible) '($reducible (reducible? expr)))))

  (defun declares-destructed-args (args)
    (reduce (lambda (ds arg) 
              (cons (declare-destructed-arg arg) ds))
            args :initial-value '()))

  (defun make-expr-fn (args &rest body)
    `(lambda (expr env)
       (declare (ignorable expr env))
       (let ,(declares-destructed-args args) ,@(car body)))))

(defmacro regist-inspect-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *inspect-function-table*))

(defmacro regist-type-fn (type args &body body)
  `(push (cons ',type ,(make-expr-fn args body)) *type-function-table*))

(defmacro regist-type (type inspect-fn type-fn)
  `(progn
     (regist-inspect-fn ,type ,@inspect-fn)
     (regist-type-fn ,type ,@type-fn)))

(defmacro regist-binop (type result-type fn)
  (let ((format (concatenate 'string "~A " (symbol-name fn) " ~A")))
    `(regist-type ,type
                  (($left $right $env)
                   (format nil ,format (s-inspect $left $env) (s-inspect $right $env)))
                  (($left $right $env)
                   (make-value ',result-type 
                               (,fn 
                                (s-reduce-1 $left  $env) 
                                (s-reduce-1 $right $env)))))))

(regist-type number
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-type bool
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-type symbol
             (($value) (format nil "~A" $value))
             (($value) $value))

(regist-type variable
             (($value) (format nil "~A" $value))
             (($value $env) (get-variable-value $value $env)))

(regist-type do-nothing
             (() (format nil "DO-NOTHING"))
             (() nil))

(regist-type assign
             (($left $right $env)  
              (format nil "~A = ~A" 
                      (s-inspect $left $env)
                      (s-inspect $right $env)))
             (($env $left $right)
              (if (reducible? $right) 
                  (make-assign $left (s-reduce-1 $right $env))
                  (progn
                   (push-variable $left $right $env)
                   (make-do-nothing)))))

(regist-binop add number +)
(regist-binop sub number -)
(regist-binop mul number *)
(regist-binop div number /)
(regist-binop gt bool >)
(regist-binop lt bool <)
(regist-binop eq bool =)
広告を非表示にする