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 |

2009-12-31

2009年を振り返る

| 23:36 | 2009年を振り返る - わだばLisperになる を含むブックマーク はてなブックマーク - 2009年を振り返る - わだばLisperになる

今年もまとめエントリーを書いてみたいと思います。

1月

  • みんなでLISPを勉強するブログ に参加
  • CL勉強会を30回目にして一旦終了としました。

しかし、また、オンライン勉強会やりたいです

2月

  • Shibuya.lisp TT#2
  • 第4回 Smiley hackathonに参加

LISP以外のコミュニティに初参加してみましたが、色々な視点が全然違うので非常に面白かったです。

3月

  • ひきこもり資金が尽きたため社会復帰
  • ILC2009のDavid Moon氏のPLOT発表に興奮していました。

今ではすっかり忘れていますw

  • Smiley HackathonにインスパイアされたSlimy Hackathonをオンラインで2日間/48時間開催しました

まったく期待してなかったのに何故か成果物が多かったです。不思議なものです。

4月

社会復帰直後のため、更新が滞っていました

その割には、Let Over Lambda読書会等には参加していたようです

5月

  • Lingr->Chatonへの移行記念に、CL勉強会をちょっと復活させてみようと思いましたが、企画倒れに終りました

私の気合いが足りなかったようですw

  • Common Lispの本はどれだけ日本で出版されているのかを適当に纒めてみましたが、何故か好評でした

6月

CiNiiでLISP系の論文を探して読んでそれをネタにエントリーを書いたりしていました

7月

  • 第5回Smiley Hackathon 参加
  • Shibuya.lisp TT#3

オンライン参加ではどういうことになるのか体験してみたり

8月

夏バテのためかエントリー激減

  • 第6回Smiley Hackathon 参加

9月

何故か、オレオレ構文を作る熱が復活し、妙な構文を量産しはじめていたようです。

10月

  • KMRCLを読み始めました
  • 日常のちょっとした作業を諦めずCLで書くように心掛けはじめました

11月

延々とKMRCLのエントリーが続きます

  • Shibuya.lisp TT#5
  • 数理システム LISPセミナー

LISPセミナーはまとめ記事を書こう書こうと思っていましたが、結局まとれられていません…。

12月

先月に引き続き延々とKMRCLのエントリーです。

  • LISP365とかいう毎日LISPの話題をお届けるという企画を実行することにしました

参加者のみなさんの面白いエントリーが読めたので良かったかなと思います。

まとめ

今年1年と、2年前(2007)の自分のブログを比べて眺めてみると、昔の方が今のエントリーより内容が偏っていて自分自身では面白いと感じます。

また、きちんとアイデアを纒めて書ききれてないせいか、書いたことを忘れてしまい、それを再発見してまたエントリーにしていることも多くなって来た気がしました。

来年は、もうちょっと偏った内容にできたら良いなあと思っています。

また、この2、3年で蓄積した情報がをまとめ切れていなかったり、立ち上げたもの中途半端になっているものが多くあるので来年は纒める年にしたいなとも思いました。

KMRCLを眺める (54) PLIST-ALIST

| 01:01 | KMRCLを眺める (54) PLIST-ALIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (54) PLIST-ALIST - わだばLisperになる

今回は、KMRCLのlists.lisp中からPLIST-ALISTです。

前回のALIST-PLISTの逆というわけですね。

定義は、

(defun plist-alist (plist)
  (do ((alist '())
       (pl plist (cddr pl)))
      ((null pl) alist)
    (setq alist (acons (car pl) (cadr pl) alist))))

動作は…

(PLIST-ALIST '(A 1 B 2 C 3 D 4 E 5 F 6 G 7))
;⇒ ((G . 7) (F . 6) (E . 5) (D . 4) (C . 3) (B . 2) (A . 1))

あれ、多分期待の結果とは逆になってますよね。

最後にひっくり返さなければいけないんじゃないかと…。うっかりミスでしょうか。

(defun plist-alist (plist)
  (do ((alist '())
       (pl plist (cddr pl)))
      ((null pl) (nreverse alist)) ;逆転
    (setq alist (acons (car pl) (cadr pl) alist))))

ちなみにこういう系統の関数はLOOPだと簡潔に書けることが多いようです。

(DEFUN MY-PLIST-ALIST (PLIST)
  (LOOP :FOR (X Y) :ON PLIST :BY #'CDDR :COLLECT (CONS X Y)))

(MY-PLIST-ALIST '(A 1 B 2 C 3 D 4 E 5 F 6 G 7))
;⇒ ((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6) (G . 7))

何故、LOOPで書かないのかを考えてみるに、これまで眺めてきたコードからすると、Kevin Rosenberg氏もPaul Graham氏と同様にLOOPが嫌いなんじゃないかなあと推測しています…。

2009-12-30

KMRCLを眺める (53) ALIST-PLIST

| 02:37 | KMRCLを眺める (53) ALIST-PLIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (53) ALIST-PLIST - わだばLisperになる

今回は、KMRCLのlists.lisp中からALIST-PLISTです。

名前からしてalistをplistにするんだなと分かります。

伝統的なLISPだと、ALIST-TO-PLIST、Scheme系だとALIST->PLISTという名付け方が多いみたいですが、こういう風に二者を並べただけのものも、それなりにある気がします。

定義は、

(defun alist-plist (alist)
  (apply #'append (mapcar #'(lambda (x) (list (car x) (cdr x))) alist)))

です。

動作は、

(DEFVAR *ALIST*
  (MAPCAR #'CONS '(A B C D E F G) '(1 2 3 4 5 6 7)))

*ALIST*
;⇒ ((A . 1) (B . 2) (C . 3) (D . 4) (E . 5) (F . 6) (G . 7))

(ALIST-PLIST *ALIST*)
;⇒ (A 1 B 2 C 3 D 4 E 5 F 6 G 7)

眺めて思うのは、折角定義したMAPAPPENDは使わないんだろうか、というところ。

(DEFUN MY-ALIST-PLIST2 (ALIST)
  (MAPAPPEND (lambda (x) (list (car x) (cdr x)))
             ALIST))

しかし、自分で定義しておきながら使ってないというのは、便利そうな定義を後で纒めたりしてできた、ユーティリティ系ライブラリにはありがちかもしれません。

2009-12-29

KMRCLを眺める (52) (SETF GET-ALIST)

| 01:12 | KMRCLを眺める (52) (SETF GET-ALIST) - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (52) (SETF GET-ALIST) - わだばLisperになる

今回は、KMRCLのlists.lisp中から(SETF GET-ALIST)です。

GET-ALISTのSETTER版といったところ。定義は、

(defun (setf get-alist) (value key alist &key (test #'eql))
  "This won't work if the alist is NIL."
  (update-alist key value alist :test test)
  value)

動作は、

(LET ((AL (COPY-ALIST '((FOO . 1) (BAR . 2) (BAZ . 3)))))
  (SETF (GET-ALIST 'FOO AL) 100)
  AL)
;⇒ ((FOO . 100) (BAR . 2) (BAZ . 3))

前々回のUPDATE-ALISTを利用しています。

UPDATE-ALISTはマクロで定義されていましたが、なぜマクロなのか謎でした。

UPDATE-ALISTのコメントを良く読むと"Macro to support below (setf get-alist)"

とのこと。

なるほど!そういうことか!だからマクロなのか!と思いましたが、

(DEFUN UPDATE-ALIST-FN (AKEY VALUE ALIST &KEY (TEST #'EQL) (KEY #'IDENTITY))
  (LET ((ELEM (ASSOC AKEY ALIST :TEST TEST :KEY KEY))
        (VAL VALUE))
    (COND (ELEM (SETF (CDR ELEM) VAL))
          (ALIST (SETF (CDR (LAST ALIST)) (LIST (CONS AKEY VAL))))
          (T (SETF ALIST (LIST (CONS AKEY VAL)))))
    ALIST))

(DEFUN (SETF GET-ALIST-FN) (VALUE KEY ALIST &KEY (TEST #'EQL))
  (UPDATE-ALIST-FN KEY VALUE ALIST :TEST TEST)
  VALUE)

(LET ((AL (COPY-ALIST '((FOO . 1) (BAR . 2) (BAZ . 3)))))
  (SETF (GET-ALIST-FN 'FOO AL) 100)
  AL)
;⇒ ((FOO . 100) (BAR . 2) (BAZ . 3))

いや、やっぱり関数で良いんじゃないかと…。

いまいち自分は、(DEFUN (SETF ...))、DEFSETF、DEFINE-SETF-EXPANDERの使い分けに迷いますが、DEFSETFだと

(DEFSETF GET-ALIST-FN2 (KEY ALIST) (VAL)
  `(UPDATE-ALIST-FN ,KEY ,VAL ,ALIST))

(LET ((AL (COPY-ALIST '((FOO . 1) (BAR . 2) (BAZ . 3)))))
  (SETF (GET-ALIST-FN2 'FOO AL) 100)
  AL)
;⇒ ((FOO . 100) (BAR . 2) (BAZ . 3))

とも書けます。

2009-12-28

KMRCLを眺める (51) GET-ALIST

| 00:11 | KMRCLを眺める (51) GET-ALIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (51) GET-ALIST - わだばLisperになる

今回は、KMRCLのlists.lisp中からGET-ALISTです。

定義は、

(defun get-alist (key alist &key (test #'eql))
  (cdr (assoc key alist :test test)))

となっていますが、gethashのalist版といったところですね。

(DEFPARAMETER *ALIST* (LIST (CONS :A :B) (CONS :C :D) (CONS :E :F)))
(DEFPARAMETER *ALIST-EMPTY* () )

*ALIST*
;⇒ ((:A . :B) (:C . :D) (:E . :F))

(GET-ALIST :A *ALIST*)
;⇒ :B

(GET-ALIST :A *ALIST-EMPTY*)
;⇒ NIL

GETHASHのように成功/失敗も含めて多値で返してくれると便利ですが…

(GET-ALIST :A '((A . NIL)))
;⇒ NIL
(GET-ALIST :A '((B . T)))
;⇒ NIL

2009-12-27

KMRCLを眺める (50) UPDATE-ALIST

| 00:48 | KMRCLを眺める (50) UPDATE-ALIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (50) UPDATE-ALIST - わだばLisperになる

今回は、KMRCLのlists.lisp中からUPDATE-ALISTです。

とりあえず定義ですが、

(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
  "Macro to support below (setf get-alist)"
  (let ((elem (gensym "ELEM-"))
        (val (gensym "VAL-")))
    `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
           (,val ,value))
       (cond
        (,elem
         (setf (cdr ,elem) ,val))
        (,alist
         (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
         (t
          (setf ,alist (list (cons ,akey ,val)))))
       ,alist)))

という風になっています。

マクロ展開した方が読みやすいので展開すると

(LET ((#:ELEM-2898 (ASSOC :Z *ALIST2* :TEST #'EQL :KEY #'IDENTITY))
      (#:VAL-2899 :BBBB))
  (COND (#:ELEM-2898 (SETF (CDR #:ELEM-2898) #:VAL-2899))
        (*ALIST2* (SETF (CDR (LAST *ALIST2*)) (LIST (CONS :Z #:VAL-2899))))
        (T (SETF *ALIST2* (LIST (CONS :Z #:VAL-2899)))))
  *ALIST2*)

となります。

指定したキーで該当する要素があれば、指定した値に更新。

なければ(key . val)を最後に追加

alistが空なら((key . val))というalistを作成

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

(DEFVAR *ALIST* (LIST (CONS :A :B) (CONS :C :D) (CONS :E :F)))
(DEFVAR *ALIST2* (COPY-ALIST *ALIST*))
(DEFVAR *ALIST3* () )

*ALIST*
;⇒ ((:A . :B) (:C . :D) (:E . :F))

(UPDATE-ALIST :A :BBBB *ALIST*)
;⇒ ((:A . :BBBB) (:C . :D) (:E . :F))

*ALIST2*
;⇒ ((:A . :B) (:C . :D) (:E . :F))

(UPDATE-ALIST :Z :BBBB *ALIST2*)
;⇒ ((:A . :B) (:C . :D) (:E . :F) (:Z . :BBBB))

*ALIST3*
;⇒ NIL

(UPDATE-ALIST :Z :BBBB *ALIST3*)
;⇒ ((:Z . :BBBB))

しかしこれマクロじゃなくて関数で良いような気がするんですが…。

(DEFUN UPDATE-ALIST-FN (AKEY VALUE ALIST &KEY (TEST #'EQL) (KEY #'IDENTITY))
  (LET ((ELEM (ASSOC AKEY ALIST :TEST TEST :KEY KEY))
        (VAL VALUE))
    (COND (ELEM (SETF (CDR ELEM) VAL))
          (ALIST (SETF (CDR (LAST ALIST)) (LIST (CONS AKEY VAL))))
          (T (SETF ALIST (LIST (CONS AKEY VAL)))))
    ALIST))

2009-12-26

Smiley Hackathon #7に参加してきました!

| 21:18 | Smiley Hackathon #7に参加してきました! - わだばLisperになる を含むブックマーク はてなブックマーク - Smiley Hackathon #7に参加してきました! - わだばLisperになる

先日の12/19(土)にSmiley Hackathon #7またまた参加させて頂きました。

今回も主催の d:id:acotie さん 会場提供のGaiaXさんありがとうございました。

やってたこと

LISPコミュニティをハックするという名目のもとに、延々とLISPサイトのリンク切れを直しておりました。

なぜ私がリンク切れを直しているのかといいますと話が長くなるのですが、「日本Lispユーザ会のページは更新されているのですか?」と運営の方に私が質問したところから始まるのですね。

今後も少しずつですが、修復とアップデートをしていきたいです。

今回、最近LISPに興味があるという、刺身☆ブーメランさん(d:id:a666666)とLISP野郎のakaさんが参加していて個人的LISP色の強い回となりましたが、HTMLを直しながら喋りつづけていたため、周りのakaさん、jun_ichiroさん他の作業を邪魔しつづけておりました。

また、Hackathon後半に、刺身☆ブーメランさんとお話したのですが、もの凄い聞き上手のため、調子にのってLISPのデモ的なことをしておりました。

次も参加してみたいです!!

KMRCLを眺める (49) ALISTP

| 00:40 | KMRCLを眺める (49) ALISTP - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (49) ALISTP - わだばLisperになる

今回は、KMRCLのlists.lisp中からALISTPです。

alistかどうかを判別するというのは名前からわかりますが、実装は、

(defun alistp (alist)
  (when (listp alist)
    (dolist (elem alist)
      (unless (alist-elem-p elem)
        (return-from alistp nil)))
    t))

という風に前回定義したALIST-ELEM-Pを利用しています。

動作は、

(alistp '(a b c d))
;⇒ NIL

(alistp '((a a) (b) (c) (d)))
;⇒ NIL

(alistp '((a) (b) (c) (d)))
;⇒ T

(alistp '((a . a) (b . b) (c . c) (d . d)))
;⇒ T

です。

無駄なものを調べないように途中で判定を打ち切るようにしてありますが、標準関数のEVERYも無駄な調査はしないようなので

(DEFUN MY-ALISTP (ALIST)
  (AND (LISTP ALIST)
       (EVERY #'ALIST-ELEM-P ALIST)))

で良いんじゃないかなあと。

速度もどっこいどっこいです。

(DEFVAR *NOT-ALIST*
  (LET ((U (LIST '(D D))))
    (DOTIMES (I (* 100000))
      (PUSH (CONS I I) U))
    U))

;; KL:ALISTP
(LOOP :REPEAT (* 100 100)
      :DO (KL:ALISTP *NOT-ALIST*))
;⇒ NIL
----------
Evaluation took:
  9.675 seconds of real time
  9.680000 seconds of total run time (9.680000 user, 0.000000 system)
  100.05% CPU
  23,162,850,045 processor cycles
  1,443,888 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

;; MY-ALISTP
(LOOP :REPEAT (* 100 100)
      :DO (MY-ALISTP *NOT-ALIST*))
;⇒ NIL
----------
Evaluation took:
  9.239 seconds of real time
  9.240000 seconds of total run time (9.210000 user, 0.030000 system)
  100.01% CPU
  22,119,721,731 processor cycles
  1,483,040 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz
(DEFVAR *NOT-ALIST2*
  (LET (U)
    (DOTIMES (I (* 100000))
      (PUSH (CONS I I) U))
    (PUSH '(D D) U)
    U))

;; KL:ALISTP
(LOOP :REPEAT (* 100 100)
      :DO (KL:ALISTP *NOT-ALIST2*))
;⇒ NIL
----------
Evaluation took:
  0.000 seconds of real time
  0.000000 seconds of total run time (0.000000 user, 0.000000 system)
  100.00% CPU
  1,030,212 processor cycles
  0 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

;; MY-ALISTP
(LOOP :REPEAT (* 100 100)
      :DO (MY-ALISTP *NOT-ALIST2*))
;⇒ NIL
----------
Evaluation took:
  0.001 seconds of real time
  0.000000 seconds of total run time (0.000000 user, 0.000000 system)
  0.00% CPU
  1,036,746 processor cycles
  0 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

2009-12-25

bit誌上でのTAO/ELISの連載「マルチパラダイム言語 TAO」公開!

| 00:27 | bit誌上でのTAO/ELISの連載「マルチパラダイム言語 TAO」公開! - わだばLisperになる を含むブックマーク はてなブックマーク - bit誌上でのTAO/ELISの連載「マルチパラダイム言語 TAO」公開! - わだばLisperになる

先日のShibuya.lisp TT#5でも竹内先生のカレンダーのデモでTAOが動く姿をみることができましたが、TAO/ELISの話になると必ずといって良い程話題にのぼる1988年のbit誌上におけるTAO/ELISの連載がnue.orgにて公開されました!

丸一年、十二回の連載ですが、マイクロプログラムに始まって、マルチユーザー環境でのLISPの実現まで非常に興味深い内容になっています。

個人的には、マイクロプログラミングの詳細や、deflogic-methodというLISPとSmalltalkとPrologの全部が混ってしまったような構文と、マルチユーザー環境での変数のスコープの取扱い等が特に面白いと感じました。

今も昔もLISPは処理系の実装者が多い言語ですが、処理系実装者には刺激になる内容ではないでしょうか!!

KMRCLを眺める (48) ALIST-ELEM-P

| 00:18 | KMRCLを眺める (48) ALIST-ELEM-P - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (48) ALIST-ELEM-P - わだばLisperになる

今回は、KMRCLのlists.lisp中からALIST-ELEM-Pで、ここからalist、plist編に突入のようです。

名前からするに、alistの一要素かどうかを調べる述語っぽいですが、とりあえず定義をみてみると、

;; alists and plists

(defun alist-elem-p (elem)
  (and (consp elem) (atom (car elem)) (atom (cdr elem))))

となっています。

これだと値の部分がatomじゃないとalistの要素じゃないという感じなのですが、

(LIST (ALIST-ELEM-P 'A)
      (ALIST-ELEM-P '(A . B))
      (ALIST-ELEM-P '(A B))
      (ALIST-ELEM-P '(A))) ; = (A .  () )とも言える
;⇒ (NIL T NIL T)
((A . (B C) (D . E))) = ((A B C) (D . E)))

のように値にリストを格納してもalistじゃないかなと自分は思っていたのですが、どうなのでしょう。

HyperSpecを参照してみても特にCARもCDRもATOMである必要はないように思えましたが…。

2009-12-24

KMRCLを眺める (47) APPEND-SUBLISTS

| 03:02 | KMRCLを眺める (47) APPEND-SUBLISTS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (47) APPEND-SUBLISTS - わだばLisperになる

今回は、KMRCLのlists.lisp中からAPPEND-SUBLISTSです。

名前からするとSUBLISTをAPPENDするんだろうという感じですが、そのままです。

実装は、

(defun append-sublists (list)
  "Takes a list of lists and appends all sublists"
  (let ((results (car list)))
    (dolist (elem (cdr list) results)
      (setq results (append results elem)))))

という風になっていて、DOLISTで順にAPPENDしています。

動作は、

(DEFVAR *LIST*
  '((FOO BAR BAZ (:QUUX))
    (:FOO :BAR :BAZ (QUUX))
    (1 2 3 (4))))

(APPEND-SUBLISTS *LIST*)
;⇒ (FOO BAR BAZ (:QUUX) :FOO :BAR :BAZ (QUUX) 1 2 3 (4))

つまり、

(APPLY #'APPEND *LIST*)
;⇒ (FOO BAR BAZ (:QUUX) :FOO :BAR :BAZ (QUUX) 1 2 3 (4))

で良いんじゃないかなと思いますが、ANSI CLだと、CALL-ARGUMENTS-LIMITは50ということもあり得るので、そういうためのAPPEND-SUBLISTSなのかもしれません。

といっても

(REDUCE #'APPEND *LIST*)
;⇒ (FOO BAR BAZ (:QUUX) :FOO :BAR :BAZ (QUUX) 1 2 3 (4))

として回避する方が多いような気はしますが…。

しかし関数名が説明的というところは長所かもしれません。

2009-12-23

KMRCLを眺める (46) MAPCAR2-APPEND-STRING

| 03:13 | KMRCLを眺める (46) MAPCAR2-APPEND-STRING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (46) MAPCAR2-APPEND-STRING - わだばLisperになる

今回は、KMRCLのlists.lisp中からMAPCAR2-APPEND-STRINGです。

このまえのMAPCAR-APPEND-STRING系統と同じように-NONTAILRECが付かないのが末尾再帰バージョンです。

動作は、

(MAPCAR2-APPEND-STRING 
 (LAMBDA (X Y &AUX (X (STRING-CAPITALIZE (PRINC-TO-STRING X)))
                   (Y (PRINC-TO-STRING Y)))
   (CONCATENATE 'STRING X Y))
 '(FOO BAR BAZ)
 '(1 2 3 4))
;⇒ "Foo1Bar2Baz3"

というところ。

定義は、

(defun mapcar2-append-string (func la lb &optional (accum ""))
  "Concatenate results of mapcar lambda call's over two lists"
  (let ((a (car la))
        (b (car lb)))
    (if (and a b)
        (mapcar2-append-string func (cdr la)  (cdr lb)
                               (concatenate 'string accum (funcall func a b)))
      accum)))

とこれまた末尾再帰であることが確認できます。

やっぱりIFのインデントが読みにくいんですが、割とインデントでパターンを認識してる割り合いが高いということなのかもしれません。

どうにも一番最後のaccumがIFの外にあるように見えてしまう…。

2009-12-22

KMRCLを眺める (45) MAPCAR2-APPEND-STRING-NONTAILREC

| 00:19 | KMRCLを眺める (45) MAPCAR2-APPEND-STRING-NONTAILREC - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (45) MAPCAR2-APPEND-STRING-NONTAILREC - わだばLisperになる

今回は、KMRCLのlists.lisp中からMAPCAR2-APPEND-STRING-NONTAILRECです。

名前のMAPCAR2〜の2はなんなんだという感じですが、リストを2つ引数に取るからのようです。

MAPCAR2という名前よりいっそのことZIPと付けた方が分かり易いようなそうでもないような。

さらに-NONTAILRECという接尾語は前々回のMAPCAR-APPEND-STRING-NONTAILRECと同じく末尾再帰でないということを表わしています。

定義は、

(defun mapcar2-append-string-nontailrec (func la lb)
  "Concatenate results of mapcar lambda call's over two lists"
  (let ((a (car la))
        (b (car lb)))
    (if (and a b)
      (concatenate 'string (funcall func a b)
                   (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
      "")))

です。

動作例は、

(MAPCAR2-APPEND-STRING-NONTAILREC 
 (LAMBDA (X Y) 
         (CONCATENATE 'STRING X Y))
 '("FOO" "BAR" "BAZ")
 '("123" "456" "789"))
;⇒ "FOO123BAR456BAZ789"

こんな感じですが、どの辺りで使うのかぱっとは思い浮かばないです…。

MAPCAR2-APPEND-STRINGがぴったりはまる時に限って、これの存在を思い出せずに、適当に自作してしまう、そんな予感がしました。

2009-12-21

KMRCLを眺める (44) MAPCAR-APPEND-STRING

| 02:34 | KMRCLを眺める (44) MAPCAR-APPEND-STRING - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (44) MAPCAR-APPEND-STRING - わだばLisperになる

今回は、KMRCLのlists.lisp中からMAPCAR-APPEND-STRINGです。

前回のMAPCAR-APPEND-STRING-NONTAILRECは名前のとおり、末尾再帰ではありませんでしたが、MAPCAR-APPEND-STRINGは末尾再帰バージョンです。

定義は、

(defun mapcar-append-string (func v &optional (accum ""))
  "Concatenate results of mapcar lambda calls"
  (aif (car v)
       (mapcar-append-string
        func
        (cdr v)
        (concatenate 'string accum (funcall func it)))
       accum))

となっていて、&optionalでアキュムレータを取っています。

(MAPCAR-APPEND-STRING #'STRING-UPCASE 
                      '("foo" "bar" "baz"))
⇒ "FOOBARBAZ"

末尾再帰がそんなに効いてくるんだろうか、ということで測定してみましたが、末尾再帰かどうかがネックになるというより、扱うデータの量による壁が先に来る気がしました…。

(DEFVAR *STRINGS* () )

(DO-ALL-SYMBOLS (VAR)
  (PUSH (SYMBOL-NAME VAR)
        *STRINGS*))

(PROG () (MAPCAR-APPEND-STRING #'VALUES 
                               (SUBSEQ *STRINGS* 0 10000)))
;⇒ NIL
----------
Evaluation took:
  4.417 seconds of real time
  4.180000 seconds of total run time (3.410000 user, 0.770000 system)
  [ Run times consist of 1.620 seconds GC time, and 2.560 seconds non-GC time. ]
  94.63% CPU
  10,575,353,205 processor cycles
  3,648,198,304 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz


(PROG () (MAPCAR-APPEND-STRING-NONTAILREC #'VALUES 
                                          (SUBSEQ *STRINGS* 0 10000)))
;⇒ NIL
----------
Evaluation took:
  4.477 seconds of real time
  4.540000 seconds of total run time (3.820000 user, 0.720000 system)
  [ Run times consist of 1.650 seconds GC time, and 2.890 seconds non-GC time. ]
  101.41% CPU
  10,717,103,601 processor cycles
  3,666,619,088 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

2009-12-20

KMRCLを眺める (43) MAPCAR-APPEND-STRING-NONTAILREC

| 02:45 | KMRCLを眺める (43) MAPCAR-APPEND-STRING-NONTAILREC - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (43) MAPCAR-APPEND-STRING-NONTAILREC - わだばLisperになる

今回は、KMRCLのlists.lisp中からMAPCAR-APPEND-STRING-NONTAILRECです。

名前からするに、MAPCARしつつ、結果を文字列として合体する関数でいて末尾再帰ではない実装という感じです。

定義は、

(defun mapcar-append-string-nontailrec (func v)
  "Concatenate results of mapcar lambda calls"
  (aif (car v)
       (concatenate 'string (funcall func it)
                    (mapcar-append-string-nontailrec func (cdr v)))
       ""))

こんな感じで、CONCATENATEで文字をつなげていて、AIFが上手く使われています。

動作は、

(MAPCAR-APPEND-STRING-NONTAILREC #'STRING-UPCASE 
                                 '("foo" "bar" "baz"))
⇒ "FOOBARBAZ"

という感じです。

実装を見たところそんなに効率を追求している風にも見えないし、FORMATで文字列をつなげても、そんなに速度は変わらないんじゃないかなあ、と思い実験してみたところ、およそ10倍弱の差でMAPCAR-APPEND-STRING-NONTAILRECが速いという結果が出ました。

MAPCAR-APPEND-STRING-NONTAILRECが割と速いというべきか、思ったよりFORMATが遅いというべきか…。

(LOOP :REPEAT 100000
      :DO (MAPCAR-APPEND-STRING-NONTAILREC #'VALUES 
                                           '("foo" "bar" "baz")))
;⇒ NIL
----------
Evaluation took:
  0.127 seconds of real time
  0.130000 seconds of total run time (0.130000 user, 0.000000 system)
  [ Run times consist of 0.010 seconds GC time, and 0.120 seconds non-GC time. ]
  102.36% CPU
  304,275,915 processor cycles
  38,418,352 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz
(LOOP :REPEAT 100000
      :DO (FORMAT NIL "~{~A~}" '("foo" "bar" "baz")))
;⇒ NIL
----------
Evaluation took:
  1.028 seconds of real time
  1.020000 seconds of total run time (1.000000 user, 0.020000 system)
  [ Run times consist of 0.340 seconds GC time, and 0.680 seconds non-GC time. ]
  99.22% CPU
  2,460,705,210 processor cycles
  633,721,168 bytes consed
  
Intel(R) Core(TM)2 Duo CPU     P8600  @ 2.40GHz

2009-12-19

KMRCLを眺める (42) MAPAPPEND

| 23:59 | KMRCLを眺める (42) MAPAPPEND - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (42) MAPAPPEND - わだばLisperになる

今回は、KMRCLのlists.lisp中からMAPAPPENDです。

MAPAPPENDも、昔からの定番ユーティリティで、70年代初頭位に定義されたものを見たことがある気がします。

MAPPENDだったり、MAP-APPENDだったり、APPEND-MAPだったり色々な名前で呼ばれていますが、MAPした結果をAPPENDで連結するという名前そのままな動作をする関数です。

定義は

(defun mapappend (func seq)
  (apply #'append (mapcar func seq)))

動作は、

(MAPAPPEND #'VALUES
           '((1 A) (2 B) (3 C) (4 D) (5 E)))
;⇒ (1 A 2 B 3 C 4 D 5 E)

こんな感じです。

CL標準でこういう動作をするものには、MAPCANがありますが、こちらは、破壊的に連結します。

上のようなことを元のリストを破壊しないように行なうには、

(MAPCAN #'COPY-LIST 
        '((1 A) (2 B)() (3 C) (4 D) (5 E)))

という感じでしょうか。

2009-12-17

KMRCLを眺める (41) REMOVE-KEYWORDS

| 21:33 | KMRCLを眺める (41) REMOVE-KEYWORDS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (41) REMOVE-KEYWORDS - わだばLisperになる

今回は、KMRCLのlists.lisp中からREMOVE-KEYWORDSです。

昨日は、REMOVE-KEYWORDで削除するキーも1種類でしたが、今回は、REMOVE-KEYWORDSということで、削除するキーのリストを取るようです。

(REMOVE-KEYWORDS '(:RE :MO :VE :ME) 
                 '(:RE 1 :MO 2 :VE 3 :ME 4 :FOO 5 :BAR 6))
;⇒ (:FOO 5 :BAR 6)

実装は

(defun remove-keywords (key-names args)
  (loop for ( name val ) on args by #'cddr
        unless (member (symbol-name name) key-names
                       :key #'symbol-name :test 'equal)
        append (list name val)))

というものですが、前回のREMOVE-KEYWORDの謎なコーディングより普通な書き方をしているようです。

関数名はキーワードとなっていますが、シンボルならなんでも良いわけですね。

2009-12-16

KMRCLを眺める (40) REMOVE-KEYWORD

| 22:31 | KMRCLを眺める (40) REMOVE-KEYWORD - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (40) REMOVE-KEYWORD - わだばLisperになる

今回は、KMRCLのlists.lisp中からREMOVE-KEYWORDです。

名前から想像するに、キーワード引数を処理するような場合に使えそうですが、定義は、

;; ECL doesn't allow FOR clauses after UNTIL.
#-ecl
(defun remove-keyword (key arglist)
  (loop for sublist = arglist then rest until (null sublist)
        for (elt arg . rest) = sublist
        unless (eq key elt) append (list elt arg)))

となっています。

動きを確認してみると、

(REMOVE-KEYWORD :BAR () )
;⇒ NIL

(REMOVE-KEYWORD :BAR '(:FOO))
;⇒ (:FOO NIL)

(REMOVE-KEYWORD :BAR '(:FOO 1 :BAR 2 :BAZ 3))
;⇒ (:FOO 1 :BAZ 3)

(REMOVE-KEYWORD :BAR '(:FOO 1 :BAR 2 :BAZ 3 :E))
;⇒ (:FOO 1 :BAZ 3 :E NIL)

というところで、

(LET ((KEYS (LIST :TEST #'EQL :FROM-END 'T)))
  (APPLY #'MEMBER 1 '(1 2 3 4) 
         (REMOVE-KEYWORD :FROM-END KEYS)))
;⇒ (1 2 3 4)

などど使うのかもしれません。

ちなみに、

;; ECL doesn't allow FOR clauses after UNTIL.

という風にコメントがあるのですが、確かに、上の定義では動きません。

しかし、

(DEFUN REMOVE-KEYWORD (KEY ARGLIST)
  (LOOP :FOR (ELT ARG . REST) :ON ARGLIST :BY #'CDDR
        :UNLESS (EQ KEY ELT) :COLLECT ELT :AND :COLLECT ARG))

とでも書けば、ECLでも動くんじゃないかと思うんですが(実際問題なく動きます)謎です。

2009-12-15

KMRCLを眺める (39) FLATTEN

| 23:36 | KMRCLを眺める (39) FLATTEN - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (39) FLATTEN - わだばLisperになる

今回は、KMRCLのlists.lisp中からFLATTENです。

FLATTENも古からあるLISPの定番のユーティリティ関数ではないかと思います。

動作は、

(DEFVAR *TREE* '(1 A 2 B 3 C 4 D () () (5 E 6 F 7 G (8 9 10) 11 12) 13))

(FLATTEN *TREE*)
;⇒ (1 A 2 B 3 C 4 D 5 E 6 F 7 G 8 9 10 11 12 13)

というもので、ツリー状の要素をべたなリストにします。

(defun flatten (lis)
  (cond ((atom lis) lis)
        ((listp (car lis))
         (append (flatten (car lis)) (flatten (cdr lis))))
        (t (append (list (car lis)) (flatten (cdr lis))))))

Common Lisp等のように空リスト()とNILというアトムが同一の表現だと()/NILをリストとみるか要素とみるかで若干迷ってしまう気もするんですが、NILは空リストとする動作の方がほとんどのようです。

2009-12-14

アナフォリックDEFUNでバグに勝つる!

| 23:09 | アナフォリックDEFUNでバグに勝つる! - わだばLisperになる を含むブックマーク はてなブックマーク - アナフォリックDEFUNでバグに勝つる! - わだばLisperになる

再帰している関数を、foo-bar-1、foo-bar-2、foo-bar-3などど、試行錯誤しつつ作成していて、良く遭遇しがちなミスに、名前の付け替え忘れというのがあるかと思います。

foo-bar-1のコードをコピペし、バグを直したつもりでfoo-bar-2を実行してみると、全然バグは直っておらず、なんでなんだ!と散々悩んで良く見てみると、foo-bar-2の中ではfoo-bar-1が呼ばれていた、などというものです。

こんな名前の付け替え漏れの間違いも自身をSELFで呼び出すようにしておけば発生しないのではないか?、ということで、ALAMBDAのようなADEFUNを作ってみました。

(DEFMACRO ADEFUN (NAME ARGS &BODY BODY)
  `(DEFUN ,NAME (,@ARGS)
     (MACROLET ((SELF (,@ARGS) `(,',NAME ,,@ARGS)))
       ,@BODY)))

使用例

(ADEFUN FIND-TREE3 (SYM TREE)
  (ACOND2 ((OR (NULL TREE) (ATOM TREE))
           (VALUES NIL NIL))
          
          ((EQL SYM (CAR TREE))
           (VALUES (CDR TREE) 'T))

          ((SELF SYM (CAR TREE))
           (VALUES IT 'T))

          ((SELF SYM (CDR TREE))
           (VALUES IT 'T))

          ('T (VALUES NIL NIL))))

;; FIB
(ADEFUN FIB (N)
  (IF (< N 2)
      1
      (+ (SELF (1- N))
         (SELF (- N 2)))))

FLETで良いと思いますが、なんとなくでMACROLETで自身のエイリアス名を定義しています。

2009-12-13

CL365からLISP365にイベント名変更しました

| 22:08 | CL365からLISP365にイベント名変更しました - わだばLisperになる を含むブックマーク はてなブックマーク - CL365からLISP365にイベント名変更しました - わだばLisperになる

Ruby Advent Calendar jpが羨しかったので、CL365という年中CLネタを書くというイベントを作ったのですが、CL限定というのが狭すぎたみたいなので、LISP全般にしました。

心の言語が、Common Lisp、Scheme、Dylan、Goo、Clojure等々の方々どうぞ心の言語ネタでご参加ください!

Advent Calendarのように役立つTipsでなくてもOKです。

このRSSを購読すれば毎日CLの記事が読める!これで勝つる!というのを目指しています。

ちなみに、1日先着1名でなくても複数名のエントリーOKな方針です。

KMRCLを眺める (38) FIND-TREE

| 18:58 | KMRCLを眺める (38) FIND-TREE - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (38) FIND-TREE - わだばLisperになる

今回は、KMRCLのlists.lisp中からFIND-TREEです。

名前からして、FINDのツリー版という感じですが、結果としてアイテムではなく、CDRを返すのがなんらかのミソのようです。MEMBER的?

定義は

(defun find-tree (sym tree)
  "Finds an atom as a car in tree and returns cdr tree at that positions"
  (if (or (null tree) (atom tree))
      nil
    (if (eql sym (car tree))
        (cdr tree)
      (aif (find-tree sym (car tree))
          it
        (aif (find-tree sym (cdr tree))
            it
            nil)))))

で、

動作は、

(DEFVAR *TREE* '(1 A 2 B 3 C 4 D () () (5 E 6 F 7 G (8 9 10) 11 12) 13))

(FIND-TREE 'FOO *TREE*)
;⇒ NIL

(FIND-TREE 1 *TREE*)
;⇒ (A 2 B 3 C 4 D NIL NIL (5 E 6 F 7 G (8 9 10) 11 12) 13)

(FIND-TREE () *TREE*)
;⇒ (NIL (5 E 6 F 7 G (8 9 10) 11 12) 13)

(FIND-TREE 5 *TREE*)
;⇒ (E 6 F 7 G (8 9 10) 11 12)

(FIND-TREE 'G *TREE*)
;⇒ ((8 9 10) 11 12)

しかし、

(FIND-TREE 10 *TREE*)
;⇒ NIL

(FIND-TREE 12 *TREE*)
;⇒ NIL

を見るように、真偽値のNILなのか、()が返ってきてるのか分からない問題があるようです。

ということで、GETHASHのように多値で成功/失敗を返すバージョンを作成してみました。

試しに、ACOND2を使ってみています。

(DEFUN FIND-TREE2 (SYM TREE)
  (ACOND2 ((OR (NULL TREE) (ATOM TREE))
           (VALUES NIL NIL))

          ((EQL SYM (CAR TREE))
           (VALUES (CDR TREE) 'T))

          ((FIND-TREE2 SYM (CAR TREE))
           (VALUES IT 'T))

          ((FIND-TREE2 SYM (CDR TREE))
           (VALUES IT 'T))

          ('T (VALUES NIL NIL))))
(FIND-TREE2 'G *TREE*)
;⇒ ((8 9 10) 11 12)
;   T

(FIND-TREE2 12 *TREE*)
;⇒ NIL
;   T

2009-12-12

CL365始めました

| 22:08 | CL365始めました - わだばLisperになる を含むブックマーク はてなブックマーク - CL365始めました - わだばLisperになる

Ruby Advent Calendar jpが羨しかったので、CL365という年中CLネタを書くというイベントを作りました。

Advent Calendarのように役立つTipsでなくてもOKですので興味のある方は是非参加してみてください!

このRSSを購読すれば毎日CLの記事が読める!これで勝つる!というのを目指しています。

ちなみに、1日1つでなくても他の人と被ってもOKな方針です。

IFのインデント

| 22:10 | IFのインデント - わだばLisperになる を含むブックマーク はてなブックマーク - IFのインデント - わだばLisperになる

REMOVE-FROM-TREE-IFのコードでIFのインデントが読み辛い…と書いていて、IFのインデントに関しての古のLispハッカー達がMLで議論していたのを思い出したので掲載してみます。(CADR System 99の>doc>if.answerより)

Lispマシン初期では、今のEmacs Lispのようにthen節とelse節のインデントが違っていたらしいのですが、いつの間にやら揃える派の人がLispマシンに変更を加えてしまい、それを元に戻したRMS(ずらす派)と揃える派のやりとりです。

Date: 16 February 1982 01:57-EST
From: Richard M. Stallman <RMS at MIT-AI>
To: BUG-LISPM at MIT-AI

Does anyone object to indenting the else-clauses in IF two spaces
less than the then-clause?

This was flushed, but nobody admitted to flushing it, and the only
response I got before was a favorable one.  Unless opinion is clearly
against it, I will reinstall it.
Date: Tuesday, 16 February 1982  16:03-EST
From: DLW at SCRC-TENEX

Yes, I object to the special indentation for IF.  Also, if you look at
various init files you can find other people who, like me, remove
the special indentation.  Moon does.  Daniel Weise does, and he told
me that most of the people that he works with do too.

I don't know who changed the default; I didn't even know that it had
been changed (since my environment is customized anyway).
LEVITT@MIT-AI 02/16/82 15:58:53 Re:  IF indentation syntax
To: RMS at MIT-AI

I recommended &BODY style indentation to BUG-LISPM for IF over a year
ago.  I strongly prefer it.  At the time, DLW pointed out that for
"parallel constructions", with just a pair of forms, the other way
makes more sense, but still I find that harder to read.  His was the
only response I got at the time, and of course it was never
implemented until you did it (I had little doubt) a while ago.

From whom did you obtain your consensus on IF indentation aesthetics?
Since I imagine many of us will want to use Symbolics bands in the
future, won't it be a big hassle for you to re-install things like
this every time they release a new band?  Maybe you start putting a
bunch of "patches" that users have said they like, but Symbolics
doesn't care to support, into LMLIB;, and announce them.  Isn't that
the current convention?
dcb@MIT-AI 02/16/82 09:39:27
To: RMS at MIT-AI

By all means PLEASE re-install it.
	dan
Date: 16 February 1982 09:25-EST
From: Gerald R. Barber <JerryB at MIT-AI>
To: RMS at MIT-AI

No.  I prefer that else clauses are indented differently that the then
clause, it helps distinquish the two.
Date: 16 February 1982 04:47-EST
From: George J. Carrette <GJC at MIT-MC>

Yes, I object. I never use more that one else clause, so I think it
looks silly to have (IF (FOO X) (BAR X) (BAZ X))  indent as
(IF (FOO X)
    (BAR X)
  (BAZ X))

It is pretty to have parens line-up as much as possible. Certainly
with C-M-F and C-M-B it is never a readability problem.
RWG@MIT-MC 02/16/82 05:06:10 Re: Indenting IF

I used to prefer maximally aligned parens, but given the evolution of
Lisp syntax, I now lean toward the higher information content possible
with less rigid indenting.  In the case of IF with one ELSE clause, I
initially bletched when I saw RMS's contour, then decided it was in
fact mnemonic:  the outcome consonant with the predicate indented
consonantly, and mutatis mutandis for the ELSE.
Date: 16 February 1982 03:13-EST
From: Alan Bawden <ALAN at MIT-MC>

I didn't flush it, but three cheers for whoever did!  I detest having my IF's
indent that way.  The only time I ever mentiond this in public I got a whole
room full of people jumping up and down hating it right along with me.  (I
recall DLW and DANIEL to be amoung them.)  Moon tells me that he also dislikes
it.
Date: Wednesday, 17 February 1982, 00:39-EST
From: David A. Moon <Moon at SCRC-TENEX>
Subject: IF indentation

I answered your previous query.  I don't like the different indentation
for the else clauses; however it's not quite that simple.  When I use
symmetrical IFs, which I nearly always use, I greatly prefer having the
THEN and the ELSE indented the same way.  When I use multiple-else-clause
IF, I indent it the new way you (I assume) thought of.  However, after
much consideration and experimentation I decided that I liked it better
for the automatic indenter to do it the old way, and I would type
control-Tab myself if I wanted it the new way.  Consequently I put something
in my init file to turn off the new mode.

Most people I happened to ask about this preferred it the old way, however
if you reinstall it I will continue to make my init file turn it off.
Date: 16 February 1982 21:55-EST
From: Andrew L. Ressler <ALR at MIT-ML>
Subject: IF Indentation

I like it.  If people want to turn it off in their inits I could
care less but I like it to be the default.
Andrew
GSB@MIT-ML 02/16/82 20:10:14 Re: IF clause indenting

I've developed the habit of using IF in the simple cases where
the "then" and "else" clauses are equivalent, and i just about
never use multiple "else" clauses, so have always preferred
having them indent equivalently.  Of course, not using multiple
"else" clauses is partly a response to having it not supported
everywhere (once-upon-a-time?).  Indentation is something i can
always customize if i really want anyway, so i don't really
care that much.
EB@MIT-AI 02/17/82 17:48:53

I vote to keep the special IF indentation, though at first I thought
it was ugly.
BAK@MIT-AI 02/18/82 17:06:21

I am DEFINITELY against it.  I don't see the point of having the the
and else clauses go to different places.

KMRCLを眺める (37) REMOVE-FROM-TREE-IF

| 21:13 | KMRCLを眺める (37) REMOVE-FROM-TREE-IF - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (37) REMOVE-FROM-TREE-IF - わだばLisperになる

今回は、KMRCLのlists.lisp中からREMOVE-FROM-TREE-IFです。

定義は

(defun remove-from-tree-if (pred tree &optional atom-processor)
  "Strip from tree of atoms that satistify predicate"
  (if (atom tree)
      (unless (funcall pred tree)
        (if atom-processor
            (funcall atom-processor tree)
          tree))
    (let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
          (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
      (cond
       ((and car-strip (atom (cadr tree)) (null cdr-strip))
        (list car-strip))
       ((and car-strip cdr-strip)
        (cons car-strip cdr-strip))
       (car-strip
        car-strip)
       (cdr-strip
        cdr-strip)))))

動作は、名前からすると、REMOVE-IFのtree版というところですが、

(DEFVAR *TREE* '(1 A 2 B 3 C 4 D () () (5 E 6 F 7 G (8 9 10) 11 12) 13))

(REMOVE-FROM-TREE-IF #'VALUES *TREE*)
;⇒ NIL

(REMOVE-FROM-TREE-IF #'NULL *TREE*)
;=> (1 A 2 B 3 C 4 D (5 E 6 F 7 G (8 9 10) 11 12) 13)

(REMOVE-FROM-TREE-IF (LAMBDA (X)
                       (IF (SYMBOLP X)
                           X
                           (EVENP X)))
                     *TREE*)
;⇒ (1 3 (5 7 (9) 11) 13)

(REMOVE-FROM-TREE-IF #'SYMBOLP
                     *TREE*
                     (LAMBDA (N) (AND (ODDP N) N)))
;⇒ (1 3 (5 7 (9) 11) 13)

(REMOVE-FROM-TREE-IF #'NUMBERP *TREE*)
;⇒ (A B C D (E F . G))

なんだかちょっと素直じゃないような気も。

再帰する部分が何度も出てくるので、LETの束縛部分に書いてありますが、自分も好きで長くなくても良くこう書きます。

それと、瑣末なところですが、REMOVE-FROM-TREE-IFの定義に使われているIFのインデント方式は読み辛いです…

KMRCLを眺める (36) APPENDNEW

| 14:58 | KMRCLを眺める (36) APPENDNEW - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (36) APPENDNEW - わだばLisperになる

今回は、KMRCLのlists.lisp中からAPPENDNEWです。

定義は

(defun appendnew (l1 l2)
  "Append two lists, filtering out elem from second list that are already in first list"
  (dolist (elem l2 l1)
    (unless (find elem l1)
      (setq l1 (append l1 (list elem))))))

となっています。

L1に含まれていない要素だけ末尾に足してゆくのが分かります。

使用例/動作例は、

(APPENDNEW (LIST 'A 'B 'C 'D)
           (LIST 1 'A 2 'B 3 'C 4 'D))
;⇒ (A B C D 1 2 3 4)

という感じでしょうか。

CLの標準でもこういうのが用意されているような気がしたので、探してみましたが、PUSHNEWとも違うし、UNIONとも違うしで、ありそうで無い関数のようです。

2009-12-10

KMRCLを眺める (35) FILTER

| 23:50 | KMRCLを眺める (35) FILTER - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (35) FILTER - わだばLisperになる

今回は、KMRCLのlists.lisp中からFILTERです。

filterは、関数型言語のユーティリティとしては割と有名なのではないでしょうか。

定義は

(defun filter (fn lst)
  "Filter a list by function, eliminate elements where fn returns nil"
  (let ((acc nil))
    (dolist (x lst (nreverse acc))
      (when (funcall fn x)
        (push x acc)))))

という感じですが、CLのREMOVE-IF-NOTの簡易版というところです。

(DEFVAR *LIST* '(1 2 3 4 NIL NIL 5 NIL 6 NIL 7))

(FILTER #'VALUES *LIST*)
;⇒ (1 2 3 4 5 6 7)

(REMOVE-IF-NOT #'VALUES *LIST*)
;⇒ (1 2 3 4 5 6 7)

REMOVE-IF-NOTは名前が少しひねくれているので、FILTERを定義したくなる気持ちも分からないではないです…。

一応、REMOVE-IF-NOTはsequence汎用ではあります。

(DEFVAR *VECTOR* #(1 2 3 4 NIL NIL 5 NIL 6 NIL 7))
(DEFVAR *STRING* "12345687890abcdef")

(REMOVE-IF-NOT #'VALUES *VECTOR*)
;⇒ #(1 2 3 4 5 6 7)

(REMOVE-IF-NOT #'DIGIT-CHAR-P *STRING*)
;⇒ "12345687890"

2009-12-09

KMRCLを眺める (34) MAP-AND-REMOVE-NILS

| 23:31 | KMRCLを眺める (34) MAP-AND-REMOVE-NILS - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (34) MAP-AND-REMOVE-NILS - わだばLisperになる

今回は、KMRCLのlisps.lisp中からMAP-AND-REMOVE-NILSです。

名前からしてMAP系の関数を使っていてよくありがちな状況を解決してくれそうです。

定義は

(defun map-and-remove-nils (fn lst)
  "mao a list by function, eliminate elements where fn returns nil"
  (let ((acc nil))
    (dolist (x lst (nreverse acc))
      (let ((val (funcall fn x)))
        (when val (push val acc))))))

こんな感じですが、複数のリストには対応してないんですね。

使われ方としては、

(DEFVAR *L* (ALEXANDRIA:IOTA 25))

(MAP-AND-REMOVE-NILS (LAMBDA (X) (AND (EVENP X) X))
                     *L*)
;⇒ (0 2 4 6 8 10 12 14 16 18 20 22 24)

;; MAP-AND-REMOVE-NILSを使いたくなりそうな場面
(REMOVE NIL
        (MAPCAR (LAMBDA (X) (AND (EVENP X) X))
                *L*))
;⇒ (0 2 4 6 8 10 12 14 16 18 20 22 24)

;; しかし、大抵の場合REMOVE-IF等で済みそう…
(REMOVE-IF-NOT #'EVENP
               *L*)
;⇒ (0 2 4 6 8 10 12 14 16 18 20 22 24)

という感じでしょうか。

2009-12-08

KMRCLを眺める (33) MKLIST

| 23:44 | KMRCLを眺める (33) MKLIST - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (33) MKLIST - わだばLisperになる

前回でKMRCLのmacros.lispの中は全部眺めました。

このままKRMCL全部を眺めるのも如何なものか、と思ったのですが、暇なので全部眺めてみようと思います。

ということで、lists.lispに突入です。一ヶ月位リスト関係のユーティリティが続きます。

今回は、そのlists.lisp.の中からMKLISTです。

(defun mklist (obj)
  "Make into list if atom"
  (if (listp obj) obj (list obj)))

定義をみれば動作は、すぐ分かると思いますが、

引数がアトムの時には、listで包み、そうでなければ、渡された引数を返すというものです。

(MKLIST :FOO)
;⇒ (:FOO)

(MKLIST '(:FOO))
;⇒ (:FOO)

しかし、この動きにMKLISTという名前は自分なら付けないなあと思いつつ、しかし、どっかで見た記憶があるなと、Google Code Searchで検索してみたところ、PAIPの中に出てきたユーティリティでした。

今回のMKLISTのような関数を眺めていて思うのですが、こういう引数をそのまま返すことがある関数は、破壊的ではないものの、返って来た値に破壊的変更を加えると元のリストを破壊することになるので、そういうことをするときには注意です。

例えば、

(LET ((FOO (LIST :FOO :BAR :BAZ)))
  (NRECONC (MKLIST FOO) (LIST :QUUX))
  FOO)
;⇒ (:FOO :QUUX) ;(:FOO :BAR :BAZ)を期待(多分)

こういう場合に、あれれ?ということになるやもしれません。

ちなみにANSI CL標準の関数にも割とこういう、引数とEQなリストを返しても良い(と仕様で決まっている)関数が転がっていますので暇なときには探してみましょう!

2009-12-06

KMRCLを眺める (32) defvar-unbound

| 20:53 | KMRCLを眺める (32) defvar-unbound - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (32) defvar-unbound - わだばLisperになる

今回は、KMRCLのmacros.lispの中からDEFVAR-UNBOUNDです。

最初は、どういう意図なのか良く分からず、ドキュメンテーションに"defvar with a documentation string."などと書いている意味がわかりませんでした。

しかし、DEFVARの仕様を良く考えてみると、変数をunboundにしたままドキュメンテーションを付けることができないことに気付きました。

(DEFVAR *FOO* "Documentation")

*FOO*
;⇒ "Documentation
(DEFVAR-UNBOUND *BAR* "Documentation")

*BAR*
;>>> unbound

(DOCUMENTATION '*BAR* 'VARIABLE)
;⇒ "Documentation

なるほど、自分は、あまりドキュメンテーションを付けたりしていなかったので気付きませんでしたが、確かにこういう場合は便利かもしれません。

2009-12-05

Filtered Functions面白そう

| 20:00 | Filtered Functions面白そう - わだばLisperになる を含むブックマーク はてなブックマーク - Filtered Functions面白そう - わだばLisperになる

今日公開されたFiltered Functionsが面白そうだったので、とりあえず、記念にfizzbuzzしてみました。

詳しくは、

を参照したり、リンク中の論文のPDFを参照してみてください。

;; ディスパッチの関数を利用する版
(DEFINE-FILTERED-FUNCTION FIZZBUZZ (N)
  (:FILTERS (:FIZZBUZZ
             (LAMBDA (N)
               (COND ((AND (ZEROP (REM N 3))
                           (ZEROP (REM N 5)))
                      'FIZZBUZZ)
                     ((ZEROP (REM N 3))
                      'FIZZ)
                     ((ZEROP (REM N 5))
                      'BUZZ)
                     ('T 'OTHER))))))

(DEFMETHOD FIZZBUZZ :FILTER :FIZZBUZZ ((N (EQL 'FIZZ)))
  'FIZZ)

(DEFMETHOD FIZZBUZZ :FILTER :FIZZBUZZ ((N (EQL 'BUZZ)))
  'BUZZ)

(DEFMETHOD FIZZBUZZ :FILTER :FIZZBUZZ ((N (EQL 'FIZZBUZZ)))
  'FIZZBUZZ)

(DEFMETHOD FIZZBUZZ :FILTER :FIZZBUZZ ((N (EQL 'OTHER)))
  N)
(KMRCL:FOR (I 1 100)
  (PRINT (FIZZBUZZ I)))
|1 
|2 
|FIZZ 
|4 
|BUZZ 
|FIZZ 
|7 
|8 
|FIZZ 
|BUZZ 
|11 
|FIZZ 
|13 
|14 
|FIZZBUZZ 
|...
;⇒ NIL
;; メソッドコンビネーション風味
(DEFINE-FILTERED-FUNCTION FIZZBUZZ2 (N)
  (:FILTERS (:3 (ZEROP (REM N 3)))
            (:5 (ZEROP (REM N 5)))
            (:3&5 (AND (ZEROP (REM N 5))
                       (ZEROP (REM N 3))))))

(DEFMETHOD FIZZBUZZ2 ((N NUMBER))
  N)

(DEFMETHOD FIZZBUZZ2 :AROUND :FILTER :3&5 (N)
  (DECLARE (IGNORE N))
  'FIZZBUZZ)

(DEFMETHOD FIZZBUZZ2 :AROUND :FILTER :3 (N)
  (DECLARE (IGNORE N))
  'FIZZ)

(DEFMETHOD FIZZBUZZ2 :AROUND :FILTER :5 (N)
  (DECLARE (IGNORE N))
   'BUZZ))
(KMRCL:FOR (I 1 100)
  (PRINT (FIZZBUZZ2 I)))
|1 
|2 
|FIZZ 
|4 
|BUZZ 
|FIZZ 
|7 
|8 
|FIZZ 
|BUZZ 
|11 
|FIZZ 
|13 
|14 
|FIZZBUZZ 
|...
;⇒ NIL

CLOS登場の初期には、Filtered Functionsのようにディスパッチの方法/拡張が色々研究されていたようなのですが、これをきっかけにまた色々活発になると面白そうですねー。

KMRCLを眺める (31) defconstant*

| 19:56 | KMRCLを眺める (31) defconstant* - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (31) defconstant* - わだばLisperになる

今回は、KMRCLのmacros.lispの中からDEFCONSTANT*です。

DEFCONSTANT*は割と定番のマクロな気がします。

定義は、

(defmacro defconstant* (sym value &optional doc)
  "Ensure VALUE is evaluated only once."
   `(defconstant ,sym (if (boundp ',sym)
                          (symbol-value ',sym)
                          ,value)
     ,@(when doc (list doc))))

という感じで、変数を再度DEFCONSTANTしてしまうのを防ぐマクロです。

DEFCONSTANTは、コンパイル時やロード時に評価されるかどうかは処理系が好きにして良いらしく、SBCL等ではコンパイル時にも評価されます。

;; /tmp/foo.lispというファイル
(DEFCONSTANT +CONST+ 42)
;; SBCL
(COMPILE-FILE "/tmp/foo.lisp")
+CONST+
;⇒ 42
;; Allegro CL
(COMPILE-FILE "/tmp/foo.lisp")
+CONST+
;>>> Attempt to take the value of the unbound variable `+CONST+'.

というわけなので、SBCLだとファイルをロードしなくてもDEFCONSTANTの再定義でぶつかることがあります。

The constant +CONST+ is being redefined (from 42 to 43)
   [Condition of type DEFCONSTANT-UNEQL]
See also:
  Common Lisp Hyperspec, DEFCONSTANT [:macro]
  SBCL Manual, Idiosyncrasies [:node]

というようなエラーはSBCLだとライブラリを読み込むときに良く遭遇しますが、こういうケースをDEFCONSTANT*だと回避できるわけですね。

2009-12-04

KMRCLを眺める (30) ppmx

| 22:20 | KMRCLを眺める (30) ppmx - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (30) ppmx - わだばLisperになる

今回は、KMRCLのmacros.lispの中からPPMXです。

一体なんだか良く分からないような名前ですが、動きからするとpretty print macro expand とかそういう辺りじゃないでしょうか。

恐らく、REPLで打つのに都合の良いように名前を短かくしたのだと思います。

定義は、

(defmacro ppmx (form)
  "Pretty prints the macro expansion of FORM."
  `(let* ((exp1 (macroexpand-1 ',form))
          (exp (macroexpand exp1))
          (*print-circle* nil))
     (cond ((equal exp exp1)
            (format t "~&Macro expansion:")
            (pprint exp))
           (t (format t "~&First step of expansion:")
              (pprint exp1)
              (format t "~%~%Final expansion:")
              (pprint exp)))
     (format t "~%~%")
     (values)))

こんな感じで、MACROEXPAND-1の結果とMACROEXPANDの結果の両方を表示しれくれるユーティリティです。

(DOTIMES (I 10)
  (PRINT I))

をPPMXにかけると

First step of expansion:
(DO ((I 0 (1+ I))) ((>= I 10) NIL) (DECLARE (TYPE UNSIGNED-BYTE I)) (PRINT I))

Final expansion:
(BLOCK NIL
  (LET ((I 0))
    (DECLARE (TYPE UNSIGNED-BYTE I))
    (TAGBODY
      (GO #:G2642)
     #:G2641
      (TAGBODY (PRINT I))
      (PSETQ I (1+ I))
     #:G2642
      (UNLESS (>= I 10) (GO #:G2641))
      (RETURN-FROM NIL (PROGN NIL)))))

NIL

という風に展開して表示されます。

今回のPPMXもSlimeから呼べると便利かもしれないということで、拡張を書いてみました。

今回は、拡張を定義するマクロを作り、それで定義してみています。

;; Emacs lisp
(defmacro define-slime-eval-and-grab-output (fn-name)
  (let ((expr (format "(prin1 (%s %%s))" fn-name))
        (main-fn (intern (format "slime-%s" fn-name)))
        (show-fn (intern (format "slime-show-%s" fn-name)))
        (eval-and-fn (intern (format "slime-eval-and-%s" fn-name)))
        (buffer-name (format "*SLIME %s*" (upcase (symbol-name fn-name)))))
    `(eval-after-load "slime"
       '(progn
          (defun ,main-fn ()
            (interactive)
            (,eval-and-fn
             ,(list 'list ''swank:eval-and-grab-output
                    `(format ,expr 
                             (slime-defun-at-point)))))
          (defun ,eval-and-fn (form)
            (slime-eval-async form 
                              (slime-rcurry #',show-fn
                                            (slime-current-package))))
          
          (defun ,show-fn (string package)
            (slime-with-popup-buffer (,buffer-name package t t)
              (lisp-mode)
              (princ (first string))
                (goto-char (point-min))))
            ',main-fn))))

;; kmrcl:ppmx
(define-slime-eval-and-grab-output kmrcl:ppmx)

define-slime-eval-and-grab-outputで、対話的なslime-kmrcl:ppmxというコマンドが定義されます。

Emacs lispだとバッククォートのネストが良く分からないことになるので、ネストを回避しましたが、随分読みにくくなります…。

2009-12-03

KMRCLを眺める (29) with-ignore-errors

| 22:30 | KMRCLを眺める (29) with-ignore-errors - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (29) with-ignore-errors - わだばLisperになる

今回は、KMRCLのmacros.lispの中からWITH-IGNORE-ERRORSです。

その名前から想像できるように、ボディ部をIGNORE-ERRORSで包むというもので定義はこんな感じです。

(defmacro with-ignore-errors (&rest forms)
  `(progn
     ,@(mapcar
        (lambda (x) (list 'ignore-errors x))
        forms)))
(WITH-IGNORE-ERRORS 
  (ERROR "foo")
  (ERROR "bar")
  (ERROR "baz"))

(PROGN
  (IGNORE-ERRORS (ERROR "foo"))
  (IGNORE-ERRORS (ERROR "bar"))
  (IGNORE-ERRORS (ERROR "baz")))

のように展開されます。式が一つずつIGNORE-ERRORSで包まれています。

(WITH-IGNORE-ERRORS 
  (ERROR "foo")
  (ERROR "bar")
  (ERROR "baz"))
;=> NIL
;   #<SIMPLE-ERROR {100BD5FFE1}>

とにかく手短にエラーを無視したいときには便利なのではないでしょうか。

KMRCLを眺める (28) def-cached-instance

| 00:40 | KMRCLを眺める (28) def-cached-instance - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (28) def-cached-instance - わだばLisperになる

今回は、KMRCLのmacros.lispの中からDEF-CACHED-INSTANCEです。

前回のDEF-CACHED-VECTORに引き続き、今度はインスタンスをキャッシュして使い回すんだろうと思います。

定義は、

(defmacro def-cached-instance (name)
  (let* ((new-name (concat-symbol "new-" name "-instance"))
         (release-name (concat-symbol "release-" name "-instance"))
         (cache-name (concat-symbol "*cached-" name "-instance-table*"))
         (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defvar ,cache-name nil)
       (defvar ,lock-name (make-lock ',name))

         (defun ,new-name ()
           (with-lock-held (,lock-name)
             (if ,cache-name
                 (pop ,cache-name)
                 (make-instance ',name))))

         (defun ,release-name (instance)
           (with-lock-held (,lock-name)
             (push instance ,cache-name))))))

で、

マクロ展開は、

(DEF-CACHED-INSTANCE FOO)

;==>

(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (DEFVAR *CACHED-FOO-INSTANCE-TABLE* NIL)
  (DEFVAR *CACHED-FOO-INSTANCE-LOCK* (MAKE-LOCK 'FOO))
  (DEFUN NEW-FOO-INSTANCE ()
    (WITH-LOCK-HELD (*CACHED-FOO-INSTANCE-LOCK*)
      (IF *CACHED-FOO-INSTANCE-TABLE*
          (POP *CACHED-FOO-INSTANCE-TABLE*)
          (MAKE-INSTANCE 'FOO))))
  (DEFUN RELEASE-FOO-INSTANCE (INSTANCE)
    (WITH-LOCK-HELD (*CACHED-FOO-INSTANCE-LOCK*)
      (PUSH INSTANCE *CACHED-FOO-INSTANCE-TABLE*))))

という感じです、前回のDEF-CACHED-VECTORに比べてわかりやすいです。

動作としては、

;; FOOクラス作成
(DEFCLASS FOO () ())

;; 10個貯める
(DOTIMES (I 10 *CACHED-FOO-INSTANCE-TABLE*)
  (RELEASE-FOO-INSTANCE (MAKE-INSTANCE 'FOO)))
;⇒ (#<FOO {***100BC2C051****}> #<FOO {100BC2C011}> #<FOO {100BC2BFD1}>
;    #<FOO {100BC2BF91}> #<FOO {100BC2BF51}> #<FOO {100BC2BF11}>
;    #<FOO {100BC2BED1}> #<FOO {100BC2BE91}> #<FOO {100BC2BE51}>
;    #<FOO {%%%100BC2BE11%%%}>)

;; 15個取り出す
(LET (ANS)
  (DOTIMES (I 15)
    (PUSH (NEW-FOO-INSTANCE) ANS))
  (LIST ANS '<= *CACHED-FOO-INSTANCE-TABLE*))
;⇒ ((#<FOO {100C3587D1}> #<FOO {100C358791}> #<FOO {100C358751}>
;     #<FOO {100C358711}> #<FOO {100C3586D1}> #<FOO {%%%100BC2BE11%%%}>
;     #<FOO {100BC2BE51}> #<FOO {100BC2BE91}> #<FOO {100BC2BED1}>
;     #<FOO {100BC2BF11}> #<FOO {100BC2BF51}> #<FOO {100BC2BF91}>
;     #<FOO {100BC2BFD1}> #<FOO {100BC2C011}> #<FOO {***100BC2C051***}>)
;     <= NIL)

キャッシュしたインスタンスを全部取り出した後は、新規作成して返すという動きがなんとなく分かるかと思います。

前回のDEF-CACHED-VECTORの時から名前に通常のシンボルが使えないというのは、なにか変だと思っていたのですが、KMRCLのMAKE-LOCKがSBCLの場合に上手く機能していなかったようです。

具体的には、SB-THREAD:MAKE-MUTEXの:name引数にはNILか文字列なのですが、ここにシンボルが渡ってきてしまっていたのが問題でした。

(defun make-lock (name)
  #+allegro (mp:make-process-lock :name name)
  #+cmu (mp:make-lock name)
  #+lispworks (mp:make-lock :name name)
  #+sb-thread (sb-thread:make-mutex :name (STRING name)) ;(STRING)を噛ませることで修正
  #+openmcl (ccl:make-lock name)
  )

2009-12-02

KMRCLを眺める (27) def-cached-vector

| 00:42 | KMRCLを眺める (27) def-cached-vector - わだばLisperになる を含むブックマーク はてなブックマーク - KMRCLを眺める (27) def-cached-vector - わだばLisperになる

今回は、KMRCLのmacros.lispの中からDEF-CACHED-VECTORです。

いまいち用途が分からないのですが、名前からしてベクターをキャッシュして使い回すんだろうと思います。

(defmacro def-cached-vector (name element-type)
  (let ((get-name (concat-symbol "get-" name "-vector"))
        (release-name (concat-symbol "release-" name "-vector"))
        (table-name (concat-symbol "*cached-" name "-table*"))
        (lock-name (concat-symbol "*cached-" name "-lock*")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defvar ,table-name (make-hash-table :test 'equal))
       (defvar ,lock-name (kmrcl::make-lock ,name))

         (defun ,get-name (size)
           (kmrcl::with-lock-held (,lock-name)
             (let ((buffers (gethash (cons size ,element-type) ,table-name)))
               (if buffers
                   (let ((buffer (pop buffers)))
                     (setf (gethash (cons size ,element-type) ,table-name) buffers)
                     buffer)
                 (make-array size :element-type ,element-type)))))

         (defun ,release-name (buffer)
           (kmrcl::with-lock-held (,lock-name)
             (let ((buffers (gethash (cons (array-total-size buffer)
                                           ,element-type)
                                     ,table-name)))
               (setf (gethash (cons (array-total-size buffer)
                                    ,element-type) ,table-name)
                 (cons buffer buffers))))))))

という定義で、これを展開すると、

(DEF-CACHED-VECTOR :FOO 'INTEGER)
;>>> 展開
(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
  (DEFPARAMETER *CACHED-FOO-TABLE* (MAKE-HASH-TABLE :TEST 'EQUAL))
  (DEFVAR *CACHED-FOO-LOCK* (MAKE-LOCK :FOO))
  (DEFUN GET-FOO-VECTOR (SIZE)
    (WITH-LOCK-HELD (*CACHED-FOO-LOCK*)
      (LET ((BUFFERS (GETHASH (CONS SIZE 'INTEGER) *CACHED-FOO-TABLE*)))
        (IF BUFFERS
            (LET ((BUFFER (POP BUFFERS)))
              (SETF (GETHASH (CONS SIZE 'INTEGER) *CACHED-FOO-TABLE*) BUFFERS)
              BUFFER)
            (MAKE-ARRAY SIZE :ELEMENT-TYPE 'INTEGER)))))
  (DEFUN RELEASE-FOO-VECTOR (BUFFER)
    (WITH-LOCK-HELD (*CACHED-FOO-LOCK*)
      (LET ((BUFFERS
             (GETHASH (CONS (ARRAY-TOTAL-SIZE BUFFER) 'INTEGER)
                      *CACHED-FOO-TABLE*)))
        (SETF (GETHASH (CONS (ARRAY-TOTAL-SIZE BUFFER) 'INTEGER)
                       *CACHED-FOO-TABLE*)
              (CONS BUFFER BUFFERS))))))

になります。

この展開形から使われ方を想像するに、

(DEF-CACHED-VECTOR :FOO 'INTEGER)

;; 0〜3個のINTEGERを要素とするベクターを3個ずつ作成
(DOTIMES (X 3)
  (DOTIMES (SIZE 4)
    (RELEASE-FOO-VECTOR (MAKE-ARRAY SIZE :ELEMENT-TYPE 'INTEGER))))

(ALEXANDRIA:HASH-TABLE-ALIST *CACHED-FOO-TABLE*)
;⇒ (((3 . INTEGER) #(0 0 0) #(0 0 0) #(0 0 0))
;    ((2 . INTEGER) #(0 0) #(0 0) #(0 0)) 
;    ((1 . INTEGER) #(0) #(0) #(0))
;    ((0 . INTEGER) #() #() #()))

;; 3個の要素のベクターを5つ取り出す(※作成しておいたのは3つ)
(DO ((ANS () (CONS (GET-FOO-VECTOR 3) ANS))
     (TIMES 5 (1- TIMES)))
    ((ZEROP TIMES) ANS))
;⇒ (#(0 0 0) #(0 0 0) #(0 0 0) #(0 0 0) #(0 0 0))

(ALEXANDRIA:HASH-TABLE-ALIST *CACHED-FOO-TABLE*)
;⇒ (((3 . INTEGER)) ;空になった
;   ((2 . INTEGER) #(0 0) #(0 0) #(0 0))
;   ((1 . INTEGER) #(0) #(0) #(0)) 
;   ((0 . INTEGER) #() #() #()))

という感じなのかなあと。

RELEASE-FOO-VECTORは、ベクターの大きさと、要素の型をキーとして、ベクターを貯めているリストを作成

GET-FOO-VECTORは、上記のキーで、ベクターを貯めているリストをポップする。空なら新規にベクターを作成

という感じでしょうか。

上の例では、RELEASE-FOO-VECTORしているときに、MAKE-ARRAYで新規に作成していますが、GET-FOO-VECTORで作成するようにすると、決まった個数以上は新規に作成しないということもできる気がします(といっても予め使う個数を新規で準備しておく必要あり)。

しかし、本来はどういう使い方を意図しているのかは結局良く分からず…。