diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 4f94eb4..28d5146 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -1,73 +1,49 @@ #lang br -(provide #%top-interaction #%module-begin #%datum #%top #%app) +(provide #%top-interaction #%module-begin (all-defined-out)) -(provide chip-program) -(define #'(chip-program "CHIP" _arg ...) +(define-inverting #'(chip-program "CHIP" _arg ...) #'(chip _arg ...)) -(provide pin-spec) -(define #'(pin-spec _label _pin-list ";") +(define-inverting #'(pin-spec _label _pin-list ";") #'_pin-list) -(require (for-syntax sugar/debug)) +(define-inverting #'(pin-list _id _comma-id ...) + #'(_id _comma-id ...)) +(define-inverting #'(comma-id "," _id) + #'_id) -(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) - (remove-separators #'_pin-or-commas ",")) - -(begin-for-syntax - (define (expand-macro mac) - (syntax-disarm (local-expand mac 'expression #f) #f))) - -(provide part-spec) -(define #'(part-spec "PARTS:" _part-list) +(define-inverting #'(part-spec "PARTS:" _part-list) #'_part-list) -(provide part-list) -(define #'(part-list . _part-or-semicolons) - (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)) +(define-inverting #'(part-list _part ...) + #'(begin _part ...)) -(provide part) -(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] ...))))) +(define-inverting #'(part _partname "(" _firstpin "=" _firstval _commaidpair ... (_lastpin _pinout) ")" ";") + #'(begin + (define _pinout (call-part _partname [_firstpin _firstval] _commaidpair ...)))) -(define #'(chip _chipname "{" - _input-pins - _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 - (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 ...)))) '_chipname))))) +(define #'(comma-id-pair "," _firstid "=" _secondid) + #'(_firstid _secondid)) -(provide call-part) -(define #'(call-part _Part [_pin-in _val-id] ...) +(define-inverting #'(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)))) \ No newline at end of file + (keyword-apply local-name '(kw ...) (list _val-id ...) null)))) + +(define-inverting #'(chip _chipname "{" + (_input-pin ...) + (_output-pin ...) + _part-spec "}") + #'(begin + (provide _chipname) + (define _chipname + (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-spec + (values _output-pin ...)))) '_chipname)))) diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt index 9ddd06c..00b2c98 100644 --- a/beautiful-racket/br/demo/hdl/parser.rkt +++ b/beautiful-racket/br/demo/hdl/parser.rkt @@ -4,10 +4,14 @@ chip-program : "CHIP" ID "{" pin-spec pin-spec part-spec "}" pin-spec : ("IN" | "OUT") pin-list ";" -pin-list : ID ["," ID]* +pin-list : ID comma-id* + +comma-id : "," ID part-spec : "PARTS:" part-list -part-list : [part]+ +part-list : part+ + +part : ID "(" ID "=" ID comma-id-pair* ")" ";" -part : ID "(" ID "=" ID ["," ID "=" ID]* ")" ";" +comma-id-pair : "," ID "=" ID \ No newline at end of file