syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Actually use current-value->placeholder

This commit is contained in:
Tony Garnock-Jones 2019-08-21 21:20:26 +01:00
parent 79af429b58
commit 27ac21bed1
1 changed files with 38 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
implementations/racket/preserves/main.rkt
View File

@ -143,44 +143,48 @@
(encode-array-like 0 (cons key fields)))
(define (encode-value v)
(match v
[#f (bytes #b00000000)]
[#t (bytes #b00000001)]
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
[(annotated annotations _ item)
(bit-string ((apply bit-string-append
(map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary)))
annotations)) :: binary)
((encode-value item) :: binary))]
[(stream-of 'string p) (encode-stream 1 1 bytes? p)]
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? p)]
[(stream-of 'symbol p) (encode-stream 1 3 bytes? p)]
[(stream-of 'sequence p) (encode-stream 2 1 (lambda (x) #t) p)]
[(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) p)]
[(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) p)]
(match ((current-value->placeholder) v)
[(? integer? n)
(bit-string (#b0001 :: bits 4) (n :: (wire-length)))]
[#f
(match v
[#f (bytes #b00000000)]
[#t (bytes #b00000001)]
[(? single-flonum?) (bit-string #b00000010 (v :: float bits 32))]
[(? double-flonum?) (bit-string #b00000011 (v :: float bits 64))]
[(annotated annotations _ item)
(bit-string ((apply bit-string-append
(map (lambda (a) (bit-string #b00000101 ((encode-value a) :: binary)))
annotations)) :: binary)
((encode-value item) :: binary))]
[(stream-of 'string p) (encode-stream 1 1 bytes? p)]
[(stream-of 'byte-string p) (encode-stream 1 2 bytes? p)]
[(stream-of 'symbol p) (encode-stream 1 3 bytes? p)]
[(stream-of 'sequence p) (encode-stream 2 1 (lambda (x) #t) p)]
[(stream-of 'set p) (encode-stream 2 2 (lambda (x) #t) p)]
[(stream-of 'dictionary p) (encode-stream 2 3 (lambda (x) #t) p)]
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))]
;; [0 (bytes #b10000000)]
[(? integer?)
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
(define byte-count (quotient (+ raw-bit-count 7) 8))
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
[(? string?) (encode-binary-like 1 (string->bytes/utf-8 v))]
[(? bytes?) (encode-binary-like 2 v)]
[(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))]
[(? integer? x) #:when (<= -3 x 12) (bit-string (#b0011 :: bits 4) (x :: bits 4))]
;; [0 (bytes #b10000000)]
[(? integer?)
(define raw-bit-count (+ (integer-length v) 1)) ;; at least one sign bit
(define byte-count (quotient (+ raw-bit-count 7) 8))
(bit-string (#b0100 :: bits 4) (byte-count :: (wire-length)) (v :: integer bytes byte-count))]
[(? string?) (encode-binary-like 1 (string->bytes/utf-8 v))]
[(? bytes?) (encode-binary-like 2 v)]
[(? symbol?) (encode-binary-like 3 (string->bytes/utf-8 (symbol->string v)))]
[(record label fields) (encode-record label fields)]
[(? non-object-struct?)
(define key (prefab-struct-key v))
(when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v))
(encode-record key (cdr (vector->list (struct->vector v))))]
[(record label fields) (encode-record label fields)]
[(? non-object-struct?)
(define key (prefab-struct-key v))
(when (not key) (error 'encode-value "Cannot encode non-prefab struct ~v" v))
(encode-record key (cdr (vector->list (struct->vector v))))]
[(? list?) (encode-array-like 1 v)]
[(? set?) (encode-array-like 2 (set->list v))]
[(? dict?) (encode-array-like 3 (dict-keys-and-values v))]
[(? list?) (encode-array-like 1 v)]
[(? set?) (encode-array-like 2 (set->list v))]
[(? dict?) (encode-array-like 3 (dict-keys-and-values v))]
[_ (error 'encode-value "Cannot encode value ~v" v)]))
[_ (error 'encode-value "Cannot encode value ~v" v)])]))
;;---------------------------------------------------------------------------