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

refactoring

Browse Source
This commit is contained in:
Matthew Butterick 2016-05-25 11:24:17 -07:00
parent 4e0e306777
commit fc826f9269
8 changed files with 130 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
beautiful-racket-lib/br/define.rkt
View File

@ -64,10 +64,12 @@
(when (member 'else all-but-last-pat-datums) (when (member 'else all-but-last-pat-datums)
(raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name)))) (raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name))))
(with-syntax* ([((pat . result-exprs) ... else-result-exprs) (with-syntax* ([((pat . result-exprs) ... else-result-exprs)
(syntax-case #'patexprs (syntax else) (syntax-parse #'patexprs
[(((syntax pat) result-expr) ... (else . else-result-exprs)) #:literals (syntax else)
;; syntax notation on pattern is optional
[(((~or (syntax pat) pat) result-expr) ... (else . else-result-exprs))
#'((pat result-expr) ... else-result-exprs)] #'((pat result-expr) ... else-result-exprs)]
[(((syntax pat) result-expr) ...) [(((~or (syntax pat) pat) result-expr) ...)
#'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'top-id.name))))])] #'((pat result-expr) ... (list (raise-syntax-error 'define-cases (format "no matching case for syntax pattern ~v" (syntax->datum stx)) (syntax->datum #'top-id.name))))])]
[LITERALS (generate-literals #'(pat ...))]) [LITERALS (generate-literals #'(pat ...))])
#'(define-syntax top-id.name (λ (stx) #'(define-syntax top-id.name (λ (stx)
@ -94,8 +96,8 @@
(define foo-val 'got-foo-val) (define foo-val 'got-foo-val)
(define (foo-func) 'got-foo-func) (define (foo-func) 'got-foo-func)
(br:define-cases #'op (br:define-cases #'op
[#'(_ "+") #''got-plus] [(_ "+") #''got-plus]
[#'(_ _ARG) #''got-something-else] [(_ _ARG) #''got-something-else]
[#'(_) #'(foo-func)] [#'(_) #'(foo-func)]
[#'_ #'foo-val]) [#'_ #'foo-val])
@ -295,17 +297,21 @@
(define-syntax (br:define-macro stx) (define-syntax (br:define-macro stx)
(syntax-case stx (syntax) (syntax-case stx (syntax)
[(_ pat . body) [(_ (id . patargs) . body)
#'(br:define (syntax pat) . body)])) #'(br:define (syntax (id . patargs)) . body)]
[(_ id [pat . patbody] ...)
#'(br:define-cases (syntax id) [pat . patbody] ...)]))
(define-syntax (br:define-macro-cases stx) (define-syntax (br:define-macro-cases stx)
(syntax-case stx (syntax) (syntax-case stx (syntax)
[(_ pat . body) [(_ id . body)
#'(br:define-cases (syntax pat) . body)])) #'(br:define-cases (syntax id) . body)]))
(module+ test (module+ test
(br:define-macro (add _x) #'(+ _x _x)) (br:define-macro (add _x) #'(+ _x _x))
(check-equal? (add 5) 10) (check-equal? (add 5) 10)
(br:define-macro-cases add-again [#'(_ X) #'(+ X X)]) (br:define-macro-cases add-again [(_ X) #'(+ X X)])
(check-equal? (add-again 5) 10)) (check-equal? (add-again 5) 10)
(br:define-macro add-3rd [(_ X) #'(+ X X)])
(check-equal? (add-3rd 5) 10))

2
beautiful-racket-lib/br/eopl.rkt
View File

@ -64,7 +64,7 @@
[(_ _base-type _input-var [(_ _base-type _input-var
[_subtype (_positional-var ...) . _body] ... [_subtype (_positional-var ...) . _body] ...
[else . _else-body]) [else . _else-body])
(inject-syntax ([#'(_subtype? ...) (suffix-ids #'(_subtype ...) "?")]) (inject-syntax ([#'(_subtype? ...) (suffix-id #'(_subtype ...) "?")])
#'(cond #'(cond
[(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)]) [(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)])
. _body)] ... . _body)] ...

135
beautiful-racket/br/demo/basic/expander.rkt
View File

@ -10,22 +10,23 @@
(define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""]) (define-language-variables [A 0][B 0][C 0][D 0][E 0][F 0][G 0][H 0][I 0][J 0][K 0][L 0][M 0][N 0][O 0][P 0][Q 0][R 0][S 0][T 0][U 0][V 0][W 0][X 0][Y 0][Z 0][A$ ""][B$ ""][C$ ""][D$ ""][E$ ""][F$ ""][G$ ""][H$ ""][I$ ""][J$ ""][K$ ""][L$ ""][M$ ""][N$ ""][O$ ""][P$ ""][Q$ ""][R$ ""][S$ ""][T$ ""][U$ ""][V$ ""][W$ ""][X$ ""][Y$ ""][Z$ ""])
(define #'(basic-module-begin _parse-tree ...) (define-macro (basic-module-begin SRC-EXPR ...)
#'(#%module-begin #'(#%module-begin
(inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$) (inject-language-variables (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z A$ B$ C$ D$ E$ F$ G$ H$ I$ J$ K$ L$ M$ N$ O$ P$ Q$ R$ S$ T$ U$ V$ W$ X$ Y$ Z$)
(println (quote _parse-tree ...)) (println (quote SRC-EXPR ...))
_parse-tree ...))) SRC-EXPR ...)))
; #%app and #%datum have to be present to make #%top work ; #%app and #%datum have to be present to make #%top work
(define #'(basic-top . id) (define-macro (basic-top . ID)
#'(begin #'(begin
(displayln (format "got unbound identifier: ~a" 'id)) (displayln (format "got unbound identifier: ~a" 'ID))
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id))))) (procedure-rename (λ xs (cons 'ID xs)) (string->symbol (format "undefined:~a" 'ID)))))
(define #'(program _line ...) #'(run (list _line ...))) (define-macro (program LINE ...) #'(run (list LINE ...)))
(struct exn:line-not-found exn:fail ()) (struct exn:line-not-found exn:fail ())
(struct exn:program-end exn:fail ())
(define (run lines) (define (run lines)
@ -39,9 +40,10 @@
(exn:line-not-found (exn:line-not-found
(format "line number ~a not found in program" ln) (format "line number ~a not found in program" ln)
(current-continuation-marks))))) (current-continuation-marks)))))
(with-handlers ([exn:program-end? (λ(exn) (void))])
(void
(for/fold ([program-counter 0]) (for/fold ([program-counter 0])
([i (in-naturals)] ([i (in-naturals)])
#:break (eq? program-counter 'end))
(cond (cond
[(= program-counter (vector-length program-lines)) (basic:END)] [(= program-counter (vector-length program-lines)) (basic:END)]
[else [else
@ -49,85 +51,73 @@
(define maybe-next-line (and line-function (line-function))) (define maybe-next-line (and line-function (line-function)))
(cond (cond
[(number? maybe-next-line) (line-number->index maybe-next-line)] [(number? maybe-next-line) (line-number->index maybe-next-line)]
[(eq? 'end maybe-next-line) 'end] [else (add1 program-counter)])])))))
[else (add1 program-counter)])]))
(void))
(define #'(cr-line _arg ...) #'(begin _arg ...)) (define-macro (cr-line ARG ...) #'(begin ARG ...))
(define current-return-stack (make-parameter empty)) (define current-return-stack (make-parameter empty))
(define-cases #'line (define-macro line
[#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE))) [(_ NUMBER (statement-list (statement "GOSUB" WHERE)))
#'(cons _NUMBER #'(cons NUMBER
(λ _ (λ _
(let ([return-stack (current-return-stack)]) (let ([return-stack (current-return-stack)])
(cond (cond
[(or (empty? return-stack) [(or (empty? return-stack)
(not (= _NUMBER (car return-stack)))) (not (= NUMBER (car return-stack))))
(current-return-stack (cons _NUMBER (current-return-stack))) (current-return-stack (cons NUMBER (current-return-stack)))
(basic:GOTO _WHERE)] (basic:GOTO WHERE)]
[else (current-return-stack (cdr (current-return-stack)))]))))] [else (current-return-stack (cdr (current-return-stack)))]))))]
[#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))]) [(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))])
(define-cases #'statement-list (define-macro statement-list
[#'(_ _STATEMENT) #'(begin _STATEMENT)] [(_ STATEMENT) #'(begin STATEMENT)]
[#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)]) [(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)])
(define-cases #'statement (define-macro statement
[#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)] [(statement ID "=" EXPR) #'(set! ID EXPR)]
;[#'(statement "PRINT" ARG ...) #'(print ARG ...)] [(statement PROC-STRING ARG ...)
;[#'(statement "RETURN" ARG ...) #'(return ARG ...)] (with-pattern
;[#'(statement "END" ARG ...) #'(end ARG ...)] ([PROC-ID (prefix-id "basic:" #'PROC-STRING)])
[#'(statement _proc-string _arg ...) #'(PROC-ID ARG ...))])
(inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)])
#'(PROC-ID _arg ...))])
(define-cases #'basic:IF (define-macro basic:IF
[#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT) [(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT)
#'(if (true? _COND) #'(if (true? COND)
_TRUE-RESULT TRUE-RESULT
_FALSE-RESULT)] FALSE-RESULT)]
[#'(_ _COND "THEN" _TRUE-RESULT) [(_ COND "THEN" TRUE-RESULT)
#'(when (true? _COND) #'(when (true? COND)
_TRUE-RESULT)]) TRUE-RESULT)])
(define-cases #'value
[#'(value "(" _EXPR ")") #'_EXPR]
[#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)]
[#'(value _ID-OR-DATUM) #'_ID-OR-DATUM])
(define true? (compose1 not zero?)) (define true? (compose1 not zero?))
(define (cond->int cond) (if cond 1 0)) (define (cond->int cond) (if cond 1 0))
(define (basic:and . args) (cond->int (andmap true? args))) (define (basic:and . args) (cond->int (andmap true? args)))
(define (basic:or . args) (cond->int (ormap true? args))) (define (basic:or . args) (cond->int (ormap true? args)))
(define-cases #'expr-list (define-macro expr
[#'(_ _EXPR) #'_EXPR] [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)]
[#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)]) [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)]
[(_ COMP-EXPR) #'COMP-EXPR])
(define-cases #'expr (define-macro comp-expr
[#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)] [(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded
[#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)] [(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))])
[#'(_ _COMP-EXPR) #'_COMP-EXPR]) #'(cond->int (OP LEXPR REXPR)))]
[(_ ARG) #'ARG])
(define-cases #'comp-expr
[#'(_ _LEXPR "=" _REXPR) #'(comp-expr _LEXPR "equal?" _REXPR)] ; special case because = is overloaded
[#'(_ _LEXPR _op _REXPR) (inject-syntax ([#'OP (string->symbol (syntax->datum #'_op))])
#'(cond->int (OP _LEXPR _REXPR)))]
[#'(_ _ARG) #'_ARG])
(define <> (compose1 not equal?)) (define <> (compose1 not equal?))
(define-cases #'sum (define-macro sum
[#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)] [(_ TERM "+" SUM) #'(+ TERM SUM)]
[#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)] [(_ TERM "-" SUM) #'(- TERM SUM)]
[#'(_ _TERM) #'_TERM]) [(_ TERM) #'TERM])
(define-cases #'product (define-macro product
[#'(_ _value "*" _product) #'(* _value _product)] [(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)]
[#'(_ _value "/" _product) #'(/ _value _product)] [(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)]
[#'(_ _value) #'_value]) [(_ VALUE) #'VALUE])
(define print-list list) (define print-list list)
@ -140,23 +130,26 @@
[(list print-list-item ...) (for-each displayln print-list-item)])) [(list print-list-item ...) (for-each displayln print-list-item)]))
(define (TAB num) (make-string num #\space)) (define (TAB num) (make-string num #\space))
(define #'(INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...)))) (define-macro (INT _ARG ...) #'(inexact->exact (truncate (expr _ARG ...))))
(define (SIN num) (sin num)) (define (SIN num) (sin num))
(define (ABS num) (inexact->exact (abs num))) (define (ABS num) (inexact->exact (abs num)))
(define (RND num) (* (random) num)) (define (RND num) (* (random) num))
(define-cases #'basic:INPUT (define-macro basic:INPUT
[#'(_ _PRINT-LIST ";" _ID) [(_ PRINT-LIST ";" _ID)
#'(begin #'(begin
(basic:PRINT (append _PRINT-LIST (list ";"))) (basic:PRINT (append PRINT-LIST (list ";")))
(basic:INPUT _ID))] (basic:INPUT _ID))]
[#'(_ _ID) #'(set! _ID (let* ([str (read-line)] [(_ ID) #'(set! ID (let* ([str (read-line)]
[num (string->number str)]) [num (string->number str)])
(if num num str)))]) (or num str)))])
(define (basic:GOTO where) where) (define (basic:GOTO where) where)
(define (basic:RETURN) (car (current-return-stack))) (define (basic:RETURN) (car (current-return-stack)))
(define (basic:END) (define (basic:END)
'end) (raise
(exn:program-end
""
(current-continuation-marks))))

7
beautiful-racket/br/demo/basic/parser.rkt
View File

@ -26,10 +26,9 @@ sum : product [("+" | "-") sum]
product : value [("*" | "/") product] product : value [("*" | "/") product]
expr-list : expr ["," expr-list]* @value : ID | id-expr
| /"(" expr /")"
value : ID ["(" expr-list ")"]
| "(" expr ")"
| STRING | STRING
| NUMBER | NUMBER
/id-expr : ID [/"(" expr [/"," expr]* /")"]

40
beautiful-racket/br/demo/bf/bf-expander.rkt
View File

@ -1,36 +1,34 @@
#lang br #lang br
(define #'(bf-module-begin _PARSE-TREE ...) (define-macro (bf-module-begin SRC-EXPR ...)
#'(#%module-begin #'(#%module-begin
_PARSE-TREE ...)) SRC-EXPR ...))
(provide (rename-out [bf-module-begin #%module-begin]) (provide (rename-out [bf-module-begin #%module-begin]))
#%top-interaction)
(define #'(bf-program _OP-OR-LOOP ...) (define-macro (bf-program OP-OR-LOOP ...)
#'(begin _OP-OR-LOOP ...)) #'(begin OP-OR-LOOP ...))
(provide bf-program) (provide bf-program)
(define-cases #'op (define-macro op
[#'(op ">") #'(move-pointer 1)] [(op ">") #'(move-pointer 1)]
[#'(op "<") #'(move-pointer -1)] [(op "<") #'(move-pointer -1)]
[#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))] [(op "+") #'(set-current-byte! (add1 (get-current-byte)))]
[#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))] [(op "-") #'(set-current-byte! (sub1 (get-current-byte)))]
[#'(op ".") #'(write-byte (get-current-byte))] [(op ".") #'(write-byte (get-current-byte))]
[#'(op ",") #'(set-current-byte! (read-byte))]) [(op ",") #'(set-current-byte! (read-byte))])
(provide op) (provide op)
(define bf-vector (make-vector 30000 0)) (define bf-vector (make-vector 30000 0))
(define bf-pointer 0) (define bf-pointer 0)
(define (move-pointer how-far) (define (move-pointer how-far) (set! bf-pointer (+ bf-pointer how-far)))
(set! bf-pointer (+ bf-pointer how-far)))
(define (get-current-byte) (define (get-current-byte) (vector-ref bf-vector bf-pointer))
(vector-ref bf-vector bf-pointer)) (define (set-current-byte! val) (vector-set! bf-vector bf-pointer val))
(define (set-current-byte! val)
(vector-set! bf-vector bf-pointer val))
(define #'(loop "[" _OP-OR-LOOP ... "]") (define-macro (loop LOOP-ARG ...)
#'(until (zero? (get-current-byte)) #'(until (zero? (get-current-byte))
_OP-OR-LOOP ...)) LOOP-ARG ...))
(provide loop) (provide loop)
(provide #%top-interaction)

2
beautiful-racket/br/demo/bf/bf-parser.rkt
View File

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

6
beautiful-racket/br/demo/stacker-test.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang reader br/demo/stacker
push 4
push 8
+
push 3
*

24
beautiful-racket/br/demo/stacker.rkt
View File

@ -1,33 +1,29 @@
#lang br #lang br
(define (read-syntax source-path input-port) (define (read-syntax source-path input-port)
(define src-strs (remove-blank-lines (port->lines input-port))) (define src-strs (remove-blank-lines (port->lines input-port)))
(define (make-datum str) (format-datum '(dispatch ~a) str)) (define (make-datum str) (format-datum '(dispatch ~a) str))
(define src-exprs (map make-datum src-strs)) (define src-exprs (map make-datum src-strs))
(strip-context (strip-context
(inject-syntax ([#'(_SRC-EXPR ...) src-exprs]) (with-pattern ([(SRC-EXPR ...) (map make-datum src-strs)])
#'(module stacker-mod br/demo/stacker #'(module stacker-mod br/demo/stacker
_SRC-EXPR ...)))) SRC-EXPR ...))))
(provide read-syntax) (provide read-syntax)
(define #'(stacker-module-begin _READER-LINE ...) (define-macro (stacker-module-begin READER-LINE ...)
#'(#%module-begin #'(#%module-begin
_READER-LINE ... READER-LINE ...
(display (first stack)))) (display (first stack))))
(provide (rename-out [stacker-module-begin #%module-begin])) (provide (rename-out [stacker-module-begin #%module-begin]))
(provide #%top-interaction)
(define stack empty) (define stack empty)
(define (push num) (set! stack (cons num stack))) (define (push num) (set! stack (cons num stack)))
(provide push) (provide push)
(define (dispatch arg-1 [arg-2 #f]) (define-cases dispatch
(cond [(_ push num) (push num)]
[(number? arg-2) (push arg-2)] [(_ op) (define op-result (op (first stack) (second stack)))
[else (set! stack (cons op-result (drop stack 2)))])
(define op arg-1)
(define op-result (op (first stack) (second stack)))
(set! stack (cons op-result (drop stack 2)))]))
(provide dispatch) (provide dispatch)
(provide + *) (provide + * #%app #%datum #%top-interaction)
(provide #%app #%datum)