resume in stx pattern

pull/2/head
Matthew Butterick 8 years ago
parent 7e367b3d8d
commit b4a47b754f

@ -1,3 +1,3 @@
#lang reader "bf-reader.rkt"
Greatest language ever!
++++++++[>++++++++<-]>.
++++-+++-++-++[>++++-+++-++-++<-]>.[

@ -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)

@ -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)

@ -1,4 +1,4 @@
#lang brag
bf-program : (op | loop)*
op : ">" | "<" | "+" | "-" | "." | ","
loop : /"[" (op | loop)* /"]"
loop : "[" (op | loop)* "]"

@ -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)

@ -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)

Loading…
Cancel
Save