418 lines
14 KiB
Scheme
418 lines
14 KiB
Scheme
;;; This file is part of the Scheme Untergrund Library.
|
|
|
|
;;; Copyright (c) 2003 by Taylor Campbell
|
|
;;; For copyright information, see the file COPYING which comes with
|
|
;;; the distribution.
|
|
|
|
;;;;;; - 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 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?))
|
|
(define unknown-byte-error-byte caddr)
|
|
(define unknown-byte-error-profile cadddr)
|
|
|
|
(define-condition-type 'banana:unsupported-type '(banana-error))
|
|
(define unsupported-type-error?
|
|
(condition-predicate 'banana:unsupported-type))
|
|
(define unsupported-type-error-type caddr)
|
|
(define unsupported-type-error-value cadddr)
|
|
|
|
(define-condition-type 'read-eof-error '(read-error))
|
|
(define read-eof-error? (condition-predicate 'read-eof-error))
|
|
|
|
;;;;;; - Utility functions -
|
|
|
|
;; Used in NONE-ENCODER/STRING.
|
|
(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))))))
|
|
|
|
;; Used in NONE-ENCODER/LIST.
|
|
(define (byte-vector-concatenate bvectors)
|
|
(let* ((len (fold (lambda (bv counter)
|
|
(+ (byte-vector-length bv) counter))
|
|
0 bvectors))
|
|
(new (make-byte-vector len 0)))
|
|
(let loop1 ((to 0) (bvectors bvectors))
|
|
(if (null? bvectors)
|
|
new
|
|
(let* ((bv (car bvectors))
|
|
(from-len (byte-vector-length bv)))
|
|
(let loop2 ((to to) (from 0))
|
|
(if (= from from-len)
|
|
(loop1 to (cdr bvectors))
|
|
(begin
|
|
(byte-vector-set!
|
|
new to (byte-vector-ref bv from))
|
|
(loop2 (+ to 1) (+ from 1))))))))))
|
|
|
|
;; Variant of BYTE-VECTOR-CONCATENATE.
|
|
(define (byte-vector-append . 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)))
|
|
;(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)))
|
|
;(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))))))
|
|
|
|
;; [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)))
|
|
((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.
|
|
(define (posint->byte-vector int)
|
|
(do ((int int (arithmetic-shift int -7))
|
|
(bytes '() (cons (bitwise-and int #x7f) bytes)))
|
|
((zero? int) (reverse-list->byte-vector bytes))))
|
|
|
|
;; BYTE-VECTOR->POSINT is just like POSINT->BYTE-VECTOR but the
|
|
;; other way around.
|
|
(define (byte-vector->posint bv)
|
|
(let ((len (byte-vector-length bv)))
|
|
(do ((i 0 (+ i 1))
|
|
(result 0 (+ result (* (byte-vector-ref bv i)
|
|
(expt 128 i)))))
|
|
((= i len) result))))
|
|
|
|
;; REAL->BYTE-VECTOR and BYTE-VECTOR->REAL just return 0.0 and a
|
|
;; byte vector of zeros, because I haven't the foggiest idea how
|
|
;; to implement them correctly.
|
|
(define (real->byte-vector r)
|
|
(make-byte-vector 8 0))
|
|
|
|
(define (byte-vector->real bv)
|
|
0.0)
|
|
|
|
(define (prettify-byte b)
|
|
(number->string b 16))
|
|
|
|
(define (map-byte-vector->list f bv)
|
|
(let ((len (byte-vector-length bv)))
|
|
(do ((i (- len 1) (- i 1))
|
|
(result '() (cons (f (byte-vector-ref bv i)) result)))
|
|
((negative? i) result))))
|
|
|
|
(define (prettify-byte-vector bv)
|
|
(map-byte-vector->list prettify-byte bv))
|
|
|
|
;;;;;; - Banana -
|
|
|
|
;;;; 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 parent)
|
|
profile?
|
|
(name profile-name)
|
|
(encoder profile-encoder)
|
|
(decoder-table profile-decoder-table)
|
|
(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 parent name encoder decoder-alist)
|
|
(really-make-profile name encoder
|
|
(alist->decoder-table decoder-alist)
|
|
parent))
|
|
|
|
;; ETB = Element Type Byte
|
|
(define (lookup-etb-decoder byte profile)
|
|
(let loop ((p profile))
|
|
(if 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)
|
|
(define none-etb/negint #x83)
|
|
(define none-etb/float #x84)
|
|
(define none-etb/largeposint #x85)
|
|
(define none-etb/largenegint #x86)
|
|
|
|
(define none-etb-v/list (byte-vector none-etb/list))
|
|
(define none-etb-v/posint (byte-vector none-etb/posint))
|
|
(define none-etb-v/string (byte-vector none-etb/string))
|
|
(define none-etb-v/negint (byte-vector none-etb/negint))
|
|
(define none-etb-v/float (byte-vector none-etb/float))
|
|
(define none-etb-v/largeposint (byte-vector none-etb/largeposint))
|
|
(define none-etb-v/largenegint (byte-vector none-etb/largenegint))
|
|
|
|
(define none-encoder/list
|
|
(lambda (lst)
|
|
(if (null? lst)
|
|
(byte-vector 0 none-etb/list)
|
|
(byte-vector-concatenate
|
|
(append (list (posint->byte-vector (length lst)))
|
|
(list none-etb-v/list)
|
|
(map (lambda (x) (encode x profile/none))
|
|
lst))))))
|
|
|
|
(define none-encoder/posint
|
|
(lambda (int)
|
|
(byte-vector-append (posint->byte-vector int)
|
|
none-etb-v/posint)))
|
|
|
|
(define none-encoder/string
|
|
(lambda (str)
|
|
(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
|
|
(lambda (int)
|
|
(byte-vector-append (posint->byte-vector (- int))
|
|
none-etb-v/negint)))
|
|
|
|
(define none-encoder/float
|
|
(lambda (float)
|
|
(byte-vector-append none-etb-v/float
|
|
(real->byte-vector float))))
|
|
|
|
(define none-encoder/largeposint
|
|
(lambda (int)
|
|
(byte-vector-append (posint->byte-vector int)
|
|
none-etb-v/largeposint)))
|
|
|
|
(define none-encoder/largenegint
|
|
(lambda (int)
|
|
(byte-vector-append (posint->byte-vector (- int))
|
|
none-etb-v/largenegint)))
|
|
|
|
(define none/encode
|
|
(lambda (obj)
|
|
(let ((not-supported
|
|
(lambda (type)
|
|
(signal 'banana:unsupported-type
|
|
'none/encode
|
|
type obj))))
|
|
((cond
|
|
((number? obj)
|
|
(cond
|
|
((inexact? obj) none-encoder/float)
|
|
((integer? obj)
|
|
(if (negative? obj)
|
|
(if (< obj -2147483648)
|
|
none-encoder/largenegint
|
|
none-encoder/negint)
|
|
(if (> obj 2147483647)
|
|
none-encoder/largeposint
|
|
none-encoder/posint)))
|
|
((rational? obj) (not-supported "rational"))
|
|
((real? obj) none-encoder/float)
|
|
((complex? obj) (not-supported "complex"))
|
|
(else (not-supported "unknown number"))))
|
|
((list? obj) none-encoder/list)
|
|
((string? obj) none-encoder/string)
|
|
(else (not-supported "unknown value")))
|
|
obj))))
|
|
|
|
;; CPS version, if you want it.
|
|
; (define none-decoder/list
|
|
; (lambda (bytes inport)
|
|
; (let loop ((len (byte-vector->posint bytes))
|
|
; (k (lambda (x) x)))
|
|
; (if (zero? len)
|
|
; (k '())
|
|
; (loop (- len 1)
|
|
; (lambda (x)
|
|
; (k (cons (read-element! inport) x))))))))
|
|
|
|
;; Linear-recursive version, if you want it.
|
|
; (define none-decoder/list
|
|
; (lambda (bytes inport)
|
|
; (let loop ((len (byte-vector->posint bytes)))
|
|
; (if (zero? len)
|
|
; '()
|
|
; (cons (read-element! inport) (loop (- len 1)))))))
|
|
|
|
(define none-decoder/list
|
|
(lambda (bytes inport)
|
|
(let loop ((len (byte-vector->posint bytes)) (vals '()))
|
|
(if (zero? len)
|
|
(reverse vals)
|
|
(loop (- len 1) (cons (read-element! inport
|
|
profile/none)
|
|
vals))))))
|
|
|
|
(define none-decoder/posint
|
|
(lambda (bytes inport)
|
|
(byte-vector->posint bytes)))
|
|
|
|
(define none-decoder/string
|
|
(lambda (bytes inport)
|
|
(let* ((len (byte-vector->posint bytes))
|
|
(new (make-string len)))
|
|
(let loop ((i 0))
|
|
(if (= i len)
|
|
new
|
|
(let ((char (read-char inport)))
|
|
(if (eof-object? char)
|
|
(signal 'read-eof-error
|
|
"reached eof"
|
|
'none-decoder/string
|
|
inport)
|
|
(begin
|
|
(string-set! new i char)
|
|
(loop (+ i 1))))))))))
|
|
|
|
(define none-decoder/negint
|
|
(lambda (bytes inport)
|
|
(- (byte-vector->posint bytes))))
|
|
|
|
(define none-decoder/float
|
|
(lambda (bytes inport)
|
|
(let ((v (make-byte-vector 9 0)))
|
|
(byte-vector-set! v 0 none-etb/float)
|
|
(do ((i 1 (+ i 1)))
|
|
((= i 9))
|
|
(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
|
|
;; difference circumstances.
|
|
(define none-decoder/largeposint none-decoder/posint)
|
|
|
|
;; The same can be said of NONE-DECODER/NEGINT and
|
|
;; NONE-DECODER/LARGENEGINT.
|
|
(define none-decoder/largenegint none-decoder/negint)
|
|
|
|
(define profile/none
|
|
(make-profile "none" none/encode
|
|
`((,none-etb/list . ,none-decoder/list)
|
|
(,none-etb/posint . ,none-decoder/posint)
|
|
(,none-etb/string . ,none-decoder/string)
|
|
(,none-etb/negint . ,none-decoder/negint)
|
|
(,none-etb/float . ,none-decoder/float)
|
|
(,none-etb/largeposint . ,none-decoder/largeposint)
|
|
(,none-etb/largenegint . ,none-decoder/largenegint))))
|
|
|
|
(define (etb? b)
|
|
(> b #x7f))
|
|
|
|
(define (read-element! inport profile)
|
|
(let loop ((bytes '()))
|
|
(let ((current-char (read-char inport)))
|
|
(if (eof-object? current-char)
|
|
(signal 'read-eof-error
|
|
"reached EOF"
|
|
'read-element!
|
|
inport)
|
|
(let ((current-byte (char->ascii current-char)))
|
|
(if (etb? current-byte)
|
|
((lookup-etb-decoder current-byte profile)
|
|
(reverse-list->byte-vector bytes)
|
|
inport)
|
|
(loop (cons current-byte bytes))))))))
|
|
|
|
(define (decode x . profile)
|
|
(let ((profile (if (pair? profile) (car profile) profile/none)))
|
|
(cond
|
|
((input-port? x) (read-element! x profile))
|
|
((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)))))
|
|
|
|
(define (encode obj . profile)
|
|
(let ((f (profile-encoder (if (pair? profile)
|
|
(car profile)
|
|
profile/none))))
|
|
(f obj)))
|