convert to `define-inverting`

dev-elider-3
Matthew Butterick 9 years ago
parent 8bbe358753
commit 2feaa1084d

@ -1,58 +1,42 @@
#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 ...)))
(define-inverting #'(part-list _part ...)
#'(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-id-etc ... out "=" _pin-out ")" ";")
(with-syntax ([((_pin-in _val-id) ...) (ugly-processing #'(_pin-id-etc ...))])
(define-inverting #'(part _partname "(" _firstpin "=" _firstval _commaidpair ... (_lastpin _pinout) ")" ";")
#'(begin
(define _pin-out (call-part _partname [_pin-in _val-id] ...)))))
(define _pinout (call-part _partname [_firstpin _firstval] _commaidpair ...))))
(define #'(comma-id-pair "," _firstid "=" _secondid)
#'(_firstid _secondid))
(define #'(chip _chipname "{"
_input-pins
_output-pins
(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))))
(define-inverting #'(chip _chipname "{"
(_input-pin ...)
(_output-pin ...)
_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
@ -61,13 +45,5 @@
(λ (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)))))
(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))))
_part-spec
(values _output-pin ...)))) '_chipname))))

@ -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
Loading…
Cancel
Save