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

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

@ -12,7 +12,7 @@
(module+ test
(require rackunit)
(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))
(check-equal? (begin (a-write 0) (b-write 0) (out)) 1)
(check-equal? (begin (a-write 0) (b-write 1) (out)) 1)
(check-equal? (begin (a-write 1) (b-write 0) (out)) 1)
(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")]
[(PREFIX-OUT-BUS ...) (prefix-id #'CHIP-PREFIX #'(OUT-BUS ...))])
#'(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 ...) ...
PART ...
(provide PREFIX-OUT-BUS ...)
@ -23,7 +23,11 @@
([(PARTNAME-BUS-LEFT ...) (prefix-id #'PARTNAME "-" #'(BUS-LEFT ...))]
[CHIP-MODULE-PATH (format-string "~a.hdl.rkt" #'PARTNAME)])
#'(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) ...))))
@ -40,6 +44,10 @@
([(in-bus-assignments out-bus-assignments)
(syntax-case-partition #'(BUS-ASSIGNMENTS ...) ()
[((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))])])
(with-pattern
([(((IN-BUS IN-BUS-ARG ...) IN-BUS-VALUE) ...) in-bus-assignments]