LISPUSER

LISPMEMOLisp isn't a language, it's a building material. -- Alan Kay

(top)  (memo)  (rss)

最高にキモい Lisp コードを書いてみよう with 100 行リーダーマクロ

Ruby 方面でみかけたネタに触発されました.Lisp はプログラマブルな言語な のでリーダーもプログラマブルです.そこでリーダーをいじって let や defun などの構文を括弧じゃなくて end にでもしてみましょうか.

100 行程度を目標にトライしました.使ったライブラリは CL-Yacc のみです. できあがったのがこちら.

#@suck-lisp

defun fib (n)
  if (< n 0)
    (error "oops")
  elif (= n 0)
    0
  elif (= n 1)
    1
  else
    let
      x <- (fib (- n 1))
      y <- (fib (- n 2))
    in
      (+ x y)
    end
  end
end

defun f (lst)
  (print-lst lst)
end
    
defun print-lst (lst)
   when lst
      let
         x  <- (car lst)
         xs <- (cdr lst)
      in
         (print x)
         (print-lst xs)
      end
   end
end
    
defun walk (dir)
  let
     files <- nil
     dirs <- (cl-fad:list-directory dir)
  in
     (dolist (d dirs)
       if (cl-fad:directory-exists-p d)
          (setf files (append files (walk d)))
       else
          (push d files)
       end)
     files
  end
end

defun print-file-list ()
  (loop for e in (walk "./") do (format t "~A~&" e))
end

これは Common Lisp です.括弧が足りなくない?とお疑いの人のために read で読み込んでみます.

CL-USER> (read-from-string "#@suck-lisp
   
   defun fib (n)
     if (< n 0)
       (error \"oops\")
     elif (= n 0)
       0
     elif (= n 1)
       1
     else
       let
         x <- (fib (- n 1))
         y <- (fib (- n 2))
       in
         (+ x y)
       end
     end
   end")
(progn
(defun fib (n)
 (if (< n 0) (progn (error "oops"))
  (if (= n 0) (progn 0)
   (if (= n 1) (progn 1)
    (progn (let ((x (fib (- n 1))) (y (fib (- n 2)))) (+ x y))))))))
276
CL-USER> 

いかにも機械変換な汚ないコードですが,ちゃんと S 式として読み取られてい ます.

まぁ,これは小規模な例ですが実際には S 式を生のまま見せずにユーザーフレ ンドリな形式を用意するのは良くある例です.そこで,今回は上記のミニ言語 をネタに CL-Yacc 入門です.

CL-YACC ガイド

CL-Yacc は Lisp 用のパーサジェネレータです.他にも Zebu, Meta, LALR な どいくつかあります.

一般にコンパイラが行う作業は 字句解析 -> 構文解析 -> 意味解析 -> コード 生成 ですが,別にコンパイラを目標にしなくても,それぞれの段階だけでも十 分に有用です.たとえば,字句解析 -> 意味解析のレベルだけでも下記のよう な用途が考えられます.

  • 特定目的の簡易言語を作成し,それを **Lisp に変換する**
    • 普段利用している Lisp コンパイラの機能を利用できる
  • S 式でないデータを S 式表現に変換 してから操作する
    • 操作がカンタン
    • 別フォーマットへの変換が楽

Lisp では「字句解析 -> 構文解析」を行う **read 関数** が標準で備わって います.S 式で全てが済めばこれで十分なケースも多いのですが,残念ながら 世の中には S 式を嫌う人が多いようです.なんといっても,実際世の中に S 式ではないデータが溢れている現状では理想だけでは生きていけません.

CL-Yacc の基本

  • define-parser : パーサを定義する
  • parse-with-lexer : パーサを使う

この二つをつかいますが,まず目標を決めましょう.defun や if,let といっ た構文を非 S 式的表現であらわすようにします.つまり `(defun )` では なく `defun end` に,`(if )` ではなく `if end` に,`(let )` ではなく `let end` に変更します.

;; defun 構文
(defun 関数名 (引数 ...)
   処理)
↓
defun 関数名 (引数 ...)
   処理
end

;; if 構文
(if 条件
  真の場合の処理
  偽の場合の処理)
↓
if 条件
   真の場合の処理
else
   偽の場合の処理
end

;; let 構文
(let ((変数  値)
      (変数  値)
      (変数  値))
   式)
↓
let
   変数 <- 値
   変数 <- 値
in
   式
end

こんな感じ.

字句解析


ではサンプルを元に字句解析器を考えましょう.基本的に使える 式やシンボルは Lisp と完全互換にするため(read で読みとって手抜きするた め),各トークンの区切りは空白が必要という事にします.

いま考えた構文より,少なくとも終端記号として defun, if, let, は必要であ る事がわかります.それ以外はシンボルも文字も数値も atom としてしまいま しょう.また付随する構文要素 else や <- も用意します.

また,リスト中で構文をつかうために '(1 2 3) のようなリストにたいして read を呼ばずに lparen atom atom atom rparen のように S 式解析を自 前でおこないます.

;; サンプル
defun fib (n)
  if (< n 2)
     n
  else
     let
        n1 <- (fib (- n 1))
        n2 <- (fib (- n 2))
     in
        (+ n1 n2)
     end
  end
end

lexer は,これを次のように字句解析しなければなりません.

defun  :   (:defun 'defun)
fib    :   (:atom  'fib)
(      :   (:lparen '|(|)
n      :   (:atom  'n)
)      :   (:rparen '|)|)
if     :   (:if     'if)
(      :   (:lparen '|(|)
<      :   (:atom   '<)
n      :   (:atom   'n)
2      :   (:atom   2)
)      :   (:atom   '|)|)
n      :   (:atom   'n)
else   :   (:else   'else)
let    :   (:let    'let)
n1     :   (:atom   'n1)
<-     :   (:<-     '<-)
(      :   (:lparen '|)|)
fib    :   (:fib    'fib)
(      :   (:rparen '|)|)
-      :   (:atom   '-)
n      :   (:atom   'n)
1      :   (:atom   1)
)      :   (:rparen '|)|)
)      :   (:rparen '|)|)
n2     :   (:atom   'n2)
<-     :   (:<-     '<-)
(      :   (:lparen '|(|)
fib    :   (:atom   'fib)
(      :   (:lparen '|(|)
-      :   (:atom   '-)
n      :   (:atom   'n)
2      :   (:atom   2)
)      :   (:rparen '|)|)
)      :   (:rparen '|)|)
in     :   (:in   'in)
(      :   (:lparen '|(|)
+      :   (:atom   '+)
n1     :   (:atom   'n1)
n2     :   (:atom   'n2)
)      :   (:rparen '|)|)
end    :   (:end 'end)
end    :   (:end 'end)
end    :   (:end 'end)

面倒なので,() 以外は Lisp 標準の read に頼ります.

(defun lexer (stream)
  (let ((c (peek-char t stream nil :eof)))  ;; 一文字先読み
    (case c
      (:eof  (values nil nil))
      (#\(   (values :lparen (read-char stream)))
      (#\)   (values :rparen (read-char stream)))
      (t
         (let ((e (read stream)))
            (typecase e
              (symbol
                (cond ((string-equal (symbol-name e) "defun")
                       (values :let e))
                      ((string-equal (symbol-name e) "if")
                       (values :if e))
                      ((string-equal (symbol-name e) "else")
                       (values :if e))
                      ((or (string-equal (symbol-name e) "let")
                           (string-equal (symbol-name e) "let*"))
                       (values :let e))
                      ((string-equal (symbol-name e) "<-")
                       (values :<- e))
                      ((string-equal (symbol-name e) "in")
                       (values :in e))
                      ((string-equal (symbol-name e) "end")
                       (values :end e))
                      (t
                       (values :atom e))))
             (t
                (values :atom e))))))))

つくったら早速 REPL で試してみましょう.

CL-USER> (defparameter *sample* "    ;; サンプル
    defun fib (n)
      if (< n 2)
         n
      else
         let
            n1 <- (fib (- n 1))
            n2 <- (fib (- n 2))
         in
            (+ n1 n2)
         end
      end
    end
")
*sample*
CL-USER> (with-input-from-string (s *sample*)
            (loop
               (multiple-value-bind (tok val)
                   (lexer s)
                 (format t "(~S ~S)~&" tok val)
                 (unless tok (return)))))
(:def defun)
(:atom fib)
(:lparen #\()
(:atom n)
(:rparen #\))
(:if if)
(:lparen #\()
(:atom <)
(:atom n)
(:atom 2)
(:rparen #\))
(:atom n)
(:else else)
(:let let)
(:atom n1)
(:<- <-)
(:lparen #\()
(:atom fib)
(:lparen #\()
(:atom -)
(:atom n)
(:atom 1)
(:rparen #\))
(:rparen #\))
(:atom n2)
(:<- <-)
(:lparen #\()
(:atom fib)
(:lparen #\()
(:atom -)
(:atom n)
(:atom 2)
(:rparen #\))
(:rparen #\))
(:in in)
(:lparen #\()
(:atom +)
(:atom n1)
(:atom n2)
(:rparen #\))
(:end end)
(:end end)
(:end end)
(nil nil)

nil
CL-USER> 

このとおり字句解析できました.次はこれを構文解析しましょう.

構文解析 - S 式の基礎

CL-Yacc の構文定義には define-parser を使います.

(define-parser *parser-1*
  (:start-symbol program)
  (:terminals (:def :if :else :let :<- :in :end :lparen :rparen :atom))
  ...

まず最初の状態として,このパーサーで解析するのはプログラムですから program とします.そして lexer て定義した終端記号をずらずらと並べます. ここまでできたら,いよいよ本題の構文を定義します.

;; プログラムは複数の式から構成されます.
;; プログラム -> 式*
(program exprs)

;; 複数の式 (= 式*) は一つ以上の式から構成されます
(exprs
  (exprs expr)
  (expr))

では式を定義しましょう.とうぜん式は S 式だと考えてください.S 式は アトムもしくはリストです.

;; 式はリストかアトム
(expr
   list
   :atom)

そしてリストは括弧で囲まれた式から構成されます.

;; リストは ( ) もしくは ( 式* )
(list
  (:lparen :rparen)
  (:lparen exprs :rparen)

もし貴方が病的に括弧を嫌いでなければ,ほぼこれで構文定義終了なんです が….次にルールにアクションを定義してやります.アクションは,ルールの 値をすべて引数にとる関数を指定します.面倒なので無名関数で済ませます. 引数名は通常の関数と同様,意味のある名前をつけてもいいんですが,yacc に 習って順番に $1 $2 のように位置を表わす名前をつかいます.

(list
  (:lparen :rparen        #'(lambda ($1 $2) nil))
  (:lparen exprs :rparen  #'(lambda ($1 $2 $3) $2)))

解説しますと,:lparen の値は #\(, :rparen の値は #\) として帰ってきます が,たとえば () は nil になってほしいわけです.これが '(#\( #\)) だった ら鬱になりますよね?そこでアクション部で nil を返すように定義しています. 同様に要素を持つ場合も #\( #\) を無視して式を表わすリストを返すようにア クションを定義しています.

まぁ,実際に動かしてもらったほうが理解がはやいと思うのでまず S 式をパー スするパーサーを定義します.

(define-parser *parser-0*
  (:start-symbol program)
  (:terminals (:def :if :else :let :<- :in :end :lparen :rparen :atom))

  (program exprs)

  (exprs
   (expr exprs      #'(lambda ($1 $2) (cons $1 $2)))
   (expr            #'(lambda ($1) (list $1))))

  (expr
   list
   :atom)
  
  (list
    (:lparen :rparen       #'(lambda ($1 $2) ()))
    (:lparen exprs :rparen #'(lambda ($1 $2 $3) (list $2)))))

まだ defun や if や let を入力するとエラーになりますが,これを動作させ てみましょう.

CL-USER> (with-input-from-string (s "(20 (20)) (foo bar)")
           (parse-with-lexer 
              #'(lambda () (multiple-value-bind (x y) (lexer s) (format t "~A,~A~&" x y) (values x y)))
              *parser-0*))
lparen,(
atom,20
lparen,(
atom,20
rparen,)
rparen,)
lparen,(
atom,foo
atom,bar
rparen,)
nil,nil
((20 (20)) (foo bar))
CL-USER> 

ちゃんと入れ子になったリストも解析できました!!この段階でいろいろ入力して試しておきましょう.

構文解析 - 拡張編

では,最初に考えた構文を CL-Yacc 形式で見直してみましょう.字句解析は済んでいるとします.

;; defun 構文
(defun 関数名 (引数 ...)
   処理)
↓
defun 関数名 (引数 ...)
   処理
end
[CL-Yacc]
(:defun :atom :list exprs :end)

簡単ですねー.

;; if 構文
(if 条件
  真の場合の処理
  偽の場合の処理)
↓
if 条件
   真の場合の処理
else
   偽の場合の処理
end

[CL-Yacc]
(:if expr exprs :end) ;; else 節無しの場合
(:if expr exprs :else exprs :end) ;; else 節ありの場合

else の有無で二つのルールになります.なんかあまりにシンプルでおもしろく なさそうなので,次の let は妙な代入を導入して一捻りしてあります.

;; let 構文
(let ((変数  値)
      (変数  値)
      (変数  値))
   式)
↓
let
   変数 <- 値
   変数 <- 値
in
   式
end

[CL-Yacc]
(:let var-form :in exprs :end)
;; var-form は (atom :<- expr) のリストとする

どうでしょうか.あとは式の定義を拡張しておきましょう.

(expr
  list
  :atom)

↓

(expr
  def-form  ;; defun 構文
  if-form   ;; if 構文
  let-form  ;; let 構文
  list
  :atom)

これで expr が入る場所にはどこにでも構文が使えるようになりました.

(define-parser *parser-1*
  (:start-symbol program)
  (:terminals (:def :if :else :let :<- :in :end :lparen :rparen :atom))

  (program (exprs  #'(lambda ($1) (cons 'progn $1))))

  (exprs
   (expr exprs      #'(lambda ($1 $2) (cons $1 $2)))
   (expr            #'(lambda ($1) (list $1))))

  (expr
   def-form
   if-form
   let-form
   list
   :atom)

  (list
   (:lparen :rparen
                   #'(lambda ($1 $2) '()))
   (:lparen exprs :rparen
                   #'(lambda ($1 $2 $3) $2)))

  (def-form
   (:def :atom list exprs :end
                   #'(lambda ($1 $2 $3 $4 $5) `(,$1 ,$2 ,$3 ,@$4))))
  (if-form
   (:if expr exprs :end
                   #'(lambda ($1 $2 $3 $4) `(,$1 ,$2 (progn ,@$3))))
   (:if expr exprs :else exprs :end
                   #'(lambda ($1 $2 $3 $4 $5 $6) `(,$1 ,$2 (progn ,@$3) (progn ,@$5)))))
  (let-form
   (:let var-form :in exprs :end
                   #'(lambda ($1 $2 $3 $4 $5) `(,$1 ,$2 ,@$4))))
  (var-form
   (var var-form   #'(lambda ($1 $2) (cons $1 $2)))
   (var            #'(lambda ($1) (list $1))))

  (var
   (:atom :<- expr #'(lambda ($1 $2 $3) `(,$1 ,$3)))))
CL-USER> (defparameter *sample* "    ;; サンプル
        defun fib (n)
          if (< n 2)
             n
          else
             let
                n1 <- (fib (- n 1))
                n2 <- (fib (- n 2))
             in
                (+ n1 n2)
             end
          end
        end
    ")
CL-USER> (with-input-from-string (s *sample*)
           (parse-with-lexer 
           #'(lambda () (multiple-value-bind (x y) (lexer s) (format t "~A,~A~&" x y) (values x y)))
           *parser-1*))
def,defun
atom,fib
lparen,(
atom,n
rparen,)
if,if
lparen,(
atom,<
atom,n
atom,2
rparen,)
atom,n
else,else
let,let
atom,n1
<-,<-
lparen,(
atom,fib
lparen,(
atom,-
atom,n
atom,1
rparen,)
rparen,)
atom,n2
<-,<-
lparen,(
atom,fib
lparen,(
atom,-
atom,n
atom,2
rparen,)
rparen,)
in,in
lparen,(
atom,+
atom,n1
atom,n2
rparen,)
end,end
end,end
end,end
nil,nil

(progn
 (defun fib (n)
  (if (< n 2) (progn n)
   (progn (let ((n1 (fib (- n 1))) (n2 (fib (- n 2)))) (+ n1 n2))))))
CL-USER> 

できました.

リーダーマクロ

この非 S 式構文パーサーですが,このままではストリームを解析 する機能しかありません.通常の Lisp のように書くにはどうしたら良いでしょうか? 普通に考えれば,このパーサーをつかってソースを読み込んで解釈する関数を作る事になるでしょう.

(defun load-with-new-syntax (file)
  (with-open-file (s file :direction :input)
    (eval
      (parse-with-lexer #'(lambda () (lexer s)) *parser-1*))))

Lisp でも同様の事はできますが,ここでもう一つの Lisp のマイナー機能リー ダーマクロに目を向けましょう.Lisp 経験の浅い人には聞き慣れない用語かも しれませんが,実は普段使っているベクタ表記 `#()` や虚数を表わす `#C(0 1)` ,複数行コメントの `#| |#` などもリーダーマクロです.これ は,リード時(Lisp の字句解析時)に展開されるマクロであるため,リーダー マクロと呼ばれています.

では,早速リーダーマクロを作成しましょう.作りたいのは次のようなリーダー マクロです.

#@new-syntax ;; これ以降の行は全て新しい構文で解釈される

defun fib (n)
   if (<= n 1)
      n
   else
      let
         n1 <- (fib (- n 1))
         n2 <- (fib (- n 2))
      in
        (+ n1 n2)
      end
   end
end
(defun new-syntax-reader (stream)
  (read-line stream nil :eof)
  (yacc::parse-with-lexer #'(lambda () (lexer stream)) *parser-1*))

(defun sharp-at-reader (stream c1 c2)
  (new-syntax-reader stream))

(set-dispatch-macro-character #\# #\@ #'sharp-at-reader)

これだけです.これだと `#@` の行は読み飛ばされるようになっていますので 何を書いても構文が切り替わってしまいますが,ドーンといきましょう.

さて,上記のパーサーとリーダーマクロ `#@` をコンパイルしてロードした後 に,さっそく新しい構文の lisp ファイルを用意します.

;; newsyntax.lisp
#@new-syntax ;; これ以降の行は全て新しい構文で解釈される

;; 別に Lisper でもこう書きますよ :-)
defun fib (n)
   if (<= n 1)
      n
   else
      let
         n1 <- (fib (- n 1))
         n2 <- (fib (- n 2))
      in
        (+ n1 n2)
      end
   end
end
;; 別にこれでもいい ;-) ですが,やるなら Python ライクな構文にするでしょう.
defun fib2 (n)
   if (<= n 1)
      n
   else
      let
         n1 <- (fib2 (- n 1))
         n2 <- (fib2 (- n 2))
      in
        (+ n1 n2) end end end
CL-USER> (load "newsyntax.lisp")
T
CL-USER> (fib 20)
6765

これで完成です.いかがですか? Lisp の持つ構文抽象はプログラマブルなリー ダーと組み合わせで,このように括弧を減らす事すら可能です. CMU の AI Repository などを探索すると既に数十年前に C ライクな構文の実装が存在し ていた事がわかります(Dylan ではなく,Lisp そのものです.しかし,誰も使 わなかったため廃れていったようです).

しかし,見た目がどうあろうと,これも Lisp です!!

一つのエントリとしては長くなってきたので,後で CL-Yacc ページにでもまと め直します.

(defpackage :suck-syntax (:use #:cl #:yacc))
(in-package :suck-syntax)

(define-parser *suck-parser*
  (:start-symbol program)
  (:terminals (:def :when :if :else :elif :let :in :<- :end :atom :lparen :rparen))
  (program  (defs #'(lambda ($1) (cons 'progn $1))))
  (defs
   (def defs      #'(lambda ($1 $2) (cons $1 $2)))
   (def           #'(lambda ($1) (list $1))))
  (def
    (:def :atom list exprs :end
           #'(lambda ($0 $1 $2 $3 $4) `(,$0 ,$1 ,$2 ,@$3)))
    expr)
  (list
   (:lparen :rparen        #'(lambda ($1 $2) '()))
   (:lparen exprs :rparen  #'(lambda ($1 $2 $3) $2)))
  (let-form
   (:let vars :in exprs :end
           #'(lambda ($1 $2 $3 $4 $5)`(,$1 ,$2 ,@$4))))
  (if-form
   (:if expr exprs :end
           #'(lambda ($1 $2 $3 $4)
               `(,$1 ,$2 (progn ,@$3))))
   (:if expr exprs :else exprs :end
           #'(lambda ($1 $2 $3 $4 $5 $6) `(,$1 ,$2 (progn ,@$3) (progn ,@$5))))
   (:if expr exprs :elif elif-form
        #'(lambda ($1 $2 $3 $4 $5)
            `(,$1 ,$2 (progn ,@$3) ,$5))))
  (elif-form
   (expr exprs :elif elif-form
        #'(lambda ($1 $2 $3 $4) `(if ,$1 (progn ,@$2) ,$4)))
   (expr exprs :else exprs :end
        #'(lambda ($1 $2 $3 $4 $5) `(if ,$1 (progn ,@$2) (progn ,@$4))))
   (expr exprs :end
        #'(lambda ($1 $2 $3) `(if ,$1 (progn ,@$2)))))
  (when-form
   (:when expr exprs :end
           #'(lambda ($1 $2 $3 $4)
               `(,$1 ,$2 ,@$3))))
  (expr let-form when-form if-form list :atom :in)
  (exprs
   (expr exprs      #'(lambda ($1 $2) (cons $1 $2)))
   (expr            #'(lambda ($1) (list $1))))
  (vars
   (var vars        #'(lambda ($1 $2) (cons $1 $2)))
   (var             #'(lambda ($1) (list $1))))
  (var
   (:atom :<- expr  #'(lambda ($1 $2 $3) `(,$1 ,$3)))))

(defun lexer (s)
  (let ((c (peek-char t s nil :eof)))
    (case c
      (:eof (values nil nil))
      (#\( (values :lparen (read-char s)))
      (#\) (values :rparen (read-char s)))
      (t   (let ((e (read s)))
             (typecase e
               (symbol
                (cond ((or (string-equal (symbol-name e) "let")
                           (string-equal (symbol-name e) "let*"))
                       (values :let e))
                      ((or (string-equal (symbol-name e) "defun")
                           (string-equal (symbol-name e) "defmacro")
                           (string-equal (symbol-name e) "define-compiler-macro")
                           (string-equal (symbol-name e) "defmethod"))
                       (values :def e))
                      ((or (string-equal (symbol-name e) "when")
                           (string-equal (symbol-name e) "unless"))
                       (values :when e))
                      ((string-equal (symbol-name e) "if")
                       (values :if e))
                      ((string-equal (symbol-name e) "else")
                       (values :else e))
                      ((string-equal (symbol-name e) "elif")
                       (values :elif e))
                      ((string-equal (symbol-name e) "<-")
                       (values :<- e))
                      ((string-equal (symbol-name e) "in")
                       (values :in e))
                      ((string-equal (symbol-name e) "end")
                       (values :end e))
                      (t (values :atom e))))
               (t (values :atom e))))))))

(defun suck-syntax-reader (stream)
  (read-line stream nil :eof)
  (yacc::parse-with-lexer #'(lambda () (lexer stream)) *suck-parser*))

(defun sharp-at-reader (stream c1 c2)
  (declare (ignorable c1 c2))
  (suck-syntax-reader stream))

(set-dispatch-macro-character #\# #\@ #'sharp-at-reader)

posted: 2006/03/30 23:58 | permanent link to this entry | Tags:

(top)  (memo)  (rss)