resume in hdl-test
parent
fd4297ddc8
commit
1f805852f0
@ -1,13 +1,19 @@
|
||||
#lang br
|
||||
(provide (prefix-out Nand- (all-defined-out)))
|
||||
(require "helper.rkt")
|
||||
|
||||
(define+provide (Nand #:a a #:b b)
|
||||
(if (< (+ a b) 2)
|
||||
(define a (make-input))
|
||||
(define b (make-input))
|
||||
|
||||
|
||||
(define (out)
|
||||
(if (< (+ (a) (b)) 2)
|
||||
1
|
||||
0))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (Nand #:a 0 #:b 0) 1)
|
||||
(check-equal? (Nand #:a 0 #:b 1) 1)
|
||||
(check-equal? (Nand #:a 1 #:b 0) 1)
|
||||
(check-equal? (Nand #:a 1 #:b 1) 0))
|
||||
(check-equal? (begin (a 0) (b 0) (out)) 1)
|
||||
(check-equal? (begin (a 0) (b 1) (out)) 1)
|
||||
(check-equal? (begin (a 1) (b 0) (out)) 1)
|
||||
(check-equal? (begin (a 1) (b 1) (out)) 0))
|
||||
|
||||
@ -0,0 +1,16 @@
|
||||
#lang s-exp br/demo/hdl/expander
|
||||
|
||||
#|
|
||||
CHIP Not {
|
||||
IN in;
|
||||
OUT out;
|
||||
|
||||
PARTS:
|
||||
Nand(a=in, b=in, out=out);
|
||||
}
|
||||
|#
|
||||
|
||||
(chip-program Not
|
||||
(in-spec in)
|
||||
(out-spec out)
|
||||
(part-spec (part Nand (a in) (b in) (out out))))
|
||||
@ -1,38 +0,0 @@
|
||||
#lang racket
|
||||
#|
|
||||
|
||||
CHIP Not {
|
||||
IN in;
|
||||
OUT out, outb;
|
||||
|
||||
PARTS:
|
||||
;; each part has only as many args as wires in that part
|
||||
Nand(a=in, b=in, out=nand-out);
|
||||
Fanout(in=nand-out, outa=out, outb=outb);
|
||||
|
||||
}
|
||||
|
||||
|#
|
||||
|
||||
(require "helper.rkt" "helper-macro.rkt" (for-syntax "helper.rkt" racket/syntax racket/list))
|
||||
|
||||
;; IN and OUT spec becomes provide spec, prefixed with chip name
|
||||
(provide (prefix-out Not- (combine-out in out outb)))
|
||||
|
||||
;; all IN and OUT pins are functions.
|
||||
|
||||
(define in (make-input)) ; all inputs are made from the same function that holds state like a parameter.
|
||||
|
||||
;; all outputs are computed at runtime.
|
||||
(require "Nand2.hdl.rkt" (for-syntax "Nand2.hdl.rkt"))
|
||||
(handle-part Nand2 [a in] [b in] [out nand-out])
|
||||
(require "Fanout.hdl.rkt" (for-syntax "Fanout.hdl.rkt"))
|
||||
(handle-part Fanout [in nand-out] [outa out] [outb outb])
|
||||
;(handle-require Fanout [in nand-out] [outa out] [outb outb])
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(in 1)
|
||||
(check-equal? (out) 0)
|
||||
(in 0)
|
||||
(check-equal? (out) 1))
|
||||
@ -1,24 +1,44 @@
|
||||
#lang br
|
||||
(require "helper.rkt" (for-syntax racket/base racket/syntax "helper.rkt" racket/list racket/require-transform))
|
||||
(provide #%top-interaction #%module-begin #%app #%datum (all-defined-out))
|
||||
|
||||
|
||||
(define #'(chip-program _chipname
|
||||
(pin-spec _input-pin ...)
|
||||
(pin-spec _output-pin ...)
|
||||
(part-spec (part _partname (_pin _val) ... (_lastpin _pinout)) ...))
|
||||
(in-spec _input-pin ...)
|
||||
(out-spec _output-pin ...)
|
||||
(part-spec (part _partname (_pin _val) ... ) ...))
|
||||
(with-syntax ([chip-prefix (format-id #'_chipname "~a-" #'_chipname)])
|
||||
#'(begin
|
||||
(provide (prefix-out chip-prefix (combine-out _input-pin ... _output-pin ...)))
|
||||
(define _input-pin (make-input)) ...
|
||||
(handle-part _partname (_pin _val) ...) ...)))
|
||||
|
||||
|
||||
(define #'(handle-part _prefix [_suffix _arg] ...)
|
||||
(with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'_prefix s)) (syntax->list #'(_suffix ...)))]
|
||||
[chip-module-path (datum->syntax #'_prefix (format "~a.hdl.rkt" (syntax->datum #'_prefix)))])
|
||||
#'(begin
|
||||
(require (import-chip chip-module-path) (for-syntax (import-chip chip-module-path)))
|
||||
(handle-wires [prefix-suffix _arg] ...))))
|
||||
|
||||
|
||||
(define-syntax import-chip
|
||||
(make-require-transformer
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ module-path)
|
||||
(expand-import #'module-path)]))))
|
||||
|
||||
|
||||
(define #'(handle-wires _wirearg-pair ...)
|
||||
(let-values ([(in-wire-stxs out-wire-stxs)
|
||||
(partition (λ(wirearg-pair-stx)
|
||||
(define wire-stx (car (syntax->list wirearg-pair-stx)))
|
||||
(input-wire? (syntax-local-eval wire-stx)))
|
||||
(syntax->list #'(_wirearg-pair ...)))])
|
||||
(with-syntax ([([in-wire in-arg] ...) in-wire-stxs]
|
||||
[([out-wire out-arg] ...) out-wire-stxs])
|
||||
#'(begin
|
||||
(define+provide _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))] ...)
|
||||
(define _pinout (call-part _partname [_pin _val] ...)) ...
|
||||
(values _output-pin ...)))) '_chipname))))
|
||||
|
||||
|
||||
(define #'(call-part _partname [_pin _val] ...)
|
||||
(inject-syntax ([#'part-path (findf file-exists? (list (format "~a.hdl" (syntax->datum #'_partname)) (format "~a.hdl.rkt" (syntax->datum #'_partname))))]
|
||||
[#'(kw ...) (map (λ(pi) (string->keyword (format "~a" (syntax->datum pi)))) (syntax->list #'(_pin ...)))])
|
||||
#'(let ()
|
||||
(local-require (rename-in part-path [_partname local-name]))
|
||||
(keyword-apply local-name '(kw ...) (list _val ...) null))))
|
||||
(define (out-arg)
|
||||
(in-wire (in-arg)) ...
|
||||
(out-wire)) ...))))
|
||||
@ -1,35 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax "helper.rkt" racket/list))
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
||||
(define-syntax (handle-require stx)
|
||||
(syntax-case stx ()
|
||||
[(_ prefix [suffix arg] ...)
|
||||
(with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'prefix s)) (syntax->list #'(suffix ...)))]
|
||||
[module-name (format "~a.hdl.rkt" (syntax->datum #'prefix))])
|
||||
#'(begin
|
||||
(local-require module-name (for-syntax module-name))
|
||||
(handle-wires [prefix-suffix arg] ...)))]))
|
||||
|
||||
|
||||
(define-syntax (handle-part stx)
|
||||
(syntax-case stx ()
|
||||
[(_ prefix [suffix arg] ...)
|
||||
(with-syntax ([(prefix-suffix ...) (map (λ(s) (format-id s "~a-~a" #'prefix s)) (syntax->list #'(suffix ...)))]
|
||||
[module-name (format "~a.hdl.rkt" (syntax->datum #'prefix))])
|
||||
#'(begin
|
||||
(require module-name (for-syntax module-name))
|
||||
(handle-wires [prefix-suffix arg] ...)))]))
|
||||
|
||||
|
||||
(define-syntax (handle-wires stx)
|
||||
(syntax-case stx ()
|
||||
[(_ [wire arg] ...)
|
||||
(let ()
|
||||
(define-values (in-wires out-wires) (partition (λ(stx) (let ([wire (car (syntax->list stx))])
|
||||
(input-wire? (syntax-local-eval wire)))) (syntax->list #'([wire arg] ...))))
|
||||
(with-syntax ([([in-wire in-arg] ...) in-wires]
|
||||
[([out-wire out-arg] ...) out-wires])
|
||||
#'(begin
|
||||
(define out-arg (λ () (in-wire (in-arg)) ... (out-wire))) ...)))]))
|
||||
Loading…
Reference in New Issue