From 2bd78a0595d0dcc3d38b3fd7dca495ed25f4fab2 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 25 Apr 2016 23:43:50 -0700 Subject: [PATCH] works better --- beautiful-racket/br/demo/hdl/Not2.hdl.rkt | 10 +- .../br/demo/hdl/expander-outer.rkt | 32 +++++ beautiful-racket/br/demo/hdl/expander.rkt | 118 ++++++++++-------- beautiful-racket/br/demo/hdl/parser.rkt | 11 +- beautiful-racket/br/demo/hdl/tokenizer.rkt | 2 +- 5 files changed, 110 insertions(+), 63 deletions(-) create mode 100644 beautiful-racket/br/demo/hdl/expander-outer.rkt diff --git a/beautiful-racket/br/demo/hdl/Not2.hdl.rkt b/beautiful-racket/br/demo/hdl/Not2.hdl.rkt index 0175f16..698fd5b 100644 --- a/beautiful-racket/br/demo/hdl/Not2.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Not2.hdl.rkt @@ -1,13 +1,11 @@ #lang br/demo/hdl CHIP Not { - IN a, b, c, d; - OUT x, y, z; - + IN in; + OUT out; + PARTS: - Nand(a=a, b=a, out=x); - Nand(a=a, b=a, out=y); - Nand(a=a, b=a, out=z); + Nand(a=in, b=in, out=out); } diff --git a/beautiful-racket/br/demo/hdl/expander-outer.rkt b/beautiful-racket/br/demo/hdl/expander-outer.rkt new file mode 100644 index 0000000..d637f79 --- /dev/null +++ b/beautiful-racket/br/demo/hdl/expander-outer.rkt @@ -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)))) diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 258b95a..f2d4f80 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -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); - -|# \ No newline at end of file +(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)))) \ No newline at end of file diff --git a/beautiful-racket/br/demo/hdl/parser.rkt b/beautiful-racket/br/demo/hdl/parser.rkt index fa79e36..0fee21a 100644 --- a/beautiful-racket/br/demo/hdl/parser.rkt +++ b/beautiful-racket/br/demo/hdl/parser.rkt @@ -2,9 +2,14 @@ chip-program : "CHIP" ID "{" pin-spec-in pin-spec-out part-spec "}" -pin-spec-in : "IN" ID ["," ID]* ";" +pin-spec-in : "IN" pin-list ";" -pin-spec-out : "OUT" ID ["," ID]* ";" +pin-spec-out : "OUT" pin-list ";" +pin-list : ID ["," ID]* -part-spec : "PARTS:" [ID "(" ID "=" ID "," [ ID "=" ID ","]* "out" "=" ID ")" ";"]+ +part-spec : "PARTS:" part-list + +part-list : [part ";"]+ + +part : ID "(" ID "=" ID ["," ID "=" ID]* ")" diff --git a/beautiful-racket/br/demo/hdl/tokenizer.rkt b/beautiful-racket/br/demo/hdl/tokenizer.rkt index b66aa77..37b5986 100644 --- a/beautiful-racket/br/demo/hdl/tokenizer.rkt +++ b/beautiful-racket/br/demo/hdl/tokenizer.rkt @@ -10,7 +10,7 @@ (lexer [(eof) eof] [(union #\tab #\space #\newline) (get-token input-port)] - [(union "CHIP" "IN" "OUT" "PARTS:" "out") lexeme] + [(union "CHIP" "IN" "OUT" "PARTS:") lexeme] [(char-set "{}(),;=") lexeme] [(repetition 1 +inf.0 (union alphabetic numeric)) (token 'ID (string->symbol lexeme))])) (get-token input-port))