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] ちょっとちがったので修正した。

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)))

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}>