scsh-conservatory
/
sunterlib
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

This commit is contained in:
Taylor R. Campbell 2003-10-27 22:08:10 +00:00
parent 9339ae863e
commit 9a0dcfb650
4 changed files with 113 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
s48/banana/README
View File

@ -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
profile can inherit element type byte decoders and such.
PARENT is either #F (indicating no parent) or a profile from
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

183
s48/banana/banana.scm
View File

@ -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)
(let* ((len (string-length s))
(new (make-byte-vector len 0)))
(do ((i 0 (+ i 1)))
(define (map-string->byte-vector f s)
(let ((len (string-length s)))
(do ((new (make-byte-vector len 0))
(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)
;; No need to even bother calling BYTE-VECTOR-CONCATENATE.
(make-byte-vector 0 0)
(byte-vector-concatenate vecs)))
(cond ((null? vecs) ;fast paths
(make-byte-vector 0 0))
((null? (cdr 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))
(new (make-string len)))
(do ((i 0 (+ i 1)))
(let ((len (byte-vector-length bv)))
;(let ((new (make-string len)))
; (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))
(new (make-byte-vector len 0)))
(do ((i 0 (+ i 1)))
(let ((len (string-length s)))
;(let ((new (make-byte-vectoro len)))
; (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)
(let* ((len (length l))
(new (make-byte-vector len 0)))
(do ((i 0 (+ i 1))
;; [use the REVERSE-LIST->STRING VM primitive and then COPY-BYTES!
;; (to move the characters from the resulting string to a byte
;; vector) for wicked speed?]
(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)))))
;; 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)))))))
((zero? int) (reverse-list->byte-vector bytes))))
;; 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
(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))))
;;;;;; - Banana -
;;;;;; 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)
super-profile))
;; 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))))
(alist->decoder-table decoder-alist)
parent))
;; ETB = Element Type Byte
(define (lookup-etb-decoder byte profile)
(let loop ((p profile))
(if p
(or (table-ref (profile-decoder-table p) byte)
(loop (profile-super-profile p)))
(or (let ((decoders (profile-decoder-table 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)))
(string-set! s 0 (ascii->char none-etb/float))
(let ((v (make-byte-vector 9 0)))
(byte-vector-set! v 0 none-etb/float)
(do ((i 1 (+ i 1)))
((= i 9))
(string-set! s i (read-char inport)))
(byte-vector->real (string->byte-vector s)))))
(byte-vector-set! v i (char->ascii (read-char inport))))
(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)))))

10
s48/banana/interfaces.scm
View File

@ -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
byte-vector->posint
(posint->byte-vector (proc (:exact-integer) :byte-vector))
(byte-vector->posint (proc (:byte-vector) :exact-integer))
;; Generally just for debugging or manual testing.
prettify-byte
prettify-byte-vector))
(prettify-byte (proc (:exact-integer) :string))
(prettify-byte-vector (proc (:byte-vector) :string))))

8
s48/banana/packages.scm
View File

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