CODEWITHSUNDEEP
common-lispclos
angus
angus

Reputation: 2367

How can I access a slot with class allocation without creating an instance?

I use a macro to create some classes and map strings to them in a global variable:

(defvar *labels-to-classes* (make-hash-table :test 'equal))

(defmacro define-labeled-class (name label slots)
  `(progn
     (defclass ,name ()
       ,slots)
     (setf (gethash ,label *labels-to-classes*) (find-class ',name))))

I have another class whose instances know how to make instances of these labeled classes. It uses the global hashtable.

(defclass factory ()
 ((x :accessor factory-x)))

(defmethod make-instance-from-label ((fact factory) label)
  (let ((o (make-instance (gethash label *labels-to-classes*))))
    ;; use values in fact to set up o
    o))

I think the map from strings to classes would be better located in a slot in the factory class with class allocation. But how do I fill it up when I'm defining the other classes, before I have even one instance of it?

Upvotes: 3

Views: 62

Answers (1)

coredump
coredump

Reputation: 38967

As said by Barmar in comments, you can use CLASS-PROTOTYPE. Here is an example with no custom macros, just regular MOP:

(ql:quickload :closer-mop)

;; define a metaclass: instances of this type are classes with
;; additional class slots.
(defclass labeled-class (c2mop:standard-class)
  (;; the label associated with this class
   (label :accessor label :initarg :label)
   ;; all classes whose metaclass is labeled-class share the same
   ;; cache mapping labels to classes.
   (cache :allocation :class
          :initform (make-hash-table :test #'equal))))

;; this is necessary to be able the inherit from a standard class
(defmethod c2mop:validate-superclass ((o labeled-class) (_ standard-class)) t)

;; when defining a class whose metaclass is labeled-class, store it in
;; the cache under its label
(defmethod initialize-instance :after ((c labeled-class) &key &allow-other-keys)
  "Map label of c to c in the global cache"
  (setf (gethash (label c) (slot-value c 'cache)) c))

For example, I define two labeled classes. Note how the :label argument is given as a class option; I wrote (:label . "foo") with a dot so that the argument is the string foo, not the list ("foo") (that would be the case with (:label "foo") due to how class options are defined).

(defclass my-foo-class ()
  ((x :initform 0 :reader x))
  (:label . "foo")
  (:metaclass labeled-class))

(defclass my-bar-class ()
  ((y :initform 0 :reader y))
  (:label . "bar")
  (:metaclass labeled-class))

Using the class prototype of labeled-class, it is possible to access the shared cache value:

(alexandria:hash-table-plist
 (slot-value (c2mop:class-prototype (find-class 'labeled-class))
             'cache))

("foo" #<LABELED-CLASS COMMON-LISP-USER::MY-FOO-CLASS> 
 "bar" #<LABELED-CLASS COMMON-LISP-USER::MY-BAR-CLASS>)

Upvotes: 1

Related Questions