suzanne.soy/beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

works

Browse Source
This commit is contained in:
Matthew Butterick 2016-04-08 10:05:35 -07:00
parent 2712ffa472
commit f6a680950c
4 changed files with 71 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
br-bf/bf-test-sexp.rkt
View File

@ -1,2 +1,2 @@
#lang s-exp br-bf
(bf-program (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op (loop "[" (op ">") (op "+") (op "+") (op "+") (op "+") (op "+") (op "<") (op "-") "]")) (op ">") (op "."))
(bf-program (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (op "+") (loop "[" (op ">") (op "+") (op "+") (op "+") (op "+") (op "+") (op "<") (op "-") "]") (op ">") (op "."))

38
br-bf/main.rkt
View File

@ -20,30 +20,30 @@
(for-each println (map syntax->datum result))
result))
(define #'(bf-program <op> ...)
#'(begin <op> ...))
(define #'(bf-program <op-or-loop> ...)
#'(begin <op-or-loop> ...))
(define #'(op <arg>)
(syntax-case #'(op <arg>) ()
[(op ">") #'(move-pointer 1)]
[(op "<") #'(move-pointer -1)]
[(op "+") #'(set-pointer-byte! (add1 (pointer-byte)))]
[(op "-") #'(set-pointer-byte! (sub1 (pointer-byte)))]
[(op ".") #'(write-byte (pointer-byte))]
[(op ",") #'(set-pointer-byte! (read-byte))]
[else #'<arg>])) ; <arg> must therefore be a loop
(define-cases #'op
[#'(_ ">") #'(move-pointer 1)]
[#'(_ "<") #'(move-pointer -1)]
[#'(_ "+") #'(set-pointer-byte! (add1 (get-pointer-byte)))]
[#'(_ "-") #'(set-pointer-byte! (sub1 (get-pointer-byte)))]
[#'(_ ".") #'(write-byte (get-pointer-byte))]
[#'(_ ",") #'(set-pointer-byte! (read-byte))])
(define #'(loop "[" <op> ... "]")
#'(until (zero? (pointer-byte))
<op> ...))
(define-cases f
[(_ arg) (add1 arg)]
[(_ arg1 arg2) (+ arg1 arg2)])
(define bf-vector (make-vector 10 0))
(define #'(loop "[" <op-or-loop> ... "]")
#'(until (zero? (get-pointer-byte))
<op-or-loop> ...))
(define bf-vector (make-vector 1000 0))
(define bf-pointer 0)
(define (pointer-byte) (vector-ref bf-vector bf-pointer))
(define (get-pointer-byte) (vector-ref bf-vector bf-pointer))
(define (set-pointer-byte! val) (vector-set! bf-vector bf-pointer val))
(define (move-pointer how-far)
(set! bf-pointer (+ bf-pointer how-far)))
(define (move-pointer how-far) (set! bf-pointer (+ bf-pointer how-far)))
(define (dump)
(displayln "")

19
br-bf/parser.rkt
View File

@ -2,6 +2,19 @@
;; use uppercase TOKEN-IDENTIFIERS for classes of tokens
;; too numerous to indicate individually
;; (e.g., numbers, strings)
bf-program : op*
op : ">" | "<" | "+" | "-" | "." | "," | loop
loop : "[" op* "]"
bf-program : (op | loop)*
op : ">" | "<" | "+" | "-" | "." | ","
loop : "[" (op | loop)* "]"
;; Alternate ways of specifying grammar
;; bf-program : op*
;; op : ">" | "<" | "+" | "-" | "." | "," | loop
;; loop : "[" op* "]"
;; bf-program : expr*
;; expr : op | loop
;; op : ">" | "<" | "+" | "-" | "." | ","
;; loop : "[" bf-program "]"

35
br/define.rkt
View File

@ -75,3 +75,38 @@
#'(zam x x))) (foo 42)) 84)
;; todo: error from define not trapped by check-exn
#;(check-exn exn:fail:syntax? (λ _ (br:define (#'times stx stx2) #'*))))
;; todo: support `else` case
(define-syntax (br:define-cases stx)
(syntax-parse stx
#:literals (syntax)
; (define-cases #'foo [#'(_ arg) #'(+ arg arg)] [#'(_ 42 bar) #'42] ...)
[(_ (syntax top-id) [(syntax (_ pat-arg ... . rest-arg)) body ...] ...)
#'(define-syntax top-id (λ (stx)
(define result
(syntax-case stx ()
[(_ pat-arg ... . rest-arg) body ...] ...))
(if (not (syntax? result))
(datum->syntax stx result)
result)))]
[(_ top-id [(_ pat-arg ... . rest-arg) body ...] ...)
#'(define top-id
(case-lambda
[(pat-arg ... . rest-arg) body ...] ...))]))
(module+ test
(br:define-cases #'op
[#'(_ "+") #''got-plus]
[#'(_ arg) #''got-something-else])
(check-equal? (op "+") 'got-plus)
(check-equal? (op 42) 'got-something-else)
(br:define-cases f
[(_ arg) (add1 arg)]
[(_ arg1 arg2) (+ arg1 arg2)])
(check-equal? (f 42) 43)
(check-equal? (f 42 5) 47))