From eac9829a03df0dee63ba7202f1d7d4bf33f67954 Mon Sep 17 00:00:00 2001
From: Abdulaziz Ghuloum <aghuloum@cs.indiana.edu>
Date: Wed, 12 Dec 2007 18:59:19 -0500
Subject: [PATCH] cleanup of tags in ikarus.io.ss

---
 scheme/ikarus.io.ss  | 125 +++++++++++++++++++++----------------------
 scheme/last-revision |   2 +-
 2 files changed, 62 insertions(+), 65 deletions(-)

diff --git a/scheme/ikarus.io.ss b/scheme/ikarus.io.ss
index 97be008..1e106df 100644
--- a/scheme/ikarus.io.ss
+++ b/scheme/ikarus.io.ss
@@ -121,34 +121,52 @@
   (define $set-port-attrs! set-$port-attrs!)
   (define $set-port-closed?! set-$port-closed?!)
   (define $make-port make-$port)
+  
+  (define ($port-tag x) (if ($port? x) ($port-attrs x) 0))
+  
+  (define ($port-fast-attrs x) (fxand ($port-tag x) fast-attrs-mask))
+  
+  (define (u8? x) (and (fixnum? x) (fx>= x 0) (fx< x 256)))
+  
+  (define (textual-port? x) 
+    (fx= (fxand ($port-tag x) textual-port-tag) textual-port-tag))
 
-  (define ($port-get-mode x)
-    (and ($port? x) (fxand ($port-attrs x) fast-get-mask)))
+  (define (binary-port? x) 
+    (fx= (fxand ($port-tag x) binary-port-tag) binary-port-tag))
 
-  (define ($port-put-mode x)
-    (and ($port? x) (fxand ($port-attrs x) fast-put-mask)))
+  (define (output-port? x) 
+    (fx= (fxand ($port-tag x) output-port-tag) output-port-tag))
 
-  (define (u8? x)
-    (and (fixnum? x) (fx>= x 0) (fx< x 256)))
+  (define (input-port? x)
+    (fx= (fxand ($port-tag x) input-port-tag) input-port-tag))
 
-  (define (textual-port? p) 
-    (and ($port? p) 
-         ($port-transcoder p) 
-         #t))
+  ;;; everything above this line will turn into primitive
+  ;;; ----------------------------------------------------------
+  
+  (define input-port-tag           #b00000001)
+  (define output-port-tag          #b00000010)
+  (define textual-port-tag         #b00000100)
+  (define binary-port-tag          #b00001000)
+  (define fast-char-text-tag       #b00010000)
+  (define fast-u7-text-tag         #b00100000)
+  (define fast-u8-text-tag         #b01100000)
+  (define r6rs-mode-tag            #b10000000)
 
-  (define (binary-port? p) 
-    (and ($port? p)
-         (not ($port-transcoder p))))
+  (define fast-attrs-mask          #b01111111)
+  (define binary-input-port-bits   #b00001001)
+  (define binary-output-port-bits  #b00001010)
+  (define textual-input-port-bits  #b00000101)
+  (define textual-output-port-bits #b00000110)
 
-  (define (output-port? p) 
-    (and ($port? p) 
-         ($port-write! p)
-         #t))
+  (define fast-get-byte-tag        #b00001001)
+  (define fast-get-char-tag        #b00010101)
+  (define fast-get-utf8-tag        #b00100101)
+  (define fast-get-latin-tag       #b01100101)
 
-  (define (input-port? p) 
-    (and ($port? p) 
-         ($port-read! p) 
-         #t))
+  (define fast-put-byte-tag        #b00001010)
+  (define fast-put-char-tag        #b00010110)
+  (define fast-put-utf8-tag        #b00100110)
+  (define fast-put-latin-tag       #b01100110)
 
   (define (input-port-name p)
     (if (input-port? p) 
@@ -165,27 +183,6 @@
         ($port-id p)
         (error 'port-id "not a port" p)))
 
-  ;;; everything above this line will turn into primitive
-  ;;; ----------------------------------------------------------
-  
-  (define fast-get-tag           #x0001)
-  (define fast-put-tag           #x0002)
-  (define fast-get-position-tag  #x0004)
-
-  (define fast-get-mask          #x00F0)
-  (define fast-get-utf8-tag      #x0010)
-  (define fast-get-latin-tag     #x0030)
-  (define fast-get-byte-tag      #x0040)
-  (define fast-get-char-tag      #x0080)
-
-  (define fast-put-mask          #x0F00)
-  (define fast-put-utf8-tag      #x0100)
-  (define fast-put-latin-tag     #x0300)
-  (define fast-put-byte-tag      #x0400)
-  (define fast-put-char-tag      #x0800)
-  
-  (define r6rs-mode-tag          #x1000)
-
   (define guarded-port
     (let ([G (make-guardian)])
       (define (clean-up)
@@ -223,7 +220,7 @@
     (unless (or (procedure? close) (not close))
       (error who "close should be either a procedure or #f" close))
     ($make-custom-binary-port 
-      (fxior fast-get-tag fast-get-byte-tag)
+      binary-input-port-bits
       0
       id read! #f get-position
       set-position! close 256))
@@ -239,7 +236,7 @@
     (unless (or (procedure? close) (not close))
       (error who "close should be either a procedure or #f" close))
     ($make-custom-binary-port 
-      (fxior fast-put-tag fast-put-byte-tag)
+      binary-output-port-bits
       256
       id #f write! get-position
       set-position! close 256))
@@ -255,7 +252,7 @@
     (unless (or (procedure? close) (not close))
       (error who "close should be either a procedure or #f" close))
     ($make-custom-textual-port 
-      (fxior fast-get-tag fast-get-char-tag)
+      textual-input-port-bits
       0
       id read! #f get-position
       set-position! close 256))
@@ -271,7 +268,7 @@
     (unless (or (procedure? close) (not close))
       (error who "close should be either a procedure or #f" close))
     ($make-custom-textual-port 
-      (fxior fast-put-tag fast-put-char-tag)
+      textual-output-port-bits
       256
       id #f write! get-position
       set-position! close 256))
@@ -281,23 +278,23 @@
   (define (input-transcoder-attrs x)
     (cond
       [(not x) ;;; binary input port
-       (fxior fast-get-tag fast-get-byte-tag)]
+       binary-input-port-bits]
       [(and (eq? 'latin-1-codec (transcoder-codec x))
             (eq? 'none (transcoder-eol-style x)))
-       (fxior fast-get-tag fast-get-latin-tag)]
-      [else 0]))
+       (fxior textual-input-port-bits fast-u8-text-tag)]
+      [else textual-input-port-bits]))
 
   (define (output-transcoder-attrs x)
     (cond
       [(not x) ;;; binary input port
-       (fxior fast-put-tag fast-put-byte-tag)]
+       binary-output-port-bits]
       [(and (eq? 'latin-1-codec (transcoder-codec x))
             (eq? 'none (transcoder-eol-style x)))
-       (fxior fast-put-tag fast-put-latin-tag)]
+       (fxior textual-output-port-bits fast-u8-text-tag)]
       [(and (eq? 'utf-8-codec (transcoder-codec x))
             (eq? 'none (transcoder-eol-style x)))
-       (fxior fast-put-tag fast-put-utf8-tag)]
-      [else 0]))
+       (fxior textual-output-port-bits fast-u7-text-tag)]
+      [else textual-output-port-bits]))
 
   (define open-bytevector-input-port
     (case-lambda
@@ -396,7 +393,7 @@
              ($make-port 0 buffer-size (make-string buffer-size) 0
                 #t ;;; transcoder
                 #f
-                (fxior fast-put-tag fast-put-char-tag)
+                (fxior textual-output-port-bits fast-char-text-tag)
                 "*string-output-port*"
                 #f
                 (lambda (str i c) 
@@ -435,7 +432,7 @@
     ($make-port 0 (string-length str) str 0 
        #t ;;; transcoder
        #f ;;; closed?
-       (fxior fast-get-tag fast-get-char-tag)
+       (fxior textual-input-port-bits fast-char-text-tag)
        "*string-input-port*" 
        (lambda (str i c) 0) ;;; read!
        #f ;;; write!
@@ -839,7 +836,7 @@
           [(utf-8-codec)
            ;;;
            ($set-port-attrs! p 
-             (fxior fast-get-tag fast-get-utf8-tag))
+             (fxior textual-input-port-bits fast-u7-text-tag))
            (eof-object? (advance-bom p who '(#xEF #xBB #xBF)))]
           [else (error 'slow-get-char "codec not handled")])))
 
@@ -861,7 +858,7 @@
     ;;;
     (define (lookahead-char p)
       (define who 'lookahead-char)
-      (let ([m ($port-get-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-get-utf8-tag)
            (let ([i ($port-index p)])
@@ -912,7 +909,7 @@
 
     (define (get-char p)
       (define who 'get-char)
-      (let ([m ($port-get-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-get-utf8-tag)
            (let ([i ($port-index p)])
@@ -975,12 +972,12 @@
              (error who "read! returned a value out of range" j)]))))
     (define (slow-get-u8 p who start) 
       (assert-binary-input-port p who)
-      ($set-port-attrs! p (fxior fast-get-tag fast-get-byte-tag))
+      ($set-port-attrs! p fast-get-byte-tag)
       (get-u8-byte-mode p who start))
     ;;;
     (define (get-u8 p)
       (define who 'get-u8)
-      (let ([m ($port-get-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-get-byte-tag)
            (let ([i ($port-index p)])
@@ -992,7 +989,7 @@
           [else (slow-get-u8 p who 1)])))
     (define (lookahead-u8 p)
       (define who 'lookahead-u8)
-      (let ([m ($port-get-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-get-byte-tag)
            (let ([i ($port-index p)])
@@ -1004,7 +1001,7 @@
 
   (define (port-eof? p)
     (define who 'port-eof?)
-    (let ([m ($port-get-mode p)])
+    (let ([m ($port-fast-attrs p)])
       (cond
         [(not (eq? m 0))
          (if (fx< ($port-index p) ($port-size p))
@@ -1623,7 +1620,7 @@
           (f (fx+ i 1) n))))
     (define (do-put-char p c who)
       (unless (char? c) (error who "not a char" c))
-      (let ([m ($port-put-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-put-utf8-tag)
            (let ([i ($port-index p)])
@@ -1698,7 +1695,7 @@
     (define (put-u8 p b)
       (define who 'put-u8)
       (unless (u8? b) (error who "not a u8" b))
-      (let ([m ($port-put-mode p)])
+      (let ([m ($port-fast-attrs p)])
         (cond
           [(eq? m fast-put-byte-tag)
            (let ([i ($port-index p)])
diff --git a/scheme/last-revision b/scheme/last-revision
index eb0b863..4f72037 100644
--- a/scheme/last-revision
+++ b/scheme/last-revision
@@ -1 +1 @@
-1225
+1227