:init-once slot

init-once-slot.lisp

;;; -*- mode: Lisp; coding: utf-8  -*-

(cl:in-package "BCL-USER")

(defclass init-once-slot-class (standard-class)
  ())

(defmethod clos:process-a-slot-option 
           ((class init-once-slot-class) option value
            already-processed-options slot)
  (if (eq option :init-once)
      (list* :init-once value already-processed-options)
      (call-next-method)))

(defclass init-once-slot-definition (standard-slot-definition)
  ((init-once :initform nil :initarg :init-once
              :accessor slot-definition-init-once)))

(defclass init-once-direct-slot-definition-class
          (init-once-slot-definition standard-direct-slot-definition)
  ())

(defclass init-once-effective-slot-definition-class
          (init-once-slot-definition standard-effective-slot-definition)
  ())

(defmethod direct-slot-definition-class
           ((class init-once-slot-class) &rest initargs)
  (find-class 'init-once-direct-slot-definition-class))

(defmethod effective-slot-definition-class
           ((class init-once-slot-class) &rest initargs)
  (find-class 'init-once-effective-slot-definition-class))

(defmethod compute-effective-slot-definition ((class init-once-slot-class)
                                              name
                                              direct-slot-definitions)
  (let ((slot (call-next-method)))
    (when (typep slot 'init-once-slot-definition)
      (setf (slot-definition-init-once slot)
            (slot-definition-init-once (find name direct-slot-definitions
                                             :key #'slot-definition-name))))
    slot))

(defmethod (setf slot-value-using-class)
           (val (class init-once-slot-class) (obj standard-object) (slotd init-once-effective-slot-definition-class))
  (if (and (slot-definition-init-once slotd)
           (slot-boundp-using-class class obj
                                    (slot-definition-name slotd)))
      (let ((*package* (find-package :keyword)))
        (error "Instance slot ~S is immutable for object ~S"
               (slot-definition-name slotd)
               obj))
      (call-next-method)))

(defclass foo (standard-object)
  ((a :init-once T)
   (b :init-once nil))
  (:metaclass init-once-slot-class))

(let ((foo (a 'foo)))
  (setf (~ foo 'b) 42)
  (setf (~ foo 'a) 42)
  )
;!!! Error: Instance slot a is immutable for object #<bcl-user::foo 80100878C3>