Source

scheme-bert / src / encode.ss

#!r6rs

(import (rnrs base) 
        (rnrs bytevectors) 
        (rnrs lists) 
        (rnrs hashtables)
        (rnrs mutable-pairs)
        (rnrs io ports)
        (rnrs control)
        (rnrs arithmetic bitwise)
        (rnrs arithmetic flonums)
        (mzlib pregexp)
        (erl-ext-types)
        (srfi :19))


(define (map/and proc lst)
  (cond
    ((null? lst)
     #t)
    ((proc (car lst))
     (map/and proc (cdr lst)))
    (else
     #f)))

(define (write-1 outpr byte)
  (put-u8 outpr byte))

(define (write-2 outpr short)
  (put-u8 outpr (bitwise-arithmetic-shift-right short 8))
  (put-u8 outpr (bitwise-and short #xff)))

(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-binary outpr data)
  (write-1 outpr BIN)
  (let ((b (string->bytevector data (native-transcoder))))
    (write-4 outpr (bytevector-length b))
    (put-bytevector outpr b)))

(define (write-str outpr str)
  (put-bytevector outpr (string->bytevector str (native-transcoder))))

(define (write-atom outpr symbol)
  (let* ((str (symbol->string symbol))
         (len (string-length str)))
    (if (< len 256)
        (if (eq? #f (pregexp-match "^[a-zA-Z]+[a-zA-Z0-9_]*$" str))
            (error "write-symbol" "Syntax error, unexpected character.")
            (begin
              (write-1 outpr ATOM)
              (write-2 outpr len)
              (write-str outpr str)))
        (error "write-symbol" "Length error, should be in range [0,255]"))))


(define (write-list outpr data)
  (cond
    ((null? data)
     (write-1 outpr NIL))
    ((map/and (lambda (x) (isbyte? x)) data)
     (write-1 outpr STRING)
     (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)
          (write-1 outpr NIL))))

(define (write-tuple outpr data)
  (let ((len (vector-length data)))
    (if (< len 256)
        (begin
          (write-1 outpr SMALL_TUPLE)
          (write-1 outpr len))
        (begin
          (write-1 outpr LARGE_TUPLE)
          (write-4 outpr len)))
    (let vector-do ((position 0))
      (unless (= position len)
        (begin
          (write-any-raw outpr (vector-ref data position))
          (vector-do (+ position 1)))))))

(define (isbyte? x)
  (and (integer? x) (> x 0) (< x 256)))

(define (write-fixnum outpr num)
  (cond
    ((isbyte? num)
     (write-1 outpr SMALL_INT)
     (write-1 outpr num))
    ((and (<= num MAX_INT) (>= num MIN_INT))
     (write-1 outpr INT)
     (write-4 outpr num))
    (else (write-bignum outpr num))))


(define (write-bignum outpr num)
  (let ((n (ceiling (/ (bitwise-length num) 8)))) bitwise-length
    (if (< n 256)
        (begin
          (write-1 outpr SMALL_BIGNUM)
          (write-1 outpr n))
        (begin
          (write-1 outpr LARGE_BIGNUM)
          (write-4 outpr n)))
    (write-bignum-guts outpr num)))

(define (write-bignum-guts outpr num)
  (if (< num 0)
      (write-1 outpr 1)
      (write-1 outpr 0))
  (let wr-b ((absnum (abs num)))
    (unless (zero? absnum)
      (begin
        (write-1 outpr (mod absnum 256))
        (wr-b (bitwise-arithmetic-shift-right absnum 8))))))


(define (write-hash outpr hash)
  (let-values (((a b) (hashtable-entries hash)))
    (write-any-raw 
     outpr
     (vector 'bert
             'dict
             (vector->list
              (vector-map (lambda (k v) (vector (convert k) (convert v)))
                          a
                          b))))))


(define (write-any-raw outpr obj)
  (cond
    ((list? obj)
     (write-list outpr obj))
    ((hashtable? obj)
     (write-hash outpr obj))
    ((vector? obj)
     (write-tuple outpr obj))
    ((symbol? obj)
     (write-atom outpr obj))
    ((integer? obj)
     (write-fixnum outpr obj))
    ((string? obj)
     (write-binary outpr obj))
    (else (error "write-any-raw" "Not implemented."))))

(define (write-any outpr obj)
  (write-1 outpr MAGIC)
  (write-any-raw outpr obj))

(define (convert obj)
  (cond
    ((eq? obj #t)
     (vector 'bert 'true))
    ((eq? obj #f)
     (vector 'bert 'false))
    ((eqv? obj 'nil)
     (vector 'bert 'nil))
    ((time? obj)
     (let ((t (time-second obj)))
       (vector 'bert 
               'time 
               (div t 1000000) 
               (mod t 1000000)
               (div (time-nanosecond obj) 1000))))
    (else obj)))

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

(define (encode-pretty obj)
  (bytevector->u8-list (encode obj)))

(define (test-1)
  ; {foo,42,666,{12,[],{255,'Bar'},111222333444555666}}
  (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)))
      #t
      (error "test-1" "failed")))

(define (test-2)
  ; {bert,dict,[{two,2},{one,1},{three,3}]}
  (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 3 100 0 4 98 101 114 116 100 0 4 100 105 99 116 108 0 0 0 3 104 2 97 2 100 0 3 116 119 111 104 2 97 1 100 0 3 111 110 101 104 2 97 3 100 0 5 116 104 114 101 101 106)))
        #t
        (error "test-2" "failed"))))

(define (test-3)
  ; {bert, time, erlang:now()}
  (if (equal? (encode (make-time time-utc 234389000 1281880551))
              (u8-list->bytevector '(131 104 5 100 0 4 98 101 114 116 100 0 4 116 105 109 101 98 0 0 5 1 98 0 13 111 167 98 0 3 147 149)))
      #t
      (error "test-3" "failed")))

(define (tests)
  (and (test-1) (test-2) (test-3)))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.