From 918efa4609d3e6576ac5a3c7fdbd4af2392c4046 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Thu, 26 May 2016 17:57:04 -0700 Subject: [PATCH] notes --- beautiful-racket/br/demo/chip8.rkt | 56 ++++++++++++----------- beautiful-racket/br/demo/hdl/Nand.hdl.rkt | 8 ++-- beautiful-racket/br/demo/hdl/expander.rkt | 12 ++++- 3 files changed, 43 insertions(+), 33 deletions(-) diff --git a/beautiful-racket/br/demo/chip8.rkt b/beautiful-racket/br/demo/chip8.rkt index b294901..4ea33f3 100644 --- a/beautiful-racket/br/demo/chip8.rkt +++ b/beautiful-racket/br/demo/chip8.rkt @@ -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 diff --git a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt index 8e98888..ce89334 100644 --- a/beautiful-racket/br/demo/hdl/Nand.hdl.rkt +++ b/beautiful-racket/br/demo/hdl/Nand.hdl.rkt @@ -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)) diff --git a/beautiful-racket/br/demo/hdl/expander.rkt b/beautiful-racket/br/demo/hdl/expander.rkt index 9e53675..9f2bbed 100644 --- a/beautiful-racket/br/demo/hdl/expander.rkt +++ b/beautiful-racket/br/demo/hdl/expander.rkt @@ -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]