ugly but effective

beautiful-racket/br/demo/hdl/And.hdl

@@ -1,14 +1,13 @@
-#lang s-exp br/demo/hdl/expander0
+#lang br/demo/hdl
-
+
-(chip And
+CHIP And {
-      (a b)
+          IN a, b;
-      (out)
+             OUT out;
-      ((Nand [a a] [b b] [out nand-out])
+             
-       (Not [in nand-out] [out out])))
+             PARTS:
-
+             Nand(a=a, b=b, out=nandout);
-(module+ test
+             Not(in=nandout, out=out);
-  (require rackunit)
+             }
-  (check-equal? (And #:a 0 #:b 0) 0)
+
-  (check-equal? (And #:a 0 #:b 1) 0)
+
-  (check-equal? (And #:a 1 #:b 0) 0)
+
-  (check-equal? (And #:a 1 #:b 1) 1))

beautiful-racket/br/demo/hdl/Nand-Derived.hdl.rkt

@@ -0,0 +1 @@
+#lang racket

beautiful-racket/br/demo/hdl/Not.hdl

@@ -1,11 +1,13 @@
-#lang s-exp br/demo/hdl/expander0
+#lang br/demo/hdl
+
+CHIP Not {
+          IN in;
+          OUT out;
+             
+             PARTS:
+             Nand(a=in, b=in, out=out);
+             
+             }
+
 
-(chip Not
-      (in)
-      (out)
-      ((Nand [a in] [b in] [out out])))
 
-(module+ test
-  (require rackunit)
-  (check-equal? (Not #:in 0) 1)
-  (check-equal? (Not #:in 1) 0))

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

@@ -1,11 +1,12 @@
 #lang br/demo/hdl
 
-CHIP Not {
+CHIP And {
-          IN in;
+          IN a, b;
              OUT out;
              
              PARTS:
-             Nand(a=in, b=in, out=out);
+             Nand(a=a, b=b, out=nandout);
+             Not(in=nandout, out=out);
              }
 
 

beautiful-racket/br/demo/hdl/Or.hdl

@@ -1,16 +1,13 @@
-#lang s-exp br/demo/hdl/expander0
+#lang br/demo/hdl
 
-(chip Or
+CHIP Or {
-      (a b)
+         IN a, b;
-      (out)
+            OUT out;
-      ((Not [in a] [out nota])
+            
-       (Not [in b] [out notb])
+            PARTS:
-       (And [a nota] [b notb] [out and-out])
+            Not(in=a, out=nota);
-       (Not [in and-out] [out out])))
+            Not(in=b, out=notb);
-
+            And(a=nota, b=notb, out=andout);
-(module+ test
+            Not(in=andout, out=out);
-  (require rackunit)
+            
-  (check-equal? (Or #:a 0 #:b 0) 0)
+            }
-  (check-equal? (Or #:a 0 #:b 1) 1)
-  (check-equal? (Or #:a 1 #:b 0) 1)
-  (check-equal? (Or #:a 1 #:b 1) 1))

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

@@ -5,40 +5,46 @@
 (define #'(chip-program "CHIP" _arg ...)
   #'(chip _arg ...))
 
-(provide pin-spec-in)
+(provide pin-spec)
-(define #'(pin-spec-in "IN" _pin-list ";")
+(define #'(pin-spec _label _pin-list ";")
   #'_pin-list)
 
-(provide pin-spec-out)
-(define #'(pin-spec-out "OUT" _pin-list ";")
-  #'_pin-list)
-
-
 (require (for-syntax sugar/debug))
 
 
+(define-for-syntax (remove-separators stx-or-list sep)
+  (for/list ([item (in-list (if (list? stx-or-list)
+                                stx-or-list
+                                (syntax->list stx-or-list)))]
+             #:when (not (equal? sep (syntax->datum item))))
+            item))
+
 (provide pin-list)
 (define #'(pin-list . _pin-or-commas)
-  (for/list ([stx (in-list (syntax->list #'_pin-or-commas))]
+  (remove-separators #'_pin-or-commas ","))
-             #:when (not (equal? "," (report (syntax->datum stx)))))
-            stx))
 
 (begin-for-syntax
   (define (expand-macro mac)
-    (syntax-disarm (report (local-expand mac 'expression #f)) #f)))
+    (syntax-disarm (local-expand mac 'expression #f) #f)))
 
 (provide part-spec)
 (define #'(part-spec "PARTS:" _part-list)
   #'_part-list)
 
 (provide part-list)
-(define #'(part-list _part ";")
+(define #'(part-list . _part-or-semicolons)
-  #'_part)
+  (inject-syntax ([#'(part ...) (remove-separators #'_part-or-semicolons "'")])
+                 #'(begin part ...)))
+
+(require (for-syntax sugar/list))
+(define-for-syntax (ugly-processing stx)
+  (slice-at (remove-separators (remove-separators stx ",") "=") 2))
 
 (provide part)
-(define #'(part _partname "(" _pin-in "=" _val-id "," _pin-in2 "=" _val-id2 "," out "=" _pin-out ")")
+(define #'(part _partname "(" _pin-id-etc ... out "=" _pin-out ")" ";")
+  (with-syntax ([((_pin-in _val-id) ...) (ugly-processing #'(_pin-id-etc ...))])
            #'(begin
-               (define _pin-out (call-part _partname [_pin-in _val-id][_pin-in2 _val-id2]))))
+               (define _pin-out (call-part _partname [_pin-in _val-id] ...)))))
 
 (define #'(chip _chipname "{"
                 _input-pins
@@ -50,12 +56,13 @@
                  #'(begin
                      (provide _chipname)
                      (define _chipname
-                       (make-keyword-procedure
+                       (procedure-rename
+                        (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 ...))))))))
+                            (values _output-pin ...)))) '_chipname)))))
 
 (provide call-part)
 (define #'(call-part _Part [_pin-in _val-id] ...)

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

@@ -1,15 +1,13 @@
 #lang ragg
 
-chip-program : "CHIP" ID "{" pin-spec-in pin-spec-out part-spec "}"
+chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}"
 
-pin-spec-in : "IN" pin-list ";"
+pin-spec : ("IN" | "OUT") pin-list ";"
-
-pin-spec-out : "OUT" pin-list ";"
 
 pin-list : ID ["," ID]*
 
 part-spec : "PARTS:" part-list
 
-part-list : [part ";"]+
+part-list : [part]+
 
-part : ID "(" ID "=" ID ["," ID "=" ID]* ")"
+part : ID "(" ID "=" ID ["," ID "=" ID]* ")" ";"

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

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