Commits

Yasir M. Arsanukaev  committed a5073aa

Initial commit.

  • Participants

Comments (0)

Files changed (3)

+Copyright 2010 Yasir M. Arsanukaev. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are
+permitted provided that the following conditions are met:
+
+   1. Redistributions of source code must retain the above copyright notice, this list of
+      conditions and the following disclaimer.
+
+   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 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.
+(module encode scheme 
+  ;(require scheme/tcp)
+  ;(require scheme/mpair)
+  (require rnrs/bytevectors-6)
+  (require rnrs/io/ports-6)
+  
+  (require "types.ss")
+  
+  (define (write-1 outpr byte)
+    (put-u8 outpr byte))
+  
+  (define (write-2 outpr short)
+    (put-bytevector outpr (integer->integer-bytes short 2 #t #t)))
+  
+  (define (write-4 outpr long)
+    (put-bytevector outpr (integer->integer-bytes long 4 #t #t)))
+  
+  (define (write-list outpr data)
+    (cond
+      [(empty? data)
+       (write-1 outpr NIL)]
+      [(andmap (lambda (x) (byte? 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-fixnum outpr num)
+    (cond
+      [(byte? 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 (/ (integer-length num) 8))])
+      (if (< n 256)
+          (begin
+            (write-1 outpr SMALL_BIGNUM)
+            (write-1 outpr n))
+          (begin
+            (write-1 outpr LARGE_BIGNUM)
+            (write-4 n)))
+      (write-bignum-guts outpr num)))
+  
+  (define (write-bignum-guts outpr num)
+    (define (wr-b num)
+      (if (zero? num)
+          'ok
+          (begin
+            (write-1 outpr (modulo num 256))
+            (wr-bn (arithmetic-shift num -8)))))   
+    (if (num . < . 0)
+        (write-1 outpr 1)
+        (write-1 outpr 0))
+    (wr-b (abs num))
+    )
+  
+  (define (write-any-raw outpr obj)
+    (cond
+      [(list? obj)
+       (write-list outpr obj)]
+      [(integer? obj)
+       (write-fixnum outpr obj)]
+      [else (error "write-any-raw: Not implemented.\n")]))
+  
+  (define (write-any obj)
+    (let-values ([(outpr extr-proc) (open-bytevector-output-port)])
+      (write-1 outpr MAGIC)
+      (write-any-raw outpr obj)
+      (bytevector->u8-list (extr-proc)))))
+(module types scheme
+        (provide 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
+                 )
+        (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 (- (arithmetic-shift 1 27) 1))
+        (define MIN_INT (- (arithmetic-shift 1 27)))
+        )
+