Search code examples
processcommon-lispslotsclos

lisp, CLOS: adding a slot to the process class


My program is getting errors with multithreading, so I want to expand the with-lock-grabbed macro to keep track of the stack of locks a process acquires. I want to do this by simply adding a slot to process to store the lock-stack.

Unfortunately, I don't understand how to add a slot at runtime without destroying what's already there. ensure-class completely redefines the class. I don't want this, since I don't know what other slots process already has.

How can I add a slot? In particular, I would like to add these two slots:

    (lock-stack :documentation "stores a list of all locks of the process.
Only used for debugging"
    :type list
    :initform nil
    :accessor lock-stack-acc
)
(lock-stack-error-found :documentation "indicates that an error on the locks was already found.
Only used for debugging"
    :type boolean
    :initform nil
    :accessor lock-stack-error-found-acc
)

Solution

  • Someone on GoogleGroups linked me to the answer: https://groups.google.com/group/comp.lang.lisp/msg/7e24e8417cd1b6e6?dmode=source

    (defun direct-slot-defn->initarg (slot-defn)
      (list :name (slot-definition-name slot-defn)
            :readers (slot-definition-readers slot-defn)
            :writers (slot-definition-writers slot-defn)
            :initform (slot-definition-initform slot-defn)
            :initargs (slot-definition-initargs slot-defn)
            :initfunction (slot-definition-initfunction slot-defn)))
    
    (defun add-slot-to-class (class name &key (initform nil)
                                    accessors readers writers
                                    initargs
                                    (initfunction (constantly nil)))
      (check-type class symbol)
      (let ((new-slots (list (list :name name
                                   :readers (union accessors readers)
                                   :writers (union writers
                                                   (mapcar #'(lambda (x)
                                                               (list 'setf
    x))
                                                           accessors)
                                                   :test #'equal)
                                   :initform initform
                                   :initargs initargs
                                   :initfunction initfunction))))
        (dolist (slot-defn (class-direct-slots (find-class class)))
          (push (direct-slot-defn->initarg slot-defn)
                new-slots))
        (ensure-class class :direct-slots new-slots)))