mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

updates

Browse Source
pull/10/head
Matthew Butterick 8 years ago
parent 87009e367b
commit f25679622a
4 changed files with 80 additions and 95 deletions
Show Stats Download Patch File Download Diff File

100
beautiful-racket-demo/hdl-tst-demo/expander.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang br/quicklang #lang br/quicklang
(require (for-syntax br/syntax racket/string) rackunit racket/file) (require (for-syntax racket/string) rackunit racket/file)
(provide #%module-begin (all-defined-out)) (provide #%module-begin
(matching-identifiers-out #rx"^tst-" (all-defined-out)))
(define (print-cell val fmt) (define (print-cell val fmt)
(match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1 (match-define (list _ radix-letter number-strings) (regexp-match #px"^%(.)(.*)$" fmt)) ; like %B1.16.1
@ -36,65 +36,59 @@
(define-macro (tst-program EXPR ...) (define-macro (tst-program EXPR ...)
(with-shared-id (with-shared-id (compare-files)
(compare-files) #'(begin
#'(begin EXPR ...
EXPR ... (compare-files))))
(compare-files))))
(define-macro (load-expr CHIPFILE-STRING) (define-macro (tst-load-expr CHIPFILE-STRING)
(set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" "")) (set! chip-prefix (string-replace (syntax->datum #'CHIPFILE-STRING) ".hdl" ""))
(with-pattern (with-pattern
([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)]) ([CHIPFILE.RKT (format-string "~a.rkt" #'CHIPFILE-STRING)])
#'(require CHIPFILE.RKT))) #'(require CHIPFILE.RKT)))
(define-macro (output-file-expr OUTPUT-FILE-STRING) (define-macro (tst-output-file-expr OUTPUT-FILE-STRING)
(with-shared-id (with-shared-id (output-file output-filename)
(output-file output-filename)
#'(begin
(define output-filename OUTPUT-FILE-STRING)
(with-output-to-file output-filename
(λ () (printf ""))
#:mode 'text
#:exists 'replace))))
(define-macro (compare-to-expr COMPARE-FILE-STRING)
(with-shared-id
(compare-files output-filename)
#'(define (compare-files)
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(define-macro (output-list-expr (COL-NAME FORMAT-SPEC) ...)
(with-shared-id
(eval-result eval-chip output output-filename)
(with-pattern
([(COL-ID ...) (suffix-id #'(COL-NAME ...))]
[(CHIP-COL-ID ...) (prefix-id chip-prefix "-" #'(COL-NAME ...))])
#'(begin #'(begin
(define (output COL-ID ...) (define output-filename OUTPUT-FILE-STRING)
(print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...)))) (with-output-to-file output-filename
(define eval-result #f) (λ () (printf ""))
(define (eval-chip) (list (CHIP-COL-ID) ...)) #:mode 'text
(output COL-NAME ...))))) #:exists 'replace))))
(define-macro (tst-compare-to-expr COMPARE-FILE-STRING)
(with-shared-id (compare-files output-filename)
#'(define (compare-files)
(check-equal? (file->lines output-filename) (file->lines COMPARE-FILE-STRING)))))
(define-macro (tst-output-list-expr (COL-NAME FORMAT-SPEC) ...)
(with-shared-id (eval-result eval-chip output output-filename)
(with-pattern
([(COL-ID ...) (suffix-ids #'(COL-NAME ...))]
[(CHIP-COL-ID ...) (prefix-ids chip-prefix "-" #'(COL-NAME ...))])
#'(begin
(define (output COL-ID ...)
(print-line output-filename (map print-cell (list COL-ID ...) (list FORMAT-SPEC ...))))
(define eval-result #f)
(define (eval-chip) (list (CHIP-COL-ID) ...))
(output COL-NAME ...)))))
(define-macro (set-expr IN-BUS IN-VAL) (define-macro (tst-set-expr IN-BUS IN-VAL)
(with-pattern (with-pattern
([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))]) ([CHIP-IN-BUS-ID-WRITE (prefix-id chip-prefix "-" (suffix-id #'IN-BUS "-write"))])
#'(CHIP-IN-BUS-ID-WRITE IN-VAL))) #'(CHIP-IN-BUS-ID-WRITE IN-VAL)))
(define-macro (eval-expr) (define-macro (tst-eval-expr)
(with-shared-id (with-shared-id (eval-result eval-chip)
(eval-result eval-chip) #'(set! eval-result (eval-chip))))
#'(set! eval-result (eval-chip))))
(define-macro (output-expr) (define-macro (tst-output-expr)
(with-shared-id (with-shared-id (output eval-result)
(output eval-result) #'(apply output eval-result)))
#'(apply output eval-result)))

8
beautiful-racket-demo/hdl-tst-demo/main.rkt
Unescape Escape View File

@ -2,6 +2,10 @@
(module reader br (module reader br
(require br/reader-utils "parser.rkt" "tokenizer.rkt") (require br/reader-utils "parser.rkt" "tokenizer.rkt")
(define-read-and-read-syntax (source-path input-port) (define-read-and-read-syntax (source-path port)
(define-values (line col pos) (port-next-location port))
(define port+newline (input-port-append #f port (open-input-string "\n")))
(port-count-lines! port+newline)
(set-port-next-location! port+newline line col pos)
#`(module hdl-mod hdl-tst-demo/expander #`(module hdl-mod hdl-tst-demo/expander
#,(parse source-path (tokenize input-port))))) #,(parse source-path (make-tokenizer port+newline)))))

32
beautiful-racket-demo/hdl-tst-demo/parser.rkt
Unescape Escape View File

@ -1,23 +1,13 @@
#lang brag #lang brag
tst-program : load-expr output-file-expr compare-to-expr output-list-expr /";" test-expr* tst-program : tst-load-expr tst-output-file-expr tst-compare-to-expr tst-output-list-expr /";" tst-test-expr*
tst-load-expr : /"load" ID /","
load-expr : /"load" ID /"," tst-output-file-expr : /"output-file" ID /","
tst-compare-to-expr : /"compare-to" ID /","
output-file-expr : /"output-file" ID /"," tst-output-list-expr : /"output-list" tst-column [tst-column]+
/tst-column : ID FORMAT-STRING
compare-to-expr : /"compare-to" ID /"," @tst-test-expr : tst-step-expr+ /";"
@tst-step-expr : (tst-set-expr | tst-eval-expr | tst-output-expr) [/","]
output-list-expr : /"output-list" column [column]+ tst-set-expr : /"set" ID VAL
tst-eval-expr : /"eval"
/column : ID FORMAT-STRING tst-output-expr : /"output"
@test-expr : step-expr+ /";"
@step-expr : (set-expr | eval-expr | output-expr) [/","]
set-expr : /"set" ID VAL
eval-expr : /"eval"
output-expr : /"output"

35
beautiful-racket-demo/hdl-tst-demo/tokenizer.rkt
Unescape Escape View File

@ -1,21 +1,18 @@
#lang br #lang br/quicklang
(require brag/support (require brag/support)
racket/string) (provide make-tokenizer)
(provide tokenize) (define hdl-test-lexer
(define (tokenize input-port) (lexer-srcloc
(define (next-token) [(eof) eof]
(define get-token [(:or (from/to "/*" "*/")
(lexer-src-pos (from/to "//" #\newline)) (token 'COMMENT lexeme #:skip? #t)]
[(eof) eof] [whitespace (token lexeme #:skip? #t)]
[(union [(:or "load" "output-list" "output-file" "compare-to" "set" "eval" "output" "," ";") lexeme]
(:seq "/*" (complement (:seq any-string "*/" any-string)) "*/") [(:seq "%" (:+ alphabetic numeric ".")) (token 'FORMAT-STRING lexeme)]
(:seq "//" (repetition 1 +inf.0 (char-complement #\newline)) #\newline)) [(:+ numeric) (token 'VAL (string->number lexeme))]
(token 'COMMENT lexeme #:skip? #t)] [(:+ alphabetic numeric "-" ".") (token 'ID lexeme)]))
[(union #\tab #\space #\newline) (return-without-pos (get-token input-port))]
[(union "load" "output-list" "output-file" "compare-to" "set" "eval" "output" (char-set ",;")) lexeme] (define (make-tokenizer ip)
[(:seq "%" (repetition 1 +inf.0 (union alphabetic numeric (char-set ".")))) (token 'FORMAT-STRING lexeme)] (define (next-token) (hdl-test-lexer ip))
[(repetition 1 +inf.0 numeric) (token 'VAL (string->number lexeme))]
[(repetition 1 +inf.0 (union alphabetic numeric (char-set "-."))) (token 'ID lexeme)]))
(get-token input-port))
next-token) next-token)

Write Preview
Loading…
Cancel
Save