suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

notes

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-26 17:57:04 -07:00
parent ae24f3a10b
commit 918efa4609
3 changed files with 43 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

56
beautiful-racket/br/demo/chip8.rkt
View File

@ -33,33 +33,35 @@
(check-equal? #xA (glue-bytes (list #xA))) (check-equal? #xA (glue-bytes (list #xA)))
(check-equal? #x0 (glue-bytes (list #x0)))) (check-equal? #x0 (glue-bytes (list #x0))))
(define-syntax (define-memory-vector stx) (define-macro (define-memory-vector ID [FIELD LENGTH SIZE] ...)
(syntax-case stx () (with-pattern
[(_ ID [FIELD LENGTH SIZE] ...) ([(PREFIXED-ID ...) (prefix-id #'ID "-" #'(FIELD ...))]
(with-syntax ([(ID-FIELD-REF ...) (map (λ(field) (format-id stx "~a-~a-ref" #'ID field)) (syntax->list #'(FIELD ...)))] [(PREFIXED-ID-REF ...) (suffix-id #'(PREFIXED-ID ...) "-ref")]
[(ID-FIELD-SET! ...) (map (λ(field) (format-id stx "~a-~a-set!" #'ID field)) (syntax->list #'(FIELD ...)))] [(PREFIXED-ID-SET! ...) (suffix-id #'(PREFIXED-ID ...) "-set!")]
[(FIELD-OFFSET ...) (reverse (cdr [(FIELD-OFFSET ...) (reverse (cdr
(for/fold ([offsets '(0)]) (for/fold ([accum-stxs (list #'0)])
([len (in-list (syntax->list #'(LENGTH ...)))] ([len-size-stx (in-list (syntax->list #'((LENGTH SIZE) ...)))])
[size (in-list (syntax->list #'(SIZE ...)))]) (cons (with-pattern
(cons (+ (syntax-local-eval #`(* #,len #,size)) (car offsets)) offsets))))]) ([accum (car accum-stxs)]
#'(begin [(len size) len-size-stx])
(define ID (make-vector (+ (* LENGTH SIZE) ...))) #'(+ (* len size) accum)) accum-stxs))))])
(define (ID-FIELD-REF idx) #'(begin
(unless (< idx LENGTH) (define ID (make-vector (+ (* LENGTH SIZE) ...)))
(raise-argument-error 'ID-FIELD-REF (format "index less than field length ~a" LENGTH) idx)) (define (PREFIXED-ID-REF idx)
(glue-bytes (unless (< idx LENGTH)
(for/list ([i (in-range SIZE)]) (raise-argument-error 'PREFIXED-ID-REF (format "index less than field length ~a" LENGTH) idx))
(vector-ref ID (+ FIELD-OFFSET i idx))))) (glue-bytes
... (for/list ([i (in-range SIZE)])
(define (ID-FIELD-SET! idx val) (vector-ref ID (+ FIELD-OFFSET i idx)))))
(unless (< idx LENGTH) ...
(raise-argument-error 'ID-FIELD-SET! (format "index less than field length ~a" LENGTH) idx)) (define (PREFIXED-ID-SET! idx val)
(unless (< val (expt 16 SIZE)) (unless (< idx LENGTH)
(raise-argument-error 'ID-FIELD-SET! (format "value less than field size ~a" (expt 16 SIZE)) val)) (raise-argument-error 'PREFIXED-ID-SET! (format "index less than field length ~a" LENGTH) idx))
(for ([i (in-range SIZE)] (unless (< val (expt 16 SIZE))
[b (in-list (explode-bytes val))]) (raise-argument-error 'PREFIXED-ID-SET! (format "value less than field size ~a" (expt 16 SIZE)) val))
(vector-set! ID (+ FIELD-OFFSET i idx) b))) ...))])) (for ([i (in-range SIZE)]
[b (in-list (explode-bytes val))])
(vector-set! ID (+ FIELD-OFFSET i idx) b))) ...)))
(define-memory-vector chip (define-memory-vector chip
[opcode 1 2] ; two bytes [opcode 1 2] ; two bytes

8
beautiful-racket/br/demo/hdl/Nand.hdl.rkt
View File

@ -12,7 +12,7 @@
(module+ test (module+ test
(require rackunit) (require rackunit)
(check-equal? (begin (a 0) (b 0) (out)) 1) (check-equal? (begin (a-write 0) (b-write 0) (out)) 1)
(check-equal? (begin (a 0) (b 1) (out)) 1) (check-equal? (begin (a-write 0) (b-write 1) (out)) 1)
(check-equal? (begin (a 1) (b 0) (out)) 1) (check-equal? (begin (a-write 1) (b-write 0) (out)) 1)
(check-equal? (begin (a 1) (b 1) (out)) 0)) (check-equal? (begin (a-write 1) (b-write 1) (out)) 0))

12
beautiful-racket/br/demo/hdl/expander.rkt
View File

@ -11,7 +11,7 @@
[(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")] [(IN-BUS-WRITE ...) (suffix-id #'(IN-BUS ...) "-write")]
[(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))]) [(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
#'(begin #'(begin
(provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...))) (provide (prefix-out CHIP-PREFIX (combine-out IN-BUS ... IN-BUS-WRITE ...)))
(define-input-bus IN-BUS IN-WIDTH ...) ... (define-input-bus IN-BUS IN-WIDTH ...) ...
PART ... PART ...
(provide PREFIX-OUT-BUS ...) (provide PREFIX-OUT-BUS ...)
@ -23,7 +23,11 @@
([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))] ([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
[CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)]) [CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
#'(begin #'(begin
(require (import-chip CHIP-MODULE-PATH) (for-syntax (import-chip CHIP-MODULE-PATH))) (require (import-chip CHIP-MODULE-PATH)
;; need for-syntax to make phase 1 binding available
;; so we can determine during expansion which buses are `input-bus?`
;; because the pin-spec syntax is inherently ambiguous
(for-syntax (import-chip CHIP-MODULE-PATH)))
(handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...)))) (handle-buses ((PARTNAME-BUS-LEFT . BUS-LEFT-ARGS) BUS-RIGHT-EXPR) ...))))
@ -40,6 +44,10 @@
([(in-bus-assignments out-bus-assignments) ([(in-bus-assignments out-bus-assignments)
(syntax-case-partition #'(BUS-ASSIGNMENTS ...) () (syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
[((PREFIXED-WIRE . _) _) [((PREFIXED-WIRE . _) _)
;; we "pre-evaluate" #'PREFIXED-WIRE so we can set up the program correctly.
;; This is not ideal: usually we want evaluate runtime expressions only at runtime.
;; But in this case, it controls which identifiers we `define`
;; so there's no way around it. Runtime would be too late.
(input-bus? (syntax-local-eval #'PREFIXED-WIRE))])]) (input-bus? (syntax-local-eval #'PREFIXED-WIRE))])])
(with-pattern (with-pattern
([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments] ([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]