[cells-devel] make-instance, initarg, c-in

[Ramarren]

I forgot that a single initarg can specify multiple slots! So the code
should be more like:

(defmodel auto-cin-model ()
  ())

(defun class-initargs (class)
  (let ((slots (closer-mop:class-slots class)))
    (let ((class-initargs
           (mapcar #'closer-mop:slot-definition-initargs slots)))
      (remove-if #'(lambda (x)
                     (= (length x) 1))
                 (mapcar #'list* slots class-initargs)))))

(defun slots-for-initarg (initarg class-initargs)
  (loop for (slot . initargs) in class-initargs
       appending (when (member initarg initargs)
                   (list slot))))

(defmethod shared-initialize :after ((instance auto-cin-model)
slot-names &rest initargs)
  (declare (ignore slot-names))
  (let ((class-initargs (class-initargs (class-of instance)))
        (leftmost-initargs (make-hash-table)))
    (loop for (init-arg init-value) on initargs by #'cddr
          do (loop
               for init-slot in (slots-for-initarg init-arg class-initargs)
               for slot-name = (closer-mop:slot-definition-name init-slot)
               do (when (and (not (gethash init-slot leftmost-initargs))
                             (cells::md-slot-cell-type (class-name
(class-of instance)) slot-name)
                             (not (typep init-value 'cell)))
                    (setf (slot-value instance slot-name) (c-in init-value))
                    (setf (gethash init-slot leftmost-initargs) t))))))

Of course, it would be much easier to just iterate over all slots and
set those which are not cells but should be to c-in, but there is
"initarg" in the subject after all.

Regards,
Jakub Higersberger

On Wed, Jul 1, 2009 at 7:53 AM, Ramarren<ramarren at gmail.com> wrote:
> Hello,
>
> Not that I think this is a really good idea, but you can do it using
> the infamous MOP, using http://www.cliki.net/closer-mop as a
> compatibility layer:
>
> (defmodel auto-cin-model ()
>  ())
>
> (defun class-initargs (class)
>  (let ((slots (closer-mop:class-slots class)))
>    (let ((class-initargs
>           (mapcar #'closer-mop:slot-definition-initargs slots)))
>      (remove-if #'(lambda (x)
>                     (= (length x) 1))
>                 (mapcar #'list* slots class-initargs)))))
>
> (defmethod shared-initialize :after ((instance auto-cin-model)
> slot-names &rest initargs)
>  (declare (ignore slot-names))
>  (let ((class-initargs (class-initargs (class-of instance)))
>        (leftmost-initargs (make-hash-table)))
>    (loop for (init-arg init-value) on initargs by #'cddr
>          for init-slot = (car (rassoc init-arg class-initargs :test #'member))
>          for slot-name = (closer-mop:slot-definition-name init-slot)
>          do (when (and (not (gethash init-slot leftmost-initargs))
>                        (cells::md-slot-cell-type (class-name
> (class-of instance)) slot-name)
>                        (not (typep init-value 'cell)))
>               (setf (slot-value instance slot-name) (c-in init-value)))
>             (setf (gethash init-slot leftmost-initargs) t))))
>
> Now all models inheriting from auto-cin-model will have this
> behaviour. This is only marginally tested, so probably contains bugs.
> For one thing, it overrides cells-created shared-initialize, but that
> is only for checking for error which is impossible in this situation
> anyway.
>
> Regards,
> Jakub Higersberger
>
> On Tue, Jun 30, 2009 at 11:32 PM, Bastian Müller<turbo24prg at web.de> wrote:
>> Hi,
>>
>> I'm currently using cells and it works very well,
>> except one thing seems a little unhandy:
>>
>> When defining a model it's possible to use (c-in ..)
>> as an initform to define a slot as a cell, but when
>> instantiating a class you have to supply (c-in ...)
>> instead the normal value, eg.
>>
>> (defmodel x ()
>>  ((y :accessor y
>>      :initarg :y
>>      :initform (c-in nil))
>>   ...))
>>
>> (let ((test (make-instance 'x :y (c-in 1))))
>>  (setf (y test) 2))
>>
>> works, but instead sth like
>>
>> (let ((test (make-instance 'x :y 1)))
>>  (setf (y test) 2))
>>
>> would be nice.
>>
>> I tried it with
>>
>> (defmethod initialize-instance ((self x) &rest rest)
>>  (loop for slot in rest by #'cddr
>>     do (let ((value (getf rest slot))
>>              (name (intern (symbol-name slot))))
>>          (setf (slot-value self name)
>>                (c-in value)))))
>>
>> but I just get:
>>
>> The slot CELLS::.CELLS is unbound in the object #<X {10032D5FC1}>.
>>   [Condition of type UNBOUND-SLOT]
>>
>> Is there any way to get this behavior?
>>
>> kind regards,
>>  Bastian
>>
>> _______________________________________________
>> cells-devel site list
>> cells-devel at common-lisp.net
>> http://common-lisp.net/mailman/listinfo/cells-devel
>>
>