refactored ebus code

1 files changed, 150 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
+         )
+
+
+