From 2732d18bbaf2a5eabb66604d26fc3aaf7dcf84c1 Mon Sep 17 00:00:00 2001 From: "Taylor R. Campbell" Date: Fri, 28 Mar 2003 19:47:41 +0000 Subject: [PATCH] added Banana --- s48/banana/AUTHORS | 1 + s48/banana/BLURB | 1 + s48/banana/README | 132 +++++++++++++ s48/banana/banana.scm | 402 ++++++++++++++++++++++++++++++++++++++ s48/banana/interfaces.scm | 45 +++++ s48/banana/packages.scm | 18 ++ 6 files changed, 599 insertions(+) create mode 100644 s48/banana/AUTHORS create mode 100644 s48/banana/BLURB create mode 100644 s48/banana/README create mode 100644 s48/banana/banana.scm create mode 100644 s48/banana/interfaces.scm create mode 100644 s48/banana/packages.scm diff --git a/s48/banana/AUTHORS b/s48/banana/AUTHORS new file mode 100644 index 0000000..7468301 --- /dev/null +++ b/s48/banana/AUTHORS @@ -0,0 +1 @@ +Taylor Campbell diff --git a/s48/banana/BLURB b/s48/banana/BLURB new file mode 100644 index 0000000..efa9cc3 --- /dev/null +++ b/s48/banana/BLURB @@ -0,0 +1 @@ +banana: http://twistedmatrix.com/documents/specifications/banana.html diff --git a/s48/banana/README b/s48/banana/README new file mode 100644 index 0000000..d5c1ca7 --- /dev/null +++ b/s48/banana/README @@ -0,0 +1,132 @@ +'Banana' is a simple object serialisation protocol. + +- Main Procedures - + +(encode value [profile]) ==> byte-vector [procedure] + Turns a value into a byte-vector representing that value. + Generally, the 'none' profile is used (and PROFILE defaults to + PROFILE/NONE), and with that one can encode only integers + (positive, zero, and negative, and of any size), lists, strings, + and reals (*FIXME* Real number encoding and decoding doesn't + work right now -- I haven't a clue how to encode them in the + IEEE floating point format, which is what Banana requires). + Example: + (encode '(1 -1 ("hello"))) + (not printed as byte-vectors would normally print; this is + just how Banana output is ordinarily shown) + ==> 03 80 01 81 01 83 01 80 05 82 68 65 6c 6c 6c 6f + +(decode input-port/string/byte-vector [profile]) [procedure] + ==> value + Decodes the output of ENCODE, or reads similar output from an + input port, or processes a string similarly. + Example: + (decode (encode '(1 -1 ("hello")))) + ==> (1 -1 ("hello")) + +(etb? byte) [procedure] + ==> boolean + Returns #t if BYTE > 127 (#x7f), #f if otherwise. BYTE must be + an exact integer. + +- Exceptions - + +banana-error <-- error [condition type] + Subtypes of BANANA-ERROR are raised whenever anything involving + Banana-ing goes wrong. The procedure that raised the error is + stored in each BANANA-ERROR condition, too, accessed by + BANANA-ERROR-CALLER. + +(banana-error? value) [condition type predicate] + +(banana-error-caller banana-error) ==> symbol [procedure] + Returns the name of the procedure that raised BANANA-ERROR. + +banana:unknown-byte <-- banana-error [condition type] + Raised when DECODE encounters an element type byte (see the + Banana specification on http://twistedmatrix.com/ for what the + element type bytes are) that it can't find in the profile it was + passed. + +(unknown-byte-error? value) [condition type predicate] + +(unknown-byte-error-byte banana:unknown-byte) ==> byte [procedure] + Returns the byte that DECODE didn't recognise. + +(unknown-byte-error-profile banana:unknown-byte) [procedure] + ==> profile + Returns the profile that DECODE was searching through. + +banana:unsupported-type <-- banana-error [condition type] + Raised when a profile's encoder doesn't know how to Banana a + value of a certain type. + +(unsupported-type-error? value) [condition type predicate] + +(unsupported-type-error-type banana:unsupported-type) [procedure] + ==> string + Returns the name of the type that a profile's encoder didn't + support. + +(unsupported-type-error-value banana:unsupported-type) [procedure] + ==> value + Returns the value of that type that a profile's encoder didn't + support. + +read-eof-error <-- read-error [condition type] + Raised when an EOF is reached and was not expected. + +- Profiles - + +Profiles are ways to extend the Banana protocol. See the Banana +specification for how they work in Banana. + +:profile [record type] + Profiles are stored in instances of this. They have four + fields, accessed by similar names -- + name -- profile-name + encoder -- profile-encoder + decoder-table -- profile-decoder-table + super-profile -- profile-super-profile + + NAME is mainly for debugging purposes. + + ENCODER should be a procedure of one argument and should return + a byte vector. + + 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. + +(make-profile string proc alist) [procedure] + Makes a profile, whose name is STRING, whose encoder is PROC, + and whose decoder table is a table made from ALIST, which should + be a list of pairs, the CAR of each being an element type byte, + and the CDR of each being a decoder procedure. + +(extend-profile profile string proc alist) [procedure] + The preferred profile constructor, this one allows you to make a + profile that inherits behaviour from another profile, but is + otherwise just like MAKE-PROFILE. + +The BANANA-EXTRAS package include a couple prettifying procedures +and a couple useful procedures should one desire to extend Banana. + +(posint->byte-vector nonnegative-integer) [procedure] + The name is slightly misleading, since it also works on zero, + but in any case, it returns a byte vector of NONNEGATIVE-INTEGER + encoded as the Banana specification states. Note that it does + -not- produce a byte vector with the PROFILE/NONE element type + byte for nonnegative integers. + +(byte-vector->posint byte-vector) [procedure] + The inverse of POSINT->BYTE-VECTOR. + +(prettify-byte byte) [procedure] + Makes BYTE look like it normally does when being described in + the context of Banana. + +(prettify-byte-vector byte-vector) [procedure] + Returns a list of prettified bytes in BYTE-VECTOR. diff --git a/s48/banana/banana.scm b/s48/banana/banana.scm new file mode 100644 index 0000000..ffe329b --- /dev/null +++ b/s48/banana/banana.scm @@ -0,0 +1,402 @@ +;;; 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 - + +(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. +(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) + +(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 . rest) + (let* ((len (string-length s)) + (new (make-byte-vector len 0))) + (do ((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-concatentate 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-CONCATENTATE. +(define (byte-vector-append . vecs) + (if (null? vecs) + ;; No need to even bother calling BYTE-VECTOR-CONCATENTATE. + (make-byte-vector 0 0) + (byte-vector-concatentate vecs))) + +;; Maybe these and the two above should be done using the +;; SEQUENCES structures that also come with Sunterlib. +(define (byte-vector->string bv) + (let* ((len (byte-vector-length bv)) + (new (make-string len))) + (do ((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))) + ((= 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)) + (l l (cdr l))) + ((= i len) 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. +;; +;; 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))))))) + +;; BYTE-VECTOR->POSINT is just like above 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)) + +(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)))) + +;;;;;; Here starts the actual Banana code. + +(define-record-type profile :profile + (really-make-profile name encoder decoder-table super-profile) + profile? + (name profile-name) + (encoder profile-encoder) + (decoder-table profile-decoder-table) + (super-profile profile-super-profile)) + +(define (make-profile name encoder decoder-alist) + (extend-profile #f name encoder decoder-alist)) + +(define (extend-profile super-profile 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)))) + +;; 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))) + (signal 'banana:unknown-byte + 'lookup-etb-decoder + byte 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-concatentate + (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) + (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 ((s (make-string 9))) + (string-set! s 0 (ascii->char none-etb/float)) + (do ((i 1 (+ i 1))) + ((= i 9)) + (string-set! s i (read-char inport))) + (byte-vector->real (string->byte-vector s))))) + +;; 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 127)) + +(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) + (apply byte-vector (reverse 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! (make-string-input-port 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))) diff --git a/s48/banana/interfaces.scm b/s48/banana/interfaces.scm new file mode 100644 index 0000000..78d50cc --- /dev/null +++ b/s48/banana/interfaces.scm @@ -0,0 +1,45 @@ +(define-interface banana-interface + (export + + (banana-error? (proc (:value) :boolean)) + + (unknown-byte-error? (proc (:value) :boolean)) + (unknown-byte-error-byte (proc (:value) :exact-integer)) + (unknown-byte-error-profile (proc (:value) :value)) + + (unsupported-type-error? (proc (:value) :boolean)) + (unsupported-type-error-type (proc (:value) :string)) + (unsupported-type-error-value (proc (:value) :value)) + + :profile + (make-profile + (proc (:string (proc (:value) :value) :pair) :value)) + (extend-profile + (proc (:value :string (proc (:value) :value) :pair) :value)) + (profile? (proc (:value) :boolean)) + (profile-name (proc (:value) :string)) + (profile-encoder (proc (:value) + (proc (:value) :value))) + (profile-decoder-table (proc (:value) :value)) + (profile-super-profile (proc (:value) :value)) + + profile/none + + ;; Do these next two really need to stay here? + (etb? (proc (:exact-integer) :boolean)) + + (read-element! (proc (:input-port :value) :value)) + + (decode (proc (:value &opt :value) :value)) + (encode (proc (:value &opt :value) :value)))) + +(define-interface banana-extras-interface + (export + + ;; These can be used for other profiles as lengths and such. + posint->byte-vector + byte-vector->posint + + ;; Generally just for debugging or manual testing. + prettify-byte + prettify-byte-vector)) diff --git a/s48/banana/packages.scm b/s48/banana/packages.scm new file mode 100644 index 0000000..03313a6 --- /dev/null +++ b/s48/banana/packages.scm @@ -0,0 +1,18 @@ +(define-structures ((banana banana-interface) + (banana-extras banana-extras-interface)) + (open scheme + define-record-types + conditions + exceptions + signals + thread-fluids + bitwise + tables + handle + byte-vectors + ascii + extended-ports + srfi-1 + srfi-2 + srfi-16) + (files banana))