Commits

Yasir M. Arsanukaev  committed 1ab54a8

Implement decoding of tuple, dictionary, list, nil and binary.

  • Participants
  • Parent commits 96d2edc

Comments (0)

Files changed (2)

-Copyright 2010 Yasir M. Arsanukaev. All rights reserved.
+The 2-clause BSD license
 
-Redistribution and use in source and binary forms, with or without modification, are
-permitted provided that the following conditions are met:
+Copyright (c) 2010 Yasir M. Arsanukaev <yarsanukaev AT gmail DOT com> 
+All rights reserved.
 
-   1. Redistributions of source code must retain the above copyright notice, this list of
-      conditions and the following disclaimer.
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met:
 
-   2. Redistributions in binary form must reproduce the above copyright notice, this list
-      of conditions and the following disclaimer in the documentation and/or other materials
-      provided with the distribution.
+   1. Redistributions of source code must retain the above copyright notice, 
+      this list of conditions and the following disclaimer.
 
-THIS SOFTWARE IS PROVIDED BY Yasir M. Arsanukaev ``AS IS'' AND ANY EXPRESS OR IMPLIED
-WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Yasir M. Arsanukaev OR
-CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
-ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+   2. Redistributions in binary form must reproduce the above copyright
+      notice, this list of conditions and the following disclaimer in the
+      documentation and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

File src/scheme-bert.ss

          (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 (dropwhile proc list)
            (let recur ((proc proc)
                        (list list)
          
          (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))))))
+             (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
                ((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))               
+               ((eq? tag FLOAT) (read-float inp))
+               ((eq? tag SMALL_TUPLE) (read-tuple-t inp 'small))
+               ((eq? tag LARGE_TUPLE) (read-tuple-t inp 'large))
+               ((eq? tag NIL) (read-nil inp))
+               ((eq? tag STRING) (read-erl-string inp))               
+               ((eq? tag LIST) (read-list inp))
+               ((eq? tag BIN) (read-bin inp))
                (else
                 (error "read-any-raw"
                        (string-append 
              (u8-list->bytevector                    
               (dropwhile (lambda(x) (> x 0)) 
                          (bytevector->u8-list (read-n inp 31))))
-             (native-transcoder)))))
+             (native-transcoder))))
+         
+         (define (read-tuple-t inp type)
+           (let ((arity (if (eq? type 'small)
+                            (read-small-int inp)
+                            (read-int inp))))
+             (if (> arity 0)
+                 (let ((tag (read-any-raw inp)))
+                   (if (eq? tag 'bert)
+                       (read-complex-type inp arity)
+                       (let ((v (make-vector arity)))
+                         (vector-set! v 0 tag)
+                         (let recur ((n 1))
+                           (if (eq? n arity)
+                               v
+                               (begin
+                                 (vector-set! v n (read-any-raw inp))
+                                 (recur (+ n 1))))))))
+                 (vector))))
+         
+         (define (read-complex-type inp arity)
+           (let ((obj (read-any-raw inp)))
+             (cond
+               ((eq? obj 'nil)
+                'nil)
+               ((eq? obj 'true)
+                #t)
+               ((eq? obj 'false)
+                #f)
+               ((eq? obj 'time)
+                (let ((second (+ (* (read-any-raw inp) 1000000) 
+                                 (read-any-raw inp)))
+                      (nanosecond (* (read-any-raw inp) 1000)))
+                  (make-time time-utc nanosecond second)))
+               ((eq? obj 'dict)
+                (read-hash inp))
+               (else 42))))
+         
+         (define (read-hash inp)
+           (let ((keyvallst (read-any-raw inp))
+                 (h (make-eq-hashtable)))
+             (for-each (lambda (pair)
+                         (let ((k (vector-ref pair 0))
+                               (v (vector-ref pair 1)))
+                           (hashtable-set! h k v)))
+                       keyvallst)
+             h))
+         
+         (define (read-list inp)
+           (let ((len (read-int inp)))
+             (let recur ((i len)
+                         (lst '()))
+               (if (zero? i)
+                   (begin
+                     (read-1 inp)
+                     lst)
+                   (recur (- i 1) (cons (read-any-raw inp) lst))))))
+         
+         (define (read-nil inp)
+           '())   ; empty list
+         
+         (define (read-erl-string inp)
+           (read-str inp (read-short inp)))
+         
+         (define (read-bin inp)
+           (read-str inp (read-int inp)))
+         
+         )