fix your soul

beautiful-racket-lib/br/define.rkt

@@ -222,10 +222,11 @@
        #'(define-syntax (_id stx)
            (syntax-case stx ()
              [(_id . rest)
-              (let ([expanded-stx (map expand-macro (syntax->list #'rest))])
+              (let* ([expanded-stx (map expand-macro (syntax->list #'rest))]
+                    [fused-stx #`(#,#'_id #,@expanded-stx)])
                 (define result
-                  (syntax-case #`(#,#'_id #,@expanded-stx) (LITERAL ...) ;; put id back together with args to make whole pattern
-                    [_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'expanded-stx)])
+                  (syntax-case fused-stx (LITERAL ...) ;; put id back together with args to make whole pattern
+                    [_pat (syntax-parameterize ([caller-stx (make-rename-transformer #'fused-stx)])
                             _body ...)] ...
                     [else (raise-syntax-error 'define-cases-inverting (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'_id))]))
                 (if (not (syntax? result))

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

@@ -0,0 +1,14 @@
+#lang br/demo/hdl/tst
+
+/* and */
+
+load And.hdl,
+output-list a, b, out;
+set a 0, set b 0,
+eval, output;
+set a 0, set b 1,
+eval, output;
+set a 1, set b 0,
+eval, output;
+set a 1, set b 1,
+eval, output;

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

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

beautiful-racket/br/demo/hdl/Nand.tst

@@ -0,0 +1,14 @@
+#lang br/demo/hdl/tst
+
+/* nand */
+
+load Nand.hdl,
+output-list a, b, out;
+set a 0, set b 0,
+eval, output;
+set a 0, set b 1,
+eval, output;
+set a 1, set b 0,
+eval, output;
+set a 1, set b 1,
+eval, output;

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

@@ -0,0 +1,10 @@
+#lang br/demo/hdl/tst
+
+/* Not */
+
+load Not.hdl,
+output-list in, out;
+set in 0,
+eval, output;
+set in 1,
+eval, output;

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

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

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

@@ -0,0 +1,14 @@
+#lang br/demo/hdl/tst
+
+/* or */
+
+load Or.hdl,
+output-list a, b, out;
+set a 0, set b 0,
+eval, output;
+set a 0, set b 1,
+eval, output;
+set a 1, set b 0,
+eval, output;
+set a 1, set b 1,
+eval, output;

beautiful-racket/br/demo/hdl/Xor-test.rkt

@@ -1,56 +0,0 @@
-#lang br
-
-#|
-load Xor.hdl,
-output-list a, b, out;
-set a 0, set b 0,
-eval, output;
-set a 0, set b 1,
-eval, output;
-set a 1, set b 0,
-eval, output;
-set a 1, set b 1,
-eval, output;
-|#
-
-(define (vals->text vals)
-  (string-join (map ~a vals) " | "))
-
-(define (display-values . vals)
-  (displayln (vals->text vals)))
-
-(define (display-dashes . vals)
-  (displayln (make-string (string-length (vals->text vals)) #\-)))
-
-(define #'(display-header _val ...)
-  #'(begin
-      (apply display-values (list '_val ...))
-      (apply display-dashes (list '_val ...))))
-
-(define (display-status)
-  (display-values a b (out)))
-
-(define proc (dynamic-require "Xor.hdl" 'Xor))
-
-(display-header a b out)
-(define a #f)
-(define b #f)
-(define (out)
-  (keyword-apply proc '(#:a #:b) (list a b) null))
-
-
-(set! a 0)
-(set! b 0)
-(display-status)
-
-(set! a 0)
-(set! b 1)
-(display-status)
-
-(set! a 1)
-(set! b 0)
-(display-status)
-
-(set! a 1)
-(set! b 1)
-(display-status)

beautiful-racket/br/demo/hdl/Xor.tst

@@ -2,7 +2,6 @@
 
 load Xor.hdl,
 output-list a, b, out;
-/*
 set a 0, set b 0,
 eval, output;
 set a 0, set b 1,
@@ -11,4 +10,3 @@ set a 1, set b 0,
 eval, output;
 set a 1, set b 1,
 eval, output;
-*/

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

@@ -1,37 +0,0 @@
-#lang racket/base
-(provide Xor)
-
-(define Xor
-  (make-keyword-procedure
-   (λ (kws kw-args . rest)
-     (define kw-pairs (map cons kws kw-args))
-     (let ([a (cdr (assq (string->keyword (format "~a" 'a)) kw-pairs))]
-           [b (cdr (assq (string->keyword (format "~a" 'b)) kw-pairs))])
-       (define nota
-         (let ()
-           (local-require "Not.hdl")
-           (Not #:in a)))
-       (define notb
-         (let ()
-           (local-require "Not.hdl")
-           (Not #:in b)))
-       (define w1
-         (let ()
-           (local-require "And.hdl")
-           (And #:a a #:b notb)))
-       (define w2
-         (let ()
-           (local-require "And.hdl")
-           (And #:a nota #:b b)))
-       (define out
-         (let ()
-           (local-require "Or.hdl")
-           (Or #:a w1 #:b w2)))
-       out))))
-
-(module+ test
-  (require rackunit)
-  (check-equal? (Xor #:a 0 #:b 0) 0)
-  (check-equal? (Xor #:a 0 #:b 1) 1)
-  (check-equal? (Xor #:a 1 #:b 0) 1)
-  (check-equal? (Xor #:a 1 #:b 1) 0))

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

@@ -1,18 +0,0 @@
-#lang s-exp br/demo/hdl/expander
-
-(chip Xor (IN a b)
-      (OUT out)
-      (PARTS
-       (Not [in a] [out nota])
-       (Not [in b] [out notb])
-       (And [a a] [b notb] [out w1])
-       (And [a nota] [b b] [out w2])
-       (Or [a w1] [b w2] [out out])))
-
-
-(module+ test
-  (require rackunit)
-  (check-equal? (Xor #:a 0 #:b 0) 0)
-  (check-equal? (Xor #:a 0 #:b 1) 1)
-  (check-equal? (Xor #:a 1 #:b 0) 1)
-  (check-equal? (Xor #:a 1 #:b 1) 0))

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

@@ -1,15 +0,0 @@
-#lang br/demo/hdl
-
-CHIP Xor {
-          IN a, b;
-             OUT out;
-             PARTS:
-             Not(in=a, out=nota);
-             Not(in=b, out=notb);
-             And(a=a, b=notb, out=w1);
-             And(a=nota, b=b, out=w2);
-             Or(a=w1, b=w2, out=out);
-}
-
-
-

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

@@ -1,32 +0,0 @@
-#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/expander0.rkt

@@ -1,24 +0,0 @@
-#lang br
-(provide (all-from-out br) chip call-part)
-
-
-(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/tst/expander.rkt

@@ -1,47 +1,54 @@
 #lang br
-(provide #%top-interaction #%module-begin #%datum #%top #%app)
+(provide #%top-interaction #%module-begin #%datum (rename-out [my-top #%top]) #%app
+         (all-defined-out))
 
-(provide tst-program)
-(define #'(tst-program _arg ...)
-  #'(begin _arg ...))
+; #%app and #%datum have to be present to make #%top work
+(define #'(my-top . id)
+  #'(begin
+      (displayln (format "got unbound identifier: ~a" 'id))
+      (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
 
+(define-inverting #'(tst-program _arg ...)
+  #'(begin 
+      _arg ...))
 
-(define-for-syntax private-proc-name (generate-temporary))
+(define-for-syntax output-here #'output-here)
 
-(provide load-expr)
-;; parse shape: (load-expr "load" Xor.hdl ",")
-(define #'(load-expr "load" _filename ",")
+(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
+  (inject-syntax ([#'output (syntax-local-introduce output-here)])
+    #'(begin
+        (provide (all-defined-out))
+        (define _procname (dynamic-require _filename-string '_procname))
+        (display-header '_colid ... '_outid)
+        (define _colid #f) ...
+        (define (_outid)
+          (keyword-apply _procname
+                         (map (compose1 string->keyword symbol->string) (list '_colid ...))
+                         (list _colid ...) null))
+        
+        (define (output)
+          (display-values _colid ... (_outid))))))
+
+(define-inverting #'(load-expr "load" (_filename-string _procname) ",")
+  #'(_filename-string _procname))
+
+(define #'(filename _filename)
   (inject-syntax ([#'filename-string (symbol->string (syntax->datum #'_filename))]
                   [#'proc-name (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
-                 #'(begin
-                     (define _filename (dynamic-require filename-string 'proc-name)))))
+                 #'(filename-string proc-name)))
 
-(begin-for-syntax
-  (define (expand-macro mac)
-    (syntax-disarm (local-expand mac 'expression #f) #f)))
+(define-inverting #'(table-expr "output-list" _column-id ...)
+  #'(_column-id ...))
 
-;; parse shape:
-;; (header-expr "output-list" a (comma-id "," b)  "," "out" ";")
-(provide header-expr)
-(define #'(header-expr "output-list" _first-id _comma-id ... "," "out" ";")
-  (inject-syntax ([#'(_other-id ...) (map expand-macro (syntax->list #'(_comma-id ...)))])
-                 #'(begin
-                     (display-header _first-id _other-id ... out)
-                     (define _first-id #f)
-                     (define _other-id #f) ...
-                     (define (out)
-                       (keyword-apply proc '(#:a #:b) (list a b) null))
-                     )))
+(define-cases #'column-id
+  [#'(_ _colid) #'_colid]
+  [#'(_ _colid ",") #'_colid])
 
-(provide comma-id)
-(define #'(comma-id "," _id)
-  #'_id)
 
-
-(define #'(display-header _val ...)
+(define #'(display-header _sym ...)
   #'(begin
-      (apply display-values (list '_val ...))
-      (apply display-dashes (list '_val ...))))
+      (apply display-values (list _sym ...))
+      (apply display-dashes (list _sym ...))))
 
 (define (vals->text vals)
   (string-join (map ~a vals) " | "))
@@ -53,30 +60,23 @@
   (displayln (make-string (string-length (vals->text vals)) #\-)))
 
 
-(provide test-expr)
-(define #'(test-expr _first-step _comma-step ... ";")
-  (inject-syntax ([#'(_other-step ...) (expand-macro #'(_comma-step ...))])
-                 #'(let ()
-                     _first-step
-                     _other-step ...)))
+(define-inverting #'(test-expr _step-expr ... ";")
+  #'(begin
+      _step-expr ...))
+
+
+(define-cases #'step-expr
+  [#'(_ _step) #'_step]
+  [#'(_ _step ",") #'_step])
 
-(provide step-expr)
-(define #'(step-expr _step)
-  #'_step)
 
-(provide set-expr)
 (define #'(set-expr "set" _id _val)
   #'(set! _id _val))
 
-(provide comma-step)
-(define #'(comma-step "," _step)
-  #'_step)
 
-(provide eval-expr)
 (define #'(eval-expr "eval")
-  #'(set! result (param-proc)))
+  #'(void))
 
-#|
-(tst-program (load-expr "load" Xor.hdl ",") (header-expr "output-list" a "," b "," out ";") (test-expr (step-expr (set-expr "set" a 0)) "," (step-expr (set-expr "set" b 0)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 0)) "," (step-expr (set-expr "set" b 1)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 1)) "," (step-expr (set-expr "set" b 0)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";") (test-expr (step-expr (set-expr "set" a 1)) "," (step-expr (set-expr "set" b 1)) "," (step-expr (eval-expr "eval")) "," (step-expr (output-expr "output")) ";"))
-|#
 
+(define #'(output-expr "output")
+  #'(output-here))

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

@@ -1,18 +1,20 @@
 #lang ragg
 
-tst-program : load-expr header-expr test-expr*
+tst-program : header-expr test-expr*
 
-load-expr : "load" ID ","
+header-expr : load-expr table-expr ";"
 
-header-expr : "output-list" ID comma-id* "," "out" ";"
+load-expr : "load" filename ","
 
-comma-id : "," ID
+filename : ID
 
-test-expr : step-expr comma-step* ";"
+table-expr : "output-list" column-id+
 
-comma-step : "," step-expr
+column-id :  ID [","]
 
-step-expr : set-expr | eval-expr | output-expr
+test-expr : step-expr+ ";"
+
+step-expr : (set-expr | eval-expr | output-expr) [","]
 
 set-expr : "set" ID VAL
 

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

@@ -12,7 +12,7 @@
        [(seq "/*" (complement (seq any-string "*/" any-string)) "*/")
         (token 'COMMENT lexeme #:skip? #t)]
        [(union #\tab #\space #\newline) (get-token input-port)]
-       [(union "load" "output-list" "set" "eval" "output" "out" (char-set ",;")) lexeme]
+       [(union "load" "output-list" "set" "eval" "output" (char-set ",;")) lexeme]
        [(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
        [(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID (string->symbol lexeme))]))
     (get-token input-port))