2011/06/19

SERIES の producing の中での setf

次のように SERIES の producing の中での setf を使うと (setf b (car a)) のところが (setf nil (car a)) になりエラーとなる。

(defun foo ()
(declare (optimizable-series-function))
(producing (z) ((a '(1 2 3)) b)
(loop
(tagbody
(if (endp a)
(terminate-producing))
(setf b (car a))
(setf a (cdr a))
(next-out z b)))))

(collect (foo))

s-code.lisp をながめると

;;;; 13. Allow `SETF like SETQ' in PRODUCING forms.

とあるのだけど、

        (cond ((and (consp f) (case (car f) ((setq) t))) ; setf removed for now
(cl:multiple-value-bind (vars lastbind binds) (detangle2 (cdr f))
(unless (cdr lastbind)
(ers 50 "~%missing value in assignment: " f))
;; setf still not supported - need to make caller setf-aware
(cl:let ((expr (cons 'setq ; should be setf
(mapcan #'xform-assignment vars binds))))
;;(format t "~s" expr)
(push expr revbody))))
...)

今はみたいなことになっている。

きっと何か問題があったんだろうけど、なんだろう?とりあえず、case のところだけ

(case (car f) ((setq setf) t))

にしてみたら上記の foo は動いたけど

(defun foo ()
(declare (optimizable-series-function))
(producing (z) ((a '(1 2 3)) (b (list nil)) c)
(loop
(tagbody
(if (endp a)
(terminate-producing))
(setf (car b) (car a))
(setf c b)
(setf a (cdr a))
(next-out z c)))))

みたいのは動かない。 ; should be setf のところを setf にしたら、 (SETQ NIL #:OUT-2) になってだめ。

ってところで力つきた。。。

[2011-06-21] ちょっとちがったので修正した。

2011/06/18

SERIES を series:install して使うときの defpackage

LET LET* MULTIPLE-VALUE-BIND FUNCALL DEFUN を shadowing import するので defpackage をラップするマクロがあると楽。

(defmacro sdefpackage (package &rest options)
`(progn
(defpackage ,package
,@options
(:use :series)
(:shadowing-import-from :series ,@series::/series-forms/))
(series::install :pkg ,package :implicit-map t)))

2011/06/05

change-class でモードの実装

McCLIM の ESA では change-class を使ってバッファ(エディタ)のモードを実装している。それそまねて、少しコードを書いてみた。

ESA では "anonymous classes are the ugly child of CL" ということで、あえて無名クラスではなく defclass を eval するようにしている(ESA/utils.lisp)。私の方は何も考えず無名クラスでいってみようと思う。

有効にするモードをスーパークラスにし指定して standard-class を make-instance して、それに change-class する。多重継承大好き。

ところで、McCLIM のソースは MOP のいろんな機能を使っていておもしろい。

(in-package :info.read-eval-print.editor)

(defun anonymous-class-p (class)
(null (class-name class)))

(defgeneric enable-mode (mode mode-to-enable &rest initargs)
(:method (mode mode-to-enable &rest initargs)
(let* ((current-class (class-of mode))
(superclasses (cons(find-class mode-to-enable)
(if (anonymous-class-p current-class)
(c2mop:class-direct-superclasses current-class)
(list current-class))))
(new-class (make-instance 'c2mop:standard-class
:direct-superclasses superclasses)))
(apply #'change-class mode new-class initargs))))

(defgeneric disable-mode (mode mode-to-disable &rest initargs)
(:method (mode mode-to-disable &rest initargs)
(let* ((current-class (class-of mode))
(superclasses (remove (find-class mode-to-disable)
(c2mop:class-direct-superclasses current-class)))
(new-class (make-instance 'c2mop:standard-class
:direct-superclasses superclasses)))
(apply #'change-class mode new-class initargs))))

(defgeneric enabled-mode (mode)
(:method (mode)
(let ((class (class-of mode)))
(if (anonymous-class-p class)
(collect (class-name (scan (c2mop:class-direct-superclasses class))))
(list (class-name class))))))

(defgeneric key-binding (mode keyseq)
(:method-combination or))

(defclass* key-map ()
((map (make-hash-table :test #'equal))))

(defclass* mode ()
((name nil)
(key-map (make-instance 'key-map))))

(defclass* fundamental-mode (mode)
())

(defclass* lisp-mode (mode)
())

(defclass* common-lisp-mode (lisp-mode)
())

(defclass* show-paren-mode (mode)
())

(defmethod print-object ((x mode) stream)
(print-unreadable-object (x stream)
(format stream "~a ~(~{~a~^ ~}~)" (name-of x) (enabled-mode x))))


(let ((x (make-instance 'fundamental-mode :name "*scratch*")))
(print x)
(enable-mode x 'common-lisp-mode)
(print x)
(enable-mode x 'show-paren-mode)
(print x)
(disable-mode x 'common-lisp-mode)
(print x)
(disable-mode x 'show-paren-mode)
(print x))
;;->
;; #<*scratch* fundamental-mode>
;; #<*scratch* common-lisp-mode fundamental-mode>
;; #<*scratch* show-paren-mode common-lisp-mode fundamental-mode>
;; #<*scratch* show-paren-mode fundamental-mode>
;; #<*scratch* fundamental-mode>
;;=> #<*scratch* fundamental-mode>

(let ((x (make-instance 'c2cl:standard-class
:direct-superclasses (list (find-class 'common-lisp-mode)
(find-class 'show-paren-mode)))))
(print (c2mop:class-direct-superclasses x))
(print (make-instance x :name "ま"))
x)
;;->
;; (#<STANDARD-CLASS COMMON-LISP-MODE> #<STANDARD-CLASS SHOW-PAREN-MODE>)
;; #<ま (COMMON-LISP-MODE SHOW-PAREN-MODE)>
;;=> #<STANDARD-CLASS NIL {10048B11E1}>