Anonymous avatar Anonymous committed 60c1846

Code rewritten to conform to the R^6RS.

Comments (0)

Files changed (1)

 #!r6rs
 
-(import (rnrs))
+(import (mzlib pregexp)
+        (rnrs base) 
+        (rnrs bytevectors) 
+        (rnrs lists) 
+        (rnrs hashtables)
+        (rnrs mutable-pairs)
+        (rnrs io ports)
+        (rnrs control)
+        (rnrs arithmetic bitwise))
 
 (define SMALL_INT 97)
 (define INT 98)
 (define MAX_INT 134217727)
 (define MIN_INT -134217728)
 
-(define (write-1 byte)
-  (write-byte byte))
+(define (map/and proc lst)
+  (cond
+    ((null? lst)
+     #t)
+    ((proc (car lst))
+     (map/and proc (cdr lst)))
+    (else
+     #f)))
 
-(define (write-2 short)
-  (write-bytes (integer->integer-bytes short 2 #t #t)))
+(define (write-1 outpr byte)
+  (put-u8 outpr byte))
 
-(define (write-4 long)
-  (write-bytes (integer->integer-bytes long 4 #t #t)))
+(define (write-2 outpr short)
+  (put-u8 outpr (bitwise-arithmetic-shift-right short 8))
+  (put-u8 outpr (bitwise-and short #xff)))
 
-(define (write-symbol symbol)
+(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-str outpr str)
+  (put-bytevector outpr (string->bytevector str (native-transcoder))))
+
+(define (write-symbol outpr symbol)
   (let* ((str (symbol->string symbol))
          (len (string-length str)))
-    (if (byte? len)
-        #|(if (regexp-match? #px"[[:alpha:]]+[[:alnum:]_]*$" 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 ATOM)
-              (write-2 len)
-              (write-string str))
-            (error "write-symbol: Syntax error, unexpected character."))|#
-        42
-        (error "write-symbol: Length error, should be in range [0,255]"))))
+              (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 data)
+(define (write-list outpr data)
   (cond
-    ((empty? data)
-     (write-1 NIL))
-    ((andmap (lambda (x) (byte? x)) data)
-     (write-1 STRING)
-     (write-2 (length data))
-     (for-each (lambda (x) (write-1 x)) data))
-    (else (write-1 LIST)
-          (write-4 (length data))
-          (for-each (lambda (x) (write-any-raw x)) data)
-          (write-1 NIL))))
+    ((null? data)
+     (write-1 outpr NIL))
+    ((map/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-vector data)
+(define (write-vector outpr data)
   (let ((len (vector-length data)))
     (if (< len 256)
         (begin
-          (write-1 SMALL_TUPLE)
-          (write-1 len))
+          (write-1 outpr SMALL_TUPLE)
+          (write-1 outpr len))
         (begin
-          (write-1 LARGE_TUPLE)
-          (write-4 len)))
+          (write-1 outpr LARGE_TUPLE)
+          (write-4 outpr len)))
     (let vector-do ((position 0))
       (unless (= position len)
         (begin
-          (write-any-raw (vector-ref data position))
+          (write-any-raw outpr (vector-ref data position))
           (vector-do (+ position 1)))))))
 
-(define (write-fixnum num)
+(define (isbyte? x)
+  (and (integer? x) (> x 0) (< x 256)))
+
+(define (write-fixnum outpr num)
   (cond
-    ((byte? num)
-     (write-1 SMALL_INT)
-     (write-1 num))
+    ((isbyte? num)
+     (write-1 outpr SMALL_INT)
+     (write-1 outpr num))
     ((and (<= num MAX_INT) (>= num MIN_INT))
-     (write-1 INT)
-     (write-4 num))
-    (else (write-bignum num))))
+     (write-1 outpr INT)
+     (write-4 outpr num))
+    (else (write-bignum outpr num))))
 
-(define (write-bignum num)
-  (let ((n (ceiling (/ (integer-length num) 8))))
+
+(define (write-bignum outpr num)
+  (let ((n (ceiling (/ (bitwise-length num) 8)))) bitwise-length
     (if (< n 256)
         (begin
-          (write-1 SMALL_BIGNUM)
-          (write-1 n))
+          (write-1 outpr SMALL_BIGNUM)
+          (write-1 outpr n))
         (begin
-          (write-1 LARGE_BIGNUM)
-          (write-4 n)))
-    (write-bignum-guts num)))
+          (write-1 outpr LARGE_BIGNUM)
+          (write-4 outpr n)))
+    (write-bignum-guts outpr num)))
 
-(define (write-bignum-guts num)
-  (define (wr-b num)
-    (unless (zero? 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 (modulo num 256))
-        (wr-b (arithmetic-shift num -8)))))
-  (if (< num 0)
-      (write-1 1)
-      (write-1 0))
-  (wr-b (abs num)))
+        (write-1 outpr (mod absnum 256))
+        (wr-b (bitwise-arithmetic-shift-right absnum 8))))))
 
-(define (write-hash hash)
+
+(define (write-hash outpr hash)
+  (let-values (((a b) (hashtable-entries hash)))
   (write-any-raw 
+   outpr
    (vector
     'bert       
     'dict 
-    (reverse (hash-map
-              hash
-              (lambda (k v) (vector (convert k) (convert v))))))))
+    (vector-map (lambda (k v) (vector (convert k) (convert v)))
+                a
+                b)))))
 
-(define (write-any-raw obj)
+
+(define (write-any-raw outpr obj)
   (cond
-    ((hash? obj)
-     (write-hash obj))
+    ((list? obj)
+     (write-list outpr obj))
+    ((hashtable? obj)
+     (write-hash outpr obj))
+    ((vector? obj)
+     (write-vector outpr obj))
     ((symbol? obj)
-     (write-symbol obj))
-    ((list? obj)
-     (write-list obj))
+     (write-symbol outpr obj))
     ((integer? obj)
-     (write-fixnum obj))
-    ((vector? obj)
-     (write-vector obj))
-    (else (error "write-any-raw: Not implemented."))))
+     (write-fixnum outpr obj))
+    (else (error "write-any-raw" "Not implemented."))))
 
-(define (write-any obj)
-  (write-1 MAGIC)
-  (write-any-raw obj))
+(define (write-any outpr obj)
+  (write-1 outpr MAGIC)
+  (write-any-raw outpr obj))
 
 (define (convert obj)
   (cond
      (vector 'bert 'true))
     ((eq? obj #f)
      (vector 'bert 'false))
-    ((void? obj)
-     (vector 'bert 'nil))
+    #|((void? obj)
+     (vector 'bert 'nil))|#
     (else obj)))
 
 (define (encode obj)
-  (with-output-to-bytes (lambda() (write-any (convert obj)))))
+  (call-with-bytevector-output-port (lambda(outpr) (write-any outpr (convert obj)))))
 
 (define (encode-pretty obj)
-  (bytes->list (encode obj)))
+  (bytevector->u8-list (encode obj)))
 
 (define (test-1)
   ; {foo,42,666,{12,[],{255,'Bar'},111222333444555666}}
-  (equal?
-   (encode (vector 'foo 42 666 (vector 12 '() (vector 255 'bar) 111222333444555666)))
-   (bytes 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)))
+  (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
+      (error "test-1" "failed")))
 
 (define (test-2)
   ; {bert,dict,[{one,1},{two,2},{three,3}]}
-  (equal?
-   (encode (hash 'one 1 'two 2 'three 3))
-   (bytes 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)))
+  (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 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
+        (error "test-2" "failed"))))
 
 (define (tests)
-  (test-1))
+  (and (test-1) (test-2)))
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.