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 |

2007-08-30

.22

| 18:41 | .22 - わだばLisperになる を含むブックマーク はてなブックマーク - .22 - わだばLisperになる

日課練習、日課練習。毎日書いてはいるんだけども、ブ

ログ更新するのが億劫で、そうすると、コードが溜って、

そうすると、大量にアップすることになるので、長大に

なるのもどうかなと思ったり、アップすること自体が更

に面倒になったり。

ということで、Common Lispで簡単に更新できるような

仕組を作ってみたいという妄想を抱く。

今回のお題は、TAOのloop。Common Lispのloopとは全然

違ってprogの使用感に近い。

色々謎なところは多いが、マニュアルから想像で適当に

作成。

ちなみにマニュアルの中の例は、中間記法で書いてあっ

たりして、TAOの混沌さが堪能できますが、Common Lisp

だと

(defun f (n)
  (loop (&aux c result)
        (:init (setq c 0) (setq result 1))
        (:until (= c n) result)
        (setq result (* (incf c) result)) ))

のようになります。

(shadow 'loop)

(defmacro tao::loop (&body body)
  "loop                                   関数[#!subr]

<説明>
  形式 : loop [exit-id] [(&aux var ...)]
                        [(:init init-form ...)]
        		[(:until pred exit-form1 exit-form2 ...)]
 			[(:while pred exit-form1 exit-form2 ...)]
 			form1 form2 ... formN
TAO の基本的な繰り返しの機能。
&aux で loop の中だけで有効な補助変数を宣言する。
:init があれば init-form を最初に一度だけ評価する。
:until の述語が成立するか、または :while の述語が成立しなくなるまで 
form1 form2 ... を順に評価する。そして、:until 文が成立、または :while
文が成立しなくなった時、対応する exit-form1 ... を順に評価して loop 
から抜け、最後の exit-form の値を返す。
:until や :while は何回でも使えるし省略可能。 exit-form は省略可能。

<例>
        (de f (n)
            (loop (&aux c result)
                  (:init (!c 0) (!result 1))
                  (:until (c = n) result)
                  (!result ((inc c) * result)) ))
        n の階乗を計算する。"
  (let ((exit-id (and (atom (car body)) (pop body)))
	(loop-tag (gensym))
	aux init newbody)
    (dolist (l body)
      (case (car l)
	(&aux   (setq aux (cdr l)))
	(:init  (push (cdr l) init))
	(otherwise (push l newbody))))
    `(block ,exit-id
       (let (,@aux)
	 (tagbody
	    ,@(mapcar (lambda (x) `(progn ,@x)) init)
	    ,loop-tag
	    ,@(mapcar 
	       (lambda (x) 
		 (cond ((eq :while (car x))
			`(or ,(cadr x) (return-from ,exit-id (progn ,@(cddr x)))))
		       ((eq :until (car x))
			`(and ,(cadr x) (return-from ,exit-id (progn ,@(cddr x)))))
		       ('T x)))
	       (nreverse newbody))
	    (go ,loop-tag))))))