├── .gitignore ├── README.md ├── cl-conspack-test.asd ├── cl-conspack.asd ├── doc ├── ConspackRanges.html ├── ConspackRanges.ods └── SPEC ├── src ├── array.lisp ├── conspack.lisp ├── decode.lisp ├── encode.lisp ├── explain.lisp ├── headers.lisp ├── indexes.lisp ├── package.lisp ├── properties.lisp ├── r-ref.lisp ├── reftable.lisp ├── secure.lisp ├── tmap.lisp └── types.lisp └── t ├── encode-decode.lisp ├── package.lisp └── security.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # News 2 | 3 | **Recent changes**: 4 | 5 | * Decoder now handles more uses of circular reference. 6 | * Properties now require `WITH-PROPERTIES` if used outside an `ENCODE` 7 | or `DECODE`, see below. 8 | 9 | # cl-conspack 10 | 11 | CONSPACK was inspired by MessagePack, and by the general lack of 12 | features among prominent serial/wire formats: 13 | 14 | * JSON isn't terrible, but can become rather large, and is potentially 15 | susceptible to READ exploits (as per the recently-fixed 16 | "10e99999999" bug in SBCL). 17 | 18 | * BSON (binary JSON) doesn't really solve much; though it encodes 19 | numbers, it's not particularly smaller or more featureful than JSON. 20 | 21 | * MessagePack is small, but lacks significant features; it can 22 | essentially encode arrays or maps of numbers, and any interpretation 23 | beyond that is up to the receiver. 24 | 25 | * Protobufs and Thrift are static. 26 | 27 | It should be noted that, significantly, **none** of these support 28 | references. Of course, references can be implemented at a higher 29 | layer (e.g., JSPON), but this requires implementing an entire 30 | additional layer of abstraction and escaping, including rewalking the 31 | parsed object hierarchy and looking for specific signatures, which can 32 | be error-prone and hurts performance. 33 | 34 | Additionally, none of these appear to have much in the way of 35 | security, and communicating with an untrusted peer is probably not 36 | recommended. 37 | 38 | CONSPACK, on the other hand, attempts to be a more robust solution: 39 | 40 | * Richer set of data types, differentiating between arrays, lists, 41 | maps, typed-maps (for encoding classes/structures etc), numbers, 42 | strings, symbols, and a few more. 43 | 44 | * Very compact representation that can be smaller than MessagePack. 45 | 46 | * In-stream references, including optional forward references, which 47 | can allow for shared or circular data structures. Additionally, 48 | remote references allow the receiver the flexibility to parse and 49 | return its own objects without further passes on the output. 50 | 51 | * Security, including byte-counting for (estimated) maximum output 52 | size, and the elimination of circular data structures. 53 | 54 | * Speed. Using [fast-io](https://github.com/rpav/fast-io) encoding 55 | and decoding can be many times faster than alternatives, even 56 | *while* tracking references (faster still without!). 57 | 58 | See [SPEC](https://github.com/conspack/cl-conspack/blob/master/doc/SPEC) for 59 | complete details on encoding. 60 | 61 | ## Usage 62 | 63 | `cl-conspack` is simple to use: 64 | 65 | ```lisp 66 | (encode '(1 2 3)) ;; => #(40 4 16 1 16 2 16 3 0) 67 | 68 | (decode (encode '(1 2 3))) ;; => (1 2 3) 69 | 70 | ;; Smaller if the element-type is known: 71 | (encode (fast-io:octets-from '(1 2 3))) 72 | ;; => #(36 3 20 1 2 3) 73 | ``` 74 | 75 | ### CLOS and general objects 76 | 77 | Conspack provides the ability to serialize and deserialize objects of 78 | any kind. 79 | 80 | The easiest way, for the common case: 81 | 82 | ```lisp 83 | (conspack:defencoding my-class 84 | slot-1 slot-2 slot-3) 85 | ``` 86 | 87 | This expands to the more flexible way, which specializes 88 | `ENCODE-OBJECT` and `DECODE-OBJECT-INITIALIZE`: 89 | 90 | ```lisp 91 | (defmethod conspack:encode-object append 92 | ((object my-class) &key &allow-other-keys) 93 | (conspack:slots-to-alist (object) 94 | slot-1 slot-2 slot-3 ...)) 95 | 96 | (defmethod conspack:decode-object-initialize progn 97 | ((object my-class) class alist &key &allow-other-keys) 98 | (declare (ignore class)) 99 | (alist-to-slots (alist object) 100 | slot-1 slot-2 slot-3)) 101 | ``` 102 | 103 | `ENCODE-OBJECT` should specialize on the object and return an alist. 104 | The alist returned will be checked for circularity if `tracking-refs` 105 | is in use. 106 | 107 | `DECODE-OBJECT-ALLOCATE` should specialize on `(eql 'class-name)`, and 108 | produce an object *based* on the class and alist. 109 | 110 | `DECODE-OBJECT-INITIALIZE` should specialize on the object (which has 111 | been produced by `DECODE-OBJECT-ALLOCATE`), and initializes it. 112 | This two step process is necessary to handle circularity correctly. 113 | 114 | As you can see, this does not require objects be in any particular 115 | format, or that you store any particular slots or values. It does not 116 | specify how you restore an object. 117 | 118 | But for the "normal" case, `SLOTS-TO-ALIST` and `ALIST-TO-SLOTS` are 119 | provided to build and restore from alists, and `DEFENCODING` can 120 | define all of this in one simple form. 121 | 122 | ### Circularity and References 123 | 124 | Circularity tracking is not on by default, you can enable it for a 125 | particular block of `encode`s or `decode`s by using `tracking-refs`: 126 | 127 | ```lisp 128 | (tracking-refs () 129 | (decode (encode CIRCULAR-OBJECT))) 130 | ``` 131 | 132 | "Remote" references are application-level references. You may encode 133 | a reference using an arbitrary object as a descriptor: 134 | 135 | ```lisp 136 | (encode (r-ref '((:url . "http://...")))) 137 | ``` 138 | 139 | When decoding, you may provide a function to handle these: 140 | 141 | ```lisp 142 | (with-remote-refs (lambda (x) (decode-url x)) 143 | (decode OBJECT)) 144 | ``` 145 | 146 | ### Indexes 147 | 148 | If you have a relatively small static set of symbols you will always 149 | use for a particular encoding/decoding, you may want to use 150 | *indexes*. These allow symbols to be very-tightly-packed: for up to 151 | 15 symbols, a single byte can encode the symbol! For up to 256, two 152 | bytes, and so on. 153 | 154 | Trivially: 155 | 156 | ```lisp 157 | (cpk:with-index (specifier-1 specifier-2 specifier-3) 158 | (cpk:encode '(specifier-1 specifier-2 specifier-3))) 159 | 160 | ;; => #(40 4 176 177 178 0) 161 | 162 | ;; Contrast this with: 163 | 164 | (cpk:encode '(specifier-1 specifier-2 specifier-3)) 165 | ;; #(40 4 130 64 11 83 80 69 67 73 70 73 69 82 45 49 129 64 16 67 79 166 | ;; 77 77 79 78 45 76 73 83 80 45 85 83 69 82 130 64 11 83 80 69 67 73 167 | ;; 70 73 69 82 45 50 129 64 16 67 79 77 77 79 78 45 76 73 83 80 45 85 168 | ;; 83 69 82 130 64 11 83 80 69 67 73 70 73 69 82 45 51 129 64 16 67 79 169 | ;; 77 77 79 78 45 76 73 83 80 45 85 83 69 82 0) 170 | ``` 171 | 172 | (This is a somewhat excessive example, since long non-keyword symbols 173 | are used. Shorter keyword symbols would be relatively shorter, but 174 | this is the general case.) 175 | 176 | For more "realistic" use, you may *define* an index and refer to it: 177 | 178 | ```lisp 179 | (define-index index-name 180 | symbol-1 symbol-2 ...) 181 | 182 | (with-named-index 'index-name 183 | (encode ...)) 184 | ``` 185 | 186 | For instance, you may define multiple indexes for multiple different 187 | format versions, read the version, and use the appropriate index: 188 | 189 | ```lisp 190 | (define-index version-1 ...) 191 | (define-index version-2 ...) 192 | 193 | (let ((version (decode-stream s))) 194 | (with-named-index version 195 | ;; Decode the rest of the stream appropriately. You may want to 196 | ;; do more checking on VERSION if security is required... 197 | (decode-stream s))) 198 | ``` 199 | 200 | Note that using `tracking-refs` will *also* help encode symbols 201 | efficiently, but not *quite* as efficiently: 202 | 203 | * The full string for the symbol (and if necessary, package), will be 204 | encoded at least once, when first encountered 205 | * Refs are tracked in-order, and may lead to longer tags than a 206 | comparable index would use 207 | 208 | However, `tracking-refs` is a perfectly suitable option, especially if 209 | flexibility is desired, since all symbol information is encoded, and 210 | nothing special is needed for decoding. 211 | 212 | ### Properties 213 | 214 | (Properties now require a `WITH-PROPERTIES` block in some 215 | circumstances, see below.) 216 | 217 | Properties are a way to specify additional information about an object 218 | that may be useful at decode-time. For instance, while hash tables 219 | are supported as maps, there are no bits to specify the `:test` 220 | parameter, so decoding a hash table of strings would produce a useless 221 | object. In this case, the `:test` property is set when encoding and 222 | checked when decoding hash tables. 223 | 224 | You may specify arbitrary properties for arbitrary objects; the only 225 | restriction is the objects must test by `EQ`. 226 | 227 | ```lisp 228 | (conspack:with-properties () 229 | (let ((object (make-instance ...))) 230 | (setf (property object :foo) 'bar) 231 | (property object :foo))) ;; => BAR 232 | ``` 233 | 234 | This sets the `:foo` property to the symbol `bar`, and it is encoded 235 | along with the object. Note this will increase the object size, by 236 | the amount required to store a map of symbols-to-values. 237 | 238 | When decoding, you can access properties about an object via 239 | `*current-properties*`: 240 | 241 | ```lisp 242 | (defmethod decode-object-initialize (...) 243 | (let ((prop (getf *current-properties* NAME))) 244 | ...)) 245 | ``` 246 | 247 | You may remove them with `remove-property` or `remove-properties`. 248 | 249 | **Properties are now only available within a `WITH-PROPERTIES` 250 | block.** This has a number of benefits, including some thread safety, 251 | and ensuring properties don't stick around forever. 252 | 253 | `ENCODE` and `DECODE` have **implicit** `WITH-PROPERTIES` blocks: you 254 | don't need to specify `WITH-PROPERTIES` if you use properties inside 255 | `ENCODE-OBJECT`, `DECODE-OBJECT`, or encode and decode any objects 256 | that have implicit properties. You only need this if you wish to 257 | access properties *outside* of the encode or decode (e.g., 258 | preassigning properties to be encoded). 259 | 260 | ### Allocation Limits and Security 261 | 262 | Conspack provides some level of "security" by *approximately* limiting 263 | the amount of bytes allocated when reading objects. 264 | 265 | By default, because format sizes are prespecified statically, it's 266 | possible to specify extremely large allocations for e.g. arrays with 267 | only a few bytes. Obviously, this is not suitable for untrusted 268 | conspack data. 269 | 270 | The solution is simply to cap allocations: 271 | 272 | ```lisp 273 | (with-conspack-security (:max-bytes 200000) 274 | (decode ...)) 275 | ``` 276 | 277 | Since actual allocation sizes are rather difficult to get in most 278 | lisps, this *approximates* the allocation based on how big each object 279 | might be, e.g.: 280 | 281 | * `pointer-size * array-size` 282 | * `string-length` 283 | * `number-size` 284 | * etc. 285 | 286 | Each object header is tallied against the limit just prior to its 287 | decoding; if the object would exceed the allowed bytes, decoding halts 288 | with an error. 289 | 290 | Further options may be added in the future. 291 | 292 | ### Interning 293 | 294 | By default, Conspack does not intern symbols, on the assumption that 295 | the producer and consumer have agreed on what symbols to use 296 | beforehand. If the decoder finds a symbol that has not already been 297 | interned, it will ignore the symbol's package and make an uninterned 298 | symbol instead. 299 | 300 | The `with-interning` macro can be used if the decoder should instead 301 | intern symbols: 302 | 303 | ```lisp 304 | (with-interning () 305 | (decode ...)) 306 | ``` 307 | 308 | Interning symbols from untrusted data could lead to denial-of-service 309 | attacks via interning long-lived symbols in memory, so be careful. 310 | 311 | ## Explaining 312 | 313 | Since conspack is a binary format, it's rather difficult for humans to 314 | read just looking at the stream of bytes. Thus an `EXPLAIN` feature 315 | is provided. This is mostly useful for debugging the format; however 316 | it may be of interest otherwise and certainly may be helpful when 317 | creating other implementations. 318 | 319 | For instance: 320 | 321 | ```lisp 322 | (explain (encode '(1 2 3))) 323 | 324 | ;; => 325 | ((:LIST 4 326 | ((:NUMBER :INT8 1) (:NUMBER :INT8 2) (:NUMBER :INT8 3) (:BOOLEAN NIL))) 327 | END-OF-FILE) 328 | ``` 329 | -------------------------------------------------------------------------------- /cl-conspack-test.asd: -------------------------------------------------------------------------------- 1 | (defsystem :cl-conspack-test 2 | :description "Tests for cl-conspack" 3 | 4 | :depends-on (:cl-conspack :fiveam) 5 | 6 | :pathname "t" 7 | :serial t 8 | 9 | :perform (test-op (o s) 10 | (uiop:symbol-call :fiveam :run! 11 | (find-symbol "CONSPACK" "CONSPACK.TEST"))) 12 | 13 | :components 14 | ((:file "package") 15 | (:file "encode-decode"))) 16 | -------------------------------------------------------------------------------- /cl-conspack.asd: -------------------------------------------------------------------------------- 1 | (defpackage :cl-conspack.asdf 2 | (:use #:cl #:asdf)) 3 | 4 | (in-package :cl-conspack.asdf) 5 | 6 | (defsystem :cl-conspack 7 | :description "CONSPACK implementation for Common Lisp" 8 | :author "Ryan Pavlik" 9 | :license "NewBSD" 10 | 11 | :depends-on (:closer-mop :alexandria :ieee-floats :trivial-utf-8 12 | :fast-io :trivial-garbage) 13 | 14 | :pathname "src" 15 | :serial t 16 | 17 | :in-order-to ((test-op (test-op "cl-conspack-test"))) 18 | 19 | :components 20 | ((:file "package") 21 | (:file "types") 22 | (:file "properties") 23 | (:file "secure") 24 | (:file "reftable") 25 | (:file "r-ref") 26 | (:file "headers") 27 | (:file "indexes") 28 | (:file "tmap") 29 | (:file "array") 30 | (:file "encode") 31 | (:file "decode") 32 | (:file "explain"))) 33 | -------------------------------------------------------------------------------- /doc/ConspackRanges.html: -------------------------------------------------------------------------------- 1 | 2 | - no title specified

Type

BinStart

BinEnd

DecStart

DecEnd

HexStart

HexEnd

Count

Total

 

Boolean

0000 0000

0000 0001

0

1

0x00

0x01

2

2

 

<Reserved>

0000 0010

0000 1111

2

15

0x02

0x0F

14

16

 

Number

0001 0000

0001 1111

16

31

0x10

0x1F

16

32

 

Container

0010 0000

0011 1111

32

63

0x20

0x3F

32

64

 

String

0100 0000

0100 0011

64

67

0x40

0x43

4

68

 

<Reserved>

0100 0100

0101 1111

68

95

0x44

0x5F

28

96

 

Ref

0110 0000

0110 0011

96

99

0x60

0x63

4

100

 

RemoteRef

0110 0100

0110 0100

100

100

0x64

0x64

1

101

 

<Reserved>

0110 0101

0110 0111

101

103

0x65

0x67

3

104

 

Pointer

0110 1000

0110 1011

104

107

0x68

0x6B

4

108

 

<Reserved>

0110 1100

0110 1111

108

111

0x6C

0x6F

4

112

 

RefInline

0111 0000

0111 1111

112

127

0x70

0x7F

16

128

 

Cons

1000 0000

1000 0000

128

128

0x80

0x80

1

129

 

Package

1000 0001

1000 0001

129

129

0x81

0x81

1

130

 

Symbol

1000 0010

1000 0011

130

131

0x82

0x83

2

132

 

Character

1000 0100

1000 0111

132

135

0x84

0x87

4

136

 

Properties

1000 1000

1000 1000

136

136

0x88

0x88

1

137

 

<Reserved>

1000 1001

1001 1111

137

159

0x89

0x9F

23

160

 

Index

1010 0000

1010 0011

160

163

0xA0

0xA3

4

164

 

<Reserved>

1010 0100

1010 1111

164

175

0xA4

0xAF

12

176

 

IndexInline

1011 0000

1011 1111

176

191

0xB0

0xBF

16

192

 

<Reserved>

1100 0000

1101 1111

192

223

0xC0

0xDF

32

224

 

Tag

1110 0000

1110 0011

224

227

0xE0

0xE3

4

228

 

<Reserved>

1110 0100

1110 1111

228

239

0xE4

0xEF

12

240

 

TagInline

1111 0000

1111 1111

240

255

0xF0

0xFF

16

256

 
          
          
-------------------------------------------------------------------------------- /doc/ConspackRanges.ods: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/conspack/cl-conspack/6e529d7b3a7223ef1bb5c7b9f18384ba67b50b09/doc/ConspackRanges.ods -------------------------------------------------------------------------------- /doc/SPEC: -------------------------------------------------------------------------------- 1 | CONSPACK 2 | -------- 3 | 4 | Conspack supports the following basic types: 5 | 6 | - Booleans, t or nil 7 | - Numbers: 8 | signed-byte {8,16,32,64,128} 9 | unsigned-byte {8,16,32,64,128} 10 | single-float 11 | double-float 12 | complex 13 | rational 14 | - Containers: 15 | Vector 16 | List 17 | Map (key-value pairs) 18 | Typed map (key-value pairs with a type hint, e.g. class or struct) 19 | - References (in-stream and remote) 20 | - Conses 21 | - Packages 22 | - Symbols 23 | - Indexes (i.e., externally-indexed symbols) 24 | 25 | Containers can either contain arbitrary objects, which include their 26 | header, or a fixed type, which stores only the post-header data 27 | per-object, potentially greatly reducing the size for some data. 28 | 29 | References, both forward and backward, properly allow for circularity 30 | and mutual references. 31 | 32 | Specification 33 | ------------- 34 | 35 | Boolean: #b0000000n; n = 0 or 1, nil or t 36 | (count = 2) 37 | 38 | Reserved: #b00000010 - #b00001111 (count = 14) 39 | 40 | Number: #b0001nnnn; nnnn = type 41 | (count = 16) 42 | bytes; numeric value per type, for nnnn = #x0..#xB 43 | 44 | or 45 | 46 | #b00011100; Complex 47 | Number; Real-part 48 | Number; Imaginary-part 49 | 50 | or 51 | 52 | #b00011111; Rational 53 | Number; Numerator 54 | Number; Denominator 55 | 56 | nnnn: #x0: (signed-byte 8) 57 | #x1: (signed-byte 16) 58 | #x2: (signed-byte 32) 59 | #x3: (signed-byte 64) 60 | #x4: (unsigned-byte 8) 61 | #x5: (unsigned-byte 16) 62 | #x6: (unsigned-byte 32) 63 | #x7: (unsigned-byte 64) 64 | #x8: single-float (4 bytes) 65 | #x9: double-float (8 bytes) 66 | #xA: (signed-byte 128) 67 | #xB: (unsigned-byte 128) 68 | #xC: complex 69 | #xD..#xE: reserved, count = 2 70 | #xF: rational 71 | 72 | These are all stored in big-endian (network) format. 73 | 74 | Future: long-double and bignum would probably be nice at 75 | some point. 76 | 77 | Container: #b001xxfnn; xx = type, f = static-type-flag, nn = size-bytes 78 | (count = 32) 79 | size-bytes size; number of elements in container, or 80 | number of key-value pairs in a map/tmap 81 | [type byte; when f=1, element-type for arrays, or 82 | key-type for maps] 83 | [tmap-type obj; for TMaps, a Ref or Symbol] 84 | Obj * size[*2]; objects 85 | 86 | xx: #b00: Vector 87 | #b01: List 88 | #b10: Map 89 | #b11: TMap 90 | 91 | f: #b0: Arbitrary types (all objects have prefixes) 92 | #b1: Static types (one prefix, all objects uniform) 93 | 94 | nn: #b00: 8-bit size 95 | #b01: 16-bit size 96 | #b10: 32-bit size 97 | #b11: reserved 98 | 99 | Note: In theory we could save a bit here by folding static 100 | types into the nn=#b11 and having a separate byte specify 101 | the size. 102 | 103 | element-type: Only the following are valid: 104 | - Number types 105 | - Containers? 106 | - Strings 107 | - _Non-fixed_ Refs 108 | - Conses 109 | - Packages 110 | - Symbols 111 | - _Non-fixed_ Indexes 112 | 113 | Note: Because the type-byte is only specified _once_, 114 | certain types may be restricted; e.g., if a symbol is 115 | specified with the keyword flag, then all elements are 116 | keywords. If it's specified _without_, then to include 117 | keywords, a reference to the keyword package must be 118 | included. 119 | 120 | Also, since no header bytes are read, it is impossible to 121 | tag or refer to objects in a static container (except map 122 | _values_, which always have headers). 123 | 124 | List Note: The last element in a list is the final CDR. 125 | This means that lists normally need a final #x00 element. 126 | This is necessary to support circular lists. This also 127 | means that "dotted lists" (e.g., '(1 2 . 3)) are 128 | supported. 129 | 130 | This also has implications for list length: for example, a 131 | list which may appear to have 5 elements but shares a CDR 132 | needs to have its header report a shorter length. In 133 | practice, this should be easy; length is O(n) anyway, and 134 | you just need to walk the list and watch for any 135 | previously-tagged conses while counting. 136 | 137 | A list must has a minimum length of 2! The final element 138 | of a normal one-element list should be NIL. A 1-element 139 | list may be expressed as a cons with a NIL CDR; the result 140 | should decode identically, and is one byte shorter. 141 | 142 | A 0-element list is not expressed as '(NIL . NIL), but 143 | just NIL. It should be encoded as NIL, i.e., #x00. 144 | 145 | Map note: Maps define the :TEST property (see Properties 146 | below), which may be one of :EQL or :EQUAL as per Common 147 | Lisp. :EQ and :EQUALP are not necessarily supported. 148 | Also as per CL, :EQL is the default if unspecified. 149 | 150 | TMap note: The type value may be a reference, but it may 151 | not be a forward reference. Also, keywords are reserved 152 | for use by conspack and related. 153 | 154 | Future: Static arrays with a type #x00 or #x01 should 155 | probably be optimized to packed-bit vectors. 156 | 157 | String #b010000nn; nn = size-bytes 158 | (count = 4) 159 | size-bytes bytes; length of string in bytes 160 | length bytes; UTF-8 string 161 | 162 | Note: To re-emphasize, length is the number of bytes, not 163 | the number of characters. 164 | 165 | Ref: #b011fdddd; f = inline-flag, dddd = id or size-bytes 166 | (count = 32) 167 | [size-bytes bytes; if f=0, value of index] 168 | 169 | f: #b0: id follows 170 | #b1: id is lower nibble 171 | 172 | dddd: #b00nn: size-bytes per container if f = 0 173 | 174 | otherwise, 4-bit reference ID. 175 | 176 | Notes: References may be forward, which means the parser 177 | needs to keep a list of places to fix up if necessary. 178 | This shouldn't be overly difficult in most languages. 179 | 180 | As a restriction, objects should be encoded normally the 181 | first time they are encountered, and forward references 182 | should only occur when they refer to the object currently 183 | being encoded. This basically restricts forward 184 | references to elements in a container which refer to the 185 | container. 186 | 187 | The encoder will also need to "notice" all objects being 188 | encoded first, so they can be tagged as written (see 189 | Tags). 190 | 191 | R-Ref: #b01100100 (count = 1) 192 | Obj; 193 | 194 | Remote reference. This represents a placeholder that is 195 | understood by the caller, and is meant to identify 196 | something outside the scope of conspack. 197 | 198 | The object is used as an identifier for the remote 199 | reference, and is not otherwise understood by conspack. 200 | Implementations should ideally allow the caller to process 201 | the object into something useful immediately, so the 202 | resulting structure need not be traversed a second time. 203 | 204 | Reserved: #b01100101 .. #b01100111, count = 3 205 | 206 | Pointer: #b011010nn nn = size-bytes 207 | (count = 4) 208 | size-bytes PTR; 209 | 210 | Pointer value; this is more-or-less intended for 211 | implementing object skipping and offsets. However, there 212 | is no predefined interpretation, other than to distinguish 213 | it from an integer. 214 | 215 | Reserved: #b01101100 .. #b01101111, count = 4 216 | 217 | Cons: #b10000000 (count = 1) 218 | Obj; CAR of cons 219 | Obj; CDR of cons 220 | 221 | Note: Any list may be expressed as a series of cons; 222 | decoding should be identical. This is likely inefficient, 223 | however. 224 | 225 | Package: #b10000001 (count = 1) 226 | Obj; String or reference to package name 227 | 228 | Note: Forward references are invalid here. 229 | 230 | Symbol: #b1000001f; f = keyword flag 231 | (count = 2) 232 | Obj; String or ref which is symbol-name 233 | [Obj; Package or reference to package, if f = 0] 234 | 235 | Note: Forward references are invalid here. 236 | 237 | Character: #b100001nn; nn = byte-count (i.e., 1-4) 238 | (count = 4) 239 | byte-count bytes; the character value, UTF-8 240 | 241 | Represent a character encoded in UTF-8. 242 | 243 | Properties: #b10001000 (count = 1) 244 | list; A list object specifying properties 245 | Obj; The object for which these properties apply 246 | 247 | The first object shall be a list object or backward 248 | reference to a list object in the form of a PLIST. This 249 | may specify arbitrary properties for the next object. 250 | Certain conspack types may have specific reserved 251 | properties; other non-reserved properties are not an 252 | error. 253 | 254 | Implementations should read and automatically associate 255 | the properties with the next object, or provide it in 256 | context. That is, properties should be available on 257 | demand, rather than as a separate object. 258 | 259 | Not all objects may support property association. 260 | Numbers, characters, and other types for which a 261 | language lacks "individual identity" may not support 262 | properties. However, this does not mean decoders can 263 | ignore predefined properties. 264 | 265 | Implementations MUST count the properties object against 266 | any byte-count memory restriction. These properties may 267 | remain indefinitely loaded. 268 | 269 | In fixed-type containers, it is not possible to specify 270 | properties for elements. The property header is not a 271 | valid type for fixed-type containers. For non-fixed 272 | containers, properties may be specified for individual 273 | elements. 274 | 275 | Notes: A tag before the Properties object tags the 276 | *properties*. To tag the object to which the properties 277 | apply, the tag must be placed after the PLIST and before 278 | the next object. It is also valid to place a tag between 279 | the Properties header and the PLIST object; this tags the 280 | *list object* rather than the Properties. 281 | 282 | Forward references to PLIST, or the list object, are 283 | invalid. 284 | 285 | 286 | Reserved #b10001001 - #b10011111, count = 23 287 | 288 | Index: #b101fdddd; f = inline-flag, dddd = id or size-bytes 289 | (count = 32) 290 | [size-bytes bytes; if f=0, value of index] 291 | 292 | Indexes are essentially enumerations which can be mapped 293 | to a symbol or keyword. 294 | 295 | Tag: #b111fdddd; f = inline-flag, dddd = id or size-bytes 296 | (count = 32) 297 | [size-bytes bytes; if f=0, value of index] 298 | 299 | f: #b0: id follows 300 | #b1: id is lower nibble 301 | 302 | dddd: #b00nn: size-bytes per container if f = 0 303 | 304 | otherwise, 4-bit reference ID. 305 | 306 | Note: Tags are written at any point before an object. 307 | They may not be written where objects are shortened, 308 | such as static containers. The parser should track 309 | the given ID as being associated with the following 310 | object. It is an error to assign the same tag twice. 311 | -------------------------------------------------------------------------------- /src/array.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:conspack) 2 | 3 | ;;;; This defines an encoding for general arrays via TMaps. 4 | ;;;; This will only be used for non-vectors; vectors are encoded more 5 | ;;;; directly as described in SPEC. 6 | 7 | (defmethod object-class-identifier ((object array) &key &allow-other-keys) 8 | ;; There are various subclasses of CL:ARRAY, some of which may be 9 | ;; implementation-specific; we don't need any of them. 10 | 'array) 11 | 12 | (defmethod encode-object append ((object array) &key &allow-other-keys) 13 | (let ((aet (array-element-type object))) 14 | `((:dimensions . ,(array-dimensions object)) 15 | (:element-type . ,aet) 16 | ;; Cheap maneuever: This displaced array is a SEQUENCE, so it can be 17 | ;; encoded through conspack's normal and efficient vector encoding. 18 | (:content . ,(make-array (array-total-size object) 19 | :element-type aet 20 | :displaced-to object))))) 21 | 22 | (defmethod decode-object-allocate ((class (eql 'array)) alist 23 | &key &allow-other-keys) 24 | (let* ((cdimensions (cdr (assoc :dimensions alist))) 25 | (caet (cdr (assoc :element-type alist)))) 26 | (make-array cdimensions :element-type caet))) 27 | 28 | (defmethod decode-object-initialize progn ((array array) class alist 29 | &key &allow-other-keys) 30 | (declare (ignore class)) 31 | (let ((ccontent (cdr (assoc :content alist)))) 32 | (loop for i below (length ccontent) 33 | do (setf (row-major-aref array i) (aref ccontent i))) 34 | array)) 35 | -------------------------------------------------------------------------------- /src/conspack.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | -------------------------------------------------------------------------------- /src/decode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; Decode Properties 4 | 5 | (defvar *current-properties* nil) 6 | 7 | ;; Reading 8 | 9 | ;;; We have to do some extra work to handle forward references (that is, 10 | ;;; references to a container within that container). DECODE-VALUE, the 11 | ;;; main function here, will return (values value T) in the absence of 12 | ;;; forward references. If there are forward references, it instead 13 | ;;; returns (values incomplete nil), where INCOMPLETE is one of these 14 | ;;; structures. The INCOMPLETE stores an uninitialized VALUE (unless we're 15 | ;;; dealing with a forward reference directly, in which case this is not 16 | ;;; possible), and DATA to be used to complete initialization of the value. 17 | ;;; DECODE-TAG will try to build an object containing references to itself, 18 | ;;; and get an INCOMPLETE. It will resolve the reference to the INCOMPLETE's 19 | ;;; VALUE, and then try completing initialization. Since only a TAG can 20 | ;;; introduce a forward reference, this should ensure everything is 21 | ;;; eventually resolved. 22 | ;;; We use this second value instead of just checking if the result is an 23 | ;;; INCOMPLETE in order to allow serializing INCOMPLETE values themselves; 24 | ;;; unlikely, but possible, and some kind of out-of-band signal is needed 25 | ;;; to deal with it. We could alternately wrap complete results in a 26 | ;;; different structure, but that would mean extra consing in the 27 | ;;; much more common case. 28 | ;;; Possible TODO: 29 | ;;; * If INCOMPLETEs kept track of which references they were waiting on, 30 | ;;; the decoder could skip completion attempts that are doomed to fail. 31 | ;;; Would let complex circular references be decoded more efficiently, 32 | ;;; and maybe make the code simpler? 33 | ;;; * The alists passed to DECODE-OBJECT-ALLOCATE vary based on what are 34 | ;;; forward references. This is because we attempt to get as complete 35 | ;;; an alist as possible, meaning we can't construct tagged TMaps 36 | ;;; before recursing into their keys and value. It might be possible to 37 | ;;; include a mechanism for specifying which alist entries are required 38 | ;;; for allocation to avoid this. 39 | 40 | (defstruct (incomplete (:constructor make-incomplete (type value data))) 41 | type value data) 42 | 43 | (defun decode-boolean (header) 44 | (use-bytes +platform-bytes+) 45 | (values (logbitp 0 header) t)) 46 | 47 | (defun decode-number (header buffer) 48 | (values 49 | (ecase (decode-number-header header) 50 | (:int8 (use-bytes 1) (read8 buffer)) 51 | (:int16 (use-bytes 2) (read16-be buffer)) 52 | (:int32 (use-bytes 4) (read32-be buffer)) 53 | (:int64 (use-bytes 8) (read64-be buffer)) 54 | (:uint8 (use-bytes 1) (readu8 buffer)) 55 | (:uint16 (use-bytes 2) (readu16-be buffer)) 56 | (:uint32 (use-bytes 4) (readu32-be buffer)) 57 | (:uint64 (use-bytes 8) (readu64-be buffer)) 58 | (:single-float 59 | (use-bytes 4) 60 | (ieee-floats:decode-float32 (readu32-be buffer))) 61 | (:double-float 62 | (use-bytes 8) 63 | (ieee-floats:decode-float64 (readu64-be buffer))) 64 | (:int128 (use-bytes 16) (read128-be buffer)) 65 | (:uint128 (use-bytes 16) (readu128-be buffer)) 66 | (:complex 67 | (use-bytes +platform-bytes+) 68 | (let ((realpart (decode-value buffer)) 69 | (imagpart (decode-value buffer))) 70 | (complex realpart imagpart))) 71 | (:rational 72 | (use-bytes +platform-bytes+) 73 | (let ((num (decode-value buffer)) 74 | (den (decode-value buffer))) 75 | (rationalize (/ num den))))) 76 | t)) 77 | 78 | (defun decode-size (bytes buffer) 79 | (ecase bytes 80 | (1 (readu8 buffer)) 81 | (2 (readu16-be buffer)) 82 | (4 (readu32-be buffer)))) 83 | 84 | (defun decode-string (header buffer &optional len) 85 | (let ((len (or len (decode-size (size-bytes header) buffer)))) 86 | (use-bytes len) 87 | (let ((octets (make-octet-vector len))) 88 | (fast-read-sequence octets buffer) 89 | (values (trivial-utf-8:utf-8-bytes-to-string octets) t)))) 90 | 91 | (defun decode-list (header buffer &optional len) 92 | (let ((len (or len (decode-size (size-bytes header) buffer))) 93 | (fixed-header (when (container-fixed-p header) 94 | (fast-read-byte buffer)))) 95 | (container-precheck-bytes len fixed-header) 96 | (when (< len 2) 97 | (error 'invalid-size :value len :reader "Length of LIST must be >= 2")) 98 | (loop with first = (cons nil nil) 99 | with incomplete = nil 100 | for i below (1- len) 101 | for cons = first then (setf (cdr cons) (cons nil nil)) 102 | do (setf (car cons) 103 | (multiple-value-bind (value complete-p) 104 | (decode-value buffer fixed-header) 105 | (unless complete-p (push cons incomplete)) 106 | value)) 107 | finally (return 108 | (multiple-value-bind (last complete-p) 109 | (decode-value buffer fixed-header) 110 | ;; We use the vector as a special mark indicating 111 | ;; the CDR needs to be completed. 112 | (unless complete-p (push (vector cons) incomplete)) 113 | (setf (cdr cons) last) 114 | (if incomplete 115 | (values (make-incomplete :list first incomplete) nil) 116 | (values first t))))))) 117 | 118 | (defun try-list-completion (incomplete) 119 | (let ((conses (incomplete-data incomplete)) 120 | ;; A bit inefficient in that we cons up a new list when we don't 121 | ;; strictly need to, but this is a rare case anyway. 122 | new-conses) 123 | (loop for cons in conses 124 | do (if (vectorp cons) 125 | ;; CDR 126 | (let* ((vec cons) 127 | (cons (aref vec 0))) 128 | (multiple-value-bind (new complete-p) 129 | (try-completion (cdr cons)) 130 | (if complete-p 131 | (setf (cdr cons) new) 132 | (push vec new-conses)))) 133 | ;; CAR 134 | (multiple-value-bind (new complete-p) 135 | (try-completion (car cons)) 136 | (if complete-p 137 | (setf (car cons) new) 138 | (push cons new-conses))))) 139 | (cond (new-conses 140 | (setf (incomplete-data incomplete) new-conses) 141 | (values incomplete nil)) 142 | (t (values (incomplete-value incomplete) t))))) 143 | 144 | (defun decode-vector (header buffer &optional len) 145 | (let* ((len (or len (decode-size (size-bytes header) buffer))) 146 | (fixed-header (when (container-fixed-p header) 147 | (fast-read-byte buffer))) 148 | (fixed-type 149 | (when fixed-header 150 | (number-type-to-lisp 151 | (decode-number-header fixed-header))))) 152 | (container-precheck-bytes len fixed-header) 153 | (let ((v (make-array len :element-type (or fixed-type t)))) 154 | (loop with incomplete = nil 155 | for i below len 156 | do (setf (aref v i) 157 | (multiple-value-bind (value complete-p) 158 | (decode-value buffer fixed-header) 159 | (unless complete-p (push i incomplete)) 160 | value)) 161 | finally (return 162 | (if incomplete 163 | (values (make-incomplete :vector v incomplete) nil) 164 | (values v t))))))) 165 | 166 | (defun try-vector-completion (incomplete) 167 | (let ((vec (incomplete-value incomplete)) 168 | (indices (incomplete-data incomplete)) 169 | new-indices) 170 | (loop for index in indices 171 | for subincomplete = (aref vec index) 172 | do (multiple-value-bind (new complete-p) 173 | (try-completion subincomplete) 174 | (if complete-p 175 | (setf (aref vec index) new) 176 | (push index new-indices)))) 177 | (cond (new-indices 178 | (setf (incomplete-data incomplete) new-indices) 179 | (values incomplete nil)) 180 | (t (values vec t))))) 181 | 182 | (defun decode-map (header buffer &optional len) 183 | (let* ((len (or len (decode-size (size-bytes header) buffer))) 184 | (fixed-header (when (container-fixed-p header) 185 | (fast-read-byte buffer))) 186 | (hash (make-hash-table :test (if (eq :equal (getf *current-properties* :test)) 187 | 'equal 'eql) 188 | :size len))) 189 | (container-precheck-bytes (* 2 len) fixed-header) 190 | (loop with incomplete = nil 191 | for i below len 192 | do (multiple-value-bind (key key-complete-p) 193 | (decode-value buffer fixed-header) 194 | (multiple-value-bind (value value-complete-p) 195 | (decode-value buffer) 196 | (setf (gethash key hash) value) 197 | (cond ((and key-complete-p value-complete-p)) 198 | (key-complete-p 199 | (push (list :value key value) incomplete)) 200 | (value-complete-p 201 | (push (list :key key) incomplete)) 202 | (t (push (list :key-value key value) incomplete))))) 203 | finally (return 204 | (if incomplete 205 | (values (make-incomplete :map hash incomplete) nil) 206 | (values hash t)))))) 207 | 208 | (defun try-map-completion (incomplete) 209 | (let ((hash (incomplete-value incomplete)) 210 | (data (incomplete-data incomplete)) 211 | new-data) 212 | (loop for datum in data 213 | for which = (car datum) 214 | do (ecase which 215 | (:key (let ((key (second datum))) 216 | (multiple-value-bind (new complete-p) 217 | (try-completion key) 218 | (if complete-p 219 | (let ((value (gethash key hash))) 220 | ;; Delete the incomplete key first in an 221 | ;; effort to avoid expanding the table. 222 | (remhash key hash) 223 | (setf (gethash new hash) value)) 224 | (push datum new-data))))) 225 | (:value (let ((key (second datum)) (val (third datum))) 226 | (multiple-value-bind (new complete-p) 227 | (try-completion val) 228 | (if complete-p 229 | (setf (gethash key hash) new) 230 | (push datum new-data))))) 231 | (:key-value 232 | (let ((key (second datum)) (val (third datum))) 233 | (multiple-value-bind (new-val val-complete-p) 234 | (try-completion val) 235 | (multiple-value-bind (new-key key-complete-p) 236 | (try-completion key) 237 | (when key-complete-p (remhash key hash)) 238 | (setf (gethash new-key hash) new-val) 239 | (cond ((and key-complete-p val-complete-p)) 240 | (key-complete-p 241 | (push (list :value new-key new-val) new-data)) 242 | (val-complete-p 243 | (push (list :key new-key) new-data)) 244 | (t (push datum new-data))))))))) 245 | (cond (new-data 246 | (setf (incomplete-data incomplete) data) 247 | (values incomplete nil)) 248 | (t (values hash t))))) 249 | 250 | (defun decode-tmap (header buffer &optional len) 251 | (let* ((len (or len (decode-size (size-bytes header) buffer))) 252 | (fixed-header (when (container-fixed-p header) 253 | (fast-read-byte buffer))) 254 | (class (decode-value buffer))) 255 | (container-precheck-bytes (* 2 len) fixed-header) 256 | (unless (symbolp class) 257 | ;; This additionally means that the class cannot be an incomplete. 258 | (error 'invalid-tmap-type :value class :reason "Not a symbol")) 259 | (loop with incomplete = nil 260 | with alloc-pairs = nil 261 | for i below len 262 | collect (multiple-value-bind (key key-complete-p) 263 | (decode-value buffer fixed-header) 264 | (multiple-value-bind (value value-complete-p) 265 | (decode-value buffer) 266 | (let ((pair (cons key value)) 267 | (akey key) (avalue value) (complete-enough-p t)) 268 | ;; Push any incompleteness fixups. 269 | ;; Push the pair to the alist for -allocate 270 | ;; unless either is a totally unresolved ref. 271 | (unless key-complete-p 272 | (push (cons :key pair) incomplete) 273 | (if (eq (incomplete-type key) :ref) 274 | (setf complete-enough-p nil) 275 | (setf akey (incomplete-value key)))) 276 | (unless value-complete-p 277 | (push (cons :value pair) incomplete) 278 | (if (eq (incomplete-type value) :ref) 279 | (setf complete-enough-p nil) 280 | (setf avalue (incomplete-value value)))) 281 | (when complete-enough-p 282 | (push (if (and (eq key akey) (eq value avalue)) 283 | pair 284 | (cons akey avalue)) 285 | alloc-pairs)) 286 | pair))) 287 | into pairs 288 | finally (return 289 | (let ((obj (decode-object-allocate class alloc-pairs))) 290 | (cond 291 | (incomplete 292 | (values (make-incomplete 293 | :tmap obj (list* pairs class incomplete)) 294 | nil)) 295 | (t 296 | (decode-object-initialize obj class pairs) 297 | (values obj t)))))))) 298 | 299 | (defun try-tmap-completion (incomplete) 300 | (declare (optimize debug)) 301 | (let* ((obj (incomplete-value incomplete)) 302 | (data (incomplete-data incomplete)) 303 | (pairs (first data)) (class (second data)) (work (cddr data)) 304 | new-data) 305 | (assert work) 306 | (loop for datum in work 307 | for (which . pair) = datum 308 | for inc = (ecase which (:key (car pair)) (:value (cdr pair))) 309 | do (multiple-value-bind (new complete-p) 310 | (try-completion inc) 311 | (if complete-p 312 | (ecase which 313 | (:key (setf (car pair) new)) 314 | (:value (setf (cdr pair) new))) 315 | (push datum new-data)))) 316 | (cond (new-data 317 | (setf (incomplete-data incomplete) (list* pairs class new-data)) 318 | (values incomplete nil)) 319 | (t 320 | (decode-object-initialize obj class pairs) 321 | (values obj t))))) 322 | 323 | (defun decode-container (header buffer &optional len) 324 | (let ((type (decode-container-type header))) 325 | (ecase type 326 | (:list (decode-list header buffer len)) 327 | (:vector (decode-vector header buffer len)) 328 | (:map (decode-map header buffer len)) 329 | (:tmap (decode-tmap header buffer len))))) 330 | 331 | (defun decode-ref-id (header buffer) 332 | (if (logbitp 4 header) 333 | (logand header #xF) 334 | (decode-size (size-bytes header) buffer))) 335 | 336 | (defun decode-ref (header buffer) 337 | (let ((id (decode-ref-id header buffer))) 338 | (use-bytes +platform-bytes+) 339 | (multiple-value-bind (obj exists-p) (get-ref id) 340 | (cond (exists-p (values obj t)) 341 | (t 342 | (unless *conspack-forward-refs* 343 | (error 'invalid-forward-ref 344 | :value id 345 | :reason "Forward refs restricted.")) 346 | (values (make-incomplete :ref nil id) nil)))))) 347 | 348 | (defun try-ref-completion (incomplete) 349 | (multiple-value-bind (obj exists-p) (get-ref (incomplete-data incomplete)) 350 | (if exists-p (values obj t) (values incomplete nil)))) 351 | 352 | (defun decode-r-ref (header buffer) 353 | (declare (ignore header)) 354 | (use-bytes +platform-bytes+) 355 | (let ((object (decode-value buffer))) 356 | (values (funcall *remote-ref-fun* object) t))) 357 | 358 | (defun decode-pointer (header buffer &optional len) 359 | (let ((len (or len (size-bytes header)))) 360 | (use-bytes +platform-bytes+ 2) 361 | (values (pointer (decode-size len buffer) (* 8 len)) t))) 362 | 363 | (defun decode-tag (header buffer) 364 | (let ((id (decode-ref-id header buffer))) 365 | (multiple-value-bind (obj complete-p) (decode-value buffer) 366 | (cond (complete-p 367 | ;; Store the complete value in the ref table for later refs. 368 | (add-ref id obj) 369 | (values obj t)) 370 | (t 371 | ;; Make sure we don't have a #1=#1# situation. 372 | (when (eq (incomplete-type obj) :ref) 373 | (error 'vacuous-ref 374 | :value id 375 | :reason "Tag's value cannot be a forward ref.")) 376 | ;; Store the allocated value in the ref table and try completion. 377 | ;; (try-completion returns the same values decode-value should.) 378 | (add-ref id (incomplete-value obj)) 379 | (try-completion obj)))))) 380 | 381 | (defun decode-cons (header buffer) 382 | (declare (ignore header)) 383 | (use-bytes +platform-bytes+ 2) 384 | (multiple-value-bind (car car-complete-p) (decode-value buffer) 385 | (multiple-value-bind (cdr cdr-complete-p) (decode-value buffer) 386 | (let ((cons (cons car cdr))) 387 | (cond ((and car-complete-p cdr-complete-p) (values cons t)) 388 | (car-complete-p 389 | (values (make-incomplete :cons cons (cons t nil)) nil)) 390 | (cdr-complete-p 391 | (values (make-incomplete :cons cons (cons nil t)) nil)) 392 | (t (values (make-incomplete :cons cons (cons nil nil)) nil))))))) 393 | 394 | (defun try-cons-completion (incomplete) 395 | (let ((cons (incomplete-value incomplete)) 396 | (which (incomplete-data incomplete))) 397 | (unless (car which) 398 | (multiple-value-bind (car car-complete-p) (try-completion (car cons)) 399 | (when car-complete-p 400 | (setf (car cons) car (car which) car-complete-p)))) 401 | (unless (cdr which) 402 | (multiple-value-bind (cdr cdr-complete-p) (try-completion (cdr cons)) 403 | (when cdr-complete-p 404 | (setf (cdr cons) cdr (cdr which) cdr-complete-p)))) 405 | (if (and (car which) (cdr which)) 406 | (values cons t) 407 | (values incomplete nil)))) 408 | 409 | (defun decode-package (header buffer) 410 | (declare (ignore header)) 411 | (use-bytes +platform-bytes+) 412 | (let ((package-name (decode-value buffer))) 413 | (unless (stringp package-name) 414 | (error 'invalid-package-name :value package-name :reason "Not a string.")) 415 | (let ((package (find-package package-name))) 416 | (unless package 417 | (error 'invalid-package-name :value package-name 418 | :reason "Package does not exist.")) 419 | (values package t)))) 420 | 421 | (defvar *intern-symbols* nil) 422 | 423 | (defun decode-symbol (header buffer) 424 | (let ((symbol-name (decode-value buffer))) 425 | (use-bytes +platform-bytes+) 426 | (unless (stringp symbol-name) 427 | (error 'invalid-symbol-name :value symbol-name :reason "Not a string.")) 428 | (let ((package (if (keyword-p header) 429 | (find-package :keyword) 430 | (decode-value buffer)))) 431 | (values (if package 432 | (if *intern-symbols* 433 | (intern symbol-name package) 434 | (multiple-value-bind (symbol status) 435 | (find-symbol symbol-name package) 436 | (if status 437 | symbol 438 | (make-symbol symbol-name)))) 439 | (make-symbol symbol-name)) 440 | t)))) 441 | 442 | (defmacro with-interning (nil &body body) 443 | `(let ((*intern-symbols* t)) ,@body)) 444 | 445 | (defun decode-character (header buffer) 446 | (let ((len (logand header #b11))) 447 | (use-bytes len) 448 | (let ((octets (make-octet-vector len))) 449 | (fast-read-sequence octets buffer) 450 | (values (aref (trivial-utf-8:utf-8-bytes-to-string octets) 0) t)))) 451 | 452 | (defun decode-index (header buffer) 453 | (let* ((id (decode-ref-id header buffer)) 454 | (sym (find-in-index id))) 455 | (unless sym 456 | (error 'invalid-index :value id :reason "ID not found in index")) 457 | (use-bytes +platform-bytes+) 458 | (values sym t))) 459 | 460 | (defun mark-properties (next-object) 461 | (unless (or (characterp next-object) 462 | (numberp next-object)) 463 | (setf (gethash next-object *properties*) 464 | *current-properties*))) 465 | 466 | (defun decode-properties (header buffer) 467 | (declare (ignore header)) 468 | (multiple-value-bind (*current-properties* cpp) (decode-value buffer) 469 | (unless cpp 470 | (error 'forward-referenced-properties 471 | :value *current-properties* 472 | :reason "Properties cannot be a forward ref.")) 473 | (multiple-value-bind (next-object complete-p) (decode-value buffer) 474 | (cond (complete-p (mark-properties next-object)) 475 | ((not (eq (incomplete-type next-object) :ref)) 476 | (mark-properties (incomplete-value next-object))) 477 | (t (error 'vacuous-properties 478 | :value (incomplete-data next-object) 479 | :reason "Cannot set properties of forward ref."))) 480 | (values next-object complete-p)))) 481 | 482 | (defun decode-value (buffer &optional header) 483 | (let ((header (or header (fast-read-byte buffer)))) 484 | (ecase (decode-header header) 485 | (:boolean (decode-boolean header)) 486 | (:number (decode-number header buffer)) 487 | (:string (decode-string header buffer)) 488 | (:container (decode-container header buffer)) 489 | (:tag (decode-tag header buffer)) 490 | (:ref (decode-ref header buffer)) 491 | (:r-ref (decode-r-ref header buffer)) 492 | (:pointer (decode-pointer header buffer)) 493 | (:cons (decode-cons header buffer)) 494 | (:package (decode-package header buffer)) 495 | (:symbol (decode-symbol header buffer)) 496 | (:character (decode-character header buffer)) 497 | (:properties (decode-properties header buffer)) 498 | (:index (decode-index header buffer))))) 499 | 500 | (defun try-completion (incomplete) 501 | (ecase (incomplete-type incomplete) 502 | (:list (try-list-completion incomplete)) 503 | (:vector (try-vector-completion incomplete)) 504 | (:map (try-map-completion incomplete)) 505 | (:tmap (try-tmap-completion incomplete)) 506 | (:cons (try-cons-completion incomplete)) 507 | (:ref (try-ref-completion incomplete)))) 508 | 509 | (defun %decode (buffer) 510 | (with-properties () 511 | (tracking-refs () 512 | (multiple-value-bind (value complete-p) (decode-value buffer) 513 | (if complete-p 514 | value 515 | (error 'toplevel-forward-ref :value value 516 | :reason "There are unresolved forward reference(s).")))))) 517 | 518 | (defun decode (byte-vector &optional (offset 0)) 519 | (with-fast-input (buffer byte-vector nil offset) 520 | (values (%decode buffer) (fast-io:buffer-position buffer)))) 521 | 522 | (defun decode-stream (stream &optional (offset 0)) 523 | (with-fast-input (buffer nil stream offset) 524 | (values (%decode buffer) (fast-io:buffer-position buffer)))) 525 | 526 | (defun decode-file (path) 527 | (with-open-file (stream path :element-type '(unsigned-byte 8)) 528 | (let (eof) 529 | (tracking-refs () 530 | (loop as object = (handler-case 531 | (decode-stream stream) 532 | (end-of-file () (setf eof t) (values))) 533 | until eof 534 | collect object))))) 535 | 536 | -------------------------------------------------------------------------------- /src/encode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; Utility 4 | 5 | (defstruct pointer 6 | (value 0) 7 | (bit-width nil)) 8 | 9 | (defun pointer (value &optional bit-width) 10 | (make-pointer :value value :bit-width bit-width)) 11 | 12 | (defmethod print-object ((o pointer) s) 13 | (print-unreadable-object (o s :type t) 14 | (format s "#x~8,'0X:~D" (pointer-value o) (pointer-bit-width o)))) 15 | 16 | ;; Encoding 17 | 18 | (defun encode-header (header-byte buffer &optional fixed-header 19 | size-value size-type) 20 | "Combine `VALUES` with LOGIOR and write." 21 | (let ((size-type (cond 22 | (fixed-header (size-type fixed-header)) 23 | (size-type size-type) 24 | (size-value (len-size-type size-value)) 25 | (t 0)))) 26 | (unless fixed-header 27 | (writeu8 (logior size-type header-byte) buffer)) 28 | (when size-value 29 | (encode-length size-type size-value buffer)))) 30 | 31 | (defun encode-length (size-type len buffer) 32 | (declare (type (unsigned-byte 8) size-type)) 33 | (ecase size-type 34 | (#b00 (writeu8 len buffer)) 35 | (#b01 (writeu16-be len buffer)) 36 | (#b10 (writeu32-be len buffer)))) 37 | 38 | (defun encode-boolean (value buffer &optional fixed-header) 39 | (when fixed-header 40 | (error "FIXED-HEADER specified for boolean.")) 41 | (if value 42 | (writeu8 #b1 buffer) 43 | (writeu8 #b0 buffer))) 44 | 45 | (defun encode-number (value buffer &optional fixed-header) 46 | (let ((type (if fixed-header 47 | (decode-number-header fixed-header) 48 | (number-type value)))) 49 | (encode-header (number-header type) buffer fixed-header) 50 | (ecase type 51 | (:int8 (write8 value buffer)) 52 | (:uint8 (writeu8 value buffer)) 53 | (:int16 (write16-be value buffer)) 54 | (:uint16 (writeu16-be value buffer)) 55 | (:int32 (write32-be value buffer)) 56 | (:uint32 (writeu32-be value buffer)) 57 | (:int64 (write64-be value buffer)) 58 | (:uint64 (writeu64-be value buffer)) 59 | (:int128 (write128-be value buffer)) 60 | (:uint128 (writeu128-be value buffer)) 61 | (:single-float (writeu32-be (ieee-floats:encode-float32 value) buffer)) 62 | (:double-float (writeu64-be (ieee-floats:encode-float64 value) buffer)) 63 | (:complex 64 | (%encode (realpart value) buffer) 65 | (%encode (imagpart value) buffer)) 66 | (:rational 67 | (%encode (numerator value) buffer) 68 | (%encode (denominator value) buffer))))) 69 | 70 | (defun encode-string (value buffer &optional fixed-header) 71 | (let ((octets (trivial-utf-8:string-to-utf-8-bytes value))) 72 | (encode-header +string-header+ buffer fixed-header (length octets)) 73 | (fast-write-sequence octets buffer))) 74 | 75 | (defun encode-list (value buffer &optional fixed-header fixed-type) 76 | (let ((len (list-length-with-refs value))) 77 | (if (or (consp (cdr value)) fixed-header) 78 | (progn 79 | (encode-header (container-header :list fixed-type) buffer 80 | fixed-header len) 81 | (when fixed-type (encode-header fixed-type buffer)) 82 | (loop for i on value 83 | for x from 0 below len 84 | do (encode-ref-or-value (car i) buffer fixed-type) 85 | until (or (null (cdr i)) 86 | (get-ref-id (cdr i))) 87 | finally 88 | (cond 89 | ((and (not fixed-type) (listp i)) 90 | (encode-ref-or-value (cdr i) buffer fixed-type)) 91 | ((not fixed-type) 92 | (encode-ref-or-value i buffer fixed-type))))) 93 | (encode-cons value buffer)))) 94 | 95 | (defun encode-vector (value buffer &optional fixed-header fixed-type) 96 | (let ((fixed-type (or fixed-type 97 | (number-header (find-fixed-type (array-element-type value)))))) 98 | (encode-header (container-header :vector fixed-type) buffer 99 | fixed-header (length value)) 100 | (when fixed-type 101 | (encode-header fixed-type buffer)) 102 | (loop for i across value do 103 | (encode-ref-or-value i buffer fixed-type)))) 104 | 105 | (defun encode-hash (value buffer &optional fixed-header fixed-type) 106 | (encode-header (container-header :map fixed-type) buffer 107 | fixed-header (hash-table-count value)) 108 | (loop for k being each hash-key in value using (hash-value v) do 109 | (encode-ref-or-value k buffer) 110 | (encode-ref-or-value v buffer))) 111 | 112 | (defun encode-tmap (value buffer &optional fixed-header) 113 | (let* ((encoded-alist (if *ref-context* 114 | (gethash value (ref-context-encoded-objects *ref-context*)) 115 | (encode-object value))) 116 | (len (length encoded-alist))) 117 | (encode-header (container-header :tmap nil) buffer fixed-header len) 118 | (encode-ref-or-value (object-class-identifier value) buffer) 119 | (loop for i in encoded-alist do 120 | (encode-ref-or-value (car i) buffer) 121 | (encode-ref-or-value (cdr i) buffer)))) 122 | 123 | (defun encode-sequence (value buffer &optional fixed-header fixed-type) 124 | (etypecase value 125 | (list (encode-list value buffer fixed-header fixed-type)) 126 | (vector (encode-vector value buffer fixed-header fixed-type)) 127 | (hash-table (encode-hash value buffer fixed-header fixed-type)))) 128 | 129 | (defun encode-ref (value buffer &optional fixed-header) 130 | (if (and (not fixed-header) (typep value '(unsigned-byte 4))) 131 | (writeu8 (logior +ref-header+ +reftag-inline+ 132 | (logand value #xF)) 133 | buffer) 134 | (encode-header +ref-header+ buffer fixed-header value))) 135 | 136 | (defun encode-r-ref (value buffer &optional fixed-header) 137 | (encode-header +r-ref-header+ buffer fixed-header) 138 | (%encode value buffer)) 139 | 140 | (defun encode-pointer (value buffer &optional fixed-header) 141 | (encode-header +pointer-header+ buffer fixed-header 142 | (pointer-value value) 143 | (when-let (width (pointer-bit-width value)) 144 | (bits-size-type width)))) 145 | 146 | (defun encode-tag (value buffer &optional fixed-header) 147 | (if (and (not fixed-header) (typep value '(unsigned-byte 4))) 148 | (writeu8 (logior +tag-header+ +reftag-inline+ 149 | (logand value #xF)) 150 | buffer) 151 | (encode-header +tag-header+ buffer fixed-header value))) 152 | 153 | (defun encode-cons (value buffer &optional fixed-header) 154 | (encode-header +cons-header+ buffer fixed-header) 155 | (encode-ref-or-value (car value) buffer) 156 | (encode-ref-or-value (cdr value) buffer)) 157 | 158 | (defun encode-package (value buffer &optional fixed-header) 159 | (encode-header +package-header+ buffer fixed-header) 160 | (encode-ref-or-value (package-name value) buffer)) 161 | 162 | (defun encode-symbol (value buffer &optional fixed-header) 163 | (encode-header (symbol-header value) buffer fixed-header) 164 | (encode-ref-or-value (symbol-name value) buffer) 165 | (unless (keywordp value) 166 | (encode-ref-or-value (symbol-package value) buffer))) 167 | 168 | (defun encode-character (value buffer &optional fixed-header) 169 | (let ((bytes (trivial-utf-8:string-to-utf-8-bytes (string value)))) 170 | (encode-header (logior +character-header+ (length bytes)) 171 | buffer fixed-header) 172 | (fast-write-sequence bytes buffer))) 173 | 174 | (defun encode-properties (value buffer) 175 | (encode-header +properties-header+ buffer) 176 | (encode-ref-or-value value buffer)) 177 | 178 | (defun encode-index (value buffer &optional fixed-header) 179 | (if (and (not fixed-header) (typep value '(unsigned-byte 4))) 180 | (writeu8 (logior +index-header+ +reftag-inline+ 181 | (logand value #xF)) 182 | buffer) 183 | (encode-header +index-header+ buffer fixed-header value))) 184 | 185 | (defun %properties-encode (value buffer) 186 | ;; FIXME: This should all be in a separate function or method 187 | (typecase value 188 | (hash-table 189 | (when (eq 'equal (hash-table-test value)) 190 | (setf (property value :test) :equal)))) 191 | (when-let ((p (properties value))) 192 | (encode-properties p buffer))) 193 | 194 | (defun %encode (value buffer &optional fixed-header) 195 | (unless (or fixed-header 196 | (not (tracking-refs-p)) 197 | (written-p value)) 198 | (let ((id (get-ref-id value))) 199 | (when id 200 | (encode-tag id buffer) 201 | (wrote value)))) 202 | (etypecase value 203 | (boolean (encode-boolean value buffer fixed-header)) 204 | (number (encode-number value buffer fixed-header)) 205 | (string (encode-string value buffer fixed-header)) 206 | ((or sequence hash-table) (encode-sequence value buffer fixed-header)) 207 | (package (encode-package value buffer fixed-header)) 208 | (symbol 209 | (let ((id (find-in-index value))) 210 | (if id 211 | (encode-index id buffer fixed-header) 212 | (encode-symbol value buffer fixed-header)))) 213 | (character (encode-character value buffer fixed-header)) 214 | (r-ref (encode-r-ref (r-ref-value value) buffer fixed-header)) 215 | (pointer (encode-pointer value buffer fixed-header)) 216 | (t (encode-tmap value buffer fixed-header)))) 217 | 218 | (defun encode-ref-or-value (value buffer &optional fixed-header) 219 | (%properties-encode value buffer) 220 | (if (and (tracking-refs-p) 221 | (or (not fixed-header) (ref-p fixed-header)) 222 | (written-p value)) 223 | (encode-ref (get-ref-id value) buffer fixed-header) 224 | (%encode value buffer fixed-header))) 225 | 226 | (defun encode-to-buffer (value fast-io-buffer) 227 | (with-properties () 228 | (when (tracking-refs-p) 229 | (notice-recursively value)) 230 | (encode-ref-or-value value fast-io-buffer))) 231 | 232 | (defun encode-to-file (value filename) 233 | (with-open-file (stream filename :direction :output :if-exists :supersede 234 | :element-type '(unsigned-byte 8)) 235 | (encode value :stream stream))) 236 | 237 | (defun encode (value &key stream) 238 | (with-fast-output (buffer stream) 239 | (encode-to-buffer value buffer))) 240 | -------------------------------------------------------------------------------- /src/explain.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; Debugging 4 | 5 | (defvar *explain-eof* nil) 6 | 7 | (defmacro explaining-errors (&body body) 8 | `(handler-case 9 | (unless *explain-eof* 10 | (progn ,@body)) 11 | (invalid-header (c) (list 'invalid-header 12 | (conspack-error-value c) 13 | (conspack-error-reason c))) 14 | (end-of-file () 15 | (setf *explain-eof* t) 16 | 'end-of-file))) 17 | 18 | (defun explain-container (buffer header) 19 | (let* ((item) 20 | (size (decode-size (size-bytes header) buffer)) 21 | (container-type (decode-container-type header)) 22 | (nobjects (ecase container-type 23 | ((:vector :list) size) 24 | ((:map) (* 2 size)) 25 | ((:tmap) (1+ (* 2 size)))))) ; 1+ for class 26 | (push container-type item) 27 | (push size item) 28 | (if (container-fixed-p header) 29 | (progn 30 | (push :fixed item) 31 | (let ((fixed-header (readu8 buffer))) 32 | (if (eq :number (decode-header fixed-header)) 33 | (push (decode-number-header fixed-header) item) 34 | (push (decode-header fixed-header) item)) 35 | (push (explain-buffer buffer nobjects fixed-header) 36 | item))) 37 | (push (explain-buffer buffer nobjects) item)) 38 | item)) 39 | 40 | (defun explain-buffer (buffer &optional n fixed-header) 41 | "This will try and find and interpret as many bytes as possible, 42 | up to `N` objects, or until end-of-file, if `N` is `nil`." 43 | (let (header output (i 0)) 44 | (tagbody 45 | :top 46 | (handler-case 47 | (loop do 48 | (setf header (or fixed-header (readu8 buffer))) 49 | (let (item) 50 | (push (decode-header header) item) 51 | (cond 52 | ((string-p header) 53 | (let ((size (decode-size (size-bytes header) buffer))) 54 | (push (decode-string header buffer size) 55 | item))) 56 | ((container-p header) 57 | (setf item (explain-container buffer header))) 58 | ((number-p header) 59 | (push (decode-number-header header) item) 60 | (push (decode-number header buffer) item)) 61 | ((tag-p header) 62 | (push (decode-ref-id header buffer) item) 63 | (push (car (explain-buffer buffer 1)) item)) 64 | ((ref-p header) 65 | (push (decode-ref-id header buffer) item)) 66 | ((remote-ref-p header) 67 | (push (car (explain-buffer buffer 1)) item)) 68 | ((index-p header) 69 | (push (decode-ref-id header buffer) item)) 70 | ((cons-p header) 71 | (push (car (explain-buffer buffer 1)) item) 72 | (push (car (explain-buffer buffer 1)) item)) 73 | ((properties-p header) 74 | (push (car (explain-buffer buffer 1)) item) 75 | (push (car (explain-buffer buffer 1)) item)) 76 | (t (push (decode-value buffer header) item))) 77 | (push (nreverse item) output)) 78 | (unless (tag-p header) (incf i)) 79 | (when (and n (>= i n)) (loop-finish))) 80 | (end-of-file () (push 'end-of-file output)) 81 | (invalid-header () 82 | (push (list :invalid-byte header) output) 83 | (go :top)))) 84 | (nreverse output))) 85 | 86 | (defun explain (vector) 87 | (with-fast-input (buffer vector) 88 | (explain-buffer buffer))) 89 | -------------------------------------------------------------------------------- /src/headers.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; Constants 4 | 5 | (defconstant +boolean-header+ #b00000000) ; #b0000000n 6 | (defconstant +number-header+ #b00010000) ; #b0001nnnn 7 | (defconstant +container-header+ #b00100000) ; #b001xxfnn 8 | (defconstant +string-header+ #b01000000) ; #b010000nn 9 | (defconstant +ref-header+ #b01100000) ; #b011fdddd 10 | (defconstant +r-ref-header+ #b01100100) ; #b01100100 11 | (defconstant +pointer-header+ #b01101000) ; #b011010nn 12 | (defconstant +tag-header+ #b11100000) ; #b111fdddd 13 | (defconstant +cons-header+ #b10000000) ; #b10000000 14 | (defconstant +package-header+ #b10000001) ; #b10000001 15 | (defconstant +symbol-header+ #b10000010) ; #b1000001f 16 | (defconstant +character-header+ #b10000100) ; #b100001nn 17 | (defconstant +properties-header+ #b10001000) ; #b10001000 18 | (defconstant +index-header+ #b10100000) ; #b101fdddd 19 | 20 | (defconstant +int8+ #x0) 21 | (defconstant +int16+ #x1) 22 | (defconstant +int32+ #x2) 23 | (defconstant +int64+ #x3) 24 | (defconstant +uint8+ #x4) 25 | (defconstant +uint16+ #x5) 26 | (defconstant +uint32+ #x6) 27 | (defconstant +uint64+ #x7) 28 | (defconstant +single-float+ #x8) 29 | (defconstant +double-float+ #x9) 30 | (defconstant +int128+ #xA) 31 | (defconstant +uint128+ #xB) 32 | (defconstant +complex+ #xC) 33 | (defconstant +rational+ #xF) 34 | 35 | (defconstant +container-vector+ #b00100000) 36 | (defconstant +container-list+ #b00101000) 37 | (defconstant +container-map+ #b00110000) 38 | (defconstant +container-tmap+ #b00111000) 39 | (defconstant +container-fixed+ #b00000100) 40 | 41 | (defconstant +reftag-inline+ #b00010000) 42 | (defconstant +symbol-keyword+ #b00000001) 43 | 44 | ;; Header testing 45 | 46 | (declaim (ftype header-test-fun 47 | boolean-p number-p container-p string-p ref-p 48 | cons-p package-p symbol-p index-p) 49 | (inline boolean-p number-p container-p string-p ref-p 50 | cons-p package-p symbol-p index-p)) 51 | 52 | (defun boolean-p (n) 53 | (= 0 (ash n -1))) 54 | 55 | (defun number-p (n) 56 | (= #b00010000 (logand n #b11110000))) 57 | 58 | (defun container-p (n) 59 | (= #b00100000 (logand n #b11100000))) 60 | 61 | (defun container-fixed-p (n) 62 | (logbitp 2 n)) 63 | 64 | (defun string-p (n) 65 | (= #b01000000 (logand n #b11111100))) 66 | 67 | (defun ref-p (n) 68 | (or 69 | ;; id-follows 70 | (= #b01100000 (logand n #b11111100)) 71 | ;; id-inline 72 | (= #b01110000 (logand n #b11110000)))) 73 | 74 | (defun remote-ref-p (n) 75 | (= +r-ref-header+ n)) 76 | 77 | (defun pointer-header-p (n) 78 | (= +pointer-header+ (logand n #b111111100))) 79 | 80 | (defun tag-p (n) 81 | (or 82 | ;; id-follows 83 | (= #b11100000 (logand n #b11111100)) 84 | ;; id-inline 85 | (= #b11110000 (logand n #b11110000)))) 86 | 87 | (defun tag-inline-p (n) 88 | (logbitp 4 n)) 89 | 90 | (defun cons-p (n) 91 | (= n #b10000000)) 92 | 93 | (defun package-p (n) 94 | (= n #b10000001)) 95 | 96 | (defun symbol-p (n) 97 | (= #b10000010 (logand n #b11111110))) 98 | 99 | (defun character-p (n) 100 | (= +character-header+ (logand n #b11111100))) 101 | 102 | (defun properties-p (n) 103 | (= +properties-header+ n)) 104 | 105 | (defun keyword-p (n) 106 | (and (symbol-p n) 107 | (logbitp 0 n))) 108 | 109 | (defun index-p (n) 110 | (= +index-header+ 111 | (logand +index-header+ n))) 112 | 113 | ;; Making headers 114 | 115 | (defun bits-size-type (bits) 116 | (ecase bits 117 | (8 #b00) 118 | (16 #b01) 119 | (32 #b10))) 120 | 121 | (defun len-size-type (len) 122 | (etypecase len 123 | ((unsigned-byte 8) #b00) 124 | ((unsigned-byte 16) #b01) 125 | ((unsigned-byte 32) #b10))) 126 | 127 | (defun number-type (number) 128 | "Find the closest/smallest encoding type for NUMBER." 129 | (etypecase number 130 | ((signed-byte 8) :int8) 131 | ((unsigned-byte 8) :uint8) 132 | ((signed-byte 16) :int16) 133 | ((unsigned-byte 16) :uint16) 134 | ((signed-byte 32) :int32) 135 | ((unsigned-byte 32) :uint32) 136 | ((signed-byte 64) :int64) 137 | ((unsigned-byte 64) :uint64) 138 | ((signed-byte 128) :int128) 139 | ((unsigned-byte 128) :uint128) 140 | (single-float :single-float) 141 | (double-float :double-float) 142 | (complex :complex) 143 | (ratio :rational))) 144 | 145 | (defun number-type-to-lisp (type) 146 | "Find the lisp type (e.g., SINGLE-FLOAT) for a specified number 147 | type (e.g., :SINGLE-FLOAT). The inverse of NUMBER-TYPE." 148 | (case type 149 | (:int8 '(signed-byte 8)) 150 | (:uint8 '(unsigned-byte 8)) 151 | (:int16 '(signed-byte 16)) 152 | (:uint16 '(unsigned-byte 16)) 153 | (:int32 '(signed-byte 32)) 154 | (:uint32 '(unsigned-byte 32)) 155 | (:int64 '(signed-byte 64)) 156 | (:uint64 '(unsigned-byte 64)) 157 | (:int128 '(signed-byte 128)) 158 | (:uint128 '(unsigned-byte 128)) 159 | (:single-float 'single-float) 160 | (:double-float 'double-float) 161 | (:complex 'complex) 162 | (:rational 'ratio))) 163 | 164 | (defun number-header (type) 165 | (when type 166 | (logior +number-header+ 167 | (ecase type 168 | (:int8 #x0) (:int16 #x1) (:int32 #x2) (:int64 #x3) 169 | (:uint8 #x4) (:uint16 #x5) (:uint32 #x6) (:uint64 #x7) 170 | (:single-float #x8) (:double-float #x9) 171 | (:int128 #xA) (:uint128 #xB) 172 | (:complex #xC) (:rational #xF))))) 173 | 174 | (defun container-type (type) 175 | (ecase type 176 | (:vector +container-vector+) 177 | (:list +container-list+) 178 | (:map +container-map+) 179 | (:tmap +container-tmap+))) 180 | 181 | (defun container-header (type fixed-p) 182 | (let ((type-bits (container-type type)) 183 | (fixed-bits (if fixed-p +container-fixed+ 0))) 184 | (logior type-bits fixed-bits))) 185 | 186 | ;;; Yes, this does assume the lisp calls types as ([UN]SIGNED-BYTE n) 187 | ;;; and not (INTEGER a b). SBCL, CCL, and CLISP do. This is 188 | ;;; considerably faster and less consing than consecutive SUBTYPEP. 189 | (defun find-fixed-type (type) 190 | (unless (eq type t) 191 | (cond 192 | ((and (consp type) (eq 'signed-byte (car type))) 193 | (case (cadr type) 194 | (8 :int8) (16 :int16) (32 :int32) (64 :int64) (128 :int128))) 195 | ((and (consp type) (eq 'unsigned-byte (car type))) 196 | (case (cadr type) 197 | (8 :uint8) (16 :uint16) (32 :uint32) (64 :uint64) (128 :uint128))) 198 | ((eq 'single-float type) :single-float) 199 | ((eq 'double-float type) :double-float)))) 200 | 201 | (defun type-header (type) 202 | (ecase type 203 | ((:int8 :int16 :int32 :int64 :int128 204 | :uint8 :uint16 :uint32 :uint64 :uint128 205 | :single-float :double-float :complex :rational) 206 | (number-header type)) 207 | ((:string)))) 208 | 209 | (defun symbol-header (value) 210 | (if (keywordp value) 211 | (logior +symbol-header+ +symbol-keyword+) 212 | +symbol-header+)) 213 | 214 | (defun character-header (c) 215 | (logior +character-header+ 216 | (length (trivial-utf-8:string-to-utf-8-bytes (string c))))) 217 | 218 | ;; Decode 219 | 220 | (declaim (ftype header-decode-fun 221 | decode-header decode-number-header)) 222 | 223 | (defun decode-header (h) 224 | (cond 225 | ((boolean-p h) :boolean) 226 | ((number-p h) :number) 227 | ((container-p h) :container) 228 | ((string-p h) :string) 229 | ((ref-p h) :ref) 230 | ((remote-ref-p h) :r-ref) 231 | ((pointer-header-p h) :pointer) 232 | ((tag-p h) :tag) 233 | ((cons-p h) :cons) 234 | ((package-p h) :package) 235 | ((symbol-p h) :symbol) 236 | ((character-p h) :character) 237 | ((properties-p h) :properties) 238 | ((index-p h) :index) 239 | (t (error 'invalid-header :value h :reason "unknown type")))) 240 | 241 | (defun decode-number-header (h) 242 | (case (logand #x0F h) 243 | (#x0 :int8) (#x1 :int16) (#x2 :int32) (#x3 :int64) 244 | (#x4 :uint8) (#x5 :uint16) (#x6 :uint32) (#x7 :uint64) 245 | (#x8 :single-float) (#x9 :double-float) 246 | (#xA :int128) (#xB :uint128) 247 | (#xC :complex) (#xF :rational) 248 | (t (error 'invalid-header :value h :reason "reserved number type")))) 249 | 250 | (declaim (ftype (function ((unsigned-byte 8)) (unsigned-byte 8)) 251 | size-type size-bytes) 252 | (inline size-type size-bytes)) 253 | (defun size-type (header) 254 | (logand #b11 header)) 255 | 256 | (defun size-bytes (header) 257 | (case (size-type header) 258 | (#b00 1) 259 | (#b01 2) 260 | (#b10 4) 261 | (t (error 'invalid-header :value header :reason "invalid size-bytes")))) 262 | 263 | (defun number-size (h) 264 | (case (logand #x0F h) 265 | (#x0 1) (#x1 2) (#x2 4) (#x3 8) 266 | (#x4 1) (#x5 2) (#x6 4) (#x7 8) 267 | (#x8 4) (#x9 8) (#xA 16) (#xB 16) 268 | (#xC 16) (#xF 16) ;; more of an estimate, really 269 | (t (error 'invalid-header :value h :reason "reserved number type")))) 270 | 271 | (defun decode-container-type (header) 272 | (case (ldb (byte 2 3) header) 273 | (#b00 :vector) 274 | (#b01 :list) 275 | (#b10 :map) 276 | (#b11 :tmap))) 277 | -------------------------------------------------------------------------------- /src/indexes.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | (defstruct (symbol-index (:constructor %make-symbol-index)) 4 | (sym->id nil :type hash-table) 5 | (id->sym nil :type vector)) 6 | 7 | (defmethod make-load-form ((object symbol-index) &optional environment) 8 | (make-load-form-saving-slots object :environment environment)) 9 | 10 | (defun make-symbol-index (len) 11 | (%make-symbol-index :sym->id (make-hash-table :size len) 12 | :id->sym (make-array (the fixnum len)))) 13 | 14 | (defvar *index* nil) 15 | (defvar *indexes* (make-hash-table)) 16 | 17 | (defun make-index (values &optional name) 18 | (let ((table (make-symbol-index (length values)))) 19 | (loop for value in values 20 | as i from 0 21 | do (setf (gethash value (symbol-index-sym->id table)) i) 22 | (setf (aref (symbol-index-id->sym table) i) value)) 23 | (when name 24 | (setf (gethash name *indexes*) table)) 25 | table)) 26 | 27 | (defun find-index (name) 28 | (gethash name *indexes*)) 29 | 30 | (defmacro with-index ((&rest values) &body body) 31 | (eval-when (:compile-toplevel :load-toplevel :execute) 32 | (let ((table (make-index values))) 33 | `(let ((*index* ,table)) 34 | ,@body)))) 35 | 36 | (defmacro with-named-index (name &body body) 37 | `(let ((*index* (find-index ,name))) 38 | ,@body)) 39 | 40 | (defmacro define-index (name &rest values) 41 | `(eval-when (:compile-toplevel :load-toplevel :execute) 42 | (make-index ',values ',name))) 43 | 44 | (defun delete-index (name) 45 | (remhash name *indexes*)) 46 | 47 | (defun find-in-index (symbol-or-number &optional (index *index*)) 48 | (when index 49 | (etypecase symbol-or-number 50 | (symbol (gethash symbol-or-number (symbol-index-sym->id index))) 51 | (number (aref (symbol-index-id->sym index) symbol-or-number))))) 52 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :conspack 2 | (:nicknames #:cpk) 3 | (:use #:closer-common-lisp #:alexandria #:fast-io) 4 | (:export #:conspack-error #:conspack-error-value #:conspack-error-reason 5 | #:invalid-header #:duplicate-id #:invalid-package-name 6 | #:invalid-symbol-name #:invalid-symbol-package 7 | #:invalid-index #:unhandled-remote-reference 8 | #:invalid-tmap-type 9 | 10 | #:encode #:encode-to-buffer #:encode-to-file 11 | #:r-ref #:make-r-ref #:with-remote-refs 12 | #:tracking-refs #:clear-refs #:make-ref-context 13 | #:with-index #:with-named-index 14 | #:make-index #:define-index #:delete-index 15 | #:find-in-index 16 | 17 | #:pointer #:pointer-value 18 | 19 | #:property #:properties #:remove-property 20 | #:remove-properties #:with-properties 21 | 22 | #:encode-object #:decode-object-allocate #:decode-object-initialize 23 | #:object-class-identifier 24 | #:slots-to-alist #:alist-to-slots 25 | #:defencoding 26 | 27 | #:decode-value #:decode #:decode-stream #:decode-file 28 | 29 | #:explain 30 | 31 | #:*conspack-interning* #:*conspack-max-bytes* 32 | #:*conspack-forward-refs* 33 | 34 | #:*current-properties* 35 | 36 | #:with-interning 37 | #:with-conspack-security)) 38 | -------------------------------------------------------------------------------- /src/properties.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | (defvar *properties* nil 4 | "Object => PLIST association for Properties. Setting a property and 5 | encoding will encode that property. Decoded properties will be 6 | included here as well.") 7 | 8 | (defmacro with-properties (nil &body body) 9 | `(let ((*properties* (or *properties* 10 | (tg:make-weak-hash-table :weakness :key)))) 11 | ,@body)) 12 | 13 | (defun property (object tag &optional default) 14 | (getf (gethash object *properties*) tag default)) 15 | 16 | (defun (setf property) (v object tag) 17 | (setf (getf (gethash object *properties*) tag) v)) 18 | 19 | (defun remove-property (object tag) 20 | (remf (gethash object *properties*) tag)) 21 | 22 | (defun remove-properties (object) 23 | (remhash object *properties*)) 24 | 25 | (defun properties (object) 26 | (unless (trivial-p object) 27 | (gethash object *properties*))) 28 | -------------------------------------------------------------------------------- /src/r-ref.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | (defstruct r-ref (value)) 4 | 5 | (defvar *remote-ref-fun* 6 | (lambda (value) 7 | (error 'unhandled-remote-reference 8 | :value value 9 | :reason "No remote reference handler provided."))) 10 | 11 | (defmacro with-remote-refs (fun &body body) 12 | `(let ((*remote-ref-fun* ,fun)) 13 | ,@body)) 14 | 15 | (declaim (inline r-ref)) 16 | (defun r-ref (value) 17 | (make-r-ref :value value)) 18 | -------------------------------------------------------------------------------- /src/reftable.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | (defvar *ref-context* nil) 4 | 5 | (declaim (inline tracking-refs-p)) 6 | (defun tracking-refs-p () *ref-context*) 7 | 8 | (defstruct ref-context 9 | (max-id 0 :type (unsigned-byte 32)) 10 | (obj-to-id (make-hash-table)) 11 | (id-to-obj (make-hash-table)) 12 | (noticed-objects (make-hash-table)) 13 | (written-objects (make-hash-table)) 14 | (encoded-objects (make-hash-table))) 15 | 16 | (defun clear-refs (&optional (context *ref-context*)) 17 | (setf (ref-context-max-id context) 0) 18 | (clrhash (ref-context-obj-to-id context)) 19 | (clrhash (ref-context-id-to-obj context)) 20 | (clrhash (ref-context-noticed-objects context)) 21 | (clrhash (ref-context-written-objects context))) 22 | 23 | (defun add-ref (id object &optional (context *ref-context*)) 24 | (when (nth-value 1 (gethash id (ref-context-id-to-obj context))) 25 | (error 'duplicate-id 26 | :value id 27 | :existing-value (gethash id (ref-context-id-to-obj context)) 28 | :new-value object)) 29 | (setf (gethash id (ref-context-id-to-obj context)) object 30 | (gethash object (ref-context-obj-to-id context)) id 31 | (ref-context-max-id context) (1+ (max id (ref-context-max-id context)))) 32 | (values)) 33 | 34 | (defun get-ref (id &optional (context *ref-context*)) 35 | (when context 36 | (gethash id (ref-context-id-to-obj context)))) 37 | 38 | (defun get-ref-id (object &optional (context *ref-context*)) 39 | (when context 40 | (gethash object (ref-context-obj-to-id context)))) 41 | 42 | (defun tag-object (object &optional (context *ref-context*)) 43 | (unless (get-ref-id object context) 44 | (add-ref (ref-context-max-id context) 45 | object context))) 46 | 47 | (defun written-p (object &optional (context *ref-context*)) 48 | (gethash object (ref-context-written-objects context))) 49 | 50 | (defun wrote (object &optional (context *ref-context*)) 51 | (setf (gethash object (ref-context-written-objects context)) t)) 52 | 53 | (defun trivial-p (object) 54 | (or (typep object 'character) 55 | (typep object 'number) 56 | (typep object 'boolean))) 57 | 58 | (defun noticed-p (object &optional (context *ref-context*)) 59 | (nth-value 1 (gethash object (ref-context-noticed-objects context)))) 60 | 61 | (defun notice-object (object &optional (context *ref-context*)) 62 | (setf (gethash object (ref-context-noticed-objects context)) t)) 63 | 64 | (defun list-length-with-refs (list &optional (context *ref-context*)) 65 | (if context 66 | (loop for i on list 67 | summing 1 into count 68 | until (and (consp (cdr i)) 69 | (get-ref-id (cdr i) context)) 70 | finally (return (1+ count))) 71 | (loop for i on list 72 | summing 1 into count 73 | while (consp (cdr i)) 74 | finally (return (1+ count))))) 75 | 76 | (defun notice-recursively (object &optional (context *ref-context*)) 77 | (unless (or (trivial-p object) (null context)) 78 | (if (noticed-p object context) 79 | (tag-object object context) 80 | (progn 81 | (notice-object object context) 82 | (typecase object 83 | (list 84 | (notice-recursively (car object) context) 85 | (notice-recursively (cdr object) context)) 86 | (vector 87 | (unless (subtypep (array-element-type object) 'number) 88 | (loop for i across object do (notice-recursively i context)))) 89 | (hash-table 90 | (loop for k being each hash-key in object 91 | using (hash-value v) do 92 | (notice-recursively k context) 93 | (notice-recursively v context))) 94 | ((or string package symbol r-ref pointer)) 95 | (t (let ((encoded-alist (encode-object object))) 96 | (notice-recursively encoded-alist context) 97 | (setf (gethash object (ref-context-encoded-objects context)) 98 | encoded-alist)))))))) 99 | 100 | (defun referrable-p (object) 101 | (or (typep object 'sequence) 102 | (typep object 'hash-table) 103 | (typep object 'symbol) 104 | (typep object 'package))) 105 | 106 | (defmacro tracking-refs (ref-context &body body) 107 | `(let ((*ref-context* (or ,ref-context 108 | *ref-context* 109 | (make-ref-context)))) 110 | ,@body)) 111 | -------------------------------------------------------------------------------- /src/secure.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; External 4 | 5 | (defvar *conspack-security* nil) 6 | (defvar *conspack-max-bytes* nil) 7 | (defvar *conspack-forward-refs* t) 8 | 9 | ;; Internal 10 | 11 | (defvar *bytes-alloc* nil) 12 | 13 | ;;; FIXME: There's more to life than x86_64 .. but trivial-features 14 | ;;; doesn't seem to implement much and I don't have platforms to test 15 | ;;; on ... 16 | (defconstant +platform-bytes+ 17 | #+(not x86-64) 18 | 4 19 | 20 | #+(or x86-64) 21 | 8) 22 | 23 | ;; Config 24 | 25 | (defmacro with-conspack-security ((&key (max-bytes nil) (forward-refs t)) 26 | &body body) 27 | `(let ((*conspack-security* t) 28 | (*conspack-max-bytes* ,max-bytes) 29 | (*conspack-forward-refs* ,forward-refs) 30 | (*bytes-alloc* (or *bytes-alloc* 0))) 31 | ,@body)) 32 | 33 | ;; Utility 34 | 35 | (declaim (ftype (function (fixnum &optional fixnum) null) 36 | use-bytes precheck-bytes)) 37 | (declaim (inline use-bytes)) 38 | (defun use-bytes (n &optional (times 1)) 39 | (when *conspack-max-bytes* 40 | (incf *bytes-alloc* (* n times)) 41 | (when (> *bytes-alloc* *conspack-max-bytes*) 42 | (error 'max-size-exceeded 43 | :value *bytes-alloc* 44 | :reason "Size restricted.")))) 45 | 46 | (defun precheck-bytes (n &optional (times 1)) 47 | (unless *conspack-max-bytes* (return-from precheck-bytes)) 48 | (when (> (+ (* n times) *bytes-alloc*) 49 | *conspack-max-bytes*) 50 | (error 'max-size-exceeded 51 | :value (+ (* n times) *bytes-alloc*) 52 | :reason "Size restricted."))) 53 | 54 | (declaim (ftype (function (fixnum (or null (unsigned-byte 8))) null) container-precheck-bytes)) 55 | (defun container-precheck-bytes (len fixed-header) 56 | (when *conspack-max-bytes* 57 | (use-bytes +platform-bytes+) 58 | (if (and fixed-header (number-p fixed-header)) 59 | (precheck-bytes (number-size fixed-header) len) 60 | (precheck-bytes +platform-bytes+ len)))) 61 | -------------------------------------------------------------------------------- /src/tmap.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | (defgeneric encode-object (object &key &allow-other-keys) 4 | (:documentation "Return an alist for `OBJECT` which will be used for 5 | key-value pairs for a Typed Map (tmap). The class of `OBJECT` will 6 | be encoded along with these and used by the decoder to recreate 7 | the object.") 8 | ;; To support inheritance, the results of multiple applicable methods 9 | ;; are appended together to form the final alist. 10 | (:method-combination append)) 11 | 12 | (defgeneric object-class-identifier (object &key &allow-other-keys) 13 | (:documentation "Return a value for `OBJECT` which will be used as 14 | the class for a Typed Map (tmap). This object will be encoded along 15 | with the key-value pairs returned by `ENCODE-OBJECT` and used by 16 | the decoder to recreate the object.") 17 | (:method (object &key &allow-other-keys) 18 | (class-name (class-of object)))) 19 | 20 | (defgeneric decode-object-allocate (class alist &key &allow-other-keys) 21 | (:documentation "Create an empty object of the given `CLASS` 22 | based on the values in the `ALIST`. Note that any values in the TMap 23 | that are or contain forward references may not appear in the alist, 24 | and containers may be uninitialized. The alist will only be complete 25 | when passed to `DECODE-OBJECT-INITIALIZE`. 26 | Methods should specialize on `CLASS (EQL symbol)`.") 27 | (:method (class alist &key &allow-other-keys) 28 | (declare (ignore alist)) 29 | ;; Assume it's a standard class. 30 | (allocate-instance (find-class class)))) 31 | 32 | (defgeneric decode-object-initialize (object class alist &key &allow-other-keys) 33 | (:documentation "Initialize an empty OBJECT of the given `CLASS` 34 | based on the values in the `ALIST`. Methods should specialize on `OBJECT`, 35 | but can use the `CLASS` if they wish. Return value is ignored.") 36 | ;; Method combo in place to make it easier to initialize subclasses. 37 | ;; Methods need only initialize their particular slots (or whatever), 38 | ;; and can rely on the superclass initializations having completed. 39 | (:method-combination progn :most-specific-last)) 40 | 41 | (defmacro slots-to-alist ((instance) &body slot-names) 42 | "Produce an `ALIST` of slot-names-to-slot-values, suitable for 43 | `ENCODE-OBJECT`." 44 | (if slot-names 45 | (alexandria:once-only (instance) 46 | (alexandria:with-gensyms (alist) 47 | `(let ((,alist nil)) 48 | ,@(loop for slot-name in slot-names 49 | collect `(when (slot-boundp ,instance ',slot-name) 50 | (push (cons ',slot-name 51 | (slot-value ,instance ',slot-name)) 52 | ,alist))) 53 | ,alist))) 54 | ())) 55 | 56 | (defmacro alist-to-slots ((alist instance) &body slot-names) 57 | "Set slots via `(SETF (SLOT-VALUE ...))` based on the values of the 58 | slots specified. 59 | 60 | Slots are set on the provided `INSTANCE`." 61 | (alexandria:once-only (alist) 62 | (alexandria:with-gensyms (object alist% pair) 63 | `(let ((,object ,instance) (,alist% ,alist)) 64 | (declare (ignorable ,alist%)) ; if no slots 65 | (prog1 ,object 66 | ,@(loop for slot-name in slot-names 67 | collect `(let ((,pair (assoc ',slot-name ,alist%))) 68 | (when ,pair 69 | (setf (slot-value ,object ',slot-name) 70 | (cdr ,pair)))))))))) 71 | 72 | (defmacro defencoding (class-name &body slot-names) 73 | "Trivially define `ENCODE-OBJECT` and `DECODE-OBJECT-INITIALIZE` 74 | to store and load the given slots." 75 | `(eval-when (:load-toplevel :execute) 76 | (defmethod encode-object append 77 | ((object ,class-name) &key &allow-other-keys) 78 | (slots-to-alist (object) ,@slot-names)) 79 | (defmethod decode-object-initialize progn 80 | ((object ,class-name) class alist &key &allow-other-keys) 81 | (declare (ignore class)) 82 | (alist-to-slots (alist object) 83 | ,@slot-names)))) 84 | -------------------------------------------------------------------------------- /src/types.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack) 2 | 3 | ;; Types 4 | 5 | (deftype header () '(unsigned-byte 8)) 6 | (deftype header-test-fun () 7 | '(function (header) boolean)) 8 | (deftype header-decode-fun () 9 | '(function (header) keyword)) 10 | 11 | (define-condition conspack-error (error) 12 | ((value :initarg :value :reader conspack-error-value) 13 | (reason :initarg :reason :reader conspack-error-reason)) 14 | (:report (lambda (c s) 15 | (with-slots (value reason) c 16 | (format s "Conspack: ~A: ~A~%Reason: ~A" 17 | (class-name (class-of c)) 18 | value reason))))) 19 | 20 | (define-condition invalid-header (conspack-error) ()) 21 | (define-condition invalid-size (conspack-error) ()) 22 | 23 | (define-condition duplicate-id (conspack-error) 24 | ((existing-value :initarg :existing-value :reader duplicate-ref-existing-value) 25 | (new-value :initarg :new-value :reader duplicate-ref-new-value)) 26 | (:report (lambda (c s) 27 | (with-slots (value existing-value new-value) c 28 | (format s "Duplicate object ID: ~A~%Existing value: ~A~%New value: ~A" 29 | value existing-value new-value))))) 30 | 31 | 32 | (define-condition invalid-package-name (conspack-error) ()) 33 | (define-condition invalid-symbol-name (conspack-error) ()) 34 | (define-condition invalid-symbol-package (conspack-error) ()) 35 | 36 | (define-condition invalid-index (conspack-error) ()) 37 | (define-condition vacuous-ref (conspack-error) ()) 38 | (define-condition vacuous-properties (conspack-error) ()) 39 | (define-condition forward-referenced-properties (conspack-error) ()) 40 | (define-condition toplevel-forward-ref (conspack-error) ()) 41 | 42 | (define-condition unhandled-remote-reference (conspack-error) ()) 43 | 44 | (define-condition invalid-tmap-type (conspack-error) ()) 45 | 46 | (define-condition security-error (conspack-error) ()) 47 | 48 | (define-condition invalid-forward-ref (security-error) ()) 49 | (define-condition max-size-exceeded (security-error) ()) 50 | -------------------------------------------------------------------------------- /t/encode-decode.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack.test) 2 | 3 | (5am:def-suite conspack) 4 | (5am:in-suite conspack) 5 | 6 | (defmacro cycle (value) 7 | (alexandria:once-only (value) 8 | `(5am:is (equalp ,value (decode (encode ,value)))))) 9 | 10 | (defun cycle/refs (value) 11 | (tracking-refs () (decode (prog1 (encode value) (clear-refs))))) 12 | 13 | (5am:test numbers 14 | (cycle 42) 15 | (cycle -42) 16 | (cycle 128) 17 | (cycle 256) 18 | (cycle (expt 2 31)) 19 | (cycle (expt 2 63)) 20 | (cycle (expt 2 127)) 21 | (cycle 5s0) 22 | (cycle 10d0) 23 | (cycle #C(0 1)) 24 | (cycle 1/2) 25 | (cycle 5999999999999/71111111111111) 26 | (cycle #C(1/2 1/2))) 27 | 28 | (5am:test strings 29 | (cycle "hi") 30 | ;; Taken from the utf-8 test file 31 | (cycle "Οὐχὶ ταὐτὰ παρίσταταί μοι γιγνώσκειν, ὦ ἄνδρες ᾿Αθηναῖοι") 32 | (cycle "ሰማይ አይታረስ ንጉሥ አይከሰስ።") 33 | (cycle "ᚻᛖ ᚳᚹᚫᚦ ᚦᚫᛏ ᚻᛖ ᛒᚢᛞᛖ ᚩᚾ ᚦᚫᛗ ᛚᚪᚾᛞᛖ ᚾᚩᚱᚦᚹᛖᚪᚱᛞᚢᛗ ᚹᛁᚦ ᚦᚪ ᚹᛖᛥᚫ")) 34 | 35 | (5am:test containers 36 | (let ((hash (make-hash-table))) 37 | (setf (gethash 5 hash) 50 38 | (gethash 6 hash) 60) 39 | (cycle hash)) 40 | (cycle '(1 2 3)) 41 | (cycle '(50000 60000 70000)) 42 | (cycle #(1 2 3)) 43 | (cycle #(500 600 700)) 44 | (cycle '((1 2) (3 4))) 45 | (cycle #(#(1 2) (3 4))) 46 | (cycle '(1 2 . 3))) 47 | 48 | (5am:test refs 49 | (let* ((ref0 (list 1 2 3)) 50 | (l0 (list 0 ref0 ref0)) 51 | (cl0 (cycle/refs l0)) 52 | (ref1 (list 42)) 53 | (vec0 (map 'vector #'identity (list ref0 ref0))) 54 | (cvec0 (cycle/refs vec0)) 55 | (hash (make-hash-table))) 56 | (setf (cdr ref1) ref1) 57 | (setf (gethash hash hash) hash) 58 | (5am:is (equalp cl0 l0)) 59 | (5am:is (eq (second cl0) (third cl0))) 60 | (let ((cref1 (cycle/refs ref1))) 61 | (5am:is (= 42 (car cref1))) 62 | (5am:is (eq cref1 (cdr cref1)))) 63 | (5am:is (equalp vec0 cvec0)) 64 | (5am:is (eq (aref cvec0 0) (aref cvec0 1))) 65 | (let ((chash (cycle/refs hash))) 66 | (eq chash (gethash chash chash))))) 67 | 68 | (5am:test packages-and-symbols 69 | (cycle (find-package :common-lisp)) 70 | (5am:is (string= (package-name (decode 71 | (encode 72 | (find-package :common-lisp)))) 73 | "COMMON-LISP")) 74 | (cycle 'foo) 75 | (cycle :foo) 76 | (let ((sym0 (decode (encode '#:|foo|)))) 77 | (5am:is (null (symbol-package sym0))) 78 | (5am:is (string= "foo" (symbol-name sym0))))) 79 | 80 | (5am:test fixed-containers 81 | (cycle (make-array 3 :element-type '(unsigned-byte 16) 82 | :initial-contents '(200 300 400)))) 83 | 84 | (5am:test indices 85 | (with-index (:a :b) 86 | (cycle :a) 87 | (cycle '(:a :b)) 88 | (cycle #(:a :b)) 89 | (cycle '(:a :b :c)))) 90 | 91 | (5am:test remote-refs 92 | (with-remote-refs (lambda (value) (list :r-ref value)) 93 | (5am:is (equal '(:r-ref 42) 94 | (decode (encode (make-r-ref :value 42))))) 95 | (5am:is (equal '(1 2 (:r-ref 3)) 96 | (decode 97 | (encode (list 1 2 (make-r-ref :value 3)))))))) 98 | 99 | ;;; Note this is for simple testing, and a terrible example, since 100 | ;;; there is no value checking. You should always make sure values 101 | ;;; are correct and assume the remote end is trying to break your 102 | ;;; code. 103 | 104 | (defstruct point x y) 105 | 106 | (defmethod encode-object append ((v point) &key &allow-other-keys) 107 | `((:x . ,(point-x v)) 108 | (:y . ,(point-y v)))) 109 | 110 | (defmethod decode-object-allocate ((c (eql 'point)) alist 111 | &key &allow-other-keys) 112 | (declare (ignore alist)) 113 | (make-point)) 114 | 115 | (defmethod decode-object-initialize progn ((o point) class alist 116 | &key &allow-other-keys) 117 | (declare (ignore class)) 118 | (setf (point-x o) (cdr (assoc :x alist)) 119 | (point-y o) (cdr (assoc :y alist)))) 120 | 121 | ;;;;;; 122 | 123 | (5am:test tmaps 124 | (cycle (make-point :x 1 :y 2))) 125 | 126 | (5am:test tmaps-and-indices 127 | (with-index (point :x :y) 128 | (cycle (make-point :x 1 :y 2)))) 129 | 130 | #+- 131 | (with-index (point :x :y) 132 | (let ((vec (encode (make-point :x 0 :y 1)))) 133 | (tracking-refs () 134 | (:bench (600000) 135 | (decode vec) 136 | (clear-refs))))) 137 | 138 | #+- 139 | (let ((str (json:encode-json-to-string (make-point :x 0 :y 1)))) 140 | (:bench (6000) 141 | (json:decode-json-from-string str))) 142 | -------------------------------------------------------------------------------- /t/package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :conspack.test 2 | (:use #:cl #:conspack)) 3 | -------------------------------------------------------------------------------- /t/security.lisp: -------------------------------------------------------------------------------- 1 | (in-package :conspack.test) 2 | 3 | (check (:category :security :name :refs :output-p t) 4 | (let ((*print-circle* t) 5 | (circle (cons 42 nil))) 6 | (setf (cdr circle) circle) 7 | (with-conspack-security (:forward-refs nil) 8 | (results 9 | (write-to-string (cycle-refs circle)))))) 10 | 11 | (check (:category :security :name :size :output-p t) 12 | (results 13 | (with-conspack-security (:max-bytes 1024) 14 | (decode (fast-io:octets-from #(40 255)))))) 15 | --------------------------------------------------------------------------------