summaryrefslogtreecommitdiff
path: root/ebus-racket/3rdparty/bzlib
diff options
context:
space:
mode:
authorYves Fischer <yvesf-git@xapek.org>2016-08-14 19:25:26 +0200
committerYves Fischer <yvesf-git@xapek.org>2016-08-14 19:25:26 +0200
commitcaae83f445935c06cd6aef36f283a4688675278a (patch)
tree5e63cbfd2877195430a8657dcd75f42b6a4d7110 /ebus-racket/3rdparty/bzlib
downloadebus-caae83f445935c06cd6aef36f283a4688675278a.tar.gz
ebus-caae83f445935c06cd6aef36f283a4688675278a.zip
refactored ebus code
Diffstat (limited to 'ebus-racket/3rdparty/bzlib')
-rw-r--r--ebus-racket/3rdparty/bzlib/base/args.ss150
-rw-r--r--ebus-racket/3rdparty/bzlib/base/assert.ss150
-rw-r--r--ebus-racket/3rdparty/bzlib/base/base.ss211
-rw-r--r--ebus-racket/3rdparty/bzlib/base/bytes.ss206
-rw-r--r--ebus-racket/3rdparty/bzlib/base/info.ss27
-rw-r--r--ebus-racket/3rdparty/bzlib/base/list.ss109
-rw-r--r--ebus-racket/3rdparty/bzlib/base/main.ss49
-rw-r--r--ebus-racket/3rdparty/bzlib/base/registry.ss215
-rw-r--r--ebus-racket/3rdparty/bzlib/base/require.ss32
-rw-r--r--ebus-racket/3rdparty/bzlib/base/syntax.ss62
-rw-r--r--ebus-racket/3rdparty/bzlib/base/text.ss69
-rw-r--r--ebus-racket/3rdparty/bzlib/base/uuid.ss202
-rw-r--r--ebus-racket/3rdparty/bzlib/base/version-case.ss118
-rw-r--r--ebus-racket/3rdparty/bzlib/base/version.ss71
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/basic.ss200
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/combinator.ss208
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/depend.ss3
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/example/calc.ss51
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/example/csv.ss42
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/example/json.ss135
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/example/regex.ss163
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/example/sql.ss138
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/info.ss35
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/input.ss83
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/main.ss32
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/primitive.ss233
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/reader.ss41
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/token.ss100
-rw-r--r--ebus-racket/3rdparty/bzlib/parseq/util.ss53
29 files changed, 3188 insertions, 0 deletions
diff --git a/ebus-racket/3rdparty/bzlib/base/args.ss b/ebus-racket/3rdparty/bzlib/base/args.ss
new file mode 100644
index 0000000..dd4659a
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/args.ss
@@ -0,0 +1,150 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; args.ss - utility for helping processing syntax-based arguments (does not belong here)
+;; yc 9/21/2009 - first version
+;; yc 9/25/2009 - move from port.plt to base.plt
+(require (for-syntax scheme/base)
+ scheme/match)
+
+;; convert an argument (and an optional argument) into an identifier
+;; p => p
+;; (p v ...) => p
+(define (arg->identifier stx)
+ (syntax-case stx ()
+ (p
+ (symbol? (syntax->datum #'p))
+ #'p)
+ ;; an optional arg.
+ ((p . _)
+ #'p)))
+
+;; (a (b v1) #:c (c v2)) => (a b c)
+(define (args->identifiers stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ (args->identifiers #'rest))
+ ((p . rest)
+ #`(#,(arg->identifier #'p) . #,(args->identifiers #'rest)))))
+
+(define (args->kw+identifiers stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #`(p . #,(args->identifiers #'rest)))
+ ((p . rest)
+ #`(#,(arg->identifier #'p) . #,(args->identifiers #'rest)))))
+
+(define (args->kw-identifiers stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #`(p . #,(args->identifiers #'rest)))
+ ((p . rest)
+ (args->kw-identifiers #'rest))))
+;; (trace args->kw-identifiers)
+
+(define (args->kw-args stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #'(p . rest))
+ ((p . rest)
+ (args->kw-args #'rest))))
+
+(define (args->non-kw-identifiers stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #'())
+ ((p . rest)
+ #`(#,(arg->identifier #'p) . #,(args->non-kw-identifiers #'rest)))))
+
+(define (args->non-kw-args stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #'())
+ ((p . rest)
+ #`(p . #,(args->non-kw-args #'rest)))))
+
+(provide arg->identifier
+ args->identifiers
+ args->kw+identifiers
+ args->kw-identifiers
+ args->non-kw-identifiers
+ args->kw-args
+ args->non-kw-args
+ )
+
+;;; typed args...
+;;; a typed args look like an optional argument, except that
+;;; it has the following:
+;;; (id type?) (id type? default)
+(define (typed-arg? stx)
+ (match (syntax->datum stx)
+ ((list (? symbol? _) _) #t)
+ ((list (? symbol? _) _ _) #t)
+ (else #f)))
+
+(define (typed-arg->arg stx)
+ (syntax-case stx ()
+ ((p type)
+ #'p)
+ ((p type default)
+ #'(p default))))
+
+(define (typed-args->args stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ #`(p . #,(typed-args->args #'rest)))
+ ((p . rest)
+ #`(#,(typed-arg->arg #'p) . #,(typed-args->args #'rest)))))
+
+(define (typed-arg->type stx)
+ (syntax-case stx ()
+ ((p type)
+ #'type)
+ ((p type default)
+ #'type)))
+
+(define (typed-args->types stx)
+ (syntax-case stx ()
+ (()
+ #'())
+ ((p . rest)
+ (keyword? (syntax->datum #'p))
+ (typed-args->types #'rest))
+ ((p . rest)
+ #`(#,(typed-arg->type #'p) . #,(typed-args->types #'rest)))))
+
+(provide typed-args->args
+ typed-args->types
+ typed-arg->arg
+ typed-arg->type
+ )
+
+
+
diff --git a/ebus-racket/3rdparty/bzlib/base/assert.ss b/ebus-racket/3rdparty/bzlib/base/assert.ss
new file mode 100644
index 0000000..aea9349
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/assert.ss
@@ -0,0 +1,150 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; assert.ss - utility for verifying result of the values...
+;; yc 1/9/2010 - fixed let/assert! and let*/assert to allow for optional test function
+;; yc 2/10/2010 - move listof? to list.ss
+(require (for-syntax scheme/base "args.ss")
+ "base.ss"
+ (only-in mzlib/etc identity)
+ (prefix-in c: scheme/contract)
+ )
+
+(define-struct (exn:assert! exn) (test? exp expected actual))
+
+(define (error/assert! test? exp expected actual (name 'assert!))
+ (raise (make-exn:assert! (if (not expected)
+ (format "~a assert! (~a ~a); actual ~a" name test? exp actual)
+ (format "~a assert! (~a ~a ~a); actual ~a" name test? exp expected actual))
+ (current-continuation-marks) test? exp expected actual)))
+
+;; assert! v test? v2
+;; assert! v true?
+;; assert! v v2 (use equal for comparison) => we can get rid of this form...
+(define-syntax named-assert!
+ (syntax-rules ()
+ ((~ name exp test? expected)
+ (let ((actual exp))
+ (if (test? actual expected)
+ actual
+ (error/assert! 'test? 'exp 'expected actual 'name))))
+ ((~ name exp test?)
+ (let ((actual exp))
+ (if (test? actual)
+ actual
+ (error/assert! 'test? 'exp #f actual 'name))))
+ ((~ name exp)
+ (named-assert! name exp identity))
+ ))
+
+(define-syntax assert!
+ (syntax-rules ()
+ ((~ args ...)
+ (named-assert! assert! args ...))))
+
+
+(define-syntax let/assert!
+ (syntax-rules ()
+ ((~ ((id test? arg) ...) exp exp2 ...)
+ (let/assert! let/assert! ((id test? arg) ...) exp exp2 ...))
+ ((~ name ((id test? arg) ...) exp exp2 ...)
+ (let ((id arg) ...)
+ (let ((id (named-assert! name id test?)) ...) exp exp2 ...)))
+ ((~ ((id arg) ...) exp exp2 ...)
+ (let/assert! let/assert! ((id identity arg) ...) exp exp2 ...))
+ ((~ name ((id arg) ...) exp exp2 ...)
+ (let/assert! name ((id identity arg) ...) exp exp2 ...))
+ ))
+
+(define-syntax let*/assert!
+ (syntax-rules ()
+ ((~ name () exp exp2 ...)
+ (begin exp exp2 ...))
+ ((~ ((id test? arg) ...) exp exp2 ...)
+ (let*/assert! let*/assert! ((id test? arg) ...) exp exp2 ...))
+ ((~ name ((id test? arg) rest ...) exp exp2 ...)
+ (let/assert! name ((id test? arg))
+ (let*/assert! name (rest ...) exp exp2 ...)))
+ ((~ ((id arg) ...) exp exp2 ...)
+ (let*/assert! ((id identity arg) ...) exp exp2 ...))
+ ((~ name ((id arg) ...) exp exp2 ...)
+ (let*/assert! name ((id identity arg) ...) exp exp2 ...))
+ ))
+
+(define-syntax (lambda/assert! stx)
+ (syntax-case stx ()
+ ((~ name (a1 ... rest-id rest-type) exp exp2 ...)
+ (and (symbol? (syntax->datum #'name))
+ (symbol? (syntax->datum #'rest-id)))
+ (with-syntax (((arg ...)
+ (typed-args->args #'(a1 ...)))
+ ((id ...)
+ (args->identifiers #'(a1 ...)))
+ ((type ...)
+ (typed-args->types #'(a1 ...)))
+ )
+ #'(lambda (arg ... . rest-id)
+ (let/assert! name ((id type id) ...
+ (rest-id rest-type rest-id))
+ exp exp2 ...))))
+ ((~ name (a1 ...) exp exp2 ...)
+ (symbol? (syntax->datum #'name))
+ (with-syntax (((arg ...)
+ (typed-args->args #'(a1 ...)))
+ ((id ...)
+ (args->identifiers #'(a1 ...)))
+ ((type ...)
+ (typed-args->types #'(a1 ...)))
+ )
+ #'(lambda (arg ...) ;; this is the general idea.. but this general idea doesn't fully work...
+ (let/assert! name ((id type id) ...)
+ exp exp2 ...))))
+ ((~ (a1 ...) exp exp2 ...)
+ #'(~ lambda/assert! (a1 ...) exp exp2 ...))
+ ))
+
+(define-syntax define/assert!
+ (syntax-rules ()
+ ((~ (name . args) exp exp2 ...)
+ (define name
+ (lambda/assert! name args exp exp2 ...)))))
+
+(provide define/assert!
+ lambda/assert!
+ let*/assert!
+ let/assert!
+ assert!
+ named-assert!
+ )
+
+(c:provide/contract
+ (struct exn:assert! ((message string?)
+ (continuation-marks continuation-mark-set?)
+ (test? c:any/c)
+ (exp c:any/c)
+ (expected c:any/c)
+ (actual c:any/c)))
+ (error/assert! (c:->* (c:any/c c:any/c c:any/c c:any/c)
+ (symbol?)
+ c:any))
+ )
+
+#|
+;; if I want to define a contract... with the following form it can become quite complicated!!!
+
+;; we can also guard the arguments @ regular lamda and also let statement...
+;; guarding the arguments...
+(define/assert! (foo (a number?) (b number? 5) #:c (c number? 5))
+ (+ a b c))
+
+(define/assert! (foo2 (a number?) (b number? 10) . (rest (listof? number?)))
+ (apply + a b rest))
+(let/assert! ((a number? 3) (b number? 'abc))
+ (+ a b))
+;;|# \ No newline at end of file
diff --git a/ebus-racket/3rdparty/bzlib/base/base.ss b/ebus-racket/3rdparty/bzlib/base/base.ss
new file mode 100644
index 0000000..6ec8496
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/base.ss
@@ -0,0 +1,211 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; base.ss - basic functionalities that do not belong anywhere else.
+;; yc 9/8/2009 - first version
+;; yc 9/25/2009 - moved assert! & let/assert! to assert.ss
+;; yc 1/12/2010 - add let*/if
+;; yc 2/5/2010 - add define-case-test & case/equal? & case/string-ci=?
+;; yc 2/13/2010 - add isa/c
+(require (for-syntax scheme/base)
+ scheme/list
+ scheme/port
+ mzlib/etc
+ mzlib/trace
+ scheme/contract
+ scheme/function
+ )
+
+(define-syntax (trace-lambda stx)
+ (syntax-case stx ()
+ ((~ args exp exp2 ...)
+ #'(letrec ((func
+ (lambda args exp exp2 ...)))
+ (trace func)
+ func))))
+
+(define-syntax (if-it stx)
+ (syntax-case stx ()
+ [(src-if-it test then else)
+ (syntax-case (datum->syntax (syntax src-if-it) 'it) ()
+ [it (syntax (let ([it test]) (if it then else)))])]))
+
+(define-syntax (when-it stx)
+ (syntax-case stx ()
+ ((~ test? exp exp2 ...)
+ (with-syntax ((it (datum->syntax #'~ 'it)))
+ #'(let ((it test?)) (when it exp exp2 ...))))))
+
+(define-syntax (cond-it stx)
+ (syntax-case stx (else)
+ ((cond-it (else exp exp2 ...))
+ #'(begin exp exp2 ...))
+ ((cond-it (test? exp exp2 ...))
+ (with-syntax ((it (datum->syntax #'cond-it 'it)))
+ #'(let ((it test?)) (when it exp exp2 ...))))
+ ((cond-it (test? exp exp2 ...) cond cond2 ...)
+ (with-syntax ((it (datum->syntax #'cond-it 'it)))
+ #'(let ((it test?))
+ (if it (begin exp exp2 ...)
+ (cond-it cond cond2 ...)))))))
+
+(define-syntax while
+ (syntax-rules ()
+ ((while test exp exp2 ...)
+ (let loop ()
+ (when test
+ exp exp2 ...
+ (loop))))
+ ))
+
+(define-syntax let*/if
+ (syntax-rules ()
+ ((~ ((arg val)) exp exp2 ...)
+ (let ((arg val))
+ (if (not arg)
+ #f
+ (begin exp exp2 ...))))
+ ((~ ((arg val) (arg-rest val-rest) ...) exp exp2 ...)
+ (let ((arg val))
+ (if (not arg)
+ #f
+ (let*/if ((arg-rest val-rest) ...) exp exp2 ...))))))
+
+(define-syntax case/pred?
+ (syntax-rules (else)
+ ((~ pred? (else exp exp2 ...))
+ (begin exp exp2 ...))
+ ((~ pred? ((d d2 ...) exp exp2 ...))
+ (when (ormap pred? (list d d2 ...))
+ exp exp2 ...))
+ ((~ pred? ((d d2 ...) exp exp2 ...) rest ...)
+ (if (ormap pred? (list d d2 ...))
+ (begin exp exp2 ...)
+ (case/pred? pred? rest ...)))))
+
+(define-syntax define-case/test?
+ (syntax-rules ()
+ ((~ name test?)
+ (define-syntax name
+ (syntax-rules ()
+ ((~ v clause clause2 (... ...))
+ (case/pred? (curry test? v) clause clause2 (... ...)))))
+ )))
+
+
+(define-case/test? case/equal? equal?)
+(define-case/test? case/string-ci=? string-ci=?)
+
+;;|#
+
+;; (trace load-proc)
+;; a generic version of apply & keyword-apply that requires
+;; no sorting of the parameter args...
+(define (apply* proc . args)
+ (define (filter-kws args (acc '()))
+ (cond ((null? args) (reverse acc))
+ ((keyword? (car args))
+ (filter-kws (cdr args) (cons (car args) acc)))
+ (else
+ (filter-kws (cdr args) acc))))
+ (define (filter-kw-vals args (acc '()))
+ (cond ((null? args) (reverse acc))
+ ((keyword? (car args))
+ (if (null? (cdr args)) ;; this is wrong!!!
+ (error 'kw-apply "keyword ~a not followed by a value" (car args))
+ (filter-kw-vals (cddr args) (cons (cadr args) acc))))
+ (else
+ (filter-kw-vals (cdr args) acc))))
+ (define (filter-non-kw-vals args (acc '()))
+ (cond ((null? args) (reverse acc))
+ ((keyword? (car args))
+ (if (null? (cdr args))
+ (error 'kw-apply "keyword ~a not followed by a value" (car args))
+ (filter-non-kw-vals (cddr args) acc)))
+ (else
+ (filter-non-kw-vals (cdr args) (cons (car args) acc)))))
+ (define (sorted-kw+args args)
+ (let ((kw+args (sort (map (lambda (kw vals)
+ (cons kw vals))
+ (filter-kws args)
+ (filter-kw-vals args))
+ (lambda (kv kv1)
+ (keyword<? (car kv) (car kv1))))))
+ (values (map car kw+args) (map cdr kw+args))))
+ (define (normalize-args args)
+ (cond ((list? (last args))
+ (apply list* args))
+ (else (error 'apply* "Expect last arg as a list, given ~a" (last args)))))
+ (let ((args (normalize-args args)))
+ (let-values (((kws vals)
+ (sorted-kw+args args)))
+ (keyword-apply proc kws vals
+ (filter-non-kw-vals args)))))
+
+
+
+(define (value-or v (default #f))
+ (if (not v) default v))
+
+(define (null-or v (default #f))
+ (if (null? v) default v))
+
+(define (thunk? p)
+ (and (procedure? p)
+ (let ((a (procedure-arity p)))
+ (cond ((arity-at-least? a)
+ (= (arity-at-least-value a) 0))
+ ((number? a) (= a 0))
+ ((list? a) (member 0 a))))))
+
+;; isa/c
+;; this is useful but I did not include it until a bit too late... hmm...
+(define isa/c (-> any/c any))
+
+(define (typeof/c contract)
+ (-> contract any))
+
+(provide (all-from-out mzlib/etc
+ scheme/function
+ )
+ trace-lambda
+ if-it
+ when-it
+ cond-it
+ while
+ let*/if
+ case/pred?
+ define-case/test?
+ case/equal?
+ case/string-ci=?
+ isa/c
+ typeof/c
+ )
+
+
+(provide/contract
+ (apply* (->* (procedure?)
+ ()
+ #:rest (listof any/c)
+ any))
+ (value-or (->* (any/c)
+ (any/c)
+ any))
+ (null-or (->* (any/c)
+ (any/c)
+ any))
+ (thunk? (-> any/c boolean?))
+ )
diff --git a/ebus-racket/3rdparty/bzlib/base/bytes.ss b/ebus-racket/3rdparty/bzlib/base/bytes.ss
new file mode 100644
index 0000000..0edab66
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/bytes.ss
@@ -0,0 +1,206 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; bytes.ss - provides utility functions that works with bytes
+;; yc 10/19/2009 - first version
+;; yc 10/23/2009 - add read-bytes-avail that'll return the currently available bytes
+;; yc 10/24/2009 - add read-byte-list & read-byte-list/timeout
+;; yc 1/18/2010 - fix the issue that call-with-output-bytes was not available until v > 4.2
+;; yc 2/5/2010 - added string-char-ratios for accurately determien the ratio of ascii/latin-1/unicode chars
+(require scheme/port scheme/contract "version-case.ss" "base.ss")
+
+;; call-with-output-bytes is not available until 4.1
+(define *call-with-output-bytes
+ (+:version>= "4.2"
+ call-with-output-bytes
+ (lambda (proc)
+ (let ((out (open-output-bytes)))
+ (dynamic-wind void
+ (lambda ()
+ (proc out))
+ (lambda ()
+ (get-output-bytes out)))))))
+
+(define (port->bytes/charset in charset-in charset-out)
+ (*call-with-output-bytes
+ (lambda (out)
+ (convert-stream charset-in in charset-out out))))
+
+(define (bytes->bytes/charset bytes charset-in charset-out)
+ (port->bytes/charset (open-input-bytes bytes) charset-in charset-out))
+
+(define (bytes/charset->bytes/utf-8 bytes charset)
+ (bytes->bytes/charset bytes charset "utf-8"))
+
+(define (bytes/utf-8->bytes/charset bytes charset)
+ (bytes->bytes/charset bytes "utf-8" charset))
+
+;; there are more to handle (specifically charsets).
+(define (bytes/charset->string bytes charset)
+ (bytes->string/utf-8 (bytes/charset->bytes/utf-8 bytes charset)))
+
+(define (string->bytes/charset string charset)
+ (bytes/utf-8->bytes/charset (string->bytes/utf-8 string) charset))
+
+(define (char-latin-1? c)
+ (< 0 (char->integer c) 256))
+
+(define (char-ascii? c)
+ (< 0 (char->integer c) 128))
+
+(define (string-char-or? s test?)
+ (define (helper len i)
+ (if (= len i) #f
+ (if (test? (string-ref s i)) #t
+ (helper len (add1 i)))))
+ (helper (string-length s) 0))
+
+(define (string-char-and? s test?)
+ (define (helper len i)
+ (if (= len i) #t
+ (if (not (test? (string-ref s i))) #f
+ (helper len (add1 i)))))
+ (helper (string-length s) 0))
+
+(define (char-type c)
+ (let ((i (char->integer c)))
+ (cond ((< i 128) 'ascii)
+ ((< i 256) 'latin-1)
+ (else 'unicode))))
+
+(define (string-char-ratios s)
+ (define (helper ascii latin-1 unicode i len)
+ (if (= i len)
+ (values (/ ascii len)
+ (/ latin-1 len)
+ (/ unicode len))
+ (case (char-type (string-ref s i))
+ ((ascii) (helper (add1 ascii) latin-1 unicode (add1 i) len))
+ ((latin-1) (helper ascii (add1 latin-1) unicode (add1 i) len))
+ (else (helper ascii latin-1 (add1 unicode) (add1 i) len)))))
+ (if (= (string-length s) 0)
+ (values 1 0 0)
+ (helper 0 0 0 0 (string-length s))))
+
+(define (string-type s)
+ (define (helper len i prev)
+ (if (= len i) prev
+ (let ((type (char-type (string-ref s i))))
+ (case type
+ ((unicode) type)
+ ((latin-1)
+ (helper len (add1 i) (case prev
+ ((ascii) type)
+ (else prev))))
+ (else (helper len (add1 i) prev))))))
+ (helper (string-length s) 0 'ascii))
+
+(define (string-latin-1? s)
+ (string-char-and? s char-latin-1?))
+
+(define (string-ascii? s)
+ (string-char-and? s char-ascii?))
+
+(define (char->bytes c)
+ (string->bytes/utf-8 (string c)))
+
+(define (split-string-by-bytes-count str num)
+ (define (maker chars)
+ (list->string (reverse chars)))
+ (define (helper str i chars blen acc)
+ (if (= i (string-length str)) ;; we are done here!!!...
+ (reverse (if (null? chars) acc
+ (cons (maker chars) acc)))
+ (let* ((c (string-ref str i))
+ (count (char-utf-8-length c)))
+ (if (> (+ count blen) num) ;; we are done with this version....
+ (if (= blen 0) ;; this means the character itself is greater than the count.
+ (helper str (add1 i) '() 0 (cons (maker (cons c chars)) acc))
+ (helper str i '() 0 (cons (maker chars) acc)))
+ (helper str (add1 i) (cons c chars) (+ count blen) acc)))))
+ (helper str 0 '() 0 '()))
+
+(define (read-bytes-avail num in)
+ (define (helper bytes)
+ (let ((len (read-bytes-avail!* bytes in 0 num)))
+ (cond ((eof-object? len) bytes)
+ ((number? len) (subbytes bytes 0 len))
+ (else ;; this is a *special* value... I don't know what to do with it yet...
+ (len)))))
+ (helper (make-bytes num 0)))
+
+(define (read-byte-list num in)
+ (define (helper bytes)
+ (if (eof-object? bytes)
+ bytes
+ (bytes->list bytes)))
+ (helper (read-bytes num in)))
+
+(define (read-byte-list/timeout num in (timeout #f))
+ (define (helper alarm acc count)
+ (let ((evt (sync alarm in)))
+ (if (eq? alarm evt)
+ (reverse acc)
+ (let ((b (read-byte in)))
+ (cond ((eof-object? b)
+ (if (null? acc)
+ b
+ (reverse acc)))
+ ((= (add1 count) num)
+ (reverse (cons b acc)))
+ (else
+ (helper alarm (cons b acc) (add1 count))))))))
+ (helper (alarm-evt (+ (current-inexact-milliseconds) (* 1000 (if (not timeout)
+ +inf.0
+ timeout)))) '() 0))
+
+(define (read-bytes/timeout num in (timeout #f))
+ (define (helper bytes)
+ (if (eof-object? bytes)
+ bytes
+ (list->bytes bytes)))
+ (helper (read-byte-list/timeout num in timeout)))
+
+(define (positive-number? n)
+ (and (number? n) (> n 0)))
+
+(provide/contract
+ (char-ascii? (typeof/c char?))
+ (char-latin-1? (typeof/c char?))
+ (string-char-or? (-> string? (-> char? any) any))
+ (string-char-and? (-> string? (-> char? any) any))
+ (string-latin-1? (typeof/c string?))
+ (string-ascii? (typeof/c string?))
+ (char-type (typeof/c char?))
+ (string-char-ratios (-> string? (values number? number? number?)))
+ (string-type (typeof/c string?))
+ (split-string-by-bytes-count (-> string? exact-positive-integer? (listof string?)))
+ (port->bytes/charset (-> input-port? string? string? any))
+ (bytes->bytes/charset (-> bytes? string? string? bytes?))
+ (bytes/charset->bytes/utf-8 (-> bytes? string? bytes?))
+ (bytes/utf-8->bytes/charset (-> bytes? string? bytes?))
+ (bytes/charset->string (-> bytes? string? string?))
+ (string->bytes/charset (-> string? string? bytes?))
+ (read-bytes-avail (-> exact-positive-integer? input-port? bytes?))
+ (read-byte-list (-> exact-positive-integer? input-port? bytes?))
+ (read-bytes/timeout (->* (exact-positive-integer? input-port?)
+ ((or/c #f positive-number?))
+ bytes?))
+ (read-byte-list/timeout (->* (exact-positive-integer? input-port?)
+ ((or/c #f positive-number?))
+ any))
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/base/info.ss b/ebus-racket/3rdparty/bzlib/base/info.ss
new file mode 100644
index 0000000..f07b881
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/info.ss
@@ -0,0 +1,27 @@
+#lang setup/infotab
+(define name "bzlib/base: common utilities for bzlib")
+
+(define blurb
+ '((p "bzlib/base provides the common utilities that other bzlib packages depend on. Currently this package's interface might drastically change and will not be directly supported until it stablizes.")))
+
+(define release-notes
+ '((p "0.6 (1 6) - fixed syntax-identifier-append, added registry-clear!")
+ (p "0.5 (1 5) - adding read-bytes-avail, read-byte-list, read-byte-list/timeout, read-bytes/timeout, version.ss, version-case.ss, fixed let/assert!, added let*/assert, fixed bytes.ss needing (version) >= 4.1, added let*/if, added isa/c & typeof/c")
+ (p "0.4 (1 3) - adding bytes.ss & require.ss & syntax.ss (args.ss, assert.ss, syntax.ss, & require.ss are likely to be moved to another package)")
+ (p "0.3 (1 2) - added assert.ss, args.ss, and refactored group to here from dbd-memcached")
+ (p "0.2 (1 1) - added assert! & let/assert!")
+ (p "0.1 (1 0) - first release")))
+
+(define categories
+ '(devtools net misc))
+
+(define homepage "http://weblambda.blogspot.com")
+
+(define required-core-version "4.0")
+
+(define version "0.6")
+
+(define repositories '("4.x"))
+
+(define primary-file "main.ss")
+
diff --git a/ebus-racket/3rdparty/bzlib/base/list.ss b/ebus-racket/3rdparty/bzlib/base/list.ss
new file mode 100644
index 0000000..44b64f0
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/list.ss
@@ -0,0 +1,109 @@
+
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list.ss - basic functionalities that has to do with list processing.
+;; yc 9/8/2009 - first version
+;; yc 9/25/2009 - moved group from bzlib/dbd-memcached/dht to here; exported scheme/list
+;; yc 2/10/2010 - move listof? from assert.ss (not sure why it was there) to list.ss
+(require "base.ss" scheme/list scheme/contract)
+
+(define (assoc/cdr key alist (default #f))
+ (if-it (assoc key alist)
+ (cdr it)
+ default))
+
+(define (assoc/s key alist (default '()))
+ (let ((it (filter (lambda (kv)
+ (equal? (car kv) key))
+ alist)))
+ (if (null? it) default it)))
+
+;; this function is a combo of member & assoc
+;; it's useful when we have a malformed alist, where when the
+;; pair has no value, the key is retained
+;; (or when there is no key, the value is retained)
+(define (assoc* key lst (default #f))
+ (define (helper rest)
+ (cond ((null? rest) default)
+ ;; assoc behavior
+ ((and (pair? (car rest))
+ (equal? key (caar rest)))
+ (car rest))
+ ;; member behavior
+ ((and (not (pair? (car rest)))
+ (equal? key (car rest)))
+ rest)
+ (else
+ (helper (cdr rest)))))
+ ;; (trace helper)
+ (helper lst))
+
+(define (assoc*/cdr key lst (default #f))
+ (if-it (assoc* key lst)
+ (cdr it)
+ default))
+
+
+(define (group alist)
+ ;; for each alist with the same key - group them together!!
+ (foldl (lambda (kv interim)
+ (if-it (assoc (car kv) interim) ;; the key already exists...
+ (cons (cons (car it) (cons (cdr kv) (cdr it)))
+ (filter (lambda (kv)
+ (not (equal? it kv))) interim))
+ (cons (list (car kv) (cdr kv)) interim)))
+ '()
+ alist))
+
+
+(define (list->unique lst (equal? equal?))
+ (reverse (foldl (lambda (item interim)
+ (if (memf (lambda (item1)
+ (equal? item item1))
+ interim)
+ interim
+ (cons item interim)))
+ '()
+ lst)))
+
+(define (listof? type?)
+ (lambda (args)
+ (and (list? args)
+ (andmap type? args))))
+
+
+(provide/contract
+ (assoc/cdr (->* (any/c list?)
+ (any/c)
+ any))
+ (assoc/s (->* (any/c list?)
+ (any/c)
+ any))
+ (assoc* (->* (any/c list?)
+ (any/c)
+ any))
+ (assoc*/cdr (->* (any/c list?)
+ (any/c)
+ any))
+ (group (-> (or/c null? pair?) any))
+ (list->unique (->* (pair?)
+ (procedure?)
+ any))
+ (listof? (-> isa/c isa/c))
+ )
+(provide (all-from-out scheme/list))
+
diff --git a/ebus-racket/3rdparty/bzlib/base/main.ss b/ebus-racket/3rdparty/bzlib/base/main.ss
new file mode 100644
index 0000000..b722783
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/main.ss
@@ -0,0 +1,49 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; main.ss - provide all other modules...
+;; yc 9/8/2009 - first version
+;; yc 9/11/2009 - added uuid.ss
+;; yc 9/25/2009 - added assert.ss & move args.ss from port.plt
+;; yc 10/13/2009 - adding bytes.ss
+;; yc 10/19/2009 - adding require.ss & syntax.ss (it seems that all syntax-based files can be splitted away)...
+;; yc 1/18/2010 - added version.ss & version-case.ss
+(require "args.ss"
+ "assert.ss"
+ "base.ss"
+ "bytes.ss"
+ "list.ss"
+ "registry.ss"
+ "require.ss"
+ "syntax.ss"
+ "text.ss"
+ "uuid.ss"
+ "version.ss"
+ "version-case.ss"
+ )
+(provide (all-from-out "args.ss"
+ "assert.ss"
+ "base.ss"
+ "bytes.ss"
+ "list.ss"
+ "registry.ss"
+ "require.ss"
+ "syntax.ss"
+ "text.ss"
+ "uuid.ss"
+ "version.ss"
+ "version-case.ss"
+ ))
diff --git a/ebus-racket/3rdparty/bzlib/base/registry.ss b/ebus-racket/3rdparty/bzlib/base/registry.ss
new file mode 100644
index 0000000..d0b0c72
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/registry.ss
@@ -0,0 +1,215 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; registry.ss - generalized key/value access (including an extensible condition object)
+;; yc 9/8/2009 - first version
+;; yc 7/7/2010 - add registry-clear! & modified registry definition.
+(require mzlib/pconvert-prop
+ scheme/port
+ scheme/string
+ scheme/contract
+ "base.ss"
+ )
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; registry
+;; a abstraction over key/value pairs
+
+(define-struct registry (get set del make (table #:mutable)))
+
+(define (registry-set! reg key val)
+ (set-registry-table! reg
+ ((registry-set reg) (registry-table reg) key val)))
+
+(define (registry-del! reg key)
+ (set-registry-table! reg
+ ((registry-del reg) (registry-table reg) key)))
+
+(define (registry-ref reg key (default #f))
+ ((registry-get reg) (registry-table reg) key default))
+;; (trace registry-ref)
+
+(define (registry-clear! reg) ;; clearing the registry... we need to fill it with a default value, of course.
+ ;; that means we need a way to get the default value... does that mean we will have to empty out the whole value...
+ ;; is there a way to do so without adding a new field?
+ ;; it is completely unclear... hmm...
+ ;; a hash's function is make-hash...
+ ;; an immutable-hash's function is make-immutable-hash-helper...
+ ;; an assoc's function
+ (set-registry-table! reg ((registry-make reg))))
+
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-hash-registry
+(define (make-hash-registry (hash (make-hash)))
+ (define (set hash key val)
+ (hash-set! hash key val)
+ hash)
+ (define (del hash key)
+ (hash-remove! hash key)
+ hash)
+ (define (make (value (make-hash)))
+ (cond ((hash? value) value)
+ ((list? value)
+ (let ((h (make-hash)))
+ (for-each (lambda (kv)
+ (hash-set! h (car kv) (cdr kv)))
+ value)
+ h))
+ (else (error 'make-hash-unknown-input "~a" value))))
+ (make-registry hash-ref set del make (make hash)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-immutable-hash-registry
+(define (make-immutable-hash-registry (hash (make-immutable-hash '())))
+ (define (make (value (make-immutable-hash '())))
+ (cond ((and (immutable? value) (hash? value)) value)
+ ((hash? value) (make-immutable-hash (hash-map value cons)))
+ ((list? value) (make-immutable-hash value))
+ (else (error 'make-immutable-hash-unknown-input "~a" value))))
+ (make-registry hash-ref hash-set hash-remove make (make hash)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; make-assoc-registry (not thread safe if multiple addition & deletion)
+;; let's also a list registry via assoc.
+(define (assoc-ref lst key (default #f))
+ (define (assoc/cdr key value (default #f))
+ (let ((value (assoc key value)))
+ (if (not value) default
+ (cdr value))))
+ (assoc/cdr key lst default))
+;; (trace assoc-ref)
+;; if we just want to remove the first guy with the key... how to do that? not with filter.
+
+(define (assoc-del lst key)
+ (define (helper k kv)
+ (equal? k (car kv)))
+ ;; (trace helper)
+ (remove key lst helper))
+
+(define (assoc-set lst key val)
+ (let ((exists? #f))
+ (let ((lst (map (lambda (kv)
+ (cons (car kv)
+ (cond ((equal? (car kv) key)
+ (set! exists? #t)
+ val)
+ (else (cdr kv)))))
+ lst)))
+ (if exists? lst
+ (cons (cons key val) lst)))))
+
+(define (make-list (lst '()))
+ (if (list? lst)
+ lst
+ (error 'make-assoc-list-unknown-input "~a" lst)))
+
+(define (make-assoc-registry (lst '()))
+ (make-registry assoc-ref assoc-set assoc-del make-list (make-list lst)))
+
+;; what can be passed into ? it must be a list of lists.
+(define (list->assoc-registry lst)
+ (define (helper kvs)
+ (cons (car kvs)
+ (make-assoc-registry (cdr kvs))))
+ ;; (trace helper)
+ (make-assoc-registry (map helper lst)))
+
+(define (assoc-registry->list reg)
+ (map (lambda (kv)
+ (cons (car kv)
+ (registry-table (cdr kv))))
+ (registry-table reg)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; cond-registry (takes in a cond & result pair).
+(define (cond-ref lst key (default #f))
+ (let ((it (assf (lambda (cond)
+ (cond key)) lst)))
+ (if (not it) default
+ (cdr it))))
+
+(define (make-cond-registry (lst '()))
+ (make-registry cond-ref assoc-set assoc-del make-list (make-list lst)))
+
+(provide/contract
+ (struct registry ((get (->* (any/c any/c)
+ (any/c)
+ any))
+ (set (-> any/c any/c any/c any))
+ (del (-> any/c any/c any))
+ (make (->* ()
+ (any/c)
+ any/c))
+ (table any/c)))
+ (registry-ref (->* (registry? any/c)
+ (any/c)
+ any))
+ (registry-set! (-> registry? any/c any/c any))
+ (registry-del! (-> registry? any/c any))
+ (registry-clear! (-> registry? any))
+ (make-hash-registry (->* ()
+ ((or/c list? hash?))
+ registry?))
+ (make-immutable-hash-registry (->* ()
+ ((or/c list? (and/c immutable? hash?)))
+ registry?))
+ (assoc-ref (->* (list? any/c)
+ (any/c)
+ any))
+ (assoc-set (-> list? any/c any/c any))
+ (assoc-del (-> list? any/c any))
+ (make-assoc-registry (->* ()
+ (list?)
+ registry?))
+ (list->assoc-registry (-> list? registry?))
+ (assoc-registry->list (-> registry? list?))
+ (make-cond-registry (->* ()
+ (list?)
+ registry?))
+ )
+
+;; let's see how something can be flushed...
+(define (registry->out reg out)
+ (write (registry-table reg) out))
+
+(define (registry->string reg)
+ (let ((out (open-output-bytes)))
+ (registry->out reg out)
+ (get-output-string out)))
+
+(define (in->registry in)
+ (let ((value (read in)))
+ (cond ((list? value)
+ (make-assoc-registry value))
+ ((and (hash? value) (immutable? value))
+ (make-immutable-hash-registry value))
+ ((hash? value)
+ (make-hash-registry value))
+ ((eof-object? value)
+ (make-assoc-registry))
+ (else
+ (error 'in->registry "unknown registry type ~a" value)))))
+
+(define (string->registry string)
+ (in->registry (open-input-string string)))
+
+(provide/contract
+ (registry->out (-> registry? output-port? any))
+ (registry->string (-> registry? string?))
+ (in->registry (-> input-port? registry?))
+ (string->registry (-> string? registry?))
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/base/require.ss b/ebus-racket/3rdparty/bzlib/base/require.ss
new file mode 100644
index 0000000..fced045
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/require.ss
@@ -0,0 +1,32 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; require.ss - require-like syntaxes
+;; yc 10/19/2009 - first version
+(require (for-syntax scheme/base "syntax.ss")
+ )
+
+(define-syntax (provide/strip-prefix stx)
+ (syntax-case stx ()
+ ((~ prefix out ...)
+ (with-syntax (((in ...)
+ (syntax-map (lambda (s)
+ (syntax-identifier-append #'prefix s))
+ #'(out ...))))
+ #'(provide (rename-out (in out) ...))))))
+
+(provide provide/strip-prefix)
+
diff --git a/ebus-racket/3rdparty/bzlib/base/syntax.ss b/ebus-racket/3rdparty/bzlib/base/syntax.ss
new file mode 100644
index 0000000..a5fbb27
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/syntax.ss
@@ -0,0 +1,62 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; synatx.ss - syntax helpers
+;; yc 10/19/2009 - first version
+;; yc 7/6/2010 - fixed syntax-identifier-append
+(require (for-syntax scheme/base)
+ syntax/stx scheme/string mzlib/trace
+ scheme/contract
+ )
+
+(define (syntax-map proc stx-lst)
+ (syntax-case stx-lst ()
+ (() #'())
+ ((id . rest)
+ #`(#,(proc #'id) . #,(syntax-map proc #'rest)))))
+
+(define (syntax-identifier-append arg #:stx (stx #f) . args)
+ (define (get-first-syntax lst)
+ (define (helper lst)
+ (cond ((null? lst) (error 'syntax-identifier-append "no stx for context"))
+ ((syntax? (car lst)) (car lst))
+ (else (helper (cdr lst)))))
+ (if (not stx) (helper lst) stx))
+ (define (->string x)
+ (cond ((syntax? x) (->string (syntax->datum x)))
+ (else (format "~a" x))))
+ (define (helper args)
+ (datum->syntax (get-first-syntax args)
+ (string->symbol (string-join (map ->string args) ""))))
+ (helper (cons arg args)))
+
+(define (syntax-id-part? stx)
+ (define (helper part)
+ (or (symbol? part) (bytes? part) (string? part) (number? part)))
+ (or (and (syntax? stx)
+ (helper (syntax->datum stx)))
+ (helper stx)))
+
+(provide/contract
+ (syntax-map (-> (-> any/c any) stx-pair? any))
+ (syntax-identifier-append (->* (syntax-id-part?)
+ (#:stx syntax?)
+ #:rest (listof syntax-id-part?)
+ syntax?))
+ )
+
+(provide (all-from-out syntax/stx))
+
diff --git a/ebus-racket/3rdparty/bzlib/base/text.ss b/ebus-racket/3rdparty/bzlib/base/text.ss
new file mode 100644
index 0000000..1185b17
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/text.ss
@@ -0,0 +1,69 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; text.ss - basic "text" (or string) service.
+;; yc 9/8/2009 - first version
+;; yc 2/1/2010 - adding the ability to extend the behavior of the string function...
+(require "base.ss"
+ scheme/string
+ "registry.ss"
+ scheme/function
+ scheme/contract
+ )
+
+(define default->string (curry format "~a"))
+
+(define string-converter-table (make-cond-registry '()))
+
+(define (string-converter-ref obj)
+ (registry-ref string-converter-table obj default->string))
+
+(define (string-converter-set! type? converter)
+ (registry-set! string-converter-table type? converter))
+
+(define (string-converter-del! type?)
+ (registry-del! string-converter-table type?));;
+
+(define (stringify* arg . args)
+ (stringify (cons arg args)))
+
+(define (any->string v)
+ (cond ((string? v) v)
+ (else
+ ((string-converter-ref v) v))))
+
+(define (stringify args)
+ (string-join (map any->string args) ""))
+
+(provide/contract
+ (stringify* (->* (any/c)
+ ()
+ #:rest (listof any/c)
+ string?))
+ (stringify (-> (listof any/c) string?))
+ ;;(string-converter-table registry?)
+ (string-converter-ref (-> any/c any))
+ (string-converter-set! (-> procedure? procedure? any))
+ (string-converter-del! (-> procedure? any))
+ (any->string (-> any/c string?))
+ (rename stringify* any*->string (->* (any/c)
+ ()
+ #:rest (listof any/c)
+ string?))
+ (rename stringify any/list->string (-> (listof any/c) string?))
+ )
+
+(provide (all-from-out scheme/string)) \ No newline at end of file
diff --git a/ebus-racket/3rdparty/bzlib/base/uuid.ss b/ebus-racket/3rdparty/bzlib/base/uuid.ss
new file mode 100644
index 0000000..d4cf293
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/uuid.ss
@@ -0,0 +1,202 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; uuid.ss - provide uuid object (currently wrapping over zitterbewegung/uuid-v4)
+;; yc 9/11/2009 - first version
+(require (prefix-in z: "../../zitterbewegung/uuid/uuid-v4.ss")
+ "base.ss"
+ scheme/list
+ scheme/string
+ scheme/contract
+ ;; (planet vyzo/crypto/util)
+ )
+
+(define (bytes->integer bytes)
+ (define (helper rest num)
+ (if (null? rest) num
+ (helper (cdr rest) (+ (* num 255) (car rest)))))
+ (helper (bytes->list bytes) 0))
+
+(define (bytes->hex bytes)
+ (define (helper rest acc)
+ (if (null? rest) (list->string (map hex-byte->char (reverse acc)))
+ (helper (cdr rest)
+ (let-values (((quotient remainder)
+ (quotient/remainder (car rest) 16)))
+ (list* remainder quotient acc)))))
+ (helper (bytes->list bytes) '()))
+
+;; *uuid structure - representing UUID, and holds bytes format...
+(define-struct *uuid (bytes)
+ #:property prop:custom-write
+ (lambda (u out write?)
+ (display (format "#<uuid:~a>" (uuid->string u)) out))
+ #:property prop:equal+hash
+ (list (lambda (u1 u2 sub?)
+ (bytes=? (*uuid-bytes u1) (*uuid-bytes u2)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))))
+
+(define (uuid-time-low u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 0 4) #f #t))
+
+(define (uuid-time-mid u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 4 6) #f #t))
+
+(define (uuid-time-high u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 6 8) #f #t))
+
+(define (uuid-clock-high u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 8 9)) #f #t))
+
+(define (uuid-clock-low u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 9 10)) #f #t))
+
+(define (uuid-node u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0 0))
+ (subbytes (*uuid-bytes u) 10 16)) #f #t))
+
+(define (uuid->string u (dash? #t))
+ (define (sub start end)
+ (subbytes (*uuid-bytes u) start end))
+ (if (not dash?)
+ (bytes->hex (*uuid-bytes u))
+ (string-join (map (lambda (b)
+ (bytes->hex b))
+ (list (sub 0 4) (sub 4 6) (sub 6 8) (sub 8 10) (sub 10 16)))
+ "-")))
+
+
+(define (uuid-string? u)
+ (and (string? u)
+ (regexp-match #px"^(?i:([0-9a-f]{,8})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,12}))$" u)))
+
+(define (uuid-symbol? u)
+ (and (symbol? u)
+ (uuid-string? (symbol->string u))))
+
+(define (uuid-bytes? u)
+ (and (bytes? u)
+ (= (bytes-length u) 16)))
+
+;; an uuid should be one of the following:
+;; struct of *uuid
+;; 16-bytes byte string.
+;; a string of 32 or 36 hex chars.
+(define (uuid? u)
+ (or (*uuid? u)
+ (uuid-bytes? u)
+ (uuid-string? u)))
+
+(define (make-uuid (u (symbol->string (z:make-uuid))))
+ (cond ((*uuid? u)
+ (make-*uuid (*uuid-bytes u)))
+ ((uuid-bytes? u)
+ (make-*uuid u))
+ (else
+ (uuid-string->uuid u))))
+
+(define (hex-byte->char h)
+ (case h
+ ((0) #\0)
+ ((1) #\1)
+ ((2) #\2)
+ ((3) #\3)
+ ((4) #\4)
+ ((5) #\5)
+ ((6) #\6)
+ ((7) #\7)
+ ((8) #\8)
+ ((9) #\9)
+ ((10) #\a)
+ ((11) #\b)
+ ((12) #\c)
+ ((13) #\d)
+ ((14) #\e)
+ ((15) #\f)
+ (else (error 'hex-byte->char "Not an hex byte: ~a" h))))
+
+(define (hex-char->integer c)
+ (case c
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ ((#\0) 0)
+ ((#\a #\A) 10)
+ ((#\b #\B) 11)
+ ((#\c #\C) 12)
+ ((#\d #\D) 13)
+ ((#\e #\E) 14)
+ ((#\f #\F) 15)
+ (else (error 'hex-char->integer "char ~a out of range" c))))
+
+(define (hex-char? c)
+ (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F)))
+
+(define (hex-chars->byte chars)
+ (define (helper rest num)
+ (if (null? rest)
+ num
+ (helper (cdr rest) (+ (* 16 num) (hex-char->integer (car rest))))))
+ (helper chars 0))
+
+(define (hex-string->bytes h)
+ (define (helper rest acc)
+ (cond ((null? rest) (reverse acc))
+ ((null? (cdr rest)) ;; wrong
+ (error 'hex-string->bytes "Uneven # of hexdecimal strings: ~a" h))
+ (else
+ (helper (cddr rest)
+ (cons (hex-chars->byte (list (car rest) (cadr rest)))
+ acc)))))
+ (helper (string->list h) '()))
+
+(define (uuid-string->uuid uuid)
+ (make-*uuid (list->bytes (flatten (map hex-string->bytes (cdr (uuid-string? uuid)))))))
+
+;; how quickly can all the generation take?
+;; it seems that
+(provide/contract
+ (make-uuid (->* ()
+ (uuid?)
+ *uuid?))
+ (uuid->string (->* (*uuid?)
+ (boolean?)
+ string?))
+ (rename *uuid-bytes uuid->bytes (-> *uuid? bytes?))
+ (uuid-string? (-> any/c any))
+ (uuid-bytes? (-> any/c any))
+ (uuid-time-low (-> *uuid? number?))
+ (uuid-time-mid (-> *uuid? number?))
+ (uuid-time-high (-> *uuid? number?))
+ (uuid-clock-low (-> *uuid? number?))
+ (uuid-clock-high (-> *uuid? number?))
+ (uuid-node (-> *uuid? number?))
+ (uuid? (-> any/c any))
+ (bytes->hex (-> bytes? string?))
+ (bytes->integer (-> bytes? number?))
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/base/version-case.ss b/ebus-racket/3rdparty/bzlib/base/version-case.ss
new file mode 100644
index 0000000..a9f60d7
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/version-case.ss
@@ -0,0 +1,118 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; version-case.ss - version-based macros
+;; yc 1/18/2010 - first version
+(require (for-syntax scheme/base
+ "version.ss"
+ )
+ "version.ss"
+ )
+
+(define-syntax (+:version stx)
+ (syntax-case stx (between > >= < <= = != else)
+ ((~) #'(void))
+ ((~ (else exp)) #'exp)
+ ((~ ((between min max) exp) rest ...)
+ (version<=? (syntax->datum #'min)
+ (version)
+ (syntax->datum #'max))
+ #'exp)
+ ((~ ((between min max) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((> v) exp) rest ...)
+ (version>? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((> v) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((>= v) exp) rest ...)
+ (version>=? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((>= v) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((< v) exp) rest ...)
+ (version<? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((< v) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((<= v) exp) rest ...)
+ (version<=? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((<= v) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((= v) exp) rest ...)
+ (version=? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((= v) exp) rest ...)
+ #'(~ rest ...))
+ ((~ ((!= v) exp) rest ...)
+ (version!=? (version) (syntax->datum #'v))
+ #'exp)
+ ((~ ((!= v) exp) rest ...)
+ #'(~ rest ...))
+ ))
+
+(define-syntax +:version-between
+ (syntax-rules ()
+ ((~ min max exp otherwise)
+ (+:version ((between min max) exp) (else otherwise)))
+ ))
+
+(define-syntax define-version-if
+ (syntax-rules ()
+ ((~ name comp)
+ (define-syntax name
+ (syntax-rules ()
+ ((~ v exp otherwise)
+ (+:version ((comp v) exp) (else otherwise))))))
+ ))
+
+(define-version-if +:version> >)
+
+(define-version-if +:version>= >=)
+
+(define-version-if +:version< <)
+
+(define-version-if +:version<= <=)
+
+(define-version-if +:version= =)
+
+(define-version-if +:version!= !=)
+
+(define-syntax require/v
+ (syntax-rules ()
+ ((~ (test s1 ...) ...)
+ (+:version (test (require s1 ...)) ...))
+ ))
+
+(define-syntax provide/v
+ (syntax-rules ()
+ ((~ (test s1 ...) ...)
+ (+:version (test (provide s1 ...)) ...))
+ ))
+
+(provide +:version
+ +:version-between
+ +:version>
+ +:version>=
+ +:version<
+ +:version<=
+ +:version=
+ +:version!=
+ require/v
+ provide/v
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/base/version.ss b/ebus-racket/3rdparty/bzlib/base/version.ss
new file mode 100644
index 0000000..0932012
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/base/version.ss
@@ -0,0 +1,71 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; version.ss - version comparison utilities as well as version-based macros
+;; yc 1/18/2010 - first version
+(require (prefix-in v: version/utils)
+ scheme/contract
+ (for-syntax scheme/base
+ (prefix-in v: version/utils))
+ mzlib/trace
+ )
+
+(define (version? v)
+ (and (string? v)
+ (integer? (v:version->integer v))))
+
+(define (vcomp? comp? v v2 vs)
+ (apply comp? (map v:version->integer (list* v v2 vs))))
+
+(define (version<? v v2 . vs)
+ (vcomp? < v v2 vs))
+;; (trace version<?)
+
+(define (version<=? v v2 . vs)
+ (vcomp? <= v v2 vs))
+;; (trace version<=?)
+
+(define (version>=? v v2 . vs)
+ (vcomp? >= v v2 vs))
+;; (trace version>=?)
+
+(define (version>? v v2 . vs)
+ (vcomp? > v v2 vs))
+;; (trace version>?)
+
+(define (version=? v v2 . vs)
+ (vcomp? = v v2 vs))
+;; (trace version=?)
+
+(define (version!=? v v2 . vs)
+ (vcomp? (compose not =) v v2 vs))
+;; (trace version!=?)
+
+(define vcomp/c (->* (version? version?)
+ ()
+ #:rest (listof version?)
+ boolean?))
+
+(provide/contract
+ (version? (-> any/c boolean?))
+ (version<? vcomp/c)
+ (version<=? vcomp/c)
+ (version>=? vcomp/c)
+ (version>? vcomp/c)
+ (version=? vcomp/c)
+ (version!=? vcomp/c)
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/parseq/basic.ss b/ebus-racket/3rdparty/bzlib/parseq/basic.ss
new file mode 100644
index 0000000..4e5d94a
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/basic.ss
@@ -0,0 +1,200 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; basic.ss - a set of basic parsers
+;; yc 12/31/2009 - first version
+;; yc 7/7/2010 - updating real-number to also handle exponents.
+
+(require "depend.ss"
+ "primitive.ss"
+ "combinator.ss"
+ "input.ss"
+ )
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; char parsers.
+;; digit
+(define digit (char-between #\0 #\9))
+
+;; not-digit
+(define not-digit (char-not-between #\0 #\9))
+
+;; lower-case
+(define lower-case (char-between #\a #\z))
+
+;; upper-case
+(define upper-case (char-between #\A #\Z))
+
+;; alpha
+(define alpha (choice lower-case upper-case))
+
+;; alphanumeric
+(define alphanumeric (choice alpha digit))
+
+;; hexdecimal parser
+(define hexdecimal (char-in '(#\a #\b #\c #\d #\e #\f
+ #\A #\B #\C #\D #\E #\F
+ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))
+
+;; whitespace
+(define whitespace (char-in '(#\space #\return #\newline #\tab #\vtab)))
+
+(define not-whitespace (char-not-in '(#\space #\return #\newline #\tab #\vtab)))
+
+;; ascii
+(define ascii (char-between (integer->char 0) (integer->char 127)))
+
+;; word = a-zA-Z0-9_
+(define word (choice alphanumeric (char= #\_)))
+
+;; not-word
+(define not-word (char-when (lambda (c)
+ (not (or (char<=? #\a c #\z)
+ (char<=? #\A c #\Z)
+ (char<=? #\0 c #\9)
+ (char=? c #\_))))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; number parsers.
+
+;; signed
+(define sign (zero-one (char= #\-) #\+))
+
+;; natural
+(define natural (one-many digit))
+
+;; decimal
+;; there is a bug - anything fails in seq should automatically fail the whole thing...
+(define decimal (seq number <- (zero-many digit)
+ point <- (char= #\.)
+ decimals <- natural
+ (return (append number (cons point decimals)))))
+
+(define (hexdecimals->number hexes)
+ (define (hex->num hex)
+ (- (char->integer hex)
+ (char->integer (case hex
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) #\0)
+ ((#\a #\b #\c #\d #\e #\f) #\a)
+ ((#\A #\B #\C #\D #\E #\F) #\A)))
+ (- (case hex
+ ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) 0)
+ ((#\a #\b #\c #\d #\e #\f) 10)
+ ((#\A #\B #\C #\D #\E #\F) 10)))))
+ (define (helper rest total)
+ (if (null? rest)
+ total
+ (helper (cdr rest) (+ (hex->num (car rest)) (* total 16)))))
+ ;;(trace helper)
+ ;;(trace hex->num)
+ (helper hexes 0))
+
+(define hexdecimals (seq num <- (zero-many hexdecimal)
+ (return (hexdecimals->number num))))
+
+;; positive
+(define positive (choice decimal natural))
+
+;; signed (number)
+(define (make-signed parser)
+ (seq +/- <- sign
+ number <- parser
+ (return (cons +/- number))))
+
+;; make-number
+(define (make-number parser)
+ (seq n <- parser
+ (return (string->number (list->string n)))))
+
+;; natural-number
+(define natural-number (make-number natural))
+
+;; integer
+(define integer (make-number (make-signed natural)))
+
+;; positive-integer
+(define positive-number (make-number positive))
+
+;; real-number (now handling exponents)
+(define real-number (make-number (choice (seq exp <- (make-signed positive)
+ e <- (choice #\E #\e)
+ magenta <- (make-signed natural)
+ (return (append exp (list e) magenta)))
+ (make-signed positive)
+ )))
+
+(define hexdecimal-number (make-number hexdecimals))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string parsers.
+
+;; escaped-char
+;; allows for an escaping sequence for a particular character...
+(define (escaped-char escape char (as #f))
+ (seq (char= escape)
+ c <- (if (char? char) (char= char) char)
+ (return (if as as c))))
+
+;; e-newline
+(define e-newline (escaped-char #\\ #\n #\newline))
+
+;; e-return
+(define e-return (escaped-char #\\ #\r #\return))
+
+;; e-tab
+(define e-tab (escaped-char #\\ #\t #\tab))
+
+;; e-backslash
+(define e-backslash (escaped-char #\\ #\\))
+
+;; quoted
+;; a specific string-based bracket parser
+(define (quoted open close escape)
+ (seq (char= open)
+ atoms <- (zero-many (choice e-newline
+ e-return
+ e-tab
+ e-backslash
+ (escaped-char escape close)
+ (char-not-in (list close #\\))))
+ (char= close)
+ (return atoms)))
+
+;; make-quoted-string
+;; a simplification for creating a string parser
+(define (make-quoted-string open (close #f) (escape #\\))
+ (seq v <- (quoted open (if close close open) escape)
+ (return (list->string v))))
+
+;; single-quoted-string
+;; parse a string with single quotes
+(define single-quoted-string (make-quoted-string #\'))
+
+;; double-quoted-string
+;; parse a string with double quotes
+(define double-quoted-string (make-quoted-string #\"))
+
+;; quoted-string
+;; choosing between single and double quotes
+(define quoted-string
+ (choice single-quoted-string double-quoted-string))
+
+;; whitespaces
+;; parsing out all whitespaces together...
+(define whitespaces (zero-many whitespace))
+
+;; newline
+(define newline
+ (choice (seq r <- (char= #\return)
+ n <- (char= #\newline)
+ (return (list r n)))
+ (char= #\return)
+ (char= #\newline)))
+
+(provide (all-defined-out))
diff --git a/ebus-racket/3rdparty/bzlib/parseq/combinator.ss b/ebus-racket/3rdparty/bzlib/parseq/combinator.ss
new file mode 100644
index 0000000..b68764d
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/combinator.ss
@@ -0,0 +1,208 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; combinator.ss - higher level combinator for parsers...
+;; yc 12/31/2009 - first version
+;; yc 1/5/2010 - moved delimited, bracket, and alternate to token.ss
+(require "depend.ss"
+ mzlib/defmacro
+ (for-syntax scheme/base
+ "depend.ss"
+ scheme/match
+ )
+ "primitive.ss"
+ "input.ss"
+ )
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parser COMBINATORS
+
+;; bind
+;; Parser a -> (a -> Parser b) -> Parser b
+;; this is the function version of the monad - use this when you want to
+;; create higher combinators dynamically...
+(define (bind parser v->parser)
+ (lambda (in)
+ (let-values (((v in)
+ (parser in)))
+ ((v->parser v) in))))
+
+;; result
+;; allows the transformation of the result of the parser...
+(define (result parser transform)
+ (bind parser
+ (lambda (v)
+ (if (succeeded? v)
+ (return (transform v))
+ fail))))
+
+(define (result* parser transform)
+ (bind parser
+ (lambda (v)
+ (if (and (succeeded? v) (list? v))
+ (return (apply transform v))
+ fail))))
+
+;; seq
+;; the macro-based monad for stringing multiple parsers together...
+;; (seq parser) => parser
+;; (seq v <- parser exp ...) => (bind paser (lambda (v) (if v (seq exp ...) fail))
+(define-macro (seq . exps)
+ (define *in (gensym 'in)) ;; represents the input
+ (define *v (gensym 'v)) ;; represents the value
+ (define literal 'literal)
+ ;; sequence body for creating a sequence combinator...
+ (define (body exps)
+ (match exps
+ ((list exp)
+ `((,literal ,exp) ,*in))
+ ((list-rest var '<- exp rest)
+ `(let-values (((,var ,*in)
+ ((,literal ,exp) ,*in)))
+ (if (succeeded? ,var)
+ ,(body rest)
+ (fail in))))
+ ((list-rest exp rest)
+ (body `(,*v <- ,exp . ,rest)))
+ ))
+ `(lambda (in)
+ (let ((,*in in))
+ ,(body exps))))
+
+;; sequence
+;; a functional version of seq
+(define (sequence parsers)
+ (lambda (IN)
+ (define (helper parsers in acc)
+ (if (null? parsers)
+ ((return (reverse acc)) in)
+ (let-values (((v in)
+ ((car parsers) in)))
+ (if (succeeded? v)
+ (helper (cdr parsers) in (cons v acc))
+ (fail IN)))))
+ (helper (map literal parsers) IN '())))
+
+;; sequence*
+(define (sequence* . parsers)
+ (sequence parsers))
+
+;; #|
+;; choice
+;; (choice parser) => (bind parser (lambda (v) (if v (return v) fail))
+;; (choice parser rest ...) => (bind parser (lambda (v) (if v (choice rest ...) fail)))
+(define-macro (choice . exps)
+ (define *in (gensym 'in)) ;; represents the input
+ (define *v (gensym 'v)) ;; represents the value
+ (define (body exps)
+ (match exps
+ ((list)
+ `(fail ,*in))
+ ((list-rest exp rest)
+ `(let-values (((,*v ,*in)
+ ((literal ,exp) ,*in)))
+ (if (succeeded? ,*v)
+ ((return ,*v) ,*in)
+ ,(body rest))))
+ ))
+ `(lambda (,*in)
+ ,(body exps)))
+;;|#
+
+;; one-of
+;; a function version of choice
+(define (one-of parsers)
+ (lambda (in)
+ (define (helper parsers)
+ (if (null? parsers)
+ (fail in)
+ (let-values (((v in)
+ ((car parsers) in)))
+ (if (succeeded? v)
+ ((return v) in)
+ (helper (cdr parsers))))))
+ (helper (map literal parsers))))
+
+;; one-of*
+(define (one-of* . parsers)
+ (one-of parsers))
+
+;; all-of
+(define (all-of parsers)
+ (lambda (in)
+ (define (helper parsers v)
+ (if (null? parsers)
+ ((return v) in)
+ (let-values (((v IN)
+ ((car parsers) in)))
+ (if (succeeded? v)
+ (helper (cdr parsers) v)
+ (fail in)))))
+ (helper (map literal parsers) (make-failed 0))))
+
+;; all-of*
+(define (all-of* . parsers)
+ (all-of parsers))
+
+;; repeat
+;; returns when # of occurence falls within the min and max range
+;; default to [1,+inf]
+(define (repeat parser (min 1) (max +inf.0))
+ (define (make parser)
+ (lambda (IN)
+ (define (helper prev-in acc count)
+ (let-values (((v in)
+ (parser prev-in)))
+ (if (succeeded? v)
+ (if (< count max)
+ (helper in (cons v acc) (add1 count))
+ ((return (reverse acc)) prev-in))
+ (if (< count min)
+ (fail IN)
+ ((return (reverse acc)) in)))))
+ (helper IN '() 0)))
+ (make (literal parser)))
+
+;; zero-many
+;; returns the matched values if zero or more matches
+;; (this means that this parser will always match)
+(define (zero-many parser)
+ (repeat parser 0))
+
+;; one-many
+;; matches if parser parses one or more times
+(define (one-many parser)
+ (repeat parser))
+
+;; zero-one
+;; returns if the parser matches zero or one times
+;; when the parser does not match, it defaults to fail, but you can pass in a
+;; default value so it does not fail.
+(define (zero-one parser default)
+ (lambda (in)
+ (let-values (((v in)
+ ((literal parser) in)))
+ ((return (if (succeeded? v) v default)) in))))
+
+(provide bind
+ result
+ result*
+ seq
+ sequence
+ sequence*
+ choice
+ one-of
+ one-of*
+ all-of
+ all-of*
+ repeat
+ zero-many
+ one-many
+ zero-one
+ )
diff --git a/ebus-racket/3rdparty/bzlib/parseq/depend.ss b/ebus-racket/3rdparty/bzlib/parseq/depend.ss
new file mode 100644
index 0000000..03737ad
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/depend.ss
@@ -0,0 +1,3 @@
+#lang scheme
+(require "../base/main.ss")
+(provide (all-from-out "../base/main.ss"))
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss
new file mode 100644
index 0000000..35ada60
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss
@@ -0,0 +1,51 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; calc.ss - a simple arithmetic calculator
+;; yc 12/31/2009 - first version
+(require "../main.ss"
+ )
+
+;; determine the operator (currently there are no precedences)...
+(define OP (tokens op <- (char-in '(#\+ #\- #\* #\/))
+ (return (case op
+ ((#\+) +)
+ ((#\-) -)
+ ((#\*) *)
+ ((#\/) /)))))
+
+(define NUMBER (token real-number))
+
+;; expr := term op term
+(define expr (tokens lhs <- term
+ (let loop ((lhs lhs))
+ (choice (tokens opr <- OP
+ rhs <- term
+ (loop (list opr lhs rhs)))
+ (return lhs)))))
+;; term := factor op factor
+(define term (tokens lhs <- factor
+ (let loop ((lhs lhs))
+ (choice (tokens opr <- OP
+ rhs <- factor
+ (loop (list opr lhs rhs)))
+ (return lhs)))))
+
+;; factor := number | ( exp )
+(define factor (choice NUMBER (bracket #\( expr #\))))
+
+(define (calc in)
+ (define (helper exp)
+ (cond ((number? exp) exp)
+ ((pair? exp)
+ (apply (car exp)
+ (map helper (cdr exp))))))
+ (helper ((make-reader expr) in)))
+
+(provide calc)
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss
new file mode 100644
index 0000000..4fd1526
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss
@@ -0,0 +1,42 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; csv.ss - a customizable csv reader
+;; yc 12/31/2009 - first version
+(require "../main.ss"
+ )
+
+;; creating a delimiter-based string.
+(define (delim-string delim)
+ (seq s <- (zero-many (choice (escaped-char #\\ delim)
+ (char-not-in (list delim #\return #\newline))))
+ (return (list->string s))))
+
+;; csv-string
+;; combine between quoted string and delimited string
+(define (csv-string delim)
+ (choice quoted-string (delim-string delim)))
+
+;; csv-record
+;; reads a list of csv-strings by skipping over the delimiters
+(define (csv-record delim)
+ (delimited (csv-string delim) (char= delim)))
+
+;; csv-table
+;; reads over a csv-table
+(define (csv-table delim)
+ (delimited (csv-record delim) newline))
+
+;; make-csv-reader
+;; creates a csv-reader based on the delim...
+(define (make-csv-reader delim)
+ (make-reader (csv-table delim)))
+
+;; contract
+(provide make-csv-reader)
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/json.ss b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss
new file mode 100644
index 0000000..c8df746
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss
@@ -0,0 +1,135 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; json.ss - a parser for the json format
+;; yc 1/5/2010 - first version
+;; yc 7/76/2010 - updated json-string to handle single quotes.
+(require "../main.ss"
+ )
+
+(define hex-digit (seq d <- (choice digit #\a #\b #\c #\d #\e #\f
+ #\A #\B #\C #\D #\E #\F)
+ (return (case d
+ ((#\0) 0)
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ ((#\a #\A) 10)
+ ((#\b #\B) 11)
+ ((#\c #\C) 12)
+ ((#\d #\D) 13)
+ ((#\e #\E) 14)
+ ((#\f #\F) 15)))))
+
+(define (hex->char h)
+ (case h
+ ((0) #\0)
+ ((1) #\1)
+ ((2) #\2)
+ ((3) #\3)
+ ((4) #\4)
+ ((5) #\5)
+ ((6) #\6)
+ ((7) #\7)
+ ((8) #\8)
+ ((9) #\9)
+ ((10) #\a)
+ ((11) #\b)
+ ((12) #\c)
+ ((13) #\d)
+ ((14) #\e)
+ ((15) #\f)))
+
+
+(define (hexes->char hexes)
+ (integer->char (hexes->integer hexes)))
+
+(define (char->hexes c)
+ (integer->hexes (char->integer c)))
+
+(define (char->hex-chars c)
+ (map hex->char (char->hexes c)))
+
+(define (hexes->integer hexes)
+ (define (helper rest acc)
+ (cond ((null? rest) acc)
+ (else
+ (helper (cdr rest) (+ (* acc 16) (car rest))))))
+ (helper hexes 0))
+
+(define (integer->hexes i)
+ (define (helper q acc)
+ (if (= q 0)
+ acc
+ (let-values (((q r)
+ (quotient/remainder q 16)))
+ (helper q (cons r acc)))))
+ (helper i '()))
+
+(define unicode-char
+ (seq #\\ #\u
+ code <- (repeat hex-digit 4 4)
+ (return (hexes->char code))))
+
+(define (json-string/inner quote)
+ (zero-many (choice e-newline
+ e-return
+ e-tab
+ e-backslash
+ (escaped-char #\\ quote)
+ (escaped-char #\\ #\/)
+ (escaped-char #\\ #\\)
+ (escaped-char #\\ #\b #\backspace)
+ (escaped-char #\\ #\f #\page)
+ unicode-char
+ (char-not-in (list quote
+ #\newline
+ #\return
+ #\tab
+ #\\
+ #\backspace
+ #\page))
+ )))
+
+(define json-string
+ (choice (seq #\' atoms <- (json-string/inner #\') #\'
+ (return (list->string atoms)))
+ (seq #\" atoms <- (json-string/inner #\") #\"
+ (return (list->string atoms)))))
+
+(define json-array (tokens v <- (bracket/delimited #\[ json-value #\, #\])
+ (return (list->vector v))))
+
+(define json-object (tokens v <- (bracket/delimited #\{ json-pair #\, #\})
+ (return (make-immutable-hash v))))
+
+(define json-pair (tokens key <- (choice json-string
+ (seq c <- alpha
+ lst <- (zero-many alphanumeric)
+ (return (list->string (cons c lst)))))
+ #\:
+ value <- json-value
+ (return (cons key value))))
+
+(define json-literal (choice (tokens "true" (return #t))
+ (tokens "false" (return #f))
+ (tokens "null" (return '()))
+ ))
+
+(define json-value (choice json-literal json-array json-object real-number json-string))
+
+(define read-json (make-reader json-value))
+
+(provide read-json)
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss
new file mode 100644
index 0000000..299b999
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss
@@ -0,0 +1,163 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; regex.ss - a simple regular expression parser
+;; yc 1/1/2009 - first version
+(require "../main.ss"
+ mzlib/trace
+ )
+
+;; sof = start of file
+(define regex-sof (zero-one (char= #\^) #\$))
+
+;; eof = end of file
+(define regex-eof (zero-one (char= #\$) #\^))
+
+;; meta-chars - a list of meta characters
+(define regex-meta-chars '( #\. #\+ #\* #\? #\^ #\$ #\[ #\] #\( #\) #\{ #\} #\\))
+
+;; digit = \\d
+(define regex-digit (seq "\\d" (return digit)))
+
+;; not-digit = \\D
+(define regex-not-digit (seq "\\D" (return not-digit)))
+
+;; word = \\w
+(define regex-word (seq "\\w" (return word)))
+
+;; not-word = \\W
+(define regex-not-word (seq "\\W" (return not-word)))
+
+;; whitespace = \\s
+(define regex-whitespace (seq "\\s" (return whitespace)))
+
+;; not-whitespace = \\S
+(define regex-not-whitespace (seq "\\S" (return not-whitespace)))
+
+;; any-char = .
+(define regex-any-char (seq #\. (return any-char)))
+
+;; literal = \\d | \\D | \\w | \\W | \\s | \\S | . | \n | \r | \t | \\ | other chars
+(define regex-literal (choice regex-digit
+ regex-not-digit
+ regex-word
+ regex-not-word
+ regex-whitespace
+ regex-not-whitespace
+ regex-any-char
+ (seq v <- (choice e-newline
+ e-return
+ e-tab
+ (escaped-char #\\ any-char)
+ (char-not-in regex-meta-chars))
+ (return (char= v)))))
+
+;; atom = literal | group | choice
+(define regex-atom (choice regex-literal
+ regex-group
+ regex-choice
+ ))
+
+;; char-range = <lc>-<hc>, e.g., a-z
+(define regex-char-range (seq lc <- (char-not-in (cons #\- regex-meta-chars))
+ #\-
+ hc <- (char-not-in (cons #\- regex-meta-chars))
+ (return `(,char-between ,lc ,hc))))
+
+;; choice = [<char-range | literal>+]
+(define regex-choice (seq #\[
+ literals <- (one-many (choice regex-char-range
+ regex-literal))
+ #\]
+ (return `(,one-of* ,@literals))))
+
+;; group = (<atom>+)
+(define regex-group (seq #\(
+ chars <- (one-many regex-atom)
+ #\)
+ (return `(,sequence* ,@chars))))
+
+;; regex combinators
+;; zero-one = <atom>?
+(define regex-zero-one (seq v <- regex-atom
+ #\?
+ (return `(,zero-one ,v))))
+;; zero-many = <atom>*
+(define regex-zero-many (seq v <- regex-atom
+ #\*
+ (return `(,zero-many ,v))))
+
+;; one-many = <atom>+
+(define regex-one-many (seq v <- regex-atom
+ #\+
+ (return `(,one-many ,v))))
+
+;; range = <atom>{min,max} | <atom>{times}
+(define regex-range (seq v <- regex-atom
+ #\{
+ min <- (zero-one natural-number 0)
+ max <- (zero-one (seq #\,
+ max <- (zero-one natural-number +inf.0)
+ (return max))
+ min)
+ #\}
+ (return `(,repeat ,v ,min ,max))))
+
+;; exp = sof ? <zero-one | zero-many | one-many | range | atom>* eof ?
+(define regex-exp (seq SOF
+ sof <- regex-sof
+ atoms <- (zero-many (choice regex-zero-one
+ regex-zero-many
+ regex-one-many
+ regex-range
+ regex-atom
+ ))
+ eof <- regex-eof
+ EOF
+ (return `(,regex-parser* ,@(if (char=? sof #\^)
+ `(,SOF)
+ '())
+ ,@atoms
+ ,@(if (char=? eof #\$)
+ `(,EOF)
+ '())))))
+
+;; regex-parser
+;; convert the regexp into an useable parser, which including determining
+;; whether to allow for
+(define (regex-parser parsers)
+ (let ((regexp (sequence parsers)))
+ (if (eq? (car parsers) SOF)
+ regexp
+ (seq v <- (choice regexp
+ (seq any-char (regex-parser parsers)))
+ (return v)))))
+
+;; regex-parser*
+;; the variable arg form of regex-parser
+(define (regex-parser* parser . parsers)
+ (regex-parser (cons parser parsers)))
+
+;; make-regex-exp
+;; wrapper over regex...
+(define (make-regex-exp in)
+ (define (helper exp)
+ (cond ((list? exp) (apply (car exp) (map helper (cdr exp))))
+ (else exp)))
+ ;; (trace helper)
+ (let-values (((exp in)
+ (regex-exp (make-input in))))
+ (if (failed? exp)
+ (error 'make-regex-exp "the regular expression is invalid")
+ (lambda (in)
+ ((helper exp) (make-input in))))))
+
+(provide regex-parser
+ make-regex-exp
+ )
diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss
new file mode 100644
index 0000000..3863ab1
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss
@@ -0,0 +1,138 @@
+#lang scheme
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; sql.ss - parsing the create table statement
+;; yc 1/5/2010 - first version
+(require "../main.ss"
+ mzlib/defmacro
+ (for-syntax scheme/base
+ scheme/match
+ )
+ (planet bzlib/base)
+ )
+
+(define sql-identifier
+ (seq c <- alpha
+ rest <- (zero-many word)
+ (return (string->symbol
+ (string-downcase (list->string (cons c rest)))))))
+
+(define create-table-def
+ (tokens-ci "create" "table"
+ name <- sql-identifier
+ clauses <- (bracket #\(
+ (delimited clause-def #\,)
+ #\))
+ (return (cons name clauses))))
+
+(define clause-def
+ (choice primary-key-def foreign-key-def column-def))
+
+;; making things without order would be quite a difficult combinator.
+;; basically we need to try each of the combinator, and then as we have the binding
+;; make sure it is returned in a way that can easily be identified...
+;; for example, the first
+(define (self-and-value parser)
+ (seq v <- parser
+ (return (cons parser v))))
+
+(define (one-of-each parsers defaults)
+ ;; we need to try each one, and then figure out the *rest* that weren't matched
+ ;; continue until we are either out of the stream or out of the combinator...
+ ;; at any time there is anything that none of them matches then we will be in trouble...
+ (define (each-helper parsers)
+ (one-of (map self-and-value parsers)))
+ (define (sort-helper acc parsers defaults)
+ (map (lambda (v default)
+ (if (pair? v)
+ (cdr v)
+ default))
+ (map (lambda (parser)
+ (assf (lambda (p)
+ (eq? p parser))
+ acc))
+ parsers)
+ defaults))
+ ;; if all of them failed @ the next position, then we need to offer
+ ;; default values for the remainder of the parsers!!!
+ ;; this is where it is *interesting!!!...
+ ;; in such case we want to have a chance to work on the *fail* clause...
+ ;; this is hmm....
+ (define (helper rest acc)
+ (bind (each-helper rest)
+ (lambda (v)
+ (if (succeeded? v)
+ (let ((rest (remove (car v) rest)))
+ (if (null? rest)
+ (return (sort-helper acc parsers defaults))
+ (helper rest (cons v acc))))
+ (return (sort-helper acc parsers defaults))))))
+ (helper parsers '()))
+
+(define-syntax one-of-each*
+ (syntax-rules ()
+ ((~ (parser default) ...)
+ (one-of-each (list parser ...) (list default ...)))))
+
+(define column-def
+ (tokens name <- sql-identifier
+ attrs <- (one-of-each* (type-def 'text)
+ (nullability 'null)
+ (inline-primary-key #f)
+ (inline-foreign-key #f))
+ (return (cons name attrs))))
+
+(define nullability
+ (choice (tokens-ci "null" (return 'null))
+ (tokens-ci "not" "null" (return 'not-null))))
+
+(define type-def
+ (seq type <- (choice (string-ci= "int")
+ (string-ci= "integer")
+ (string-ci= "float")
+ (string-ci= "text"))
+ (return (string->symbol type))))
+
+(define inline-primary-key
+ (tokens-ci "primary" "key" (return 'pkey)))
+;; (trace inline-primary-key)
+
+(define sql-identifiers/paren
+ (bracket #\( (delimited sql-identifier #\,) #\)))
+
+(define inline-foreign-key
+ (tokens-ci "foreign" "key"
+ (zero-one (string-ci= "references") "references")
+ table <- sql-identifier
+ (zero-one (string-ci= "on") "on")
+ columns <- sql-identifiers/paren
+ (return `(foreign-key ,table ,columns))))
+
+(define primary-key-def
+ (tokens-ci "primary" "key"
+ name <- (zero-one sql-identifier #f)
+ columns <- sql-identifiers/paren
+ (return `(primary-key ,name ,columns))))
+
+(define foreign-key-def
+ (tokens-ci "foreign" "key"
+ name <- (zero-one sql-identifier #f)
+ columns <- sql-identifiers/paren
+ (string-ci= "references")
+ table <- sql-identifier
+ (zero-one (string-ci= "on") "on")
+ fk-columns <- sql-identifiers/paren
+ (return `(foreign-key ,name ,columns ,table ,fk-columns))))
+
+;; (provide create-table-def)
+(define sql-def (choice create-table-def))
+
+(define read-sql (make-reader sql-def))
+
+(provide read-sql)
diff --git a/ebus-racket/3rdparty/bzlib/parseq/info.ss b/ebus-racket/3rdparty/bzlib/parseq/info.ss
new file mode 100644
index 0000000..689c099
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/info.ss
@@ -0,0 +1,35 @@
+#lang setup/infotab
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; info.ss
+;; yc 12/31/2009 - first version
+(define name "BZLIB/PARSEQ: a monadic parser combinator library")
+
+(define blurb
+ '((p "Inspired by Haskell's Parse, bzlib/parsec provides a monadic parser combinator library that can handle both character and binary data parsing. ")))
+
+(define release-notes
+ '((p "0.4 (1 3) - added ability to parse exponents to real-number, and updated read-json to handle single quoted string")
+ (p "0.3 (1 2) - added additional tokenizers")
+ (p "0.2 (1 1) - fixed a bug with the all-of combinator")
+ (p "0.1 (1 0) - first release")))
+
+(define categories
+ '(devtools net misc))
+
+(define homepage "http://weblambda.blogspot.com")
+
+(define required-core-version "4.0")
+
+(define version "0.3")
+
+(define repositories '("4.x"))
+
+(define primary-file "main.ss")
+
diff --git a/ebus-racket/3rdparty/bzlib/parseq/input.ss b/ebus-racket/3rdparty/bzlib/parseq/input.ss
new file mode 100644
index 0000000..406b6f2
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/input.ss
@@ -0,0 +1,83 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; input.ss - holds the abstraction of the input object...
+;; yc 12/31/2009 - first version
+;; yc 1/8/2009 - fix build-input & Input/c
+(require scheme/contract)
+;; state
+;; the struct that abstracts the input
+;; currently this holds an input-port + the position on the port
+;; in the future this can be used to hold string, list, vector, etc.
+(define-struct input (source pos) #:prefab)
+
+;; input
+;; an utility for converting source into input state.
+(define (build-input v (pos 0))
+ (define (helper v)
+ (cond ((input-port? v) v)
+ ((string? v) (open-input-string v))
+ ((bytes? v) (open-input-bytes v))))
+ (if (input? v)
+ (new-input v pos)
+ (make-input (helper v) pos)))
+
+;; new-input
+;; make a new input based on the old input and a new position...
+(define (new-input input incr)
+ (make-input (input-source input)
+ (+ incr (input-pos input))))
+
+;; peek-bytes*
+;; return a funtion that will make a particular amount of reading based on
+;; the requested size...
+(define (peek-bytes* size)
+ (lambda (in)
+ (peek-bytes size (input-pos in) (input-source in))))
+
+;; peek-string*
+;; return a function that will read a particular size of string...
+;; this can fail since it is expected to be using utf-8 as the input size...
+(define (peek-string* size)
+ (lambda (in)
+ (peek-string size (input-pos in) (input-source in))))
+
+;; peek-byte*
+;; peek a single byte
+(define (peek-byte* in)
+ (peek-byte (input-source in) (input-pos in)))
+
+;; peek-char*
+;; peek a single char
+(define (peek-char* in)
+ (peek-char (input-source in) (input-pos in)))
+
+;; read-bytes*
+;; read out the bytes based on the size of the input...
+(define (read-bytes* in)
+ (read-bytes (input-pos in) (input-source in)))
+
+(define Input/c (or/c input? bytes? string? input-port?))
+
+(define Parser/c (-> Input/c (values any/c Input/c)))
+
+(provide input
+ input?
+ input-source
+ input-pos
+ (rename-out (build-input make-input))
+ new-input
+ peek-bytes*
+ peek-string*
+ peek-byte*
+ peek-char*
+ read-bytes*
+ Input/c
+ Parser/c
+ ) \ No newline at end of file
diff --git a/ebus-racket/3rdparty/bzlib/parseq/main.ss b/ebus-racket/3rdparty/bzlib/parseq/main.ss
new file mode 100644
index 0000000..407ef93
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/main.ss
@@ -0,0 +1,32 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; main.ss - wrapper around the main modules
+;; yc 12/31/2009 - first version
+;; yc 1/5/2010 - added token.ss
+;; yc 1/18/2010 - add reader.ss
+
+(require "input.ss"
+ "util.ss"
+ "primitive.ss"
+ "combinator.ss"
+ "basic.ss"
+ "token.ss"
+ "reader.ss"
+ )
+(provide (all-from-out "input.ss"
+ "util.ss"
+ "primitive.ss"
+ "combinator.ss"
+ "basic.ss"
+ "token.ss"
+ "reader.ss"
+ )
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/parseq/primitive.ss b/ebus-racket/3rdparty/bzlib/parseq/primitive.ss
new file mode 100644
index 0000000..2fcece5
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/primitive.ss
@@ -0,0 +1,233 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; primitive.ss - holds the primitive parsers...
+;; yc 12/31/2009 - first version
+;; yc 1/5/2010 - added literal & literal-ci
+;; yc 1/18/2010 - move make-reader to reader.ss
+
+(require "depend.ss"
+ "util.ss"
+ "input.ss"
+ scheme/contract
+ )
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; primitive parsers
+
+;; return
+(define (return v (size 0))
+ (lambda (in)
+ (values v
+ (new-input in size))))
+
+;; struct failed - represents failed parse...
+(define-struct failed (pos) #:prefab)
+
+;; succeeded?
+(define (succeeded? v) (not (failed? v)))
+
+;; fail - the parser that returns failed with the current port position.
+(define (fail in)
+ (values (make-failed (input-pos in))
+ in))
+
+;; SOF (start-of-file)
+;; returns true only when the input-pos = 0
+(define (SOF in)
+ ((if (= (input-pos in) 0)
+ (return 'sof)
+ fail) in))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; item-based primitive parsers
+
+;; item
+;; the fundamental building block
+(define (item peek isa? satisfy? size)
+ (lambda (in)
+ (let ((v (peek in)))
+ ((if (and (isa? v) (satisfy? v))
+ (return v (size v))
+ fail) in))))
+
+;; bytes=
+;; parses if the next part of the input matches the exact bytes
+(define (bytes= bytes)
+ (let ((size (bytes-length bytes)))
+ (item (peek-bytes* size)
+ bytes?
+ (lambda (b)
+ (bytes=? b bytes))
+ (the-number size))))
+
+;; string=
+;; parses if the next part of the input matches the exact string
+(define (string= s (comp? string=?))
+ (let ((size (string-bytes/utf-8-length s)))
+ (item (peek-string* size)
+ string?
+ (lambda (str)
+ (comp? str s))
+ (the-number size))))
+
+(define (string-ci= s)
+ (string= s string-ci=?))
+
+;; byte-when
+;; return the next byte when satisfy matches
+(define (byte-when satisfy? (isa? byte?) (size (the-number 1)))
+ (item peek-byte* isa? satisfy? size))
+
+;; any-byte
+;; return the next byte
+(define any-byte (byte-when identity))
+
+;; byte=
+(define (byte= b) (byte-when (lambda (v)
+ (= b v))))
+
+;; EOF
+;; return if the next byte is eof
+(define EOF (byte-when identity eof-object? (the-number 0)))
+
+;; bits=
+;; matches a byte @ the bits level... (pass in the individual bits)
+(define (bits= bits)
+ (byte-when (lambda (b) (= b (bits->byte bits)))))
+
+;; byte-in
+(define (byte-in bytes)
+ (byte-when (lambda (b) (member b bytes))))
+
+(define (byte-not-in bytes)
+ (byte-when (lambda (b) (not (member b bytes)))))
+
+(define (byte-between lb hb)
+ (byte-when (lambda (b) (<= lb b hb))))
+
+(define (byte-not-between lb hb)
+ (byte-when (compose not (lambda (b) (<= lb b hb)))))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; character-based parsers
+
+;; char-when
+;; the fundamental character-based parser
+(define (char-when satisfy?)
+ (item peek-char* char? satisfy? char-utf-8-length))
+
+;; any-char
+;; return the next character
+(define any-char (char-when identity))
+
+;; char=
+;; return the next character if it equals c
+(define (char= c (comp? char=?) (trans identity))
+ (char-when (lambda (v) (trans (comp? c v)))))
+
+;; char-ci=
+(define (char-ci= c) (char= c char-ci=?))
+
+;; char-not
+;; return the next character if it is not c
+(define (char-not= c (comp? char=?)) (char= c comp? not))
+
+;; char-ci-not
+(define (char-ci-not= c) (char-not= char-ci=?))
+
+;; char-between
+;; return the next character if it falls in between lc & hc
+(define (char-between lc hc (comp? char<=?) (trans identity))
+ (char-when (lambda (v) (trans (comp? lc v hc)))))
+
+;; char-ci-between
+(define (char-ci-between lc hc) (char-between lc hc char-ci<=?))
+
+(define (char-not-between lc hc (comp? char<=?))
+ (char-between lc hc comp? not))
+
+;; char-ci-not-between
+(define (char-ci-not-between lc hc) (char-not-between lc hc char-ci<=?))
+
+;; char-in
+;; return the next character if it one of the chars
+(define (char-in chars (comp? char=?) (trans identity))
+ (char-when (lambda (v)
+ (trans (memf (lambda (c)
+ (comp? c v))
+ chars)))))
+
+;; char-ci-in
+(define (char-ci-in chars) (char-in chars char-ci=?))
+
+;; char-not-in
+;; return the next character if it is not one of the characters
+(define (char-not-in chars (comp? char=?)) (char-in chars comp? not))
+
+;; char-ci-not-in
+(define (char-ci-not-in chars) (char-not-in chars char-ci=?))
+
+;; literal
+;; returns a parser based on the passed in literal
+(define (literal p)
+ (cond ((char? p) (char= p))
+ ((byte? p) (byte= p))
+ ((string? p) (string= p))
+ ((bytes? p) (bytes= p))
+ (else p)))
+
+;; literal-ci
+;; a ci version of literal
+(define (literal-ci p)
+ (cond ((char? p) (char-ci= p))
+ ((string? p) (string-ci= p))
+ (else (literal p))))
+
+(define Literal/c (or/c string? bytes? char? byte?))
+
+(define Literal-Parser/c (or/c Literal/c Parser/c))
+
+(provide return
+ (struct-out failed)
+ succeeded?
+ fail
+ SOF
+ item
+ bytes=
+ string=
+ string-ci=
+ byte-when
+ any-byte
+ byte=
+ EOF
+ bits=
+ byte-in
+ byte-not-in
+ byte-between
+ byte-not-between
+ char-when
+ any-char
+ char=
+ char-ci=
+ char-not=
+ char-ci-not=
+ char-between
+ char-ci-between
+ char-not-between
+ char-ci-not-between
+ char-in
+ char-ci-in
+ char-not-in
+ char-ci-not-in
+ literal
+ literal-ci
+ Literal/c
+ Literal-Parser/c
+ )
diff --git a/ebus-racket/3rdparty/bzlib/parseq/reader.ss b/ebus-racket/3rdparty/bzlib/parseq/reader.ss
new file mode 100644
index 0000000..50a5f9d
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/reader.ss
@@ -0,0 +1,41 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; reader.ss - move make-reader & Reader/c here
+;; yc 1/18/2010 - first version
+;; yc 1/21/2010 - make-reader to take on additional default params
+(require "depend.ss"
+ "input.ss"
+ "primitive.ss"
+ "combinator.ss"
+ (prefix-in c: scheme/contract)
+ )
+;; use this to create a reader that will read the bytes if the parse succeeds.
+(define (make-reader parser #:sof? (sof? #t) #:eof? (eof? #t) #:default (default #f))
+ (lambda (in #:sof? (sof? sof?) #:eof? (eof? eof?) #:default (default default))
+ (let-values (((v in)
+ ((seq (if sof? SOF (return #t))
+ v <- parser
+ (if eof? EOF (return #t))
+ (return v)) (make-input in))))
+ (unless (failed? v) (read-bytes* in))
+ (if (failed? v)
+ default
+ v))))
+
+(define Reader/c (c:->* (Input/c)
+ (#:sof? boolean? #:eof? boolean? #:default c:any/c)
+ c:any))
+(provide Reader/c)
+(c:provide/contract
+ (make-reader (c:->* (Parser/c)
+ (#:sof? boolean? #:eof? boolean? #:default c:any/c)
+ Reader/c))
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/parseq/token.ss b/ebus-racket/3rdparty/bzlib/parseq/token.ss
new file mode 100644
index 0000000..cbeb492
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/token.ss
@@ -0,0 +1,100 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; token.ss - token-based parser combinators.
+;; yc 1/5/2010 - first version
+;; yc 1/31/2010 - add tokens/by to allow for custom tokenizer, fix token to consume trailing whitespaces as well...
+(require "primitive.ss"
+ "combinator.ss"
+ "basic.ss"
+ "input.ss"
+ mzlib/defmacro
+ (for-syntax scheme/base
+ scheme/match
+ )
+ scheme/list
+ )
+
+;; token
+;; tokenizing a particular value...
+(define (token parser (delim whitespaces))
+ (seq delim
+ t <- parser
+ delim
+ (return t)))
+
+(define (token/pre parser (delim whitespaces))
+ (seq delim t <- parser (return t)))
+
+(define-macro (tokens/by tokenizer . exps)
+ (define (body exps)
+ (match exps
+ ((list exp) (list exp))
+ ((list-rest v '<- exp rest)
+ `(,v <- (,tokenizer ,exp) . ,(body rest)))
+ ((list-rest exp rest)
+ `((,tokenizer ,exp) . ,(body rest)))))
+ `(seq . ,(body exps)))
+
+;; tokens
+;; generating a sequence of tokens...
+(define-macro (tokens . exps)
+ `(tokens/by token . ,exps))
+
+;; token-ci
+;; the literal tokens for string & character are case-insensitive
+(define-macro (tokens-ci . exps)
+ `(tokens/by (compose token literal-ci) . ,exps))
+
+;; alternate
+;; alternate between 2 parsers - ideally used for parsing delimited input
+;; you can choose whether you want to have the delimiter returned...
+(define (alternate parser1 parser2)
+ (tokens v <- parser1
+ v2 <- (zero-many (seq v1 <- parser2
+ v3 <- parser1
+ (return (list v1 v3))))
+ (return (flatten (cons v v2)))))
+
+;; delimited
+;; same as alternate, except the delimiters are parsed out and not returned
+(define (delimited parser delim (tokenizer token))
+ (tokens/by tokenizer
+ v <- parser
+ v2 <- (zero-many (tokens/by tokenizer
+ v3 <- delim
+ v4 <- parser
+ (return v4)))
+ (return (cons v v2))))
+
+;; bracket
+;; parsing bracketed structures...
+(define (bracket open parser close)
+ (tokens open
+ v <- parser
+ close
+ (return v)))
+
+;; bracket/delimited
+(define (bracket/delimited open parser delim close)
+ (tokens open ;; even the parser is optional...
+ v <- (zero-one (delimited parser delim) '())
+ close
+ (return v)))
+
+(provide token
+ token/pre
+ tokens/by
+ tokens
+ tokens-ci
+ alternate
+ delimited
+ bracket
+ bracket/delimited
+ )
diff --git a/ebus-racket/3rdparty/bzlib/parseq/util.ss b/ebus-racket/3rdparty/bzlib/parseq/util.ss
new file mode 100644
index 0000000..822ce3c
--- /dev/null
+++ b/ebus-racket/3rdparty/bzlib/parseq/util.ss
@@ -0,0 +1,53 @@
+#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; PARSEQ.PLT
+;; A Parser Combinator library.
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; util.ss - an utility module... the code might be moved out of here...
+;; yc 12/31/2009 - first version
+
+(require mzlib/etc
+ )
+
+;; the-number
+;; makes a function that returns a particular number no matter what
+;; args are passed in
+(define (the-number n)
+ (lambda args n))
+
+;; bits->byte
+;; convert a list of bits into its corresponding byte (or integer...)
+;; note the byte can be greater than 255
+(define (bits->byte bits)
+ (define (->i bit)
+ (case bit
+ ((0 #f) 0)
+ ((1 #t) 1)))
+ (apply +
+ (map (lambda (bit exponent)
+ (* (->i bit) (expt 2 exponent)))
+ bits
+ (reverse (build-list (length bits) identity)))))
+
+;; byte->bits
+;; the reverse of converting byte to bits...
+(define (byte->bits b)
+ (define (helper q acc)
+ (cond ((= 0 q) acc)
+ (else
+ (let-values (((q r)
+ (quotient/remainder q 2)))
+ (helper q (cons r acc))))))
+ (helper b '()))
+
+;; string-bytes/utf-8-length
+;; return the bytes length for a string (instead of character length)
+(define (string-bytes/utf-8-length s)
+ (bytes-length (string->bytes/utf-8 s)))
+
+(provide (all-defined-out))
+