Commits

Anonymous committed 96d2edc

Rewrite byte reading functions, implement bignum, float decoding.

  • Participants
  • Parent commits 93504fa

Comments (0)

Files changed (1)

File src/scheme-bert.ss

          (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)))         
                      (cons (car lst) 
                            (recur (cdr lst) (- k 1)))))))|#
          
+         (define (dropwhile proc list)
+           (let recur ((proc proc)
+                       (list list)
+                       (acc '()))
+             (if (or (null? list) (not (proc (car list))))
+                 (reverse acc)
+                 (recur proc (cdr list) (cons (car list) acc)))))         
+         
          (define (fold/and proc lst)
            (cond
              ((null? lst)
              (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)
+           (write-1 outpr (if (< num 0) 1 0))     ; sign
+           (let wr-b ((numabs (abs num)))
+             (unless (zero? numabs)
                (begin
-                 (write-1 outpr (mod absnum 256))
-                 (wr-b (bsr absnum 8))))))         
+                 (write-1 outpr (mod numabs 256))
+                 (wr-b (bsr numabs 8))))))         
          
          (define (write-hash outpr hash)
            (let-values (((a b) (hashtable-entries hash)))
            (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-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
            (read-any (open-bytevector-input-port bytes)))
          
          (define (read-any inp)
-           (if (eq? (read-1 inp) MAGIC)
+           (if (eq? (read-small-int inp) MAGIC)
                (read-any-raw inp)
                (error "read-any" "Bad Magic")))
          
          (define (read-any-raw inp)
-           (let ((tag (read-1 inp)))
+           (let ((tag (read-small-int inp)))
              (cond
                ((eq? tag ATOM) (read-atom inp))
                ((eq? tag SMALL_INT) (read-small-int inp))
                ((eq? tag INT) (read-int inp))
+               ((eq? tag SMALL_BIGNUM) (read-bignum-t inp 'small))               
+               ((eq? tag LARGE_BIGNUM) (read-bignum-t inp 'large))
+               ((eq? tag FLOAT) (read-float inp))               
                (else
                 (error "read-any-raw"
                        (string-append 
                         "Unknown term tag: "
                         (number->string tag)))))))
          
+         (define (read-n inp len)
+           (get-bytevector-n inp len))
+         
          (define (read-1 inp)
-           (get-u8 inp))
+           (read-n inp 1))
          
          (define (read-2 inp)
-           (bor (bsl (get-u8 inp) 8)
-                (get-u8 inp)))
+           (read-n inp 2))
          
          (define (read-4 inp)
-           (bytevector-s32-ref (get-bytevector-n inp 4) 0 (endianness big)))
+           (read-n inp 4))
+         
+         (define (read-short inp)
+           (bytevector-u16-ref (read-2 inp) 0 (endianness big)))
          
          (define (read-str inp length)
-           (bytevector->string (get-bytevector-n inp length) 
+           (bytevector->string (read-n inp length) 
                                (native-transcoder)))
          
          (define (read-atom inp)
-           (let ((len (read-2 inp)))
+           (let ((len (read-short inp)))
              (string->symbol (read-str inp len))))
          
          (define (read-small-int inp)
-           (read-1 inp))
+           (bytevector-u8-ref (read-1 inp) 0))
          
          (define (read-int inp)
-           (read-4 inp))         
-         )
+           (bytevector-s32-ref (read-4 inp) 0 (endianness big)))
+         
+         (define (read-bignum-t inp type)
+           (let* ((size (if (eq? type 'small) 
+                            (read-small-int inp)
+                            (read-int inp)))
+                  (sign (read-small-int inp))
+                  (bytes (bytevector->u8-list (read-n inp size))))
+             (let recur ((i 0)
+                         (bytes bytes)
+                         (sum 0))
+               (if (null? bytes)
+                   (if (zero? sign) sum (- sum))
+                   (recur (+ i 1) (cdr bytes)
+                     (+ sum (* (car bytes) (expt 256 i))))))))        
+         
+         (define (read-float inp)      
+           (string->number 
+            (bytevector->string 
+             (u8-list->bytevector                    
+              (dropwhile (lambda(x) (> x 0)) 
+                         (bytevector->u8-list (read-n inp 31))))
+             (native-transcoder)))))