refactored ebus code

1 files changed, 62 insertions, 0 deletions

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))
+