renamings

beautiful-racket-lib/br/scope.rkt

@@ -44,7 +44,7 @@
                    [remove-id (prefix-id "remove-" #'id)]
                    [id? (suffix-id #'id "?")]
                    [id* (suffix-id #'id "*")]
-                   [(scope-id-sis ...) (suffix-ids #'scope-ids "-sis")])
+                   [(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
        #'(begin
            (define id-sis
              (let ([sis-in (list scope-id-sis ...)])

beautiful-racket-lib/br/syntax.rkt

@@ -31,6 +31,7 @@
      #'(inject-syntax (stx-expr0)
                       (inject-syntax* (stx-expr ...) . body))]))
 
+(define-syntax with-pattern (make-rename-transformer #'inject-syntax*))
 (define-syntax let-syntax-pattern (make-rename-transformer #'inject-syntax*))
 (define-syntax let*-syntax-pattern (make-rename-transformer #'inject-syntax*))
 (define-syntax syntax-let (make-rename-transformer #'inject-syntax))
@@ -78,25 +79,33 @@
       (syntax->datum x)
       x))
 
-(define-syntax-rule (prefix-id _prefix ... _base)
-  (format-id _base "~a~a" (string-append (format "~a" (->unsyntax _prefix)) ...) (syntax-e _base)))
-
-(define-syntax-rule (prefix-ids _prefix ... _bases)
-  (syntax-case-map _bases ()
-                   [_base (prefix-id _prefix ... #'_base)]))
-
-(define-syntax-rule (infix-id _prefix _base _suffix ...)
-  (format-id _base "~a~a~a" (->unsyntax _prefix) (syntax-e _base) (string-append (format "~a" (->unsyntax _suffix)) ...)))
-
-(define-syntax-rule (infix-ids _prefix _bases _suffix ...)
-  (syntax-case-map _bases ()
-                   [_base (infix-id _prefix #'_base _suffix ...)]))
-
-(define-syntax-rule (suffix-id _base _suffix ...)
-  (infix-id "" _base _suffix ...))
-
-(define-syntax-rule (suffix-ids _bases _suffix ...)
-  (infix-ids "" _bases _suffix ...))
+(define-syntax-rule (prefix-id _prefix ... _base-or-bases)
+  (let* ([bob _base-or-bases]
+         [got-single? (and (not (list? bob)) (not (syntax->list bob)))]
+         [bases (if got-single?
+                    (list bob)
+                    bob)]
+         [result (syntax-case-map
+                  bases ()
+                  [base (format-id #'base "~a~a"
+                                   (string-append (format "~a" (->unsyntax _prefix)) ...)
+                                   (syntax-e #'base))])])
+    (if got-single? (car result) result)))
+
+(define-syntax-rule (infix-id _prefix _base-or-bases _suffix ...)
+  (let* ([bob _base-or-bases]
+         [got-single? (and (not (list? bob)) (not (syntax->list bob)))]
+         [bases (if got-single?
+                    (list bob)
+                    bob)]
+         [result (syntax-case-map
+                  bases ()
+                  [base (format-id #'base "~a~a~a" (->unsyntax _prefix) (syntax-e #'base)
+                                   (string-append (format "~a" (->unsyntax _suffix)) ...))])])
+    (if got-single? (car result) result)))
+
+(define-syntax-rule (suffix-id _base-or-bases _suffix ...)
+  (infix-id "" _base-or-bases _suffix ...))
 
 (define-syntax (syntax-property* stx)
   (syntax-case stx (quote)
@@ -121,4 +130,6 @@
 (define-syntax-rule (introduce-id (id ...) . body)
   (with-syntax ([id (syntax-local-introduce (datum->syntax #f 'id))] ...)
     . body))
-  
+
+(define-syntax with-shared-id (make-rename-transformer #'introduce-id))
+

beautiful-racket/br/demo/hdl-tst/expander.rkt

@@ -1,5 +1,5 @@
 #lang br
-(require (for-syntax br/syntax br/scope racket/string) rackunit racket/file)
+(require (for-syntax br/syntax racket/string) rackunit racket/file)
 (provide #%top-interaction #%module-begin #%datum #%app (all-defined-out))
 
 
@@ -43,13 +43,13 @@
 
 (define-macro (load-expr CHIPFILE-STRING)
   (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
-  (let-syntax-pattern
+  (with-pattern
    ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
    #'(require CHIPFILE.RKT)))
 
 
 (define-macro (output-file-expr OUTPUT-FILE-STRING)
-  (introduce-id
+  (with-shared-id
    (output-file output-filename)
    #'(begin
        (define output-filename OUTPUT-FILE-STRING)
@@ -60,18 +60,18 @@
 
 
 (define-macro (compare-to-expr COMPARE-FILE-STRING)
-  (introduce-id
+  (with-shared-id
    (compare-files)
    #'(define (compare-files)
        (check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
 
 
 (define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
-  (introduce-id
+  (with-shared-id
    (eval-result eval-chip output)
-   (let-syntax-pattern
-    ([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
-     [(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
+   (with-pattern
+    ([(COL-ID ...) (suffix-id #'(COL-NAME ...))]
+     [(CHIP-COL-ID ...) (prefix-id chip-prefix "-" #'(COL-NAME ...))])
     #'(begin
         (define (output COL-ID ...)
           (print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
@@ -81,7 +81,7 @@
 
 
 (define-macro (set-expr IN-BUS IN-VAL)
-  (let-syntax-pattern
+  (with-pattern
    ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
    #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
 

beautiful-racket/br/demo/hdl/expander.rkt

@@ -6,10 +6,10 @@
                             (in-spec (IN-BUS IN-WIDTH ...) ...)
                             (out-spec (OUT-BUS OUT-WIDTH ...) ...)
                             PART ...)
-  (let-syntax-pattern
+  (with-pattern
    ([CHIP-PREFIX (suffix-id #'CHIPNAME "-")]
-    [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
-    [(PREFIX-OUT-BUS ...) (prefix-ids #'CHIP-PREFIX #'(OUT-BUS ...))])
+    [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
+    [(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
    #'(begin
        (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...))) 
        (define-input-bus IN-BUS IN-WIDTH ...) ...
@@ -19,8 +19,8 @@
 
 
 (define-macro (part PARTNAME ((BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)
-  (let-syntax-pattern
-   ([(PARTNAME-BUS-LEFT ...) (prefix-ids #'PARTNAME "-" #'(BUS-LEFT ...))]
+  (with-pattern
+   ([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
     [CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
    #'(begin
        (require (import-chip CHIP-MODULE-PATH) (for-syntax (import-chip CHIP-MODULE-PATH)))
@@ -41,9 +41,9 @@
         (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
                                [((PREFIXED-WIRE . _) _)
                                 (syntax-local-eval (syntax-shift-phase-level #'(input-bus? PREFIXED-WIRE) 1))])])
-    (let-syntax-pattern
+    (with-pattern
      ([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]
-      [(IN-BUS-WRITE ...) (suffix-ids #'(IN-BUS ...) "-write")]
+      [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
       [((OUT-BUS-EXPR (NEW-OUT-BUS)) ...) out-bus-assignments])
      #'(begin
          (define-output-bus NEW-OUT-BUS

beautiful-racket/br/demo/hdl/helper.rkt

@@ -104,28 +104,30 @@ base bus:
 (define-values (bus bus? bus-get)
   (make-impersonator-property 'bus))
 
-(define-cases #'define-base-bus
-  [#'(_macro-name _id _thunk) #'(_macro-name _id _thunk default-bus-width)]
-  [#'(_macro-name _id _thunk _bus-width-in)
-   (inject-syntax ([#'_id-thunk (suffix-id #'_id "-val")]
-                   [#'_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
-                  #`(splicing-let ([_id-thunk _thunk]
-                                   [bus-width _bus-width-in])
-                      (define _id
-                        (begin
-                          (unless (<= bus-width max-bus-width)
-                            (raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
-                          (impersonate-procedure
-                           (let ([reader (make-bus-reader 'id bus-width)])
-                             (procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" '_id bus-width))))
-                           #f _bus-type #t)))
-                      #,(when (syntax-property caller-stx 'writer)
-                          (inject-syntax ([#'_id-write (suffix-id #'_id "-write")])
-                                         #'(define _id-write
-                                             (let ([writer (make-bus-writer 'id-write bus-width)])
-                                               (λ args
-                                                 (define result (apply writer (_id-thunk) args))
-                                                 (set! _id-thunk (λ () result)))))))))])
+(define-macro-cases define-base-bus
+  [#'(_macro-name ID THUNK) #'(_macro-name ID THUNK default-bus-width)]
+  [#'(_macro-name ID THUNK _bus-width-in)
+   (with-pattern
+    ([_id-thunk (suffix-id #'ID "-val")]
+     [_bus-type (or (syntax-property caller-stx 'impersonate) #'bus)])
+    #`(splicing-let ([_id-thunk THUNK]
+                     [bus-width _bus-width-in])
+        (define ID
+          (begin
+            (unless (<= bus-width max-bus-width)
+              (raise-argument-error 'id (format "bus width <= max width ~a" max-bus-width) bus-width))
+            (impersonate-procedure
+             (let ([reader (make-bus-reader 'id bus-width)])
+               (procedure-rename (λ args (apply reader (_id-thunk) args)) (string->symbol (format "~a, a bus of width ~a" 'ID bus-width))))
+             #f _bus-type #t)))
+        #,(when (syntax-property caller-stx 'writer)
+            (with-pattern
+             ([_id-write (suffix-id #'ID "-write")])
+             #'(define _id-write
+                 (let ([writer (make-bus-writer 'id-write bus-width)])
+                   (λ args
+                     (define result (apply writer (_id-thunk) args))
+                     (set! _id-thunk (λ () result)))))))))])
 
 
 (module+ test
@@ -157,7 +159,7 @@ output bus:
 (define-values (output-bus output-bus? output-bus-get)
   (make-impersonator-property 'output-bus))
 
-(define #'(define-output-bus . _args)
+(define-macro (define-output-bus . _args)
   (syntax-property #'(define-base-bus . _args) 'impersonate #'output-bus))
 
 (module+ test
@@ -189,7 +191,7 @@ input bus:
 (define-values (input-bus input-bus? input-bus-get)
   (make-impersonator-property 'input-bus))
 
-(define-cases #'define-input-bus
+(define-macro-cases define-input-bus
   [#'(_macro-name _id)
    #'(_macro-name _id default-bus-width)]
   [#'(_macro-name _id _bus-width)