works better

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

@@ -1,13 +1,11 @@
 #lang br/demo/hdl
 
 CHIP Not {
-          IN a, b, c, d;
+          IN in;
-             OUT x, y, z;
+             OUT out;
              
              PARTS:
-             Nand(a=a, b=a, out=x);
+             Nand(a=in, b=in, out=out);
-             Nand(a=a, b=a, out=y);
-             Nand(a=a, b=a, out=z);
              }
 
 

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

@@ -0,0 +1,32 @@
+#lang br
+
+(provide #%top-interaction (rename-out [mb #%module-begin]))
+
+(define #'(mb _arg ...)
+  #'(#%module-begin
+     (module treemod br/demo/hdl/expander
+       _arg ...)
+     (require 'treemod)
+     (chip parse-tree)))
+
+
+(define #'(chip _Chip
+                (_input-pin ...)
+                (_output-pin ...)
+                ((_Part [_pin-in _val-id] ... [out _pin-out]) ...))
+  #'(begin
+      (provide _Chip)
+      (define _Chip
+        (make-keyword-procedure
+         (λ (kws kw-args . rest)
+           (define kw-pairs (map cons kws kw-args))
+           (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
+             (define _pin-out (call-part _Part [_pin-in _val-id] ...)) ...
+             (values _output-pin ...)))))))
+
+(define #'(call-part _Part [_pin-in _val-id] ...)
+  (with-syntax ([part-path (format "~a.hdl" (syntax->datum #'_Part))]
+                [(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin-in ...)))])
+    #'(let ()
+        (local-require (rename-in part-path [_Part local-name]))
+        (keyword-apply local-name '(kw ...) (list _val-id ...) null))))

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

@@ -1,54 +1,66 @@
 #lang br
-(provide (all-from-out br) (all-defined-out))
+(provide #%top-interaction #%module-begin #%datum #%top #%app)
-(require "expander0.rkt")
 
+(provide chip-program)
+(define #'(chip-program "CHIP" _arg ...)
+  #'(chip _arg ...))
 
-#|
+(provide pin-spec-in)
+(define #'(pin-spec-in "IN" _pin-list ";")
+  #'_pin-list)
 
-Be your own binding procedure.
+(provide pin-spec-out)
-Part parser should generate inner `define`.
+(define #'(pin-spec-out "OUT" _pin-list ";")
-input-pin-spec parser should generate kw procedure.
+  #'_pin-list)
-chip-name parser should generate outer define/provide form.
 
-(chip Not
-      (x)
-      (y))
 
-|#
+(require (for-syntax sugar/debug))
 
-(define-for-syntax (remove-commas stx-expr)
-  (filter (λ(i)
-            (not (equal? "," (syntax->datum i)))) (syntax->list stx-expr)))
 
-(define #'(make-kw-procedure
+(provide pin-list)
-           (pin-spec-in "IN" _pinin-or-comma ... ";")
+(define #'(pin-list . _pin-or-commas)
-           (pin-spec-out "OUT" _pinout-or-comma ... ";")
+  (for/list ([stx (in-list (syntax->list #'_pin-or-commas))]
-           _part-spec)
+             #:when (not (equal? "," (report (syntax->datum stx)))))
-  (inject-syntax ([#'(_pinin ...) (remove-commas #'(_pinin-or-comma ...))]
+            stx))
-                [#'(_pinout ...) (remove-commas #'(_pinout-or-comma ...))])
+
-    #'(make-keyword-procedure
+(begin-for-syntax
-       (λ (kws kw-args . rest)
+  (define (expand-macro mac)
-         (define kw-pairs (map cons kws kw-args))
+    (syntax-disarm (report (local-expand mac 'expression #f)) #f)))
-         (let ([_pinin (cdr (assq (string->keyword (format "~a" '_pinin)) kw-pairs))] ...)
-           #;_part-spec
-           (define _pinout (list _pinin ...)) ...
-           (list _pinout ...))))))
 
+(provide part-spec)
+(define #'(part-spec "PARTS:" _part-list)
+  #'_part-list)
 
-;; next: make part-spec work
+(provide part-list)
-#;(define #'(part-spec "PARTS:" _part ...))
+(define #'(part-list _part ";")
+  #'_part)
 
-(define #'(chip-program "CHIP" _topid "{" _pin-spec-in _pin-spec-out _part-spec "}")
+(provide part)
-  #`(begin
+(define #'(part _partname "(" _pin-in "=" _val-id "," _pin-in2 "=" _val-id2 "," out "=" _pin-out ")")
-      (provide _topid)
+           #'(begin
-      (define _topid
+               (define _pin-out (call-part _partname [_pin-in _val-id][_pin-in2 _val-id2]))))
-        (make-kw-procedure _pin-spec-in _pin-spec-out _part-spec)
-        )
-      (require rackunit)
-      (check-equal? (_topid #:a 1 #:b 2 #:c 3 #:d 4) '((1 2 3 4)(1 2 3 4)(1 2 3 4)))))
 
-#|
+(define #'(chip _chipname "{"
- PARTS:
+                _input-pins
-             Nand(a=a, b=a, out=x);
+                _output-pins
+                _part-spec "}")
+  (inject-syntax ([#'(_input-pin ...) (expand-macro #'_input-pins)]
+                  [#'(_output-pin ...) (expand-macro #'_output-pins)]
+                  [#'_part (expand-macro #'_part-spec)])
+                 #'(begin
+                     (provide _chipname)
+                     (define _chipname
+                       (make-keyword-procedure
+                        (λ (kws kw-args . rest)
+                          (define kw-pairs (map cons kws kw-args))
+                          (let ([_input-pin (cdr (assq (string->keyword (format "~a" '_input-pin)) kw-pairs))] ...)
+                            _part 
+                            (values _output-pin ...))))))))
 
-|#
+(provide call-part)
+(define #'(call-part _Part [_pin-in _val-id] ...)
+  (with-syntax ([part-path (format "~a.hdl" (syntax->datum #'_Part))]
+                [(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin-in ...)))])
+    #'(let ()
+        (local-require (rename-in part-path [_Part local-name]))
+        (keyword-apply local-name '(kw ...) (list _val-id ...) null))))

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

@@ -2,9 +2,14 @@
 
 chip-program : "CHIP" ID "{" pin-spec-in pin-spec-out part-spec "}"
 
-pin-spec-in : "IN" ID ["," ID]* ";"
+pin-spec-in : "IN" pin-list ";"
 
-pin-spec-out : "OUT" ID ["," ID]* ";"
+pin-spec-out : "OUT" pin-list ";"
 
+pin-list : ID ["," ID]*
 
-part-spec : "PARTS:" [ID "(" ID "=" ID "," [ ID "=" ID ","]* "out" "=" ID ")" ";"]+
+part-spec : "PARTS:" part-list
+
+part-list : [part ";"]+
+
+part : ID "(" ID "=" ID ["," ID "=" ID]* ")"

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

@@ -10,7 +10,7 @@
       (lexer
        [(eof) eof]
        [(union #\tab #\space #\newline) (get-token input-port)]
-       [(union "CHIP" "IN" "OUT" "PARTS:" "out") lexeme]
+       [(union "CHIP" "IN" "OUT" "PARTS:") lexeme]
        [(char-set "{}(),;=") lexeme]
        [(repetition 1 +inf.0 (union alphabetic numeric)) (token 'ID (string->symbol lexeme))]))
     (get-token input-port))