Added various optimization tweaks, cleaned up some code, added a few more comments.

s48/banana/README

@@ -1,4 +1,4 @@
-'Banana' is a simple object serialisation protocol.
+'Banana' is a simple object serialization protocol.
 
 - Main Procedures -
 
@@ -26,7 +26,7 @@
 
 (etb? byte)                                            [procedure]
     ==> boolean
-  Returns #t if BYTE > 127 (#x7f), #f if otherwise.  BYTE must be
+  Returns #T if BYTE > 127 (#x7f), #F if otherwise.  BYTE must be
   an exact integer.
 
 - Exceptions -
@@ -51,7 +51,7 @@ banana:unknown-byte <-- banana-error              [condition type]
 (unknown-byte-error? value)             [condition type predicate]
 
 (unknown-byte-error-byte banana:unknown-byte) ==> byte [procedure]
-  Returns the byte that DECODE didn't recognise.
+  Returns the byte that DECODE didn't recognize.
 
 (unknown-byte-error-profile banana:unknown-byte)       [procedure]
     ==> profile
@@ -87,7 +87,7 @@ specification for how they work in Banana.
     name          -- profile-name
     encoder       -- profile-encoder
     decoder-table -- profile-decoder-table
-    super-profile -- profile-super-profile
+    parent        -- profile-parent
 
   NAME is mainly for debugging purposes.
 
@@ -97,8 +97,9 @@ specification for how they work in Banana.
   DECODER-TABLE is a table of element type bytes to procedures of
   two arguments.
 
-  SUPER-PROFILE is either #f or a profile from which another
+  PARENT is either #F (indicating no parent) or a profile from
-  profile can inherit element type byte decoders and such.
+  which another profile can inherit element type byte decoders and
+  such.
 
 (make-profile string proc alist)                       [procedure]
   Makes a profile, whose name is STRING, whose encoder is PROC,
@@ -111,7 +112,7 @@ specification for how they work in Banana.
   profile that inherits behaviour from another profile, but is
   otherwise just like MAKE-PROFILE.
 
-The BANANA-EXTRAS package include a couple prettifying procedures
+The BANANA-EXTRAS package includes a couple prettifying procedures
 and a couple useful procedures should one desire to extend Banana.
 
 (posint->byte-vector nonnegative-integer)              [procedure]
@@ -122,7 +123,7 @@ and a couple useful procedures should one desire to extend Banana.
   byte for nonnegative integers.
 
 (byte-vector->posint byte-vector)                      [procedure]
-  The inverse of POSINT->BYTE-VECTOR.
+  The converse of POSINT->BYTE-VECTOR.
 
 (prettify-byte byte)                                   [procedure]
   Makes BYTE look like it normally does when being described in

s48/banana/banana.scm

@@ -6,19 +6,18 @@
 
 ;;;;;; - Conditions -
 
+;;;; I'll switch to SRFIs 34 and 35 once someone substitutes them
+;;;; for the current exception system in Scheme48's main source.
+
 (define-condition-type 'banana-error '(error))
 (define banana-error? (condition-predicate 'banana-error))
 ;; BANANA-ERROR conditions contain information about who signalled
-;; them in their CADRs.
+;; them for better debugging.  [use CALL-ERROR instead?]
 (define banana-error-caller cadr)
 
 (define-condition-type 'banana:unknown-byte '(banana-error))
 (define unknown-byte-error?
   (condition-predicate 'banana:unknown-byte?))
-;; See the note about BANANA-ERROR conditions.  For that reason,
-;; and that BANANA:UNKNOWN-BYTE is a subtype of BANANA-ERROR, all
-;; the information in BANANA:UNKNOWN-BYTE conditions (and all the
-;; others below BANANA-ERROR) store their own fields in the CDDRs.
 (define unknown-byte-error-byte caddr)
 (define unknown-byte-error-profile cadddr)
 
@@ -31,13 +30,13 @@
 (define-condition-type 'read-eof-error '(read-error))
 (define read-eof-error? (condition-predicate 'read-eof-error))
 
-;;;;;; - Utility functions. -
+;;;;;; - Utility functions -
 
 ;; Used in NONE-ENCODER/STRING.
-(define (map-string->byte-vector f s . rest)
+(define (map-string->byte-vector f s)
-  (let* ((len (string-length s))
+  (let ((len (string-length s)))
-         (new (make-byte-vector len 0)))
+    (do ((new (make-byte-vector len 0))
-    (do ((i 0 (+ i 1)))
+         (i 0 (+ i 1)))
         ((= i len) new)
       (byte-vector-set! new i
                         (f (string-ref s i))))))
@@ -63,65 +62,56 @@
 
 ;; Variant of BYTE-VECTOR-CONCATENATE.
 (define (byte-vector-append . vecs)
-  (if (null? vecs)
+  (cond ((null? vecs) ;fast paths
-      ;; No need to even bother calling BYTE-VECTOR-CONCATENATE.
+         (make-byte-vector 0 0))
-      (make-byte-vector 0 0)
+        ((null? (cdr vecs))
-      (byte-vector-concatenate vecs)))
+         (car vecs))
+        (else
+         (byte-vector-concatenate vecs))))
 
 ;; Maybe these and the two above should be done using the
 ;; SEQUENCES structures that also come with Sunterlib.
+;; 
+;; Or with the COPY-BYTES! VM primitive, if we care about speed.
 (define (byte-vector->string bv)
-  (let* ((len (byte-vector-length bv))
+  (let ((len (byte-vector-length bv)))
-         (new (make-string len)))
+    ;(let ((new (make-string len)))
-    (do ((i 0 (+ i 1)))
+    ;  (copy-bytes! bv 0 new 0 len)
+    ;  bv)
+    (do ((new (make-string len))
+         (i 0 (+ i 1)))
         ((= i len) new)
       (string-set! new i (ascii->char (byte-vector-ref bv i))))))
 
 (define (string->byte-vector s)
-  (let* ((len (string-length s))
+  (let ((len (string-length s)))
-         (new (make-byte-vector len 0)))
+    ;(let ((new (make-byte-vectoro len)))
-    (do ((i 0 (+ i 1)))
+    ;  (copy-bytes! s 0 new 0 len)
+    ;  s)
+    (do ((new (make-byte-vector len 0))
+         (i 0 (+ i 1)))
         ((= i len) new)
       (byte-vector-set! new i (char->ascii (string-ref s i))))))
 
-(define (list->byte-vector l)
+;; [use the REVERSE-LIST->STRING VM primitive and then COPY-BYTES!
-  (let* ((len (length l))
+;; (to move the characters from the resulting string to a byte
-         (new (make-byte-vector len 0)))
+;; vector) for wicked speed?]
-    (do ((i 0 (+ i 1))
+(define (reverse-list->byte-vector l)
+  (let ((len (length l)))
+    (do ((new (make-byte-vector len 0))
+         (i (- len 1) (- i 1))
          (l l (cdr l)))
-        ((= i len) new)
+        ((null? l) new)
       (byte-vector-set! new i (car l)))))
 
 ;; POSINT->BYTE-VECTOR converts nonnegative integers (the name is
 ;; a tad misleading, but it's easier to write and say than
 ;; NONNEGINT->BYTE-VECTOR or something) to byte vectors as
 ;; specified by the Banana protocol.
-;;
-;; *FIXME* - Shouldn't this be able to be implemented better than
-;; by consing up a list...and then reversing that list...and then
-;; converting that list into a byte vector?
-;;
-;; Tail-recursive, iterative version.
 (define (posint->byte-vector int)
   (do ((int int (arithmetic-shift int -7))
        (bytes '() (cons (bitwise-and int #x7f) bytes)))
-      ((zero? int) (list->byte-vector (reverse bytes)))))
+      ((zero? int) (reverse-list->byte-vector bytes))))
-
-;; CPS version.
-; (define (posint->byte-vector int)
-;   (do ((int int (arithmetic-shift int -7))
-;        (k (lambda (x) x)
-;           (lambda (x) (k (cons (bitwise-and int #x7f) x)))))
-;       ((zero? int) (list->byte-vector (k '())))))
-
-;; Linear-recursive version.
-; (define (posint->byte-vector int)
-;   (list->byte-vecctor
-;    (let loop ((int int))
-;      (if (zero? int)
-;          bytes
-;          (cons (bitwise-and int #x7f)
-;                (loop (arithmetic-shift int -7)))))))
 
 ;; BYTE-VECTOR->POSINT is just like POSINT->BYTE-VECTOR but the
 ;; other way around.
@@ -153,58 +143,78 @@
 (define (prettify-byte-vector bv)
   (map-byte-vector->list prettify-byte bv))
 
-(define alist->integer-table
+;;;;;; - Banana -
-  (let ((make (make-table-maker = abs)))
-    (lambda (alist)
-      (let ((table (make)))
-        (for-each (lambda (key/value)
-                    (table-set! table
-                                (car key/value)
-                                (cdr key/value)))
-                  alist)
-        table))))
 
-;;;;;; Here starts the actual Banana code.
+;;;; Decoder tables
+
+(define minimum-etb #x80) ;offset for bytes in decoder tables
+
+;; Decoder tables used to be implemented with tables of integers.
+;; How silly to not have written it to use vectors in the first
+;; place.
+
+(define (alist->decoder-table alist)
+  ;; Hope there are no duplicates in ALIST.
+  (let ((vec (make-decoder-table (length alist))))
+    (for-each (lambda (byte+decoder)
+                (vector-set! vec
+                             (- (car byte+decoder)
+                                minimum-etb)
+                             (cdr byte+decoder)))
+              alist)
+    vec))
+
+(define (make-decoder-table size)
+  (make-vector size #f))
+
+(define (decoder-table-ref dt byte)
+  (vector-ref dt (- byte minimum-etb)))
+(define (decoder-table-set! dt byte value)
+  (vector-set! dt (- byte minimum-etb) value))
+(define (decoder-table-size dt)
+  (+ (vector-length dt) minimum-etb))
+
+;;;; Profiles
 
 (define-record-type profile :profile
-  (really-make-profile name encoder decoder-table super-profile)
+  (really-make-profile name encoder decoder-table parent)
   profile?
   (name profile-name)
   (encoder profile-encoder)
   (decoder-table profile-decoder-table)
-  (super-profile profile-super-profile))
+  (parent profile-parent))
+
+(define-record-discloser :profile
+  (letrec ((profile-names (lambda (p)
+                            (if p
+                                (cons (profile-name p)
+                                      (profile-names
+                                       (profile-parent p)))
+                                '()))))
+    (lambda (p) `(profile . ,(profile-names p)))))
 
 (define (make-profile name encoder decoder-alist)
   (extend-profile #f name encoder decoder-alist))
 
-(define (extend-profile super-profile name encoder decoder-alist)
+(define (extend-profile parent name encoder decoder-alist)
   (really-make-profile name encoder
-                       (alist->integer-table decoder-alist)
+                       (alist->decoder-table decoder-alist)
-                       super-profile))
+                       parent))
-
-;; Why did this ever take a variable number of arguments?
-; (define extend-profile
-;   (case-lambda
-;     ((super-profile profile)
-;      (really-make-profile (profile-name profile)
-;                           (profile-encoder profile)
-;                           (profile-decoder-table profile)
-;                           super-profile))
-;     ((super-profile name encoder decoder-alist)
-;      (really-make-profile name encoder
-;                           (alist->integer-table decoder-alist)
-;                           super-profile))))
 
 ;; ETB = Element Type Byte
 (define (lookup-etb-decoder byte profile)
   (let loop ((p profile))
     (if p
-        (or (table-ref (profile-decoder-table p) byte)
+        (or (let ((decoders (profile-decoder-table p)))
-            (loop (profile-super-profile p)))
+              (and (< byte (decoder-table-size decoders))
+                   (decoder-table-ref decoders byte)))
+            (loop (profile-parent p)))
         (signal 'banana:unknown-byte
                 'lookup-etb-decoder
                 byte profile))))
 
+;;;; The 'none' profile
+
 (define none-etb/list          #x80)
 (define none-etb/posint        #x81)
 (define none-etb/string        #x82)
@@ -241,6 +251,7 @@
     (byte-vector-append
      (posint->byte-vector (string-length str))
      (byte-vector none-etb/string)
+     ;; COPY-BYTES! would do this much faster!
      (map-string->byte-vector char->ascii str))))
 
 (define none-encoder/negint
@@ -346,12 +357,12 @@
 
 (define none-decoder/float
   (lambda (bytes inport)
-    (let ((s (make-string 9)))
+    (let ((v (make-byte-vector 9 0)))
-      (string-set! s 0 (ascii->char none-etb/float))
+      (byte-vector-set! v 0 none-etb/float)
       (do ((i 1 (+ i 1)))
           ((= i 9))
-        (string-set! s i (read-char inport)))
+        (byte-vector-set! v i (char->ascii (read-char inport))))
-      (byte-vector->real (string->byte-vector s)))))
+      (byte-vector->real v))))
 
 ;; NONE-DECODER/POSINT and NONE-DECODER/LARGEPOSINT really do the
 ;; same thing -- the only difference is that they're called in
@@ -373,7 +384,7 @@
       (,none-etb/largenegint . ,none-decoder/largenegint))))
 
 (define (etb? b)
-  (> b 127))
+  (> b #x7f))
 
 (define (read-element! inport profile)
   (let loop ((bytes '()))
@@ -386,7 +397,7 @@
           (let ((current-byte (char->ascii current-char)))
             (if (etb? current-byte)
                 ((lookup-etb-decoder current-byte profile)
-                 (apply byte-vector (reverse bytes))
+                 (reverse-list->byte-vector bytes)
                  inport)
                 (loop (cons current-byte bytes))))))))
 
@@ -394,7 +405,7 @@
   (let ((profile (if (pair? profile) (car profile) profile/none)))
     (cond
      ((input-port?  x) (read-element! x profile))
-     ((string?      x) (read-element! (make-string-input-port x)
+     ((string?      x) (read-element! (open-input-string x)
                                       profile))
      ((byte-vector? x) (decode (byte-vector->string x) profile))
      (else (error "decode: can't decode from source" x)))))

s48/banana/interfaces.scm

@@ -21,7 +21,7 @@
      (profile-encoder (proc (:value)
                             (proc (:value) :value)))
      (profile-decoder-table (proc (:value) :value))
-     (profile-super-profile (proc (:value) :value))
+     (profile-parent (proc (:value) :value))
 
    profile/none
 
@@ -37,9 +37,9 @@
   (export
 
    ;; These can be used for other profiles as lengths and such.
-   posint->byte-vector
+   (posint->byte-vector (proc (:exact-integer) :byte-vector))
-   byte-vector->posint
+   (byte-vector->posint (proc (:byte-vector) :exact-integer))
 
    ;; Generally just for debugging or manual testing.
-   prettify-byte
+   (prettify-byte (proc (:exact-integer) :string))
-   prettify-byte-vector))
+   (prettify-byte-vector (proc (:byte-vector) :string))))

s48/banana/packages.scm

@@ -5,14 +5,10 @@
         conditions
         exceptions
         signals
-        thread-fluids
-        bitwise
-        tables
         handle
+        bitwise
         byte-vectors
         ascii
-        extended-ports
         srfi-1
-        srfi-2
+        srfi-6)
-        srfi-16)
   (files banana))