From b4a47b754f6d986e4c2e235456e7a5a767fb5585 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Mon, 29 Aug 2016 08:42:59 -0700 Subject: [PATCH] resume in stx pattern --- beautiful-racket/br/demo/bf/bf-atsign.rkt | 2 +- .../br/demo/bf/bf-expander-imperative.rkt | 31 ++++++++-------- beautiful-racket/br/demo/bf/bf-expander.rkt | 37 ++++++++++--------- beautiful-racket/br/demo/bf/bf-parser.rkt | 2 +- beautiful-racket/br/demo/bf/bf-reader.rkt | 26 ++++++------- brag/brag/private/internal-support.rkt | 4 +- 6 files changed, 52 insertions(+), 50 deletions(-) diff --git a/beautiful-racket/br/demo/bf/bf-atsign.rkt b/beautiful-racket/br/demo/bf/bf-atsign.rkt index dd149f7..a5d2b0b 100644 --- a/beautiful-racket/br/demo/bf/bf-atsign.rkt +++ b/beautiful-racket/br/demo/bf/bf-atsign.rkt @@ -1,3 +1,3 @@ #lang reader "bf-reader.rkt" Greatest language ever! -++++++++[>++++++++<-]>. \ No newline at end of file +++++-+++-++-++[>++++-+++-++-++<-]>.[ \ No newline at end of file diff --git a/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt b/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt index 8a096ab..e92e2fc 100644 --- a/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander-imperative.rkt @@ -5,10 +5,24 @@ PARSE-TREE)) (provide (rename-out [bf-module-begin #%module-begin])) -(define-macro (bf-program PROGRAM-ARG ...) - #'(void PROGRAM-ARG ...)) +(define-macro (bf-program OP-OR-LOOP-ARG ...) + #'(void OP-OR-LOOP-ARG ...)) (provide bf-program) +(define-macro-cases op + [(op ">") #'(gt)] + [(op "<") #'(lt)] + [(op "+") #'(plus)] + [(op "-") #'(minus)] + [(op ".") #'(period)] + [(op ",") #'(comma)]) +(provide op) + +(define-macro (loop LOOP-ARG ...) + #'(until (zero? (current-byte)) + LOOP-ARG ...)) +(provide loop) + (define arr (make-vector 30000 0)) (define ptr 0) @@ -23,16 +37,3 @@ (define (period) (write-byte (current-byte))) (define (comma) (set-current-byte! (read-byte))) -(define-macro-cases op - [(op ">") #'(gt)] - [(op "<") #'(lt)] - [(op "+") #'(plus)] - [(op "-") #'(minus)] - [(op ".") #'(period)] - [(op ",") #'(comma)]) -(provide op) - -(define-macro (loop LOOP-ARG ...) - #'(until (zero? (current-byte)) - LOOP-ARG ...)) -(provide loop) diff --git a/beautiful-racket/br/demo/bf/bf-expander.rkt b/beautiful-racket/br/demo/bf/bf-expander.rkt index ab0f695..7a19d52 100644 --- a/beautiful-racket/br/demo/bf/bf-expander.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander.rkt @@ -11,10 +11,27 @@ 0))) (provide bf-program) +(define-macro-cases op + [(op ">") #'gt] + [(op "<") #'lt] + [(op "+") #'plus] + [(op "-") #'minus] + [(op ".") #'period] + [(op ",") #'comma]) +(provide op) + +(define-macro (loop LOOP-ARG ...) + #'(lambda (arr ptr) + (for/fold ([apl (list arr ptr)]) + ([i (in-naturals)] + #:break (zero? (apply current-byte apl))) + (apply fold-args (list LOOP-ARG ...) apl)))) +(provide loop) + (define (fold-args bf-args arr ptr) - (for/fold ([ap (list arr ptr)]) + (for/fold ([apl (list arr ptr)]) ([bf-arg (in-list bf-args)]) - (apply bf-arg ap))) + (apply bf-arg apl))) (define (current-byte arr ptr) (vector-ref arr ptr)) @@ -29,19 +46,3 @@ (define (period arr ptr) (write-byte (current-byte arr ptr)) (list arr ptr)) (define (comma arr ptr) (list (set-current-byte arr ptr (read-byte)) ptr)) -(define-macro-cases op - [(op ">") #'gt] - [(op "<") #'lt] - [(op "+") #'plus] - [(op "-") #'minus] - [(op ".") #'period] - [(op ",") #'comma]) -(provide op) - -(define-macro (loop LOOP-ARG ...) - #'(lambda (arr ptr) - (for/fold ([ap (list arr ptr)]) - ([i (in-naturals)] - #:break (zero? (apply current-byte ap))) - (apply fold-args (list LOOP-ARG ...) ap)))) -(provide loop) diff --git a/beautiful-racket/br/demo/bf/bf-parser.rkt b/beautiful-racket/br/demo/bf/bf-parser.rkt index 2792823..ebfb9ba 100644 --- a/beautiful-racket/br/demo/bf/bf-parser.rkt +++ b/beautiful-racket/br/demo/bf/bf-parser.rkt @@ -1,4 +1,4 @@ #lang brag bf-program : (op | loop)* op : ">" | "<" | "+" | "-" | "." | "," -loop : /"[" (op | loop)* /"]" \ No newline at end of file +loop : "[" (op | loop)* "]" \ No newline at end of file diff --git a/beautiful-racket/br/demo/bf/bf-reader.rkt b/beautiful-racket/br/demo/bf/bf-reader.rkt index 2ae740e..09c98cd 100644 --- a/beautiful-racket/br/demo/bf/bf-reader.rkt +++ b/beautiful-racket/br/demo/bf/bf-reader.rkt @@ -1,20 +1,20 @@ #lang br/quicklang -(require parser-tools/lex brag/support) +(require "bf-parser.rkt") + +(define (read-syntax path port) + (define parse-tree (parse path (tokenize port))) + (define module-datum `(module bf-mod br/demo/bf/bf-expander-imperative + ,parse-tree)) + (datum->syntax #f module-datum)) +(provide read-syntax) -(define (tokenize input-port) +(require parser-tools/lex brag/support) +(define (tokenize port) (define (next-token) (define our-lexer (lexer + [(eof) eof] [(char-set "><-.,+[]") lexeme] - [(char-complement (char-set "><-.,+[]")) - (token 'COMMENT #:skip? #t)] - [(eof) eof])) - (our-lexer input-port)) + [any-char (token 'COMMENT #:skip? #t)])) + (our-lexer port)) next-token) - -(require "bf-parser.rkt") -(define (read-syntax source-path input-port) - (define parse-tree (parse source-path (tokenize input-port))) - (datum->syntax #f `(module bf-mod br/demo/bf/bf-expander-imperative - ,parse-tree))) -(provide read-syntax) diff --git a/brag/brag/private/internal-support.rkt b/brag/brag/private/internal-support.rkt index 8ff5f7d..0beec3e 100755 --- a/brag/brag/private/internal-support.rkt +++ b/brag/brag/private/internal-support.rkt @@ -15,8 +15,8 @@ (make-parameter (lambda (tok-name tok-value offset line col span) (raise (exn:fail:parsing - (format "Encountered parsing error near token ~e (~e) while parsing ~e [line=~a, column=~a, offset=~a]" - tok-name tok-value + (format "Encountered parsing error near ~e (token ~e) while parsing ~e [line=~a, column=~a, offset=~a]" + tok-value tok-name (current-source) line col offset) (current-continuation-marks)