works better
parent
0f6334c005
commit
2bd78a0595
@ -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))))
|
||||
@ -1,54 +1,66 @@
|
||||
#lang br
|
||||
(provide (all-from-out br) (all-defined-out))
|
||||
(require "expander0.rkt")
|
||||
|
||||
|
||||
#|
|
||||
|
||||
Be your own binding procedure.
|
||||
Part parser should generate inner `define`.
|
||||
input-pin-spec parser should generate kw procedure.
|
||||
chip-name parser should generate outer define/provide form.
|
||||
|
||||
(chip Not
|
||||
(x)
|
||||
(y))
|
||||
|
||||
|#
|
||||
|
||||
(define-for-syntax (remove-commas stx-expr)
|
||||
(filter (λ(i)
|
||||
(not (equal? "," (syntax->datum i)))) (syntax->list stx-expr)))
|
||||
|
||||
(define #'(make-kw-procedure
|
||||
(pin-spec-in "IN" _pinin-or-comma ... ";")
|
||||
(pin-spec-out "OUT" _pinout-or-comma ... ";")
|
||||
_part-spec)
|
||||
(inject-syntax ([#'(_pinin ...) (remove-commas #'(_pinin-or-comma ...))]
|
||||
[#'(_pinout ...) (remove-commas #'(_pinout-or-comma ...))])
|
||||
#'(make-keyword-procedure
|
||||
(λ (kws kw-args . rest)
|
||||
(define kw-pairs (map cons kws kw-args))
|
||||
(let ([_pinin (cdr (assq (string->keyword (format "~a" '_pinin)) kw-pairs))] ...)
|
||||
#;_part-spec
|
||||
(define _pinout (list _pinin ...)) ...
|
||||
(list _pinout ...))))))
|
||||
|
||||
|
||||
;; next: make part-spec work
|
||||
#;(define #'(part-spec "PARTS:" _part ...))
|
||||
|
||||
(define #'(chip-program "CHIP" _topid "{" _pin-spec-in _pin-spec-out _part-spec "}")
|
||||
#`(begin
|
||||
(provide _topid)
|
||||
(define _topid
|
||||
(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)))))
|
||||
|
||||
#|
|
||||
PARTS:
|
||||
Nand(a=a, b=a, out=x);
|
||||
|
||||
|#
|
||||
(provide #%top-interaction #%module-begin #%datum #%top #%app)
|
||||
|
||||
(provide chip-program)
|
||||
(define #'(chip-program "CHIP" _arg ...)
|
||||
#'(chip _arg ...))
|
||||
|
||||
(provide pin-spec-in)
|
||||
(define #'(pin-spec-in "IN" _pin-list ";")
|
||||
#'_pin-list)
|
||||
|
||||
(provide pin-spec-out)
|
||||
(define #'(pin-spec-out "OUT" _pin-list ";")
|
||||
#'_pin-list)
|
||||
|
||||
|
||||
(require (for-syntax sugar/debug))
|
||||
|
||||
|
||||
(provide pin-list)
|
||||
(define #'(pin-list . _pin-or-commas)
|
||||
(for/list ([stx (in-list (syntax->list #'_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)))
|
||||
|
||||
(provide part-spec)
|
||||
(define #'(part-spec "PARTS:" _part-list)
|
||||
#'_part-list)
|
||||
|
||||
(provide part-list)
|
||||
(define #'(part-list _part ";")
|
||||
#'_part)
|
||||
|
||||
(provide part)
|
||||
(define #'(part _partname "(" _pin-in "=" _val-id "," _pin-in2 "=" _val-id2 "," out "=" _pin-out ")")
|
||||
#'(begin
|
||||
(define _pin-out (call-part _partname [_pin-in _val-id][_pin-in2 _val-id2]))))
|
||||
|
||||
(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
|
||||
(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))))
|
||||
Loading…
Reference in New Issue