From 0e93ac2db91f81febdf5806b997cc58e7a9fc679 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Sat, 8 Dec 2007 14:52:35 -0500
Subject: [PATCH] Code of fasl-write is changed to use only binary output
 prims.

---
 lab/io-spec.ss              | 89 ++++++++++++++++++++++++++++++-----
 lab/io-test.ss              |  9 +++-
 scheme/ikarus.fasl.write.ss | 92 +++++++++++++++++++------------------
 scheme/last-revision        |  2 +-
 4 files changed, 132 insertions(+), 60 deletions(-)

diff --git a/lab/io-spec.ss b/lab/io-spec.ss
index b2b36ed..995a06c 100644
--- a/lab/io-spec.ss
+++ b/lab/io-spec.ss
@@ -1,20 +1,51 @@
 
 (library (io-spec) 
+  
   (export 
-    input-port? textual-port? port-eof?
+    input-port? output-port? textual-port? binary-port?
+    open-file-input-port standard-input-port current-input-port
     open-bytevector-input-port
     open-string-input-port
     make-custom-binary-input-port 
-    get-char lookahead-char get-u8 lookahead-u8 close-port
-    transcoded-port)
+    transcoded-port port-transcoder
+    close-port
+    port-eof?
+    get-char lookahead-char 
+    get-string-n get-string-n! get-string-all get-line
+    get-u8 lookahead-u8 
+    get-bytevector-n get-bytevector-n!
+    get-bytevector-some get-bytevector-all 
+    port-has-port-position? port-position
+    port-has-set-port-position!? set-port-position!
+    call-with-port
+    )
+
+  
   (import 
     (except (ikarus)
-      input-port? textual-port? port-eof?
+      input-port? output-port? textual-port? binary-port? 
+      open-file-input-port standard-input-port current-input-port
       open-bytevector-input-port
       open-string-input-port
       make-custom-binary-input-port
-      get-char lookahead-char get-u8 lookahead-u8 close-port
-      transcoded-port))
+      transcoded-port port-transcoder
+      close-port
+      port-eof?
+      get-char lookahead-char
+      get-string-n get-string-n! get-string-all get-line
+      get-u8 lookahead-u8 
+      get-bytevector-n get-bytevector-n!
+      get-bytevector-some get-bytevector-all 
+      port-has-port-position? port-position
+      port-has-set-port-position!? set-port-position!
+      call-with-port
+      ))
+
+  (define-syntax define-rrr
+    (syntax-rules ()
+      [(_ name)
+       (define (name . args) 
+         (apply error 'name "not implemented" args))]))
 
   (define-struct $port 
     (index size buffer base-index transcoder closed? attrs 
@@ -150,6 +181,10 @@
         ($port-close p))))
 
 
+  (define (output-port? p) 
+    (and ($port? p) 
+         ($port-write! p)
+         #t))
 
   (define (input-port? p) 
     (and ($port? p) 
@@ -161,6 +196,16 @@
          ($port-transcoder p) 
          #t))
 
+  (define (binary-port? p) 
+    (and ($port? p)
+         (not ($port-transcoder p))))
+
+  (define (port-transcoder p)
+    (if ($port? p)
+        (let ([tr ($port-transcoder p)])
+          (and (transcoder? tr) tr))
+        (error 'port-transcoder "not a port" p)))
+              
   (define (close-port p)
     (cond
       [(not ($port? p)) 
@@ -174,11 +219,10 @@
          (when (procedure? close)
            (close)))]))
 
-  (define-syntax define-rrr
-    (syntax-rules ()
-      [(_ name)
-       (define (name . args) 
-         (apply error 'name "not implemented" args))]))
+  (define-rrr port-has-port-position?)
+  (define-rrr port-position)
+  (define-rrr port-has-set-port-position!?)
+  (define-rrr set-port-position!)
 
   ;;; ----------------------------------------------------------
   (module (get-char lookahead-char)
@@ -412,7 +456,6 @@
                        [else (get-char-utf8-mode p who)]))])]
                [else (do-error p who)]))])))
 
-
     (define (advance-utf8-bom p who)
       (let ([i ($port-index p)]
             [j ($port-size p)]
@@ -624,7 +667,29 @@
              (eof-object? (lookahead-u8 p)))]
         [else (error 'port-eof? "not an input port" p)])))
 
+  (define-rrr open-file-input-port)
+  (define-rrr standard-input-port)
+  (define-rrr current-input-port)
 
+  (define (call-with-port p proc)
+    (if ($port? p) 
+        (if (procedure? proc) 
+            (dynamic-wind
+              void
+              (lambda () (proc p))
+              (lambda () (close-port p)))
+            (error 'call-with-port "not a procedure" proc))
+        (error 'call-with-port "not a port" p)))
+
+
+  (define-rrr get-bytevector-n)
+  (define-rrr get-bytevector-n!)
+  (define-rrr get-bytevector-some)
+  (define-rrr get-bytevector-all)
+  (define-rrr get-string-n)
+  (define-rrr get-string-n!)
+  (define-rrr get-string-all)
+  (define-rrr get-line)
 
   )
 
diff --git a/lab/io-test.ss b/lab/io-test.ss
index ec61c12..c9b298e 100755
--- a/lab/io-test.ss
+++ b/lab/io-test.ss
@@ -1,8 +1,13 @@
 #!/usr/bin/env scheme-script
 
 (import 
-  (except (ikarus) get-char get-u8 lookahead-u8 close-port input-port?
-          open-string-input-port)
+
+  (except (ikarus) get-char get-u8 lookahead-u8 close-port
+          input-port? open-string-input-port output-port?
+          standard-input-port current-input-port
+          get-bytevector-n get-bytevector-n!
+          get-string-n get-string-n! get-line)
+
   (io-spec))
 
 (define-syntax test
diff --git a/scheme/ikarus.fasl.write.ss b/scheme/ikarus.fasl.write.ss
index a104c00..0624aab 100644
--- a/scheme/ikarus.fasl.write.ss
+++ b/scheme/ikarus.fasl.write.ss
@@ -30,7 +30,10 @@
     (ikarus system $bignums)
     (except (ikarus code-objects) procedure-annotation)
     (except (ikarus) fasl-write))
-
+  
+  (define (put-tag c p)
+    (write-byte (char->integer c) p))
+  
   (define write-fixnum 
     (lambda (x p)
       (unless (fixnum? x) (error 'write-fixnum "not a fixnum" x))
@@ -48,25 +51,23 @@
   (define fasl-write-immediate
     (lambda (x p)
       (cond
-        [(null? x) (write-char #\N p)]
+        [(null? x) (put-tag #\N p)]
         [(fixnum? x) 
-         (write-char #\I p)
+         (put-tag #\I p)
          (write-fixnum x p)]
         [(char? x)
          (let ([n ($char->fixnum x)])
            (if ($fx<= n 255)
                (begin
-                 (write-char #\c p)
+                 (put-tag #\c p)
                  (write-byte n p))
                (begin
-                 (write-char #\C p)
+                 (put-tag #\C p)
                  (write-int n p))))]
-        ; (write-char #\C p)
-        ; (write-char x p)]
         [(boolean? x)
-         (write-char (if x #\T #\F) p)]
-        [(eof-object? x) (write-char #\E p)]
-        [(eq? x (void)) (write-char #\U p)]
+         (put-tag (if x #\T #\F) p)]
+        [(eof-object? x) (put-tag #\E p)]
+        [(eq? x (void)) (put-tag #\U p)]
         [else (error 'fasl-write "not a fasl-writable immediate" x)])))
   
   (define (ascii-string? s)
@@ -74,13 +75,13 @@
       (or ($fx= i n)
           (and ($char<= ($string-ref s i) ($fixnum->char 127))
                (f s ($fxadd1 i) n)))))
-
+  
   (define (count-unshared-cdrs x h n)
     (cond
       [(and (pair? x) (eq? (hashtable-ref h x #f) 0))
        (count-unshared-cdrs ($cdr x) h ($fxadd1 n))]
       [else n]))
-
+  
   (define (write-pairs x p h m n)
     (cond
       [($fx= n 0) (fasl-write-object x p h m)]
@@ -97,22 +98,22 @@
            (let ([n (count-unshared-cdrs d h 0)])
              (cond
                [($fx= n 0)
-                (write-char #\P p)
+                (put-tag #\P p)
                 (fasl-write-object d p h
                   (fasl-write-object (car x) p h m))]
                [else 
                 (cond
                   [($fx<= n 255) 
-                   (write-char #\l p)
+                   (put-tag #\l p)
                    (write-byte n p)]
                   [else
-                   (write-char #\L p)
+                   (put-tag #\L p)
                    (write-int n p)])
                 (write-pairs d p h 
                   (fasl-write-object (car x) p h m)
                   n)])))]
         [(vector? x)
-         (write-char #\V p)
+         (put-tag #\V p)
          (write-int (vector-length x) p)
          (let f ([x x] [i 0] [n (vector-length x)] [m m])
            (cond
@@ -123,14 +124,14 @@
         [(string? x) 
          (cond
            [(ascii-string? x)
-            (write-char #\s p)
+            (put-tag #\s p)
             (write-int (string-length x) p)
             (let f ([x x] [i 0] [n (string-length x)])
               (unless (fx= i n)
-                (write-char (string-ref x i) p)
+                (write-byte (char->integer (string-ref x i)) p)
                 (f x (fxadd1 i) n)))]
            [else
-            (write-char #\S p)
+            (put-tag #\S p)
             (write-int (string-length x) p)
             (let f ([x x] [i 0] [n (string-length x)])
               (unless (= i n)
@@ -138,14 +139,14 @@
                 (f x (fxadd1 i) n)))])
          m]
         [(gensym? x)
-         (write-char #\G p)
+         (put-tag #\G p)
          (fasl-write-object (gensym->unique-string x) p h
            (fasl-write-object (symbol->string x) p h m))]
         [(symbol? x) 
-         (write-char #\M p)
+         (put-tag #\M p)
          (fasl-write-object (symbol->string x) p h m)]
         [(code? x)
-         (write-char #\x p)
+         (put-tag #\x p)
          (write-int (code-size x) p)
          (write-fixnum (code-freevars x) p)
          (let ([m (fasl-write-object ($code-annotation x) p h m)])
@@ -159,7 +160,7 @@
            (cond
              [(eq? rtd (base-rtd))
               ;;; rtd record
-              (write-char #\R p)
+              (put-tag #\R p)
               (let ([names (struct-type-field-names x)]
                     [m 
                      (fasl-write-object (struct-type-symbol x) p h
@@ -173,7 +174,7 @@
                         (fasl-write-object (car names) p h m))])))]
              [else
               ;;; non-rtd record
-              (write-char #\{ p)
+              (put-tag #\{ p)
               (write-int (length (struct-type-field-names rtd)) p)
               (let f ([names (struct-type-field-names rtd)] 
                       [m (fasl-write-object rtd p h m)])
@@ -185,16 +186,16 @@
                          ((struct-field-accessor rtd (car names)) x)
                          p h m))]))]))]
         [(procedure? x)
-         (write-char #\Q p)
+         (put-tag #\Q p)
          (fasl-write-object ($closure-code x) p h m)]
         [(bytevector? x) 
-         (write-char #\v p)
+         (put-tag #\v p)
          (let ([n ($bytevector-length x)])
            (write-int n p)
            (write-bytevector x 0 n p))
          m]
         [(flonum? x) 
-         (write-char #\f p)
+         (put-tag #\f p)
          (write-byte ($flonum-u8-ref x 7) p)
          (write-byte ($flonum-u8-ref x 6) p)
          (write-byte ($flonum-u8-ref x 5) p)
@@ -205,11 +206,11 @@
          (write-byte ($flonum-u8-ref x 0) p)
          m]
         [(ratnum? x)
-         (write-char #\r p)
+         (put-tag #\r p)
          (fasl-write-object (numerator x) p h
            (fasl-write-object (denominator x) p h m))]
         [(bignum? x) 
-         (write-char #\b p) 
+         (put-tag #\b p) 
          (let ([sz ($bignum-size x)])
            (write-int (if ($bignum-positive? x) sz (- sz)) p)
            (let f ([i 0])
@@ -235,11 +236,11 @@
               (do-write x p h m)]
              [(fx> mark 0) ; marked but not written
               (hashtable-set! h x (fx- 0 m))
-              (write-char #\> p)
+              (put-tag #\> p)
               (write-int m p)
               (do-write x p h (fxadd1 m))]
              [else
-              (write-char #\< p)
+              (put-tag #\< p)
               (write-int (fx- 0 mark) p)
               m]))]
         [else (error 'fasl-write "BUG: not in hash table" x)]))) 
@@ -290,8 +291,9 @@
               (let ([code ($closure-code x)])
                 (unless (fxzero? (code-freevars code))
                   (error 'fasl-write
-                         "Cannot write a non-thunk procedure; the one given has free vars"
-                         (code-freevars code)))
+                    "Cannot write a non-thunk procedure; \
+                     the one given has free vars"
+                    (code-freevars code)))
                 (make-graph code h))]
              [(bytevector? x) (void)]
              [(flonum? x)     (void)]
@@ -304,18 +306,18 @@
     (lambda (x port)
       (let ([h (make-eq-hashtable)])
          (make-graph x h)
-         (write-char #\# port)
-         (write-char #\@ port)
-         (write-char #\I port)
-         (write-char #\K port)
-         (write-char #\0 port)
-         (write-char #\1 port)
+         (put-tag #\# port)
+         (put-tag #\@ port)
+         (put-tag #\I port)
+         (put-tag #\K port)
+         (put-tag #\0 port)
+         (put-tag #\1 port)
          (fasl-write-object x port h 1)
          (void))))
   (define fasl-write
-     (case-lambda 
-       [(x) (fasl-write-to-port x (current-output-port))]
-       [(x port)
-        (unless (output-port? port)
-          (error 'fasl-write "not an output port" port))
-        (fasl-write-to-port x port)])))
+    (case-lambda 
+      [(x) (fasl-write-to-port x (current-output-port))]
+      [(x port)
+       (unless (output-port? port)
+         (error 'fasl-write "not an output port" port))
+       (fasl-write-to-port x port)])))
diff --git a/scheme/last-revision b/scheme/last-revision
index 40bd097..5a97808 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1196
+1198