diff options
author | Yves Fischer <yvesf-git@xapek.org> | 2016-08-14 19:25:26 +0200 |
---|---|---|
committer | Yves Fischer <yvesf-git@xapek.org> | 2016-08-14 19:25:26 +0200 |
commit | caae83f445935c06cd6aef36f283a4688675278a (patch) | |
tree | 5e63cbfd2877195430a8657dcd75f42b6a4d7110 /ebus-racket/3rdparty/bzlib | |
download | ebus-caae83f445935c06cd6aef36f283a4688675278a.tar.gz ebus-caae83f445935c06cd6aef36f283a4688675278a.zip |
refactored ebus code
Diffstat (limited to 'ebus-racket/3rdparty/bzlib')
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)) + |