use cleaner grammar notation

pull/2/head
Matthew Butterick 9 years ago
parent 17d9f17f4e
commit c574ce3b54

@ -8,77 +8,51 @@
(displayln (format "got unbound identifier: ~a" 'id))
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
(define-inverting #'(tst-program _arg ...)
(define #'(tst-program _arg ...)
#'(begin
_arg ...))
(define-for-syntax output-here #'output-here)
(define-inverting #'(header-expr (_filename-string _procname) (_colid ... _outid) ";")
(inject-syntax ([#'shared-procname (shared-syntax #'_procname)]
[#'output (shared-syntax 'output)])
(define #'(header-expr _filename (_colid ... _outid))
(with-syntax* ([filename-string (symbol->string (syntax->datum #'_filename))]
[procname (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))]
[output (shared-syntax 'output)])
#'(begin
(provide (all-defined-out))
(define shared-procname (dynamic-require (findf file-exists? (list _filename-string (format "~a.rkt" _filename-string))) 'shared-procname))
(define procname (dynamic-require (findf file-exists? (list filename-string (format "~a.rkt" filename-string))) 'procname))
(display-header '_colid ... '_outid)
(define _colid (make-parameter 0)) ...
(define (_outid)
(keyword-apply shared-procname
(keyword-apply procname
(map (compose1 string->keyword symbol->string) (list '_colid ...))
(list (_colid) ...) null))
(define (output)
(display-values (_colid) ... (_outid))))))
(define-inverting #'(load-expr "load" (_filename-string _procname) ",")
#'(_filename-string _procname))
(define #'(filename _filename)
(define #'(load-expr _filename)
(inject-syntax ([#'filename-string (symbol->string (syntax->datum #'_filename))]
[#'proc-name (string->symbol (cadr (regexp-match #rx"^(.*)\\.hdl$"(symbol->string (syntax->datum #'_filename)))))])
#'(filename-string proc-name)))
(define-inverting #'(table-expr "output-list" _column-id ...)
#'(_column-id ...))
(define-cases #'column-id
[#'(_ _colid) #'_colid]
[#'(_ _colid ",") #'_colid])
(define #'(display-header _sym ...)
#'(begin
(apply display-values (list _sym ...))
(apply display-dashes (list _sym ...))))
(define (vals->text vals)
(string-join (map ~a vals) " | "))
(define (vals->text vals) (string-join (map ~a vals) " | "))
(define (display-values . vals)
(displayln (vals->text vals)))
(define (display-values . vals) (displayln (vals->text vals)))
(define (display-dashes . vals)
(displayln (make-string (string-length (vals->text vals)) #\-)))
(define #'test-expr #'begin)
(define-inverting #'(test-expr _step-expr ... ";")
#'(begin
_step-expr ...))
(define-cases #'step-expr
[#'(_ _step) #'_step]
[#'(_ _step ",") #'_step])
(define #'(set-expr "set" _id _val)
#'(_id _val))
(define #'(eval-expr "eval")
#'(void))
(define #'eval-expr #'void)
(define #'(output-expr "output")
(define #'(output-expr)
(inject-syntax ([#'output (shared-syntax 'output)])
#'(output)))

@ -2,22 +2,20 @@
tst-program : header-expr test-expr*
header-expr : load-expr table-expr ";"
header-expr : load-expr table-expr /";"
load-expr : "load" filename ","
@load-expr : /"load" ID /","
filename : ID
/table-expr : /"output-list" columns
table-expr : "output-list" column-id+
@columns : ID [/"," columns]
column-id : ID [","]
test-expr : step-expr+ /";"
test-expr : step-expr+ ";"
@step-expr : (set-expr | @eval-expr | output-expr) [/","]
step-expr : (set-expr | eval-expr | output-expr) [","]
/set-expr : /"set" ID VAL
set-expr : "set" ID VAL
eval-expr : /"eval"
eval-expr : "eval"
output-expr : "output"
output-expr : /"output"

@ -1,4 +1,4 @@
#lang br/demo/hdl/tst
#lang br/demo/hdl-tst
// This file is part of www.nand2tetris.org
// and the book "The Elements of Computing Systems"
// by Nisan and Schocken, MIT Press.

@ -33,7 +33,7 @@
[#'(_ _pin "=" _val) #'(_pin _val)])
(define #'(call-part _partname [_pin _val] ...)
(inject-syntax ([#'part-path (format "~a.hdl" (syntax->datum #'_partname))]
(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]))

Loading…
Cancel
Save