resume in stx pattern
This commit is contained in:
parent
7e367b3d8d
commit
b4a47b754f
|
@ -1,3 +1,3 @@
|
||||||
#lang reader "bf-reader.rkt"
|
#lang reader "bf-reader.rkt"
|
||||||
Greatest language ever!
|
Greatest language ever!
|
||||||
++++++++[>++++++++<-]>.
|
++++-+++-++-++[>++++-+++-++-++<-]>.[
|
|
@ -5,10 +5,24 @@
|
||||||
PARSE-TREE))
|
PARSE-TREE))
|
||||||
(provide (rename-out [bf-module-begin #%module-begin]))
|
(provide (rename-out [bf-module-begin #%module-begin]))
|
||||||
|
|
||||||
(define-macro (bf-program PROGRAM-ARG ...)
|
(define-macro (bf-program OP-OR-LOOP-ARG ...)
|
||||||
#'(void PROGRAM-ARG ...))
|
#'(void OP-OR-LOOP-ARG ...))
|
||||||
(provide bf-program)
|
(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 arr (make-vector 30000 0))
|
||||||
(define ptr 0)
|
(define ptr 0)
|
||||||
|
|
||||||
|
@ -23,16 +37,3 @@
|
||||||
(define (period) (write-byte (current-byte)))
|
(define (period) (write-byte (current-byte)))
|
||||||
(define (comma) (set-current-byte! (read-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)))
|
0)))
|
||||||
(provide bf-program)
|
(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)
|
(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)])
|
([bf-arg (in-list bf-args)])
|
||||||
(apply bf-arg ap)))
|
(apply bf-arg apl)))
|
||||||
|
|
||||||
(define (current-byte arr ptr) (vector-ref arr ptr))
|
(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 (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 (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
|
#lang brag
|
||||||
bf-program : (op | loop)*
|
bf-program : (op | loop)*
|
||||||
op : ">" | "<" | "+" | "-" | "." | ","
|
op : ">" | "<" | "+" | "-" | "." | ","
|
||||||
loop : /"[" (op | loop)* /"]"
|
loop : "[" (op | loop)* "]"
|
|
@ -1,20 +1,20 @@
|
||||||
#lang br/quicklang
|
#lang br/quicklang
|
||||||
(require parser-tools/lex brag/support)
|
(require "bf-parser.rkt")
|
||||||
|
|
||||||
(define (tokenize input-port)
|
(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)
|
||||||
|
|
||||||
|
(require parser-tools/lex brag/support)
|
||||||
|
(define (tokenize port)
|
||||||
(define (next-token)
|
(define (next-token)
|
||||||
(define our-lexer
|
(define our-lexer
|
||||||
(lexer
|
(lexer
|
||||||
|
[(eof) eof]
|
||||||
[(char-set "><-.,+[]") lexeme]
|
[(char-set "><-.,+[]") lexeme]
|
||||||
[(char-complement (char-set "><-.,+[]"))
|
[any-char (token 'COMMENT #:skip? #t)]))
|
||||||
(token 'COMMENT #:skip? #t)]
|
(our-lexer port))
|
||||||
[(eof) eof]))
|
|
||||||
(our-lexer input-port))
|
|
||||||
next-token)
|
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
|
(make-parameter
|
||||||
(lambda (tok-name tok-value offset line col span)
|
(lambda (tok-name tok-value offset line col span)
|
||||||
(raise (exn:fail:parsing
|
(raise (exn:fail:parsing
|
||||||
(format "Encountered parsing error near token ~e (~e) while parsing ~e [line=~a, column=~a, offset=~a]"
|
(format "Encountered parsing error near ~e (token ~e) while parsing ~e [line=~a, column=~a, offset=~a]"
|
||||||
tok-name tok-value
|
tok-value tok-name
|
||||||
(current-source)
|
(current-source)
|
||||||
line col offset)
|
line col offset)
|
||||||
(current-continuation-marks)
|
(current-continuation-marks)
|
||||||
|
|
Loading…
Reference in New Issue
Block a user