Permalink
Browse files

Add support for typed slots.

  • Loading branch information...
1 parent 9b74fa4 commit 2712bbd6301f0691167f2bf2d70cf60824eb4196 @stassats committed May 12, 2012
Showing with 165 additions and 21 deletions.
  1. +76 −10 disk.lisp
  2. +66 −10 mop.lisp
  3. +23 −1 packages.lisp
View
@@ -48,7 +48,9 @@
(position type *codes*)))
(defparameter *readers* (make-array (length *codes*)))
-(declaim (type (simple-array function (*)) *readers*))
+(defparameter *writers* (make-array (length *codes*)))
+(declaim (type (simple-array function (*))
+ *readers* *writers*))
(defmacro defreader (type (stream) &body body)
(let ((name (intern (format nil "~a-~a" type '#:reader))))
@@ -58,11 +60,32 @@
(setf (aref *readers* ,(type-code type))
#',name))))
+(defmacro defwriter ((type &key no-method) (object stream) &body body)
+ (let ((name (alexandria:symbolicate type '#:-writer))
+ (type-code (type-code type)))
+ `(progn
+ ,(unless no-method
+ `(defmethod write-object (object stream)
+ (write-n-bytes ,type-code 1 stream)
+ (,name object stream)))
+ (defun ,name (,object ,stream)
+ ,@body)
+ (setf (aref *writers* ,type-code)
+ #',name))))
+
(declaim (inline call-reader))
(defun call-reader (code stream)
;; (collect-stats code)
(funcall (aref *readers* code) stream))
+(defun find-reader (type)
+ (and (type-code type)
+ (aref *readers* (type-code type))))
+
+(defun find-writer (type)
+ (and (type-code type)
+ (aref *writers* (type-code type))))
+
;;;
(defconstant +sequence-length+ 2)
@@ -132,8 +155,12 @@
(lambda (class objects)
(let ((slots (slot-locations-and-initforms class))
(bytes-for-slots (number-of-bytes-for-slots class)))
- (dolist (object objects)
- (write-standard-object object slots bytes-for-slots stream))))))
+ (if (typep class 'storable-typed-class)
+ (let ((writers (slot-writers class)))
+ (dolist (object objects)
+ (write-typed-object object slots writers bytes-for-slots stream)))
+ (dolist (object objects)
+ (write-standard-object object slots bytes-for-slots stream)))))))
(declaim (inline read-next-object))
(defun read-next-object (stream)
@@ -230,8 +257,8 @@
;;; Integer
-(declaim (inline write-fixnum))
-(defun write-fixnum (n stream)
+(declaim (inline fixnum-writer))
+(defwriter (fixnum :no-method t) (n stream)
(declare (storage-fixnum n))
(write-n-signed-bytes n +fixnum-length+ stream))
@@ -257,7 +284,7 @@
(typecase object
(storage-fixnum
(write-n-bytes #.(type-code 'fixnum) 1 stream)
- (write-fixnum object stream))
+ (fixnum-writer object stream))
(t
(write-n-bytes #.(type-code 'bignum) 1 stream)
(write-bignum object stream))))
@@ -290,8 +317,8 @@
(cond ((and (typep numerator 'storage-fixnum)
(typep denominator 'storage-fixnum))
(write-n-bytes #.(type-code 'fixnum-ratio) 1 stream)
- (write-fixnum numerator stream)
- (write-fixnum denominator stream))
+ (fixnum-writer numerator stream)
+ (fixnum-writer denominator stream))
(t
(write-n-bytes #.(type-code 'ratio) 1 stream)
(write-object numerator stream)
@@ -646,8 +673,7 @@
;;; identifiable
-(defmethod write-object ((object identifiable) stream)
- (write-n-bytes #.(type-code 'identifiable) 1 stream)
+(defwriter (identifiable) (object stream)
(write-n-bytes (id object) +id-length+ stream))
(declaim (inline get-instance))
@@ -699,6 +725,36 @@
(read-next-object stream))
do (setf map (ash map -1)))))
+;;; typed objects
+
+(defun write-typed-object (object slots writers bytes-for-slots stream)
+ (declare (simple-vector slots))
+ (let ((map (make-slot-map object slots)))
+ (declare (type (unsigned-byte 32) map))
+ (write-n-bytes map bytes-for-slots stream)
+ (loop for slot-id of-type (integer 0 32) from 0
+ for writer in writers
+ while (plusp map)
+ when (oddp map)
+ do
+ (funcall writer
+ (standard-instance-access object (car (aref slots slot-id)))
+ stream)
+ do (setf map (ash map -1)))))
+
+(defun read-typed-object (object slots readers bytes-for-slots stream)
+ (declare (simple-vector slots))
+ (let ((map (read-n-bytes bytes-for-slots stream)))
+ (declare (type (unsigned-byte 32) map))
+ (loop for reader in readers
+ for slot-id of-type (integer 0 32) from 0
+ while (plusp map)
+ when (oddp map)
+ do (setf (standard-instance-access object
+ (car (aref slots slot-id)))
+ (funcall reader stream))
+ do (setf map (ash map -1)))))
+
;;;
#+sbcl (declaim (inline fast-allocate-instance))
@@ -770,6 +826,16 @@
for (class . n) of-type (t . fixnum) in info
for slots = (slot-locations-and-initforms-read class)
for bytes-for-slots = (number-of-bytes-for-slots class)
+ ;; if (typep class 'storable-typed-class)
+ ;; do
+ ;; (loop with readers = (slot-readers class)
+ ;; repeat n
+ ;; for instance = (aref array i)
+ ;; do
+ ;; (incf i)
+ ;; (read-typed-object instance slots readers
+ ;; bytes-for-slots stream))
+ ;; else
do
(loop repeat n
for instance = (aref array i)
View
@@ -42,6 +42,12 @@
:initarg :search-key
:accessor search-key)))
+(defclass storable-typed-class (storable-class)
+ ((slot-writers :initform nil
+ :accessor slot-writers)
+ (slot-readers :initform nil
+ :accessor slot-readers)))
+
(defun initialize-storable-class (next-method class &rest args
&key direct-superclasses &allow-other-keys)
(apply next-method class
@@ -70,7 +76,17 @@
(superclass standard-class))
t)
-(defclass storable-slot-mixin ()
+(defmethod validate-superclass
+ ((class standard-class)
+ (superclass storable-typed-class))
+ t)
+
+(defmethod validate-superclass
+ ((class storable-typed-class)
+ (superclass standard-class))
+ t)
+
+(defclass storable-slot ()
((storep :initarg :storep
:initform t
:reader store-slot-p)
@@ -87,23 +103,39 @@
:initform nil
:reader slot-unit)))
-(defclass storable-direct-slot-definition (storable-slot-mixin
- standard-direct-slot-definition)
+(defclass storable-typed-slot (storable-slot)
+ ((disk-type :initarg :disk-type
+ :initform nil
+ :reader disk-type)))
+
+(defclass storable-direct-slot-definition
+ (storable-slot standard-direct-slot-definition)
())
(defclass storable-effective-slot-definition
- (storable-slot-mixin standard-effective-slot-definition)
+ (storable-slot standard-effective-slot-definition)
())
-(defmethod direct-slot-definition-class ((class storable-class)
- &rest initargs)
- (declare (ignore initargs))
+(defclass storable-direct-typed-slot-definition
+ (storable-typed-slot standard-direct-slot-definition)
+ ())
+
+(defclass storable-effective-typed-slot-definition
+ (storable-typed-slot standard-effective-slot-definition)
+ ())
+
+(defmethod direct-slot-definition-class ((class storable-class) &key)
(find-class 'storable-direct-slot-definition))
-(defmethod effective-slot-definition-class ((class storable-class)
- &key &allow-other-keys)
+(defmethod effective-slot-definition-class ((class storable-class) &key)
(find-class 'storable-effective-slot-definition))
+(defmethod direct-slot-definition-class ((class storable-typed-class) &key)
+ (find-class 'storable-direct-typed-slot-definition))
+
+(defmethod effective-slot-definition-class ((class storable-typed-class) &key)
+ (find-class 'storable-effective-typed-slot-definition))
+
(defmethod compute-effective-slot-definition
((class storable-class) slot-name direct-definitions)
(declare (ignore slot-name))
@@ -119,6 +151,16 @@
unit (slot-unit direct-definition)))
effective-definition))
+(defmethod compute-effective-slot-definition
+ ((class storable-typed-class) slot-name direct-definitions)
+ (declare (ignore slot-name))
+ (let ((effective-definition (call-next-method))
+ (direct-definition (car direct-definitions)))
+ (when (typep direct-definition 'storable-direct-typed-slot-definition)
+ (with-slots (disk-type) effective-definition
+ (setf disk-type (disk-type direct-definition))))
+ effective-definition))
+
(defun slots-with-relations (class)
(loop for slot across (slots-to-store class)
for relation = (slot-relation slot)
@@ -133,7 +175,9 @@
(slot-definition-initform slot-definition)))
slot-definitions))
-(defun initialize-class-slots (class slots)
+(defgeneric initialize-class-slots (class slots))
+
+(defmethod initialize-class-slots ((class storable-class) slots)
(let* ((slots-to-store (coerce (remove-if-not #'store-slot-p slots)
'simple-vector)))
(when (> (length slots-to-store) 32)
@@ -152,6 +196,18 @@
(slots-with-relations class))
(compute-search-key class slots)))
+(defmethod initialize-class-slots :after ((class storable-typed-class) slots)
+ (loop for slot across (slots-to-store class)
+ for disk-type = (disk-type slot)
+ for reader = (or (find-reader disk-type)
+ (warn "No readers for disk-type: ~a" disk-type))
+ for writer = (or (find-writer disk-type)
+ (warn "No writers for disk-type: ~a" disk-type))
+ collect reader into readers
+ collect writer into writers
+ finally (setf (slot-readers class) readers
+ (slot-writers class) writers)))
+
(defmethod finalize-inheritance :after ((class storable-class))
(initialize-class-slots class (class-slots class)))
View
@@ -31,5 +31,27 @@
#:slot-unit
#:storage-file
#:find-slot
- #:modified))
+ #:modified
+ #:ascii-string
+ #:cons
+ #:string
+ #:null
+ #:fixnum
+ #:bignum
+ #:fixnum-ratio
+ #:ratio
+ #:double-float
+ #:single-float
+ #:complex
+ #:list-of-objects
+ #:symbol
+ #:intern-package-and-symbol
+ #:intern-symbol
+ #:character
+ #:simple-vector
+ #:vector
+ #:array
+ #:hash-table
+ #:pathname
+ #:storable-typed-class))

0 comments on commit 2712bbd

Please sign in to comment.