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-12-18

祝Pitmanual改訂版発表ということでdesetqをつくってみる

| 03:23 | 祝Pitmanual改訂版発表ということでdesetqをつくってみる - わだばLisperになる を含むブックマーク はてなブックマーク - 祝Pitmanual改訂版発表ということでdesetqをつくってみる - わだばLisperになる

どうしてなのかは知りませんが、急に12/16日の日曜日にMacLISPのマニュアルの改訂版(The Revised Maclisp Manual (The Pitmanual))が発表されました。

結構前からMACLISP infoというサイトはありまして、Maclispの情報が纏められるサイト予定地ということだったんですが、ずっとコンテンツは不在でした。

作者のKent M. Pitman氏は特にどっかに完成を発表したという訳でもないようでcomp.lang.lispにタレこみがあって初めて周知された様子。

しかし、仕上がりは結構気合いが入っていて、原稿をHTMLに直しただけでは全然なく、Common Lispとの比較や現在の視点からの考察が加えられています。

需要と供給のバランスからすれば、かなりの過剰供給っぷり。

製作には、奥さんと娘さんと本人が当たったということで、これまた不思議な家族。

ということで、なんとなく記念にMaclispのdesetqを作って遊んでみることにしました。

こないだ、Maclispのletの分割代入版を作ったときに、desetqも作ろうと思っていたのですが、こっちは放置してました。

desetqは、setqに分割代入機能が付いたものでPitmanualでの解説はThe Pitmanual: Control Formsです。

Pitman+Manualで、Pitmanual、これの前のDavid Moon氏が作ったのは、Moonualと呼ばれていたとのことで、その辺の文化を継承してるみたいです。

動作としては、

(let ((a 1) (b 2) (c 3) (d 4) (e 5) (f 6))
  (desetq (((a) b . c) d e f)  (list (list* (list a) b c) d e f) )
  (list a b c d e f))
;==> (1 2 3 4 5 6)

という感じになります。

(defmacro desetq (&rest bind-specs)
  (unless (evenp (length bind-specs))
    (error "Too many arguments in form ~S." bind-specs))
  (do ((l bind-specs (cddr l)) 
       body vars)
      ((endp l) `((lambda ,vars ,@body) ,@(mapcar (constantly ()) vars)))
    (let ((var (car l)) (val (cadr l)))
      (if (consp var)
	  (let ((tem (gensym)))
	    (multiple-value-bind (varlist vallist) (des- var tem)
	      (setq vars `(,@vallist ,@vars ,tem))
	      (setq body `(,@body (setq ,tem ,val) ,@varlist))))
	  (setq body `(,@body (setq ,var ,val)))))))

(defun des- (bind sym)
  (let (vars)
    (values 
     (labels ((frob (bind sym)
		(cond ((null bind) nil)	
		      ((atom bind)
		       `((setq  ,bind ,sym)))
		      ((null (car bind))
		       `((setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ((and (atom (car bind)) (null (cdr bind)))
		       `((setq ,(car bind) (car ,sym)))) ;last -1
		      ((atom (car bind))
		       `((setq ,(car bind) (car ,sym))
			 (setq ,sym (cdr ,sym))
			 ,@(frob (cdr bind) sym)))
		      ('T (let ((carcons (gensym)))
			    (push carcons vars)
			    `((setq ,carcons (car ,sym))
			      ,@(frob (car bind) carcons)
			      (setq ,sym (cdr ,sym))
			      ,@(frob (cdr bind) sym)))))))
       (frob bind sym))
     vars)))

  • 動作
(desetq (((a) b . c) d e f)  (list (list* (list a) b c) d e f))
;==>

((LAMBDA (#:G2 #:G1 #:G0)
   (SETQ #:G0 (LIST (LIST* (LIST A) B C) D E F))
   (SETQ #:G1 (CAR #:G0))
   (SETQ #:G2 (CAR #:G1))
   (SETQ A (CAR #:G2))
   (SETQ #:G1 (CDR #:G1))
   (SETQ B (CAR #:G1))
   (SETQ #:G1 (CDR #:G1))
   (SETQ C #:G1)
   (SETQ #:G0 (CDR #:G0))
   (SETQ D (CAR #:G0))
   (SETQ #:G0 (CDR #:G0))
   (SETQ E (CAR #:G0))
   (SETQ #:G0 (CDR #:G0))
   (SETQ F (CAR #:G0)))
 NIL NIL NIL)

と展開されます。

オリジナルのものはもうすこし綺麗に展開されるのですが、若干面倒なので、これで良しとしました。