[slime-devel] openmcl defclass documentation workaroud

[Marco Baringer]

the following code, put in openmcl-init.lisp, fixes a bug in openmcl's
defclass macro and should allow the inspector to work properly. it's
just a dirty hack till the next official release of openmcl.

;;;; defclass work around

(defclass common-lisp-user::!@$% () () (:documentation "x"))

(when (consp (documentation (find-class 'common-lisp-user::!@$%) t))
  (handler-bind ((error (lambda (c) (declare (ignore c)) (invoke-restart 'continue))))
    (defmacro defclass (class-name superclasses slots &rest class-options &environment env)
      (flet ((duplicate-options (where) (signal-program-error "Duplicate options in ~S" where))
             (illegal-option (option) (signal-program-error "Illegal option ~s" option))
             (make-initfunction (form)
               (cond ((or (eq form 't)
                          (equal form ''t))
                      '(function true))
                     ((or (eq form 'nil)
                          (equal form ''nil))
                      '(function false))
                     (t
                      `(function (lambda () ,form))))))
        (setq class-name (require-type class-name '(and symbol (not null))))
        (setq superclasses (mapcar #'(lambda (s) (require-type s 'symbol)) superclasses))
        (let* ((options-seen ())
               (signatures ())
               (slot-names))
          (flet ((canonicalize-defclass-option (option)
                   (let* ((option-name (car option)))
                     (if (member option-name options-seen :test #'eq)
                         (duplicate-options class-options)
                         (push option-name options-seen))
                     (case option-name
                       (:default-initargs
                        (let ((canonical ()))
                          (let (key val (tail (cdr option)))
                            (loop (when (null tail) (return nil))
                               (setq key (pop tail)
                                     val (pop tail))
                               (push ``(,',key ,',val  ,,(make-initfunction val)) canonical))
                            `(':direct-default-initargs (list ,@(nreverse canonical))))))
                       (:metaclass
                        (unless (and (cadr option)
                                     (typep (cadr option) 'symbol))
                          (illegal-option option))
                        `(:metaclass  ',(cadr option)))
                       (:documentation
                        (let* ((doc (cadr option)))
                          (if (and doc (not (typep doc 'string)))
                              (illegal-option option))
                          `(:documentation ',doc)))
                       (t
                        (list `',option-name `',(cdr option))))))
                 (canonicalize-slot-spec (slot)
                   (if (null slot) (signal-program-error "Illegal slot NIL"))
                   (if (not (listp slot)) (setq slot (list slot)))
                   (let* ((slot-name (require-type (car slot) 'symbol))
                          (initargs nil)
                          (other-options ())
                          (initform nil)
                          (initform-p nil)
                          (initfunction nil)
                          (type nil)
                          (type-p nil)
                          (allocation nil)
                          (allocation-p nil)
                          (documentation nil)
                          (documentation-p nil)
                          (readers nil)
                          (writers nil))
                     (when (memq slot-name slot-names)
                       (SIGNAL-PROGRAM-error "Duplicate slot name ~S" slot-name))
                     (push slot-name slot-names)
                     (do ((options (cdr slot) (cddr options))
                          name)
                         ((null options))
                       (when (null (cdr options)) (signal-program-error "Illegal slot spec ~S" slot))
                       (case (car options)
                         (:reader
                          (setq name (cadr options))
                          (push name signatures)
                          (push name readers))
                         (:writer                      
                          (setq name (cadr options))
                          (push name signatures)
                          (push name writers))
                         (:accessor
                          (setq name (cadr options))
                          (push name signatures)
                          (push name readers)
                          (push `(setf ,name) signatures)
                          (push `(setf ,name) writers))
                         (:initarg
                          (push (require-type (cadr options) 'symbol) initargs))
                         (:type
                          (if type-p
                              (duplicate-options slot)
                              (setq type-p t))
                                        ;(when (null (cadr options)) (signal-program-error "Illegal options ~S" options))
                          (setq type (cadr options)))
                         (:initform
                          (if initform-p
                              (duplicate-options slot)
                              (setq initform-p t))
                          (let ((option (cadr options)))
                            (setq initform `',option
                                  initfunction
                                  (if (constantp option)
                                      `(constantly ,option)
                                      `#'(lambda () ,option)))))
                         (:allocation
                          (if allocation-p
                              (duplicate-options slot)
                              (setq allocation-p t))
                          (setq allocation (cadr options)))
                         (:documentation
                          (if documentation-p
                              (duplicate-options slot)
                              (setq documentation-p t))
                          (setq documentation (cadr options)))
                         (t
                          (let* ((pair (or (assq (car options) other-options)
                                           (car (push (list (car options)) other-options)))))
                            (push (cadr options) (cdr pair))))))
                     `(list :name ',slot-name
                            ,@(when allocation `(:allocation ',allocation))
                            ,@(when initform-p `(:initform ,initform
                                                           :initfunction ,initfunction))
                            ,@(when initargs `(:initargs ',initargs))
                            ,@(when readers `(:readers ',readers))
                            ,@(when writers `(:writers ',writers))
                            ,@(when type-p `(:type ',type))
                            ,@(when documentation-p `(:documentation ,documentation))
                            ,@(mapcan #'(lambda (opt)
                                          `(',(car opt) ',(cdr opt))) other-options)))))
            (let* ((direct-superclasses (or superclasses '(standard-object)))
                   (direct-slot-specs (mapcar #'canonicalize-slot-spec slots))
                   (other-options (apply #'append (mapcar #'canonicalize-defclass-option class-options ))))
              `(progn
                 (eval-when (:compile-toplevel)
                   (%compile-time-defclass ',class-name ,env)
                   (progn
                     ,@(mapcar #'(lambda (s) `(note-function-info ',s nil ,env))
                               signatures)))
                 (ensure-class-for-defclass ',class-name
                                            :direct-superclasses ',direct-superclasses
                                            :direct-slots ,`(list , at direct-slot-specs)
                                            , at other-options)))))))))

hth.

-- 
-Marco
Ring the bells that still can ring.
Forget your perfect offering.
There is a crack in everything.
That's how the light gets in.
     -Leonard Cohen