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 |

2008-01-22

俺Arc祭り 2008冬 (8)

| 08:10 | 俺Arc祭り 2008冬 (8) - わだばLisperになる を含むブックマーク はてなブックマーク - 俺Arc祭り 2008冬 (8) - わだばLisperになる

やっと最後まで辿り着きました、俺Arc祭りこと、生後3週間目のArc追っかけ。

最後に来て、ラムダパラメータリストについてです。

keyの代わりに、db(ハッシュ)を使用することにし、また、分割代入をサポートするとのこと。

キーワードを一々指定するのは面倒だから、ハッシュテーブルを引数として食べさせるってことでしょうか。

便利なような便利でないような…。

ノープランで頭から作っていただけに、let、with、def、macro(mac)は定義し直し。

また、変数の分割代入ですが、混み入ってくると正しい文法なのかどうか怪しいです。

;; 動作
(def foo (x (ds (i j)) (get m n) (opt q 'a) . z)
  (list x i j m n q z))

(foo 1 '(red green) (db m 'a n 'b) 'hel 'lo)
;-> (1 RED GREEN A B HEL (LO))

(let x 5
     x)
;-> 5

(with (x 5 y 6)
  (list x y))
;-> (5 6)

(let (ds (x y (z))) '(1 2 (3))
     (list x y z))
;-> 1 2 3

(with ((ds (x y z)) '(1 2 3) a 5)
  (list x y z a))
;-> 1 2 3 5

;; これはアリなのだろうか?
(let (a . b) '(1 2 3 4)
     (list a b))
;->(1 (2 3 4))

;; これで良いのか?
(let (ds ((a b) . rest)) '((1 2) 3 4)
     (list a b rest))
;->(1 2 (3 4))

(with ((ds ((a b) . rest)) '((1 2) 3 4)
       x 10)
  (list a b rest x))
;->(1 2 (3 4) 10)

;; おれおれ定義
(cl:defmacro let (var val cl:&body body)
  `(cl:destructuring-bind ,(remove-ds 
			    (opt-to-&optional
			     (dotex-to-&rest `(,var))))
       (list ,val)
     (declare (ignorable ,@(metatilities:flatten (remove-ds `(,var)))))
     ,@body))

(cl:defmacro with (spec &body body)
  (reduce (fn (x res) `(let ,@x ,res))
	  (loop :for i :on spec :by #'cddr 
	        :collect (metatilities:firstn 2 i))
	  :initial-value `(progn ,@body)
	  :from-end 'T))

(cl:defmacro def (name args cl:&body body)
  (multiple-value-bind (spec /ds /syms) 
      (replace-specs (opt-to-&optional (dotex-to-&rest args)))
    (if /ds
	`(cl:defun ,name ,spec
	   (destructuring-bind ,/ds ,/syms
	     ,@body))
	`(cl:defun ,name ,spec
	   ,@body))))

;; 他のエッセイを読んだら、macroじゃなくて、macになってたのでついでに変更してみる
(cl:defmacro mac (name args cl:&body body)
  (multiple-value-bind (spec /ds /syms) 
      (replace-specs (opt-to-&optional (dotex-to-&rest args)))
    (if /ds
	`(cl:defmacro ,name ,spec
	   (destructuring-bind ,/ds ,/syms
	     ,@body))
	`(cl:defmacro ,name ,spec
	   ,@body))))

;; ラムダパラメータ分解ユーティリティ
(cl:defun opt-to-&optional (expr)
  (loop :for x :in expr
        :nconc (if (eq 'opt (metatilities:car-safe x))
		   `(&optional ,(if (cl:= 2 (length x))
				    (cadr x)
				    (cdr x)))
		   (list x))))

(cl:defun dotex-to-&rest (expr)
  (cl:cond ((atom expr) `(&rest ,expr))
	   ((tailp () expr) expr)
	   ('T (cl:let ((x (copy-list expr)))
		 (rplacd (last x) (list '&rest (cdr (last x))))
		 x))))

(cl:defun replace-specs (expr)
  (loop :with ds :and vars
     :for x :in expr
     :collect (cl:cond ((eq 'ds (metatilities:car-safe x))
			(cl:let ((sym (gensym "DS-")))
			  (push sym vars)
			  (push (cadr x) ds)
			  sym))
		       ((eq 'get (metatilities:car-safe x))
			(cl:let ((sym (gensym "DB-")))
			  (push (cdr x) ds)
			  (push `(list ,@(mapcar (cl:lambda (x) `(get ,x ,sym)) (cdr x))) vars)
			  sym))
		       ('T x))
     :into specs
     :finally (return (values specs ds `(list ,@vars)))))

(defun remove-ds (expr)
  (loop :for x :in expr
        :collect (if (eq 'ds (metatilities:car-safe x))
		     (cadr x)
		     x)))