Commits

Yasir M. Arsanukaev  committed f9e4cab

Use "%.20e" format and fix bug in deicmal place output during flonum? encoding.

  • Participants
  • Parent commits 703a68a

Comments (0)

Files changed (3)

File README.markdown

 Instances of the following Scheme types will be automatically converted to the
 proper simple BERT type:
 
+* `flonum?`
 * `integer?` (fixnum and bignum)
 * `symbol?`
 * `list?`

File src/encode.ss

-#!r6rs
-(library (encode)
-         (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-left bsr)
-                  (bitwise-ior bor))
-                 (rnrs arithmetic flonums)
-                 ;; TODO: modify according to Scheme implementation
-                 (mzlib pregexp)
-                 (srfi :19))
-         
-         (define FLOAT_BIAS 1022)
-         ;; 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)))
-         
-               
-         (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)
-           42
-           )
-         
-         (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))
-             ((integer? obj)
-              (write-fixnum outpr obj))
-             ((string? obj)
-              (write-binary outpr obj))
-             ((flonum? obj)
-              (write-float 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)))
-         
-         
-         
-         ; Return: sign, exponent, fraction         
-         (define (unpack 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))))
-         
-         (define (frac1 sign exp 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)))
-         
-         (define (frexp float)
-           (let-values (((sign exp frac) (unpack float)))
-             (cond
-               ((fold/and zero? (list sign exp frac))
-                (values 0 0))
-               ((zero? exp)
-                (values (frac1 sign exp (- frac 1))
-                        (+ (- (- FLOAT_BIAS) 52) (bitwise-length frac))))
-               (else 
-                (values (frac1 sign exp frac) 
-                        (- exp FLOAT_BIAS))))))
-         
-         
-         
-         
-;;;;;;; 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)))

File src/scheme-bert.ss

          
          (define (write-float outpr float)
            (write-1 outpr FLOAT)
-           (let* ((strdigits (fldigits float))
-                  (len (string-length strdigits)))
-             (write-str outpr strdigits)
+           (let* ((str (fldigits float))
+                  (len (string-length str)))
+             (write-str outpr str)
              (let pad ((x (- 31 len)))
-               (if (zero? x)
-                   '()
+               (if (zero? x) '()
                    (begin
                      (write-1 outpr 0)
                      (pad (- x 1)))))))                  
            (let ((FLOAT_BIAS 1022))
              (define (frac1 sign expon frac)
                (let ((b (make-bytevector 8)))
-                 (bytevector-u64-native-set!
-                  b
-                  0
+                 (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)))
                         (- expon FLOAT_BIAS)))))))
          
          (define (insert-decimal-exp place s)
-           (let ((s0 (if (= (string-length s) 1)
-                         "0"
+           (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 
+                 (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 (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"
                       (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)))))
+                 (string-append (if (< float 0) "-" "")                                
                                 (insert-decimal-exp place strdigits)))))
          
          ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;