changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / lisp/lib/obj/meta/storable.lisp

changeset 698: 96958d3eb5b0
parent: 9eb2c112aa16
author: Richard Westhaver <ellis@rwest.io>
date: Fri, 04 Oct 2024 22:04:59 -0400
permissions: -rw-r--r--
description: fixes 
     1 ;;; obj/meta/storable.lisp --- Storable Objects
     2 
     3 ;; The storable-class can be assigned to the :metaclass option of a
     4 ;; class to allow persistent storage of an object on disk. The
     5 ;; storable-slot-mixin is a custom slot option which can be used to
     6 ;; selectively enable slot serialization.
     7 
     8 ;;; Commentary:
     9 
    10 ;; This code is derived from XDB.
    11 
    12 ;; Note that this is not a general purpose SerDe. It is specifically designed
    13 ;; to decode/encode objects as single octet-vectors from/to an open stream
    14 ;; with minimal overhead. There is a separate interface for general-purpose
    15 ;; data encoding which can be found in the DAT system.
    16 
    17 ;;; Code:
    18 (in-package :obj/meta/storable)
    19 
    20 (sb-ext:unlock-package :sb-pcl)
    21 
    22 ;;; MOP
    23 (defclass storable-class (standard-class)
    24   ((class-id :initform nil
    25              :accessor class-id)
    26    (slots-to-store :initform nil :accessor slots-to-store)
    27    (slot-locations-and-initforms
    28     :initform nil
    29     :accessor slot-locations-and-initforms)
    30    (all-slot-locations-and-initforms
    31     :initform nil
    32     :accessor all-slot-locations-and-initforms)
    33    (initforms :initform #()
    34               :accessor class-initforms)
    35    (id-cache :initarg :id-cache
    36              :initform (make-hash-table :size 1000)
    37              :accessor id-cache)))
    38 
    39 
    40 ;;; Initialize
    41 (defun initialize-storable-class (next-method class &rest args
    42                                   &key direct-superclasses &allow-other-keys)
    43   (apply next-method class
    44          (if direct-superclasses
    45              args
    46              (list* :direct-superclasses (list (find-class 'storable-class))
    47                     args))))
    48 
    49 (defmethod initialize-instance :around ((class storable-class)
    50                                         &rest args)
    51   (apply #'initialize-storable-class #'call-next-method class args))
    52 
    53 (defmethod reinitialize-instance :around ((class storable-class)
    54                                           &rest args)
    55   (apply #'initialize-storable-class #'call-next-method class args))
    56 
    57 ;;; Validate
    58 (defmethod validate-superclass
    59     ((class standard-class)
    60      (superclass storable-class))
    61   t)
    62 
    63 (defmethod validate-superclass
    64     ((class storable-class)
    65      (superclass standard-class))
    66   t)
    67 
    68 ;;; Slot mixin
    69 (defclass storable-slot-mixin ()
    70   ((storep :initarg :storep
    71            :initform t
    72            :accessor store-slot-p)))
    73 
    74 (defclass storable-direct-slot-definition (storable-slot-mixin
    75                                            standard-direct-slot-definition)
    76   ())
    77 
    78 (defclass storable-effective-slot-definition
    79     (storable-slot-mixin standard-effective-slot-definition)
    80   ())
    81 
    82 (defmethod direct-slot-definition-class ((class storable-class)
    83                                          &rest initargs)
    84   (declare (ignore initargs))
    85   (find-class 'storable-direct-slot-definition))
    86 
    87 (defmethod effective-slot-definition-class ((class storable-class)
    88                                             &key &allow-other-keys)
    89   (find-class 'storable-effective-slot-definition))
    90 
    91 (defmethod compute-effective-slot-definition
    92     ((class storable-class) slot-name direct-definitions)
    93   (declare (ignore slot-name))
    94   (let ((effective-definition (call-next-method))
    95         (direct-definition (car direct-definitions)))
    96     (setf (store-slot-p effective-definition)
    97           (store-slot-p direct-definition))
    98     effective-definition))
    99 
   100 (defun make-slots-cache (slot-definitions)
   101   (map 'vector
   102        (lambda (slot-definition)
   103 	 (cons (sb-mop:slot-definition-location slot-definition)
   104 	       (sb-mop:slot-definition-initform slot-definition)))
   105        slot-definitions))
   106 
   107 (defun initialize-class-slots (class slots)
   108   (let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
   109                                  'simple-vector)))
   110     (setf (slots-to-store class)
   111           slots-to-store)
   112     (setf (slot-locations-and-initforms class)
   113           (make-slots-cache slots-to-store))
   114     (setf (all-slot-locations-and-initforms class)
   115           (make-slots-cache slots))
   116     (setf (class-initforms class)
   117           (map 'vector #'sb-mop:slot-definition-initform slots))))
   118 
   119 (defmethod compute-slots :around ((class storable-class))
   120   (let ((slots (call-next-method)))
   121     (initialize-class-slots class slots)
   122     slots))
   123 
   124 
   125 (sb-ext:lock-package :sb-pcl)