scheme-bert / src / scheme-bert.ss

#!r6rs
(library (scheme-bert)
         (export encode)
         (import (rnrs base) 
                 (rnrs bytevectors) 
                 (rnrs lists) 
                 (rnrs hashtables)
                 (rnrs mutable-pairs)
                 (rnrs io ports)
                 (rnrs io simple)
                 (rnrs control)
                 (rename 
                  (rnrs arithmetic bitwise) 
                  (bitwise-and band)
                  (bitwise-arithmetic-shift-left bsl)
                  (bitwise-arithmetic-shift-right bsr)
                  (bitwise-ior bor))
                 (rnrs arithmetic fixnums)                 
                 (rnrs arithmetic flonums)
                 (rnrs r5rs)
                 ;; see TODO
                 (mzlib pregexp)
                 (srfi :19))
         
         ;; Erlang external term format types
         (define SMALL_INT 97)
         (define INT 98)
         (define SMALL_BIGNUM 110)
         (define LARGE_BIGNUM 111)
         (define FLOAT 99)
         (define ATOM 100)
         (define SMALL_TUPLE 104)
         (define LARGE_TUPLE 105)
         (define NIL 106)
         (define STRING 107)
         (define LIST 108)
         (define BIN 109)
         (define FUN 117)
         (define NEW_FUN 112)
         (define MAGIC 131)
         (define MAX_INT (- (bsl 1 27) 1))
         (define MIN_INT (- (bsl 1 27)))         
         
         ;; take returns the first k elements of list lst.
         ;; It is not an error for k to exceed the length of the list -- 
         ;; in that case the whole list is returned. 
         #|(define (take lst k)
           (let recur ((lst lst)
                       (k k))
             (if (null? lst) '()
                 (if (zero? k) '()
                     (cons (car lst) 
                           (recur (cdr lst) (- k 1)))))))|#
         
         (define (fold/and proc lst)
           (cond
             ((null? lst)
              #t)
             ((proc (car lst))
              (fold/and proc (cdr lst)))
             (else #f)))
         
         (define (write-1 outpr byte)
           (put-u8 outpr byte))
         
         (define (write-2 outpr short)
           (put-u8 outpr (bsr short 8))
           (put-u8 outpr (band short #xff)))
         
         (define (write-4 outpr long)         
           (let ((b (make-bytevector 4)))
             (bytevector-s32-set! b 0 long (endianness big))
             (put-bytevector outpr b)))         
         
         (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-float outpr float)
           (write-1 outpr FLOAT)
           (let* ((str (fldigits float))
                  (len (string-length str)))
             (write-str outpr str)
             (let pad ((x (- 31 len)))
               (if (zero? x) '()
                   (begin
                     (write-1 outpr 0)
                     (pad (- x 1)))))))                  
         
         (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))
             ((fold/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 MIN_INT) (<= num MAX_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 (bsr 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))
             ((flonum? obj)  ;; should be before integer? test
              (write-float 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)))         
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Floating-point processing routines
         
         ;; funpack unpacks and returns double-precision 64 bit
         ;; IEEE-754 float's sign, exponent and fraction
         (define (funpack float)
           (let ((b (make-bytevector 8)))
             (bytevector-ieee-double-native-set! b 0 float)
             (values
              (bitwise-bit-field (bytevector-u64-native-ref b 0) 63 64)
              (bitwise-bit-field (bytevector-u64-native-ref b 0) 52 63)
              (bitwise-bit-field (bytevector-u64-native-ref b 0)  0 52))))
         
         ;; frexp is analogous to frexp(1) found in C
         (define (frexp float)
           (let ((FLOAT_BIAS 1022))
             (define (frac1 sign expon frac)
               (let ((b (make-bytevector 8)))
                 (bytevector-u64-native-set! b 0
                                             (bor (bsl (bor (bsl sign 11) FLOAT_BIAS) 52) frac))
                 (bytevector-ieee-double-native-ref b 0)))
             (let-values (((sign expon frac) (funpack float)))
               (cond
                 ((fold/and zero? (list sign expon frac))
                  (values 0 0))
                 ((zero? expon)
                  (cons (frac1 sign exp (- frac 1))
                        (+ (- (- FLOAT_BIAS) 52) (bitwise-length frac))))
                 (else 
                  (cons (frac1 sign expon frac) 
                        (- expon FLOAT_BIAS)))))))
         
         (define (insert-decimal-exp place s)
           (let* ((s0 (if (= (string-length s) 1) "0"
                          (substring s 1)))
                  (e  (if (< place 1) "e-" "e+"))
                  (t (- 20 (string-length s0)))
                  (s1 (if (not (zero? t))
                          (string-append s0 (make-string t #\0))
                          s0)))
             (string-append (substring s 0 1) "." s1 e 
                            (number->string (abs (- place 1))))))
         
         (define (fldigits float)
           (if (zero? float)
               "0.0"
               (let* ((frexpres (frexp float))
                      (f (car frexpres))
                      (e (cdr frexpres))
                      (e1 (- e 53))
                      (f1 (exact (truncate (* (abs f) (bsl 1 53)))))
                      (fdig (flonum->digits float f1 e1))
                      (place (car fdig))
                      (digits (cdr fdig))
                      (r (map (lambda(x)(integer->char (+ x #x30))) digits))
                      (strdigits (list->string r)))
                 (string-append (if (< float 0) "-" "")                                
                                (insert-decimal-exp place strdigits)))))
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; These are routines from
         ;;  "Printing Floating-Point Numbers Quickly and Accurately"
         ;; by Robert G. Burger and R. Kent Dybvig.
         ;; Refer to http://www.cs.indiana.edu/~burger/fp/index.html
         
         (define flonum->digits
           (let ([min-e -1074]
                 [bp-1 (expt 2 52)])
             (lambda (v f e)
               (let ([round? (even? f)])
                 (if (>= e 0)
                     (if (not (= f bp-1))
                         (let ([be (expt 2 e)])
                           (scale (* f be 2) 2 be be 0 round? round? v))
                         (let ([be (expt 2 e)])
                           (scale (* f be 4) 4 (* be 2) be 0 round? round? v)))
                     (if (or (= e min-e) (not (= f bp-1)))
                         (scale (* f 2) (expt 2 (- 1 e)) 1 1 0 round? round? v)
                         (scale (* f 4) (expt 2 (- 2 e)) 2 1 0 
                                round? round? v)))))))
         
         (define scale
           (lambda (r s m+ m- k low-ok? high-ok? v)
             (newline)
             (let ([est (exact (ceiling (- (log10 (abs v)) 1e-10)))])
               (if (>= est 0)
                   (fixup r (* s (expt10 est)) m+ m- est low-ok? high-ok?)
                   (let ([scale (expt10 (- est))])
                     (fixup (* r scale) s (* m+ scale) (* m- scale)
                            est low-ok? high-ok?))))))
         
         (define fixup
           (lambda (r s m+ m- k low-ok? high-ok?)
             (if ((if high-ok? >= >) (+ r m+) s) ; too low?
                 (cons (+ k 1) (generate r s m+ m- low-ok? high-ok?))
                 (cons k
                       (generate (* r 10) s (* m+ 10) 
                                 (* m- 10) low-ok? high-ok?)))))
         
         (define generate
           (lambda (r s m+ m- low-ok? high-ok?)
             (let ([d (quotient r s)]
                   [r (remainder r s)])
               (let ([tc1 ((if low-ok? <= <) r m-)]
                     [tc2 ((if high-ok? >= >) (+ r m+) s)])
                 (if (not tc1)
                     (if (not tc2)
                         (cons d (generate (* r 10) s (* m+ 10) (* m- 10)
                                           low-ok? high-ok?))
                         (list (+ d 1)))
                     (if (not tc2)
                         (list d)
                         (if (< (* r 2) s) (list d) (list (+ d 1)))))))))
         
         (define expt10
           (let ([table (make-vector 326)])
             (do ([k 0 (+ k 1)] [v 1 (* v 10)])
               ((= k 326))
               (vector-set! table k v))
             (lambda (k)
               (vector-ref table k))))
         
         (define log10
           (let ([f (/ (log 10))])
             (lambda (x)
               (* (log x) f))))
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Decoder part
         
         (define (decode bytes)
           (read-any (open-bytevector-input-port bytes)))
         
         (define (read-any inp)
           (if (eq? (read-1 inp) MAGIC)
               (read-any-raw inp)
               (error "read-any" "Bad Magic")))
         
         (define (read-any-raw inp)
           (let ((tag (read-1 inp)))
             (cond
               ((eq? tag ATOM) (read-atom inp))
               ((eq? tag SMALL_INT) (read-small-int inp))
               ((eq? tag INT) (read-int inp))
               (else
                (error "read-any-raw"
                       (string-append 
                        "Unknown term tag: "
                        (number->string tag)))))))
         
         (define (read-1 inp)
           (get-u8 inp))
         
         (define (read-2 inp)
           (bor (bsl (get-u8 inp) 8)
                (get-u8 inp)))
         
         (define (read-4 inp)
           (bytevector-s32-ref (get-bytevector-n inp 4) 0 (endianness big)))
         
         (define (read-str inp length)
           (bytevector->string (get-bytevector-n inp length) 
                               (native-transcoder)))
         
         (define (read-atom inp)
           (let ((len (read-2 inp)))
             (string->symbol (read-str inp len))))
         
         (define (read-small-int inp)
           (read-1 inp))
         
         (define (read-int inp)
           (read-4 inp))         
         )
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.