Hatena::Groupcadr

わだばLisperになる このページをアンテナに追加 RSSフィード

2004 | 12 |
2005 | 01 | 02 | 07 | 10 | 11 |
2006 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2007 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2008 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2009 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2010 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 08 | 09 | 10 | 11 | 12 |
2011 | 01 | 02 | 03 | 04 | 05 | 06 | 07 | 11 |

2010-05-29

KMRCLを眺める(158) IF*

| 18:41 | KMRCLを眺める(158) IF* - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める(158) IF* - わだばLisperになる

web-utils.lispも眺め終わったので、次のファイルということで、今回は、KMRCLのifstar.lispからIF*です。

if*は、KMRCLで定義されているというよりは、Franz社がパブリックドメインで公開しているもので、KMRCL内でもexportはされていません。

kmr氏はAllegro CLを良く使っているのか、Allegro向けの定義が良く見掛けられます。

if*なんて邪道、という意見も聞いたことがあるのですが、if*は、FranzLispのifに由来するようなので、Franz社が独自にCLを拡張しようとしているというより社内の伝統なのかもしれません。

(ちなみにFranzLispでは大文字と小文字を区別するので、大文字と小文字を区別するAllegro CLのmlispも、また伝統というかこだわりなのかもしれません)

オリジナルのFranzLispの説明では、

;--- if :: macro for doing conditionalization
;
;  This macro is compatible with both the crufty mit-version and
; the keyword version at ucb.
;
;  simple summary:
;   non-keyword use:
;	(if a b) ==> (cond (a b))
;	(if a b c d e ...) ==> (cond (a b) (t c d e ...))
;   with keywords:
;	(if a then b) ==> (cond (a b))
;	(if a thenret) ==> (cond (a))
;	(if a then b c d e) ==> (cond (a b c d e))
;	(if a then b c  else d) ==> (cond (a b c) (t d))
;	(if a then b c  elseif d  thenret  else g)
;		==> (cond (a b c) (d) (t g))

となっていてIF一つでMIT方式とFranz(UCB)方式の両方の書式に対応できたようです。

使われ方としては、

(IMPORT 'KL::IF*)
(DEFUN S= (S1 S2)
  (AND (STRING= S1 S2) S1))

(let ((s "3"))
  (if* (s= "1" s)
      thenret
   elseif (s= "2" s)
      thenret
   elseif (s= "3" s)
      thenret))
;⇒ "3"

(let ((s "3"))
  (if* (string= "1" s)
      then 1
   elseif (string= "2" s)
      then 2
   elseif (string= "3" s)
      then 3))
;⇒ 3
(let ((s "3"))
  (if* (s= "1" s)
      :thenret
   :elseif (s= "2" s)
      :thenret
   :elseif (s= "3" s)
      :thenret))
;⇒ "3"

というところでしょうか。

IF*はCONDに展開されるのですが、CONDの述語部での返り値を利用するTHENRETが使が使えます。

CONDだとスタイル上あまりこの値を利用するのは好ましくないようですが、THENRETと名前が付けば割と見通しも良いのでたまに便利に使えそうでもあります。

ただCONDの述語部では、返り値は多値で返らないので、その辺りに留意する必要がありそうです。

折角なので、インデントにもこだわって行きたいところですが、FranzLispのソースを眺めると

  1. thenや、elseは行に単独で現われない
  2. thenや、else、thenretはif*の述語の一個前か、同じ位置から開始
  3. elseifはif*と同じ位置から開始

とすることが多いようです。

また、CL版は、文字列として比較しているので、キーワードでもOKです。

定義は、

;; the if* macro used in Allegro:
;;
;; This is in the public domain... please feel free to put this definition
;; in your code or distribute it with your version of lisp.

(in-package #:kmrcl)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro if* (&rest args)
   (do ((xx (reverse args) (cdr xx))
        (state :init)
        (elseseen nil)
        (totalcol nil)
        (lookat nil nil)
        (col nil))
       ((null xx)
        (cond ((eq state :compl)
               `(cond ,@totalcol))
              (t (error "if*: illegal form ~s" args))))
       (cond ((and (symbolp (car xx))
                   (member (symbol-name (car xx))
                           if*-keyword-list
                           :test #'string-equal))
              (setq lookat (symbol-name (car xx)))))

       (cond ((eq state :init)
              (cond (lookat (cond ((string-equal lookat "thenret")
                                   (setq col nil
                                         state :then))
                                  (t (error
                                      "if*: bad keyword ~a" lookat))))
                    (t (setq state :col
                             col nil)
                       (push (car xx) col))))
             ((eq state :col)
              (cond (lookat
                     (cond ((string-equal lookat "else")
                            (cond (elseseen
                                   (error
                                    "if*: multiples elses")))
                            (setq elseseen t)
                            (setq state :init)
                            (push `(t ,@col) totalcol))
                           ((string-equal lookat "then")
                            (setq state :then))
                           (t (error "if*: bad keyword ~s"
                                              lookat))))
                    (t (push (car xx) col))))
             ((eq state :then)
              (cond (lookat
                     (error
                      "if*: keyword ~s at the wrong place " (car xx)))
                    (t (setq state :compl)
                       (push `(,(car xx) ,@col) totalcol))))
             ((eq state :compl)
              (cond ((not (string-equal lookat "elseif"))
                     (error "if*: missing elseif clause ")))
              (setq state :init)))))

となっています。

オリジナルのFranzLispifのコメント文によると4つの状態を持つシンプルなオートマトンになっているとのこと

最初に本体部がREVERSEされて渡されるのでわかりづらいですが、

  1. init: 完全なパーズ済みのボディか、then節を持った状態
  2. col: 次のif*のキーワードを待っている状態
  3. then: thenの直後で次にくる述語を待っている状態
  4. compl: thenの直後の述語をみた状態で、elseifか終了を待っている状態

の4つの変数で表わされているようです。

再帰で書いたら分かりやすくなるのかなと思い書き直しつつ、thenretで多値も扱えるようにしてみました

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defvar if**-keyword-list '("then" "thenret" "else" "elseif")))

(defmacro IF** (&body body)
  (multiple-value-bind (body thenret-vars)
      (parse-if :INIT (reverse body) nil () () () )
    (if thenret-vars
        `(LET ,thenret-vars
           (COND ,@body))
        `(COND ,@body))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun parse-if (state args elseseen col totalcol thenret-vars)
    (if (endp args)
        (if (eq state :compl)
            (values totalcol thenret-vars)
            (error "if*: illegal form ~s" args))
        (let ((lookat (if (and (symbolp (car args))
                               (member (symbol-name (car args))
                                       if**-keyword-list
                                       :test #'string-equal))
                          (intern (symbol-name (car args)) :keyword)
                          :non-keyword))
              (xx (car args))
              (next (cdr args)))
          (case state
            (:INIT
             (case lookat 
               (:non-keyword 
                (parse-if :COL next elseseen (list xx) totalcol thenret-vars))
               (:thenret
                (let ((ret (gensym)))
                  (parse-if :THEN 
                            `((car (setq ,ret (multiple-value-list ,(car next))))
                              ,@(cdr next))
                            elseseen 
                            `((values-list ,ret))
                            totalcol
                            (cons ret thenret-vars))))
               (otherwise
                (error "if*: bad keyword ~a" lookat))))
            (:COL
             (case lookat
               (:else
                (when elseseen
                  (error "if*: multiples elses"))
                (parse-if :INIT 
                          next 'T col `((t ,@col) ,@totalcol) thenret-vars))
               (:non-keyword
                (parse-if :COL
                          next elseseen (cons xx col) totalcol thenret-vars))
               (:then
                (parse-if :THEN
                          next elseseen col totalcol thenret-vars))
               (otherwise (error "if*: bad keyword ~s" lookat))))
            (:THEN
             (case lookat
               (:NON-KEYWORD
                (parse-if :COMPL 
                          next elseseen xx `((,xx ,@col) ,@totalcol) thenret-vars))
               (otherwise 
                (error "if*: keyword ~s at the wrong place " xx))))
            (:COMPL
             (case lookat
               (:elseif 
                (parse-if :INIT
                          next elseseen col totalcol thenret-vars))
               (otherwise 
                (error "if*: missing elseif clause ")))))))))
(if** (values 42 nil)
     thenret
 elseif (values nil nil)
     thenret
     else 'foo)

のようなものは、

(LET (#:G2955 #:G2954)
  (COND
    ((CAR (SETQ #:G2955 (MULTIPLE-VALUE-LIST (VALUES 42 NIL))))
     (VALUES-LIST #:G2955))
    ((CAR (SETQ #:G2954 (MULTIPLE-VALUE-LIST (VALUES NIL NIL))))
     (VALUES-LIST #:G2954))
    (T 'FOO)))

と展開されます。

しかし、再帰で書きなおしたものの想像したよりも分かりやすくなってもおらず…。

ゲスト



トラックバック - http://cadr.g.hatena.ne.jp/g000001/20100529