Commits

Yasir M. Arsanukaev  committed 703a68a

Implement float encoding. Erroneous import rename fix.

  • Participants
  • Parent commits 3de04e6

Comments (0)

Files changed (1)

File 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)
+           (put-u8 outpr (bsr long 24))
+           (put-u8 outpr (band #xff (bsr long 16)))
+           (put-u8 outpr (band #xff (bsr long 8)))
+           (put-u8 outpr (band 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-float outpr float)
+           (write-1 outpr FLOAT)
+           (let* ((strdigits (fldigits float))
+                  (len (string-length strdigits)))
+             (write-str outpr strdigits)
+             (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 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 (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 0)
+                         "e-"
+                         "e+")))
+             (string-append (substring s 0 1) "." s0 e 
+                            (number->string (abs (- place 1))))))
+         
+         (define (insert-decimal place s)
+           (cond ((zero? place)
+                  (string-append "0." s))
+                 ((> place 0)
+                  (let* ((len (string-length s))
+                         (n (- place len)))
+                    (cond ((zero? n)
+                           (string-append s ".0"))
+                          ((< n 0)
+                           (string-append (substring s 0 (+ len n))
+                                          "."
+                                          (substring s (+ len n))))
+                          ((< n 6)
+                           (string-append (make-string n #\0) ".0"))
+                          (else (insert-decimal-exp place s)))))
+                 ((> place -6)
+                  (string-append "0." (make-string (abs place) #\0) s))
+                 (else (insert-decimal-exp place s))))
+         
+         (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))
+                      (res (map (lambda(x)(integer->char (+ x #x30))) digits))
+                      (strdigits (list->string res)))
+                 (string-append (if (< float 0) "-" "")
+                                ;(insert-decimal place strdigits)))))
+                                (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))))
+         
+         
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         ;; Test cases
+         
+         (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
+               (display "test-1: failed\n")))
+         
+         (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
+                 (display "test-2: failed\n"))))
+         
+         (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
+               (display "test-3: failed\n")))
+         
+         (define (test)
+           (if (and (test-1) (test-2) (test-3))
+               (display "test: OK. All tests passed successfully.")
+               (display "test: Error. Some tests failed."))
+           (newline)))