+ (rnrs arithmetic bitwise))

(define MAX_INT 134217727)

(define MIN_INT -134217728)

+(define (map/and proc lst)

+ (map/and proc (cdr lst)))

- (write-bytes (integer->integer-bytes short 2 #t #t)))

+(define (write-1 outpr byte)

- (write-bytes (integer->integer-bytes long 4 #t #t)))

+(define (write-2 outpr short)

+ (put-u8 outpr (bitwise-arithmetic-shift-right short 8))

+ (put-u8 outpr (bitwise-and short #xff)))

-(define (write-symbol symbol)

+(define (write-4 outpr long)

+ (put-u8 outpr (bitwise-arithmetic-shift-right long 24))

+ (put-u8 outpr (bitwise-and #xff (bitwise-arithmetic-shift-right long 16)))

+ (put-u8 outpr (bitwise-and #xff (bitwise-arithmetic-shift-right long 8)))

+ (put-u8 outpr (bitwise-and long #xff)))

+(define (write-str outpr str)

+ (put-bytevector outpr (string->bytevector str (native-transcoder))))

+(define (write-symbol outpr symbol)

(let* ((str (symbol->string symbol))

(len (string-length str)))

- #|(if (regexp-match? #px"[[:alpha:]]+[[:alnum:]_]*$" str)

+ (if (eq? #f (pregexp-match "^[a-zA-Z]+[a-zA-Z0-9_]*$" str))

+ (error "write-symbol" "Syntax error, unexpected character.")

- (error "write-symbol: Syntax error, unexpected character."))|#

- (error "write-symbol: Length error, should be in range [0,255]"))))

+ (write-str outpr str)))

+ (error "write-symbol" "Length error, should be in range [0,255]"))))

-(define (write-list data)

+(define (write-list outpr data)

- ((andmap (lambda (x) (byte? x)) data)

- (write-2 (length data))

- (for-each (lambda (x) (write-1 x)) data))

- (write-4 (length data))

- (for-each (lambda (x) (write-any-raw x)) data)

+ ((map/and (lambda (x) (isbyte? x)) data)

+ (write-2 outpr (length data))

+ (for-each (lambda (x) (write-1 outpr x)) data))

+ (else (write-1 outpr LIST)

+ (write-4 outpr (length data))

+ (for-each (lambda (x) (write-any-raw outpr x)) data)

-(define (write-vector data)

+(define (write-vector outpr data)

(let ((len (vector-length data)))

+ (write-1 outpr SMALL_TUPLE)

+ (write-1 outpr LARGE_TUPLE)

(let vector-do ((position 0))

- (write-any-raw (vector-ref data position))

+ (write-any-raw outpr (vector-ref data position))

(vector-do (+ position 1)))))))

-(define (write-fixnum num)

+ (and (integer? x) (> x 0) (< x 256)))

+(define (write-fixnum outpr num)

+ (write-1 outpr SMALL_INT)

((and (<= num MAX_INT) (>= num MIN_INT))

- (else (write-bignum num))))

+ (else (write-bignum outpr num))))

-(define (write-bignum num)

- (let ((n (ceiling (/ (integer-length num) 8))))

+(define (write-bignum outpr num)

+ (let ((n (ceiling (/ (bitwise-length num) 8)))) bitwise-length

+ (write-1 outpr SMALL_BIGNUM)

- (write-bignum-guts num)))

+ (write-1 outpr LARGE_BIGNUM)

+ (write-bignum-guts outpr num)))

-(define (write-bignum-guts num)

+(define (write-bignum-guts outpr num)

+ (let wr-b ((absnum (abs num)))

- (write-1 (modulo num 256))

- (wr-b (arithmetic-shift num -8)))))

+ (write-1 outpr (mod absnum 256))

+ (wr-b (bitwise-arithmetic-shift-right absnum 8))))))

-(define (write-hash hash)

+(define (write-hash outpr hash)

+ (let-values (((a b) (hashtable-entries hash)))

- (lambda (k v) (vector (convert k) (convert v))))))))

+ (vector-map (lambda (k v) (vector (convert k) (convert v)))

-(define (write-any-raw obj)

+(define (write-any-raw outpr obj)

+ (write-list outpr obj))

+ (write-hash outpr obj))

+ (write-vector outpr obj))

+ (write-symbol outpr obj))

- (else (error "write-any-raw: Not implemented."))))

+ (write-fixnum outpr obj))

+ (else (error "write-any-raw" "Not implemented."))))

+(define (write-any outpr obj)

+ (write-any-raw outpr obj))

- (~~with-output-to-bytes~~ (lambda() (write-any (convert obj)))))

+ (call-with-bytevector-output-port (lambda(outpr) (write-any outpr (convert obj)))))

(define (encode-pretty obj)

- (byte~~s->~~list (encode obj)))

+ (bytevector->u8-list (encode obj)))

; {foo,42,666,{12,[],{255,'Bar'},111222333444555666}}

- (encode (vector 'foo 42 666 (vector 12 '() (vector 255 'bar) 111222333444555666)))

- (bytes 131 104 4 100 0 3 102 111 111 97 42 98 0 0 2 154 104 4 97 12 106 104 2 97 255 100 0 3 98 97 114 110 8 0 146 131 13 124 31 36 139 1)))

+ (if (equal? (encode (vector 'foo 42 666 (vector 12 '() (vector 255 'bar) 111222333444555666))) (u8-list->bytevector '(131 104 4 100 0 3 102 111 111 97 42 98 0 0 2 154 104 4 97 12 106 104 2 97 255 100 0 3 98 97 114 110 8 0 146 131 13 124 31 36 139 1)))

+ (error "test-1" "failed")))

; {bert,dict,[{one,1},{two,2},{three,3}]}

- (encode (hash 'one 1 'two 2 'three 3))

- (bytes 131 104 4 100 0 3 102 111 111 97 42 98 0 0 2 154 104 4 97 12 106 104 2 97 255 100 0 3 98 97 114 110 8 0 146 131 13 124 31 36 139 1)))

+ (let ((h (make-eqv-hashtable)))

+ (hashtable-set! h 1 'one)

+ (hashtable-set! h 2 'two)

+ (hashtable-set! h 3 'three)

+ (if (equal? (encode h) (u8-list->bytevector '(131 104 4 100 0 3 102 111 111 97 42 98 0 0 2 154 104 4 97 12 106 104 2 97 255 100 0 3 98 97 114 110 8 0 146 131 13 124 31 36 139 1)))

+ (error "test-2" "failed"))))

+ (and (test-1) (test-2)))