gistfile1.txt

;; automatic initarg c-in 
;; by Ramarren

(defclass 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 :around ((instance auto-cin-model)
				      slot-names &rest initargs)
  (let ((accumulator nil)
        (class-name (class-name (class-of instance))))
    (labels ((cell-slot-p (slot-name)
	       (cells::md-slot-cell-type class-name slot-name)))
      (loop for (initarg init-value) on initargs by #'cddr
	 with class-initargs = (class-initargs (class-of instance))
	 for slots = (slots-for-initarg initarg class-initargs)
	 for slot-names = (mapcar #'closer-mop:slot-definition-name slots)
	 do (push initarg accumulator)
	   (cond ((and (not (every #'cell-slot-p slot-names))
		       (not (notany #'cell-slot-p slot-names)))
		  (error "Initarg ~a specifies both cell and non
cell slots." initarg))
		 ((and (every #'cell-slot-p slot-names)
		       (not (typep init-value 'cells:cell)))
		  (push (cells:c-in init-value) accumulator))
		 (t (push init-value accumulator)))))
    (apply #'call-next-method instance slot-names (nreverse accumulator))))


;; test

(cells:defmodel test-cin (auto-cin-model cells::model-object)
  ((test :initarg :test
	 :accessor test
	 :initform (cells:c-in nil))))

(defun test-cin ()
  (let ((x (make-instance 'test-cin :test 1)))
    (setf (test x) 2))) 

;; with only (cells:defmodel test-cin (auto-cin-model) ..
;; 
;; (test-cin)
;; =>
;; If no superclass of TEST-CIN inherits directly
;; or indirectly from model-object, model-object must be included as a direct super-class in
;; the defmodel form for TEST-CIN
;;   [Condition of type SIMPLE-ERROR]

;; change to: (cells:defmodel test-cin (auto-cin-model cells:model-object) ..
;; 
;; (test-cin)
;; =>
;; 2