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-11-15


LispMの関数こまごま

| 16:33 | LispMの関数こまごま - わだばLisperになる を含むブックマーク はてなブックマーク - LispMの関数こまごま - わだばLisperになる

何となく古いコードを散策したかったので、Lispマシン(以下LispM)の関数を読んでみることにしました。

お題に使用したコードは、LMIのLambdaのシステム部分のもので、ウェブで公開されています。

お題

zl:everyと、zl:some

暗記で再現

(defun zl_every (pred list &optional (step #'cdr))
  (do ((tail list (funcall step tail)))
      ((endp tail) t)
    (unless (funcall pred (car tail))
      (return nil))))

(defun zl_some (pred list &optional (step #'cdr))
  (do ((tail list (funcall step tail)))
      ((endp tail) nil)
    (when (funcall pred (car tail))
      (return t))))

できた。zl:everyとなっているのは、Zetalispの定義がまとめてパッケージになっているため。Zetalispは、LispM用のLispでCommon Lispの直接の先祖です。Common Lispが登場すると、LispMのメーカーも基本的にCommon Lispを基盤とするようになりZetalispは互換性のため残されていたという風に見えます。ステップ用の関数を指定できたりするのが、意外というか、どういう時に役に立つのかあまり想像が付きません…。ちなみに、Lisp Machine Lispと、Zetalispの違いですが、「Evolution of Lisp」によれば、Lisp Machine Lispは元々のLispM用のLispでしたが、ハードウェアのシステムソフトを全面的にLispで記述するには、それでは弱かったので記述できるようにSymbolicsが強化したものをZetalispと命名したようです。しかし、LMIも、TIもZetalispと呼んでいて、なおかつマニュアルは、Lisp Machine LispとZetalispと共通ということなので、何が何だか分かりません。まあ、LispM用のLispはZetalispと呼んでおけば良いんでしょう。

;; 動作
(zl_every #'plusp '(1 2 3 4 5) #'cddr)
;=> T

お題

firstn

暗記で再現

(defun firstn (n list)
  (let ((new-list (make-list n)))
    (do ((list list (cdr list))
	 (new-list new-list (cdr new-list)))
	((or (endp list) (endp new-list)))
      (rplaca new-list (car list)))
    new-list))

SRFI-1のtakeと同じ機能。

PG氏のユーティリティにもあったんですが、PG氏オリジナルじゃなくて、LispM由来のものだったとは知りませんでした。

doの定番書式からすると、

(defun firstn (n list)
  (do ((list list (cdr list))
       (new-list (make-list n) (cdr new-list)))
      ((or (endp list) (endp new-list)) new-list)
    (rplaca new-list (car list))))

でも良いんじゃないかと思いましたが、doの中身で使われているnew-listとletでのnew-listは別物で、doの中身は、ポインタ移動用?で、letのは、先頭のポインタ保持用?なので、一緒にすると上手く機能しないという罠。

;; 動作
(firstn 3 '(1 2 3 4 5))
;=> (1 2 3)

お題

circular-list

暗記で再現

(defun circular-list (&rest args &aux tem)
  (when args
    (setq tem (copy-list args))
    (setf (cdr (last tem)) tem)
    tem))

できた。これまた、SRFI-1のcircular-listと同じ機能のもの。これもLispMに存在していたとは知りませんでした。

;; 動作
(mapcar #'list
	'(1 2 3 4 5 6 7 8)
	(circular-list 'a 'b))
;=> ((1 A) (2 B) (3 A) (4 B) (5 A) (6 B) (7 A) (8 B))

お題

暗記で再現

(defun zl_delete (item list &optional (times most-positive-fixnum) &aux ll pl)
  (prog ()
     A  (cond ((or (atom list) (zerop times))
	       (go R))
	      ((equal (car list) item)
	       (pop list)
	       (decf times)
	       (go A)))
        (setq ll list)
     B  (cond ((or (atom ll) (zerop times))
	       (go R))
	      ((equal (car ll) item)
	       (rplacd pl (cdr ll))
	       (decf times))
	      ((setq pl ll)))
        (pop ll)
	(go B)
     R	(return list)))

できた。これもリストのポインタ操作系で、ちょっとややこしい。

Aのセクションで、先頭から、itemが連続する場合を処理し、llにlistの先頭のポインタをコピーしてBに移行。Bでは、llは、ポインタ移動の役割で、plは、リストの継ぎ接ぎのために使われている模様。このパターンには色々見た目が違うコーディングが沢山あるようで、どうも覚えられない…。

;; 動作
(zl_delete 'b '(a b b c) 1)
;=> (a b c)

お題

delq

暗記で再現

(defun delq (item list &optional (times -1))
  (prog (ll pl)
    A   (cond ((or (atom list) (= times 0))
	       (return list))
	      ((eq item (car list))
	       (setq list (cdr list))
	       (setq times (1- times))
	       (go A)))
        (setq ll list)
    B   (cond ((or (atom ll) (= times 0))
	       (return list))
	      ((eq item (car ll))
	       (rplacd pl (cdr ll))
	       (setq times (1- times)))
	      ((setq pl ll)))
        (setq ll (cdr ll))
	(go B)))

deleteの要素の比較をeqで行なうdelq。

どうやら、こっちの方が定義が古いっぽい。理屈としては、上のzl:deleteと同じ。zl:deleteの方が意図が読み取り易かった。

;; 動作
(delq 'a '(a b c a a b c) 2)
;=> (B C A B C) 

お題

greaterp

暗記で再現

(defun greaterp (&rest numbers)
  (prog (a (b (cdr numbers)) c)
	(if (null b) (return t))
        (setq a (car numbers))
    again
	(setq c (car b))
	(if (<= a c) (return nil))
	(setq b (cdr b))
	(if (null b) (return t))
	(setq a c)
	(go again)))

できた。greaterpは、>の元祖。この定義だと、引数が無いときと1つの時は、Tを返すようになっている。Common Lispの>だと、0個の引数はエラー。

;; 動作
(greaterp 4 3 2 1)
(greaterp)
;; => t
(>)
;; error
(greaterp 8)
;; => t

お題

and

(defmacro (and alternate-macro-definition) (&rest expressions)
  (case (length expressions)
    (0 t)
    (1 (car expressions))
    (t (do* ((foo (cdr (reverse expressions)) (cdr foo))
             (result `(,(car (last expressions)))))
            ((null foo)
             (car result))
         (setq result `((if ,(car foo) . ,result)))))))

暗記で再現

(defmacro _and (&rest expressions)
  (case (length expressions)
    (0 t)
    (1 expressions)
    (otherwise 
     (do* ((foo (reverse expressions) (cdr foo))
	   (result `(,(car foo))))
	  ((endp foo) (car result))
       (setq result `((if ,(car foo) . ,result)))))))

全く同じではないけれどできた。caseで振り分けてるってのが何となく新鮮。オリジナルは、do*としているので、resultの初期化で、fooの結果が使える筈なんだけれど使ってなかったりするので、doでも良いんじゃないかと思ったりする。

お題

let-if

;;; LET-IF (gak)
(defmacro (let-if alternate-macro-definition) (condition binding-list &rest body)
  (let ((thunk (gensym)))
    (labels ((split-bindings (bindings variables values)
               (if (null bindings)
                   `(LET ((,thunk ,@body))
                      (IF ,condition
                          (PROGV ,variables ,values (FUNCALL ,thunk))
                          (FUNCALL ,thunk)))
                   (let ((this-binding (first bindings)))
                     (split-bindings (rest bindings)
                                     (cons (if (listp this-binding)
                                               (first this-binding)
                                               this-binding)
                                           variables)
                                     (cons (if (and (listp this-binding)
                                                    (cdr this-binding))
                                               (second this-binding)
                                               'nil)
                                           values))))))
      (split-bindings binding-list '() '()))))

暗記で再現

(defmacro let-if (condition binding-list &body body)
  (labels ((split-bindings (bindings variables values)
	     (if (null bindings)
		 `(if ,condition
		      (multiple-value-bind ,variables (values-list ',values) ,@body)
		      (progn ,@body))
		 (let ((this-binding (first bindings)))
		   (split-bindings (rest bindings)
				   (cons (if (consp this-binding)
					     (first this-binding)
					     this-binding)
					 variables)
				   (cons (if (and (consp this-binding)
						  (rest this-binding))
					     (second this-binding)
					     'nil)
					 values))))))
    (split-bindings binding-list '() '() )))

Common Lispで動くようにちょっと変更したけど、多分これで良いんじゃなかろうか。

(let-if cond ((変数 値)))

という形式で、condが真ならば、letの変数束縛が生きて、偽ならば、束縛は生きないというもの。

多分、

(defmacro let-if (condition binding-list &body body)
  `(if ,condition
       (let ,binding-list
	 ,@body)
       (let ()
	 ,@body)))

のような定義の動作で良いと思うんだけれども、progvの変数のバインディングに合せるために、複雑になっている模様。しかし、progvを使う必要はあるんだろうか。この辺、基本ダイナミックスコープなZetalispと、レキシカルスコープなCommon Lispで違ってきているような気がする。split-bindingsは関数として独立させてもマクロ等で便利に使えそう。

;; 動作
(let-if t ((foo 8) (bar 9))
  (list foo bar))
; => (8 9)