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

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

私に教えられることなら

ConcatenativeなFactor(Forth)ライク言語を作るのに挑戦しました

forth CommonLisp

Forth + プロトタイプベースなFactor風言語を作りました - レガシーコード生産ガイドの記事のあと、様々なバグを発見して修正しているうちに、「これはよりプリミティブなものを作って基礎をしっかりさせたほうがいいのでは」と思い、純粋にクォーテーションのみに注力したプロトタイプを作成していました。

その過程と、その前にそもそもConcatenativeな言語とは何なのか、自分なりの理解を書いておきたいと思います。あまり技術的な解説などはなく、感想などがメインです。コードは最下部にあります。

Concatenativeに対する理解

Concatenativeな言語の説明として、Forthを出発点としたのもあって、以下のようなものが多いように思えます。

> 1 2 +
これは、1をスタックに積み、2をスタックに積み、
スタックから2つの数を取り、合計をスタックに置く
+というワードを適用します

たしかに+というワードが2つの引数を取るように見えます。しかし私の理解は違って、ワード(関数)は全て、スタックを取りスタックを返す一引数関数と見なすことができ、命令列は全て関数適用の連鎖(Concatenate)である、というのがConcatenativeな言語の本質だと考えています。

f g h というコードは、h(g(f(stack)))というスタックへの関数適用だと見なせます。1 2 +というコードは、

  • スタックを取り、1を置いたスタックを返す関数
  • スタックを取り、2を置いたスタックを返す関数
  • スタックを取り、スタックの上2つの数字を足したスタックを返す関数

の連鎖です。データに見える1や2も全て関数と見なせます。

更に、Joyという言語が最初だったかと思いますが、Concatenativeな発想に併せてクォーテーションというものが導入されました。(のだろうと思います)

簡単に言うとλであり、例えばFactorで[ 1 + ]なら「1 +を実行する無名関数」を表します。これによって高階関数など関数型の利点を発揮できるようになりました。

私の考えるForth/Concatenativeの利点は

  • ネストしないので、関数適用の層を気兼ねなく使える。hoge(fuga(bar(foo(x, y)), z), a b)のような適用を、x y foo z bar fuga a b hogeとそのまま書き下せる。もしfugaをfizzで囲む必要ができても、bar fuga a bの部分をbar fuga fizz a bと書き直すだけでよい
  • ワード(関数)定義に切り出しやすい。foo z bar fugaに名前をつけられそうなら、: do-thing foo z bar fuga ;と持ってくるだけで良い場合が多く、精神的に楽
  • 上2つにより、REPLで少しずつ関数を作っていくのが非常に楽になる。少しずつ継ぎ足しながら結果を見て、長くなったら切り出して名前をつければ良い
  • λも[ foo bar ]と短く書けるものだと、高階関数の動きなども素早く試すことができる

というところです。

更に今回プリミティブなものを作るにあたって、クォーテーションを単純なリストで表すことで、リーダの先読み操作と併せて[ ]の定義すら自分でできないか、挑戦してみました。

Common Lispによるプロトタイプ作成

前回は最初からJavaScriptで作ったわけですが、リーダ部分やインターフェイスの動きなどを書いていくうちに、破棄したくなくなってしまいました。

普通のアプリケーションならなんとかなったり(目を逸らしたり)しますが、言語処理系の作成では、Forthのようにシンプルなものでも構造を書き直していくのは容易ではありません。(私の場合は、です)

そこで書いては捨てることを前提に、Common Lispで書くことにしました。シンボルやデータは全てCommon Lispのものを使い、コードはLispのリストです。

流石に記号処理は強いな、という感想でした。3回ほど最初から書きなおしましたが、動くとこに持っていくまでの早さが素晴らしいです。特に残念な部分も……SBCLのエラーメッセージが少し分かりづらいことぐらいでした。

ワードの構造について

今回は「再帰が可能である」「シンボルをクォーテーション内に含めることができる」という仕様にしました。

Forthには、処理系自体にコンパイルモードと実行モードがあります。コンパイルモードでは、読み込んだワード名を次々にそのワードのアドレスなどに変換していきます。そのコンパイルモード中でも読み取った途端に動作する、immediateフラグを与えたワードなどで構文を拡張していくことができます。

Factorの方は、各ワードにparsing-wordフラグがあり、パーシングを行うワードそれぞれがそのフラグを見て動作を決めているようです。今回はこちらです。

クォーテーション内にワードへのポインタを並べた場合、再帰が難しくなってしまいます。前方で宣言しておかないといけません。(この単純な事実に気づかずに、どうにかクォートしようと四苦八苦してました……)

ワード名のシンボルを並べた場合は、シンボルを置くことができなくなってしまいます。

そこで、環境から引くワードの名前を持った、word-refを並べていくという構造にしました。

[ word :immediate? :native? ]
  |
[ closure :env ] - [ word-ref + ]
                   [ word-ref dup ]
                   [ 3 ]

こんなカンジの構造です。closureが持つクォーテーション本体は、コンスリストです。

Forthでは基本的に自分より前に定義されたワードを参照して、同じワードを何度も定義して機能を追加していくようです。自分の再帰の利用頻度を考えると、loop/recurをつけたり、自己参照可能にする宣言をつけたりすれば、Forthのやり方でいいのかもなとも思います。

同じワードを再定義して機能追加するスタイルも試してみたいところです。コンパイルモード/実行モードのやり方で、ワードのアドレス/参照を置いていくやり方でクォーテーションを実現する実験も取り掛かりたいと思います。

実装した感想

前回もですが、段々と自分て構文を定義することで短くなっていくのは、何か育てゲーをやってるようで非常に楽しいです。特に今回は[ ]の定義を言語自身でやるということで、実際に使えた瞬間は感動しました。

ただ難関はその後で、シンタックスを定義するためのワードは結局できませんでした。単に命令が並んだリストの操作ならLispのマクロと同じように作れるかな、と思ったんですが、自分自身でdefmacroを定義するようなものなので混乱しました。ここらへんはForthのWORDなどに慣れた人や、Lispのマクロを駆使できる人ならすぐに実装できるのかもしれません。

自身で拡張した構文での例を載せておきます。

Lispのシンボルなどをそのまま使ってリストでコードを表現しているので、(forth '(1 2 +))と命令のリストを渡すことで実行できます。それを省略して命令と結果だけ書きます。また、スタックはforth関数呼び出しの度に生成されるので、実際には全部つなげて書く必要があります。

> [def hello 1 + set-token> hello ]

> 0 hello
(hello 1)

> call
(hello 2)

> call call call
(hello 5)

リストからクォーテーション生成

> 1 list cons set-token> + push
((1 +))

> drop

> [def adder list cons set-token> + symbol->word-ref push reverse >quotation ]

> 2 adder def> 2+

> 3 2+
(5)

curryを使って簡単に書く

> 2 1 [ + ] curry call
(3)

> drop

> [def adder [ + ] curry ]

> 3 adder def> 3+

> 4 3+
(7)

ネストしたクォーテーション

> [def equaler [ eq? [ set-token> equal! ] [ set-token> not-equal! ] if ] curry ]

> 3 3 equaler call
(EQUAL!)

> 10 equaler def> equal-10?

> 11 equal-10?
(NOT-EQUAL!)

map

> list[ 1 2 3 ] [ 10 * ] map
((10 20 30))

> drop

> list[ 1 2 3 4 5 ] [ dup * ] map
((1 4 9 16 25))

コード

SBCL/SLIMEで動作確認してます。[syntaxは思うように動きません。。

自身での拡張は下の方にあります。

(ql:quickload "alexandria")

;;; Environment
;;; ============================================================================

(defun make-environment (&key (variables (make-hash-table)) (parent nil) (reader nil))
  (alexandria:plist-hash-table
   (list :variables variables
         :reader reader
         :parent parent
         :id (gensym))))

(defun env->reader (env)
  (gethash :reader env))

(defun read-code-from-env (env)
  (funcall (env->reader env)))

(defun parent-env (env)
  (gethash :parent env))

(defun root-env-p (env)
  (not (gethash :parent env)))

(defun root-env (env)
  (if (root-env-p env) env (root-env (parent-env env))))

(defun no-word-error (word-name)
  (error (format nil "Word: ~S is not defined." word-name)))

(defun lookup (env key &key (no-error nil))
  (multiple-value-bind (value has-key?)
      (gethash key (gethash :variables env))
    (cond
      (has-key? value)
      ((and (root-env-p env))
       (if no-error nil (no-word-error key)))
      (t (lookup (parent-env env) key :no-error no-error)))))

(defun lookup-word (env word-ref &key (no-error nil))
  (lookup env (gethash :name word-ref) :no-error no-error))

(defun regist (env key value)
  (let ((vs (gethash :variables env)))
    (setf (gethash key vs) value)))

(defun set-immediate! (env name)
  (let ((word (lookup env name)))
    (setf (gethash :immediate? word) t)))

(defun make-child-env (parent &key (reader nil))
  (make-environment :parent parent
                    :reader (or reader (env->reader parent))))


;;; Word Definition
;;; ============================================================================

(defun make-word (code &key (source nil) (native? nil) (immediate? nil))
  (alexandria:plist-hash-table
   (list :type :word
         :code code
         :native? native?
         :immediate? immediate?
         :source source)))

(defun make-word-ref (name &key (source nil))
  (alexandria:plist-hash-table
   (list :type :word-ref
         :name name
         :source source)))

(defun make-closure (body parent-env)
  (alexandria:plist-hash-table
   (list :type :closure
         :body body
         :env (make-child-env parent-env))))

(defun word-p (word)
  (and (hash-table-p word)
       (eq (gethash :type word) :word)))

(defun closure-p (item)
  (and (hash-table-p item)
       (eq (gethash :type item) :closure)))

(defun native-word-p (word)
  (gethash :native? word))

(defun quotation-code (word)
  (gethash :code word))

(defun quotation-body (word)
  (closure-body (gethash :code word)))

(defun quotation-env (word)
  (closure-env (gethash :code word)))

(defun closure-body (code)
  (gethash :body code))

(defun closure-env (code)
  (gethash :env code))

(defun word-ref-p (word-ref)
  (and (hash-table-p word-ref)
       (eq (gethash :type word-ref) :word-ref)))

(defun immediate-word-p (word)
  (and word (word-p word)
       (gethash :immediate? word)))

;;; Word Call
;;; ============================================================================

(defun call-word (word stack env)
  (if (word-ref-p word)
      (call-word-ref word stack env)
      (cons word stack)))

(defun call-word-ref (word-ref stack env)
  (let ((word (lookup-word env word-ref)))
    (if (native-word-p word)
        (call-native word stack env)
        (call-quotation (quotation-body word) stack (quotation-env word)))))

(defun call-native (word stack env)
  (funcall (gethash :code word) stack env))

(defun call-closure (closure stack env)
  (declare (ignorable env))
  (call-quotation (closure-body closure) stack (closure-env closure)))

(defun call-quotation (code stack env)
  (let ((word (car code))
        (rest (cdr code)))
    (if (null word) stack
        (call-quotation rest (call-word word stack env) env))))


;;; Reader
;;; ============================================================================

(defun make-reader (code)
  (lambda ()
    (let ((word (car code)))
      (setf code (cdr code))
      word)))


;;; Eval Code
;;; ============================================================================

(defun eval-code (code stack env)
  (if (symbolp code)
      (call-word (make-word-ref code) stack env)
      (cons code stack)))


;;; BuiltIn Words
;;; ============================================================================

(defun make-stack-op (f)
  (make-word
   (lambda (stack env)
     (declare (ignore env))
     (funcall f stack))
   :native? t))

(defun make-op0 (f)
  (make-word
   (lambda (stack env)
     (declare (ignore env))
     (cons (funcall f) stack))
   :native? t))

(defun make-op1 (f)
  (make-word
   (lambda (stack env)
     (declare (ignore env))
     (cons (funcall f (car stack)) (cdr stack)))
   :native? t))

(defun make-op1-env (f)
  (make-word
   (lambda (stack env)
     (cons (funcall f env (car stack)) (cdr stack)))
   :native? t))

(defun make-op2 (f)
  (make-word
   (lambda (stack env)
     (declare (ignore env))
     (cons (funcall f (second stack) (first stack))
           (cddr stack)))
   :native? t))

(defun make-op2-env (f)
  (make-word
   (lambda (stack env)
     (cons (funcall f env (second stack) (first stack))
           (cddr stack)))
   :native? t))

(defun word-dup (stack)
  (cons (car stack) stack))

(defun word-swap (stack)
  (cons (second stack)
        (cons (first stack)
              (cddr stack))))

(defun word-drop (stack) (cdr stack))

(defun word-rot (stack)
  (cons (second stack)
        (cons (third stack)
              (cons (first stack)
                    (cdddr stack)))))

(defun word-def! (stack env)
  ;; define at root environment
  (let* ((name (first stack))
         (quot (second stack))
         (stack (cddr stack))
         (env (root-env env)))
    (regist env name (make-word quot))
    stack))

(defun word-def (stack env)
  ;; define at local environment
  (let* ((name (first stack))
         (quot (second stack))
         (stack (cddr stack)))
    (regist env name (make-word quot))
    stack))

(defun word-immediate! (stack env)
  (let* ((name (first stack)) 
         (stack (cdr stack)))
    (set-immediate! env name)
    stack))

(defun word->quotation (stack env)
  (let* ((src   (car stack))
         (stack (cdr stack))
         (closure (make-closure src env)))
    (cons closure stack)))

(defun word-call (stack env)
  (let* ((word  (car stack))
         (stack (cdr stack)))
    (cond
      ((closure-p word) (call-closure word stack env))
      ((word-ref-p word) (call-word word stack env))
      (t (eval-code word stack env)))))

(defun word-read-token (stack env)
  (let ((token (read-code-from-env env)))
    (cons token stack)))

(defun word-symbol->word-ref (sym)
  (if (symbolp sym) (make-word-ref sym) sym))

(defun word-curry (word closure)
  (let* ((env  (closure-env closure))
         (body (cons word (closure-body closure))))
    (make-closure body env)))

(defun word-true  (tq fq) (declare (ignore fq)) tq)
(defun word-false (tq fq) (declare (ignore tq)) fq)

(defun quoted-true (env)
  (make-closure (list (make-word-ref 'true)) env))

(defun quoted-false (env)
  (make-closure (list (make-word-ref 'false)) env))

(defun word-eq? (env a b)
  (if (equal a b) (quoted-true env) (quoted-false env)))

(defun word-null? (env x)
  (if (null x) (quoted-true env) (quoted-false env)))

(defun word-immediate? (stack env)
  (let* ((word  (car stack))
         (stack (cdr stack)))
    (cons
     (cond
       ((immediate-word-p word) (quoted-true env))
       ((and (word-ref-p word)
             (immediate-word-p (lookup-word env word :no-error t)))
        (quoted-true env))
       (t (quoted-false env)))
     stack)))


(defvar builtin-words)
(setf builtin-words
      (alexandria:plist-hash-table
       (list

        ;; stack operation
        'dup  (make-stack-op #'word-dup)
        'swap (make-stack-op #'word-swap)
        'drop (make-stack-op #'word-drop)
        'rot  (make-stack-op #'word-rot)

        ;; list operation
        'list  (make-op0 #'list)
        'cons  (make-op2 #'cons)
        'reverse (make-op1 #'reverse)
        'none (make-op1 #'identity)
        'first  (make-op1 #'car)
        'rest (make-op1 #'cdr)
        'null? (make-op1-env #'word-null?)

        ;; variable
        'def! (make-word #'word-def! :native? t)
        'def  (make-word #'word-def :native? t)
        'immediate! (make-word #'word-immediate! :native? t)

        ;; word/quotation
        '>quotation (make-word #'word->quotation :native? t)
        'call  (make-word #'word-call :native? t)
        'read-token (make-word #'word-read-token :native? t)
        'symbol->word-ref (make-op1 #'word-symbol->word-ref)
        'curry (make-op2 #'word-curry)

        ;; math
        '+ (make-op2 #'+)
        '- (make-op2 #'-)
        '* (make-op2 #'*)
        '/ (make-op2 #'/)

        ;; boolean
        'true  (make-op2 #'word-true)
        'false (make-op2 #'word-false)
        'eq?   (make-op2-env #'word-eq?)
        'immediate? (make-word #'word-immediate? :native? t)
        )))

(defun default-environment (reader)
  (make-environment :variables builtin-words
                    :reader reader))

;;; Library
;;; ============================================================================
(defvar library)
(setf library
      '(
        ;; read-wref
        ;; [ read-token symbol->word-ref ]
        read-token read-token symbol->word-ref
        read-token symbol->word-ref symbol->word-ref
        list cons cons >quotation
        read-token read-wref def!

        ;; def>
        ;; [ read-token def! ]
        read-wref read-token read-wref def!
        list cons cons >quotation read-token def> def!

        ;; -rot
        ;; [ rot rot ]
        read-wref rot read-wref rot
        list cons cons >quotation def> -rot

        ;; if
        ;; [ -rot call call ]
        read-wref -rot read-wref call read-wref call
        list cons cons cons >quotation def> if

        ;; n-read-wref
        ;; [ dup 0 eq? [ drop ] [ 1 - read-wref swap n-read-wref ] if ]
        read-wref dup 0 read-wref eq?
        read-wref drop list cons >quotation
        1 read-wref - read-wref read-wref read-wref swap
        read-wref n-read-wref list cons cons cons cons cons >quotation
        read-wref if list cons cons cons cons cons cons >quotation
        def> n-read-wref

        ;; n-cons
        ;; [ dup 0 eq? [ drop ] [ 1 - rot cons swap n-cons ] if ]
        3 n-read-wref dup 0 eq?
        read-wref drop list cons >quotation
        6 n-read-wref 1 - rot cons swap n-cons
        list cons cons cons cons cons cons >quotation
        read-wref if list cons cons cons cons cons cons >quotation
        def> n-cons

        ;; n-list
        ;; ( n -- list )
        ;; [ list swap n-cons ]
        3 n-read-wref list swap n-cons list 3 n-cons >quotation def> n-list

        ;; n-quot
        ;; ( n -- quot )
        ;; [ n-list >quotation ]
        2 n-read-wref n-list >quotation 2 n-list >quotation def> n-quot

        ;; double-dup
        ;; ( a b -- a b a b )
        ;; [ swap dup -rot dup rot ]
        5 n-read-wref swap dup -rot dup rot 5 n-quot def> double-dup
        
        ;; dup-eq?
        ;; ( a b -- a b t/f )
        ;; [ double-dup eq? ]
        2 n-read-wref double-dup eq? 2 n-quot def> dup-eq?

        ;; roll
        ;; ( a b c -- c b a )
        ;; [ rot swap ]
        2 n-read-wref rot swap 2 n-quot def> roll

        ;; over-cons
        ;; ( x _ list -- list _ )
        ;; [ -rot swap cons swap ]
        4 n-read-wref -rot swap cons swap 4 n-quot def> over-cons

        ;; push
        ;; ( list x -- list )
        2 n-read-wref swap cons 2 n-quot def> push

        ;; 2swap
        ;; ( a b c -- b a c )
        2 n-read-wref swap rot 2 n-quot def> 2swap

        ;; [ quotation ]
        ;; ---------------------------------------------------------------------
        ;; read-token-and-cons-until
        ;; ( list end -- list )
        ;; [ read-token dup-eq?
        ;;     [ drop drop ]
        ;;     [ symbol->word-ref dup immediate?
        ;;         [ swap rot call push swap read-token-and-cons-until ]
        ;;         [ roll over-cons read-token-acnd-cons-until ] if ]
        ;; if ]
        2 n-read-wref read-token dup-eq?
        2 n-read-wref drop drop 2 n-quot
        3 n-read-wref symbol->word-ref dup immediate?
        5 n-read-wref 2swap call push swap read-token-and-cons-until 5 n-quot
        3 n-read-wref roll over-cons read-token-and-cons-until 3 n-quot
        read-wref if 6 n-quot
        read-wref if 5 n-quot
        def> read-token-and-cons-until

        ;; [ ]
        ;; [ list set-token> ] read-token-and-cons-until reverse >quotation ]
        
        read-wref list read-token ]
        3 n-read-wref read-token-and-cons-until reverse >quotation
        5 n-quot def> [
        read-token [ immediate!

        [ 1 + ] def> inc
        [ 1 - ] def> dec

        [ [ none ] if ] def> when
        [ [ none ] swap if ] def> unless

        ;; set word to immediate
        [ read-token immediate! ] def> immediate>
        
        ;; set-token>
        ;; example: [ 1 2 drop ] -- [ 1 2 (WORD-REF) ]
        ;;          [ 1 2 set-token> drop ] -- [ 1 2 drop ]
        [ read-token ] def> set-token>
        immediate> set-token>

        ;; quote-until
        ;; ( end -- quot )
        [ list swap read-token-and-cons-until reverse >quotation ] def> quote-until

        ;; [def
        ;; example: [def square dup * ]
        [ read-token set-token> ] quote-until swap def! ] def> [def

        ;; list/
        ;; ( x:xs -- xs x )
        [def list/ dup rest swap first ]

        ;; read-wref>
        [def read-wref> read-wref ]
        immediate> read-wref>

        ;; append
        ;; ( xs ys -- xs-ys )
        [def append
        swap dup null? [ drop ]
        [ list/ rot swap append cons ] if ]

        ;; map
        ;; ( xs f -- xs )
        [def map
        swap dup null? [ swap drop ]
        [ list/ -rot dup rot call rot map cons ]
        if ]

        ;; list
        [def list[ list set-token> ] read-token-and-cons-until reverse ]
        immediate> list[
        
        ;; syntax
        ;; [syntax hoge ( read-words -- read-words add-words ) ]
        [def syntax-finish swap append list/ ]
        [def [syntax
        read-token ;; sytnax name
        list set-token> ] read-token-and-cons-until
        set-token> syntax-finish symbol->word-ref push reverse >quotation
        swap def! ]
        ))

;;; Interpreter
;;; ============================================================================

(defun forth-interpreter (stack env)
  (let ((code (read-code-from-env env)))
    (if (null code) stack
        (forth-interpreter (eval-code code stack env) env))))

(defun forth (code)
  (let* ((stack (list))
         (code (append library code))
         (reader (make-reader code))
         (env (default-environment reader)))
    (forth-interpreter stack env)))
広告を非表示にする