Commits

Yasir M. Arsanukaev  committed 3de04e6

frexp function extracting fraction and exponent implemented.

  • Participants
  • Parent commits d7f1d16

Comments (0)

Files changed (3)

File README.markdown

 
 See the BERT specification at [bert-rpc.org](http://bert-rpc.org).
 
-Instances of the following Scheme classes will be automatically converted to the
+Instances of the following Scheme types will be automatically converted to the
 proper simple BERT type:
 
 * `integer?` (fixnum and bignum)
 * `string?`
 * `vector?`
 
-Instances of the following Scheme classes will be automatically converted to the
+Instances of the following Scheme types will be automatically converted to the
 proper complex BERT type:
 
 * `'nil`
 * `hashtable?`
 * `time?`
 
-TODO
-----
-Implement encoding of these objects:
-
-* `flonum?`
-* `pregexp?`
-
 
 Installation
 ------------

File src/encode.ss

                  (rnrs io ports)
                  (rnrs io simple)
                  (rnrs control)
-                 (rnrs arithmetic bitwise)
+                 (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 FUN 117)
          (define NEW_FUN 112)
          (define MAGIC 131)
-         (define MAX_INT (- (bitwise-arithmetic-shift 1 27) 1))
-         (define MIN_INT (- (bitwise-arithmetic-shift 1 27)))
-
-(define (unpack float)
-  (let ((b (make-bytevector 8)))
-    (bytevector-ieee-double-native-set! b 0 float)
-    (values
-     (bitwise-bit-set? (bytevector-u8-ref b 7) 7)
-     (bitwise-bit-field (bytevector-u16-native-ref b 6) 4 15)
-     (bitwise-bit-field (bytevector-u64-native-ref b 0) 0 52))))
-
-(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 (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-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 (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))
-    ((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)))
-
-(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)))
+         (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/erl-ext-types.ss

-#!r6rs
-
-(library (erl-ext-types)
-         (export SMALL_INT
-                 INT
-                 SMALL_BIGNUM
-                 LARGE_BIGNUM
-                 FLOAT
-                 ATOM
-                 SMALL_TUPLE
-                 LARGE_TUPLE
-                 NIL
-                 STRING
-                 LIST
-                 BIN
-                 FUN
-                 NEW_FUN
-                 MAGIC
-                 MAX_INT
-                 MIN_INT)
-         
-         (import (rnrs base)
-                 (rnrs arithmetic bitwise))
-         
-         (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 (- (bitwise-arithmetic-shift 1 27) 1))
-         (define MIN_INT (- (bitwise-arithmetic-shift 1 27))))
-