Skip to content

Instantly share code, notes, and snippets.

@g000001
Created April 14, 2023 16:51
Show Gist options
  • Save g000001/339782a861b7b86dc41976025645f1bf to your computer and use it in GitHub Desktop.
Save g000001/339782a861b7b86dc41976025645f1bf to your computer and use it in GitHub Desktop.
:init-once slot
;;; -*- 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>
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment