Coverage report: /home/ellis/comp/core/std/serde.lisp

KindCoveredAll%
expression0102 0.0
branch010 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; std/serde.lisp --- Basic Lisp Serializer API
2
 
3
 ;; Read/Write Lisp Objects.
4
 
5
 ;;; Commentary:
6
 
7
 ;; This package contains macros for defining a pair of functions for a
8
 ;; category of lisp types - a READ-* function and a WRITE-* function. These
9
 ;; functions operate on a storage context which we Serialize (write) and Deserialize
10
 ;; (read) values from.
11
 
12
 ;; Within the STD system we implement the API for octet vectors as well as
13
 ;; (ALIEN (* UNSIGNED-CHAR)). These are used by higher-level packages which
14
 ;; need to portably serialize lisp objects as octet vectors.
15
 
16
 ;;; Code:
17
 (in-package :std/serde)
18
 
19
 (eval-always
20
   (define-condition serde-condition () ()
21
     (:documentation "Default SERDE condition class."))
22
   (deferror serde-error (serde-condition) ()
23
     (:documentation "An error signaled during serialization OR deserialization.")))
24
 
25
 (deferror serializer-error (serde-error)
26
   ()
27
   (:documentation "An error which occurs during object serialization."))
28
 
29
 (deferror deserializer-error (serde-error) 
30
   ()
31
   (:documentation "An error which occurs during object deserialization."))
32
 
33
 ;;; Serialize
34
 (defgeneric serializable-p (self)
35
   (:method ((self t)) nil)
36
   (:documentation "Return non-nil of object SELF is serializable."))
37
 
38
 (defgeneric serialize (obj format &key &allow-other-keys)
39
   (:documentation "Serialize OBJ to FORMAT, which is a SERIALIZABLE-TYPE-DESIGNATOR."))
40
 ;;; Deserialize
41
 (defgeneric deserializable-p (self)
42
   (:method ((self t)) nil)
43
   (:documentation "Return non-nil if object SELF is deserializable."))
44
 
45
 (defgeneric deserialize (from format &key &allow-other-keys)
46
   (:documentation "Deserialize FROM into an object of type FORMAT, which is a
47
 DESERIALIZABLE-TYPE-DESIGNATOR."))
48
 
49
 (defgeneric ser (self)
50
   (:documentation "Access the serializer of SELF."))
51
 (defgeneric (setf ser) (new self))
52
 (defgeneric de (self)
53
   (:documentation "Access the deserializer of SELF."))
54
 (defgeneric (setf de) (new self))
55
 
56
 (defgeneric serde (from to)
57
   (:documentation "Point-to-point serialization.
58
 
59
 FROM and TO should both specialize on object instances.
60
 
61
 Calling this function requires you to initialize the arguments instead
62
 of relying on a type-designator format and generating an object in the
63
 method body."))
64
 
65
 (defparameter *primitive-object-table*
66
   (let ((tbl (make-hash-table)))
67
     (dolist (obj *primitive-objects* tbl)
68
       (setf (gethash (primitive-object-name obj) tbl) (cons (symbol-value (primitive-object-lowtag obj)) (symbol-value (primitive-object-widetag obj))))))
69
   "Primitive objects are defined by SBCL and will not change. Convenient as a
70
 non-unique ID prefix.")
71
 
72
 (defparameter *simple-objects*
73
   (apply 'vector '(fixnum
74
                    character single-float 
75
                    double-float bignum
76
                    short-float complex
77
                    rational string
78
                    pathname symbol 
79
                    cons hash-table 
80
                    standard-object struct
81
                    array class 
82
                    null t))
83
   "A vector containing the simple set of lisp objects.")
84
 
85
 (defvar *core-object-table* (make-hash-table)
86
   "A hash-table mapping PRIMITIVE-TYPE names to integers.")
87
 
88
 (definline prim-type (obj)
89
   "Return the name of the primitive type of OBJ."
90
   (sb-vm::primitive-type-name (primitive-type-of obj)))
91
 
92
 (declaim (inline %lisp-object-id))
93
 (defun %lisp-object-id (obj)
94
   "Return the STD/SERDE 'id' of OBJ - which is its position in *SIMPLE-LISP-OBJECTS*."
95
   (position obj *simple-objects*))
96
 
97
 (defmacro define-io (name &body body)
98
   "Define a set of readers and writers of category NAME.
99
 
100
 BODY contains elements of the form:
101
 
102
 (OBJECT &KEY READ WRITE)"
103
   (when body
104
     `(progn
105
        (defmacro ,(symbolicate 'read- name) (ty from)
106
          `(,(intern (string (symbolicate 'read- ',name '- ty)) ,*package*) ,from))
107
        (defmacro ,(symbolicate 'write- name) (ty obj to)
108
          `(,(intern (string (symbolicate 'write- ',name '- ty)) ,*package*) ,to ,obj))
109
        ,@(loop for form in body
110
                append 
111
                   (let* ((type (car form))
112
                          (type-name (if (consp type)
113
                                         (format nil "~@[~{~A-~^~A~}~]" type)
114
                                         type))
115
                          (rfn (symbolicate 'read- name '- type-name))
116
                          (wfn (symbolicate 'write- name '- type-name)))
117
                     `(,@(when-let ((rf (cdr (assoc :read (cdr form)))))
118
                           (when #1=(cdr rf)
119
                                 `((defun ,rfn ,(car rf) ,@(if (atom #1#) (list #1#) #1#)))))
120
                       ,@(when-let ((wf (cdr (assoc :write (cdr form)))))
121
                           (when #2=(cdr wf)
122
                                 `((defun ,wfn ,(car wf) ,@(if (atom #2#) (list #2#) #2#)))))))))))