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