diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index d50763c..7a28f90 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -64,10 +64,12 @@ (when (member 'else all-but-last-pat-datums) (raise-syntax-error 'define-cases "else case must be last" (syntax->datum #'top-id.name)))) (with-syntax* ([((pat . result-exprs) ... else-result-exprs) - (syntax-case #'patexprs (syntax else) - [(((syntax pat) result-expr) ... (else . else-result-exprs)) + (syntax-parse #'patexprs + #: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)] - [(((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))))])] [LITERALS (generate-literals #'(pat ...))]) #'(define-syntax top-id.name (λ (stx) @@ -94,8 +96,8 @@ (define foo-val 'got-foo-val) (define (foo-func) 'got-foo-func) (br:define-cases #'op - [#'(_ "+") #''got-plus] - [#'(_ _ARG) #''got-something-else] + [(_ "+") #''got-plus] + [(_ _ARG) #''got-something-else] [#'(_) #'(foo-func)] [#'_ #'foo-val]) @@ -295,17 +297,21 @@ (define-syntax (br:define-macro stx) (syntax-case stx (syntax) - [(_ pat . body) - #'(br:define (syntax pat) . body)])) + [(_ (id . patargs) . body) + #'(br:define (syntax (id . patargs)) . body)] + [(_ id [pat . patbody] ...) + #'(br:define-cases (syntax id) [pat . patbody] ...)])) (define-syntax (br:define-macro-cases stx) (syntax-case stx (syntax) - [(_ pat . body) - #'(br:define-cases (syntax pat) . body)])) + [(_ id . body) + #'(br:define-cases (syntax id) . body)])) (module+ test (br:define-macro (add _x) #'(+ _x _x)) (check-equal? (add 5) 10) - (br:define-macro-cases add-again [#'(_ X) #'(+ X X)]) - (check-equal? (add-again 5) 10)) \ No newline at end of file + (br:define-macro-cases add-again [(_ X) #'(+ X X)]) + (check-equal? (add-again 5) 10) + (br:define-macro add-3rd [(_ X) #'(+ X X)]) + (check-equal? (add-3rd 5) 10)) \ No newline at end of file diff --git a/beautiful-racket-lib/br/eopl.rkt b/beautiful-racket-lib/br/eopl.rkt index 78648ea..c5353b7 100644 --- a/beautiful-racket-lib/br/eopl.rkt +++ b/beautiful-racket-lib/br/eopl.rkt @@ -64,7 +64,7 @@ [(_ _base-type _input-var [_subtype (_positional-var ...) . _body] ... [else . _else-body]) - (inject-syntax ([#'(_subtype? ...) (suffix-ids #'(_subtype ...) "?")]) + (inject-syntax ([#'(_subtype? ...) (suffix-id #'(_subtype ...) "?")]) #'(cond [(_subtype? _input-var) (match-let ([(list _positional-var ...) (struct->list _input-var)]) . _body)] ... diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 7994dba..f758950 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -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 #'(basic-module-begin _parse-tree ...) +(define-macro (basic-module-begin SRC-EXPR ...) #'(#%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$) - (println (quote _parse-tree ...)) - _parse-tree ...))) + (println (quote SRC-EXPR ...)) + SRC-EXPR ...))) ; #%app and #%datum have to be present to make #%top work -(define #'(basic-top . id) +(define-macro (basic-top . ID) #'(begin - (displayln (format "got unbound identifier: ~a" 'id)) - (procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id))))) + (displayln (format "got unbound identifier: ~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:program-end exn:fail ()) (define (run lines) @@ -39,95 +40,84 @@ (exn:line-not-found (format "line number ~a not found in program" ln) (current-continuation-marks))))) - (for/fold ([program-counter 0]) - ([i (in-naturals)] - #:break (eq? program-counter 'end)) - (cond - [(= program-counter (vector-length program-lines)) (basic:END)] - [else - (define line-function (cdr (vector-ref program-lines program-counter))) - (define maybe-next-line (and line-function (line-function))) + (with-handlers ([exn:program-end? (λ(exn) (void))]) + (void + (for/fold ([program-counter 0]) + ([i (in-naturals)]) (cond - [(number? maybe-next-line) (line-number->index maybe-next-line)] - [(eq? 'end maybe-next-line) 'end] - [else (add1 program-counter)])])) - (void)) + [(= program-counter (vector-length program-lines)) (basic:END)] + [else + (define line-function (cdr (vector-ref program-lines program-counter))) + (define maybe-next-line (and line-function (line-function))) + (cond + [(number? maybe-next-line) (line-number->index maybe-next-line)] + [else (add1 program-counter)])]))))) -(define #'(cr-line _arg ...) #'(begin _arg ...)) +(define-macro (cr-line ARG ...) #'(begin ARG ...)) (define current-return-stack (make-parameter empty)) -(define-cases #'line - [#'(_ _NUMBER (statement-list (statement "GOSUB" _WHERE))) - #'(cons _NUMBER +(define-macro line + [(_ NUMBER (statement-list (statement "GOSUB" WHERE))) + #'(cons NUMBER (λ _ (let ([return-stack (current-return-stack)]) (cond [(or (empty? return-stack) - (not (= _NUMBER (car return-stack)))) - (current-return-stack (cons _NUMBER (current-return-stack))) - (basic:GOTO _WHERE)] + (not (= NUMBER (car return-stack)))) + (current-return-stack (cons NUMBER (current-return-stack))) + (basic:GOTO WHERE)] [else (current-return-stack (cdr (current-return-stack)))]))))] - [#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))]) - -(define-cases #'statement-list - [#'(_ _STATEMENT) #'(begin _STATEMENT)] - [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)]) - -(define-cases #'statement - [#'(statement _ID "=" _EXPR) #'(set! _ID _EXPR)] - ;[#'(statement "PRINT" ARG ...) #'(print ARG ...)] - ;[#'(statement "RETURN" ARG ...) #'(return ARG ...)] - ;[#'(statement "END" ARG ...) #'(end ARG ...)] - [#'(statement _proc-string _arg ...) - (inject-syntax ([#'PROC-ID (format-datum "basic:~a" #'_proc-string)]) - #'(PROC-ID _arg ...))]) - -(define-cases #'basic:IF - [#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT) - #'(if (true? _COND) - _TRUE-RESULT - _FALSE-RESULT)] - [#'(_ _COND "THEN" _TRUE-RESULT) - #'(when (true? _COND) - _TRUE-RESULT)]) - -(define-cases #'value - [#'(value "(" _EXPR ")") #'_EXPR] - [#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)] - [#'(value _ID-OR-DATUM) #'_ID-OR-DATUM]) + [(_ NUMBER STATEMENT-LIST) #'(cons NUMBER (λ _ STATEMENT-LIST))]) + +(define-macro statement-list + [(_ STATEMENT) #'(begin STATEMENT)] + [(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)]) + +(define-macro statement + [(statement ID "=" EXPR) #'(set! ID EXPR)] + [(statement PROC-STRING ARG ...) + (with-pattern + ([PROC-ID (prefix-id "basic:" #'PROC-STRING)]) + #'(PROC-ID ARG ...))]) + +(define-macro basic:IF + [(_ COND "THEN" TRUE-RESULT "ELSE" FALSE-RESULT) + #'(if (true? COND) + TRUE-RESULT + FALSE-RESULT)] + [(_ COND "THEN" TRUE-RESULT) + #'(when (true? COND) + TRUE-RESULT)]) (define true? (compose1 not zero?)) (define (cond->int cond) (if cond 1 0)) (define (basic:and . args) (cond->int (andmap true? args))) (define (basic:or . args) (cond->int (ormap true? args))) -(define-cases #'expr-list - [#'(_ _EXPR) #'_EXPR] - [#'(_ _EXPR "," _EXPR-LIST) #'(_EXPR _EXPR-LIST)]) +(define-macro expr + [(_ COMP-EXPR "AND" SUBEXPR) #'(basic:and COMP-EXPR SUBEXPR)] + [(_ COMP-EXPR "OR" SUBEXPR) #'(basic:or COMP-EXPR SUBEXPR)] + [(_ COMP-EXPR) #'COMP-EXPR]) -(define-cases #'expr - [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)] - [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)] - [#'(_ _COMP-EXPR) #'_COMP-EXPR]) +(define-macro comp-expr + [(_ LEXPR "=" REXPR) #'(comp-expr LEXPR "equal?" REXPR)] ; special case because = is overloaded + [(_ LEXPR OP-STR REXPR) (with-pattern ([OP (replace-context #'here (prefix-id #'OP-STR))]) + #'(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-cases #'sum - [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)] - [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)] - [#'(_ _TERM) #'_TERM]) +(define-macro sum + [(_ TERM "+" SUM) #'(+ TERM SUM)] + [(_ TERM "-" SUM) #'(- TERM SUM)] + [(_ TERM) #'TERM]) -(define-cases #'product - [#'(_ _value "*" _product) #'(* _value _product)] - [#'(_ _value "/" _product) #'(/ _value _product)] - [#'(_ _value) #'_value]) +(define-macro product + [(_ VALUE "*" PRODUCT) #'(* VALUE PRODUCT)] + [(_ VALUE "/" PRODUCT) #'(/ VALUE PRODUCT)] + [(_ VALUE) #'VALUE]) (define print-list list) @@ -140,23 +130,26 @@ [(list print-list-item ...) (for-each displayln print-list-item)])) (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 (ABS num) (inexact->exact (abs num))) (define (RND num) (* (random) num)) -(define-cases #'basic:INPUT - [#'(_ _PRINT-LIST ";" _ID) +(define-macro basic:INPUT + [(_ PRINT-LIST ";" _ID) #'(begin - (basic:PRINT (append _PRINT-LIST (list ";"))) + (basic:PRINT (append PRINT-LIST (list ";"))) (basic:INPUT _ID))] - [#'(_ _ID) #'(set! _ID (let* ([str (read-line)] - [num (string->number str)]) - (if num num str)))]) + [(_ ID) #'(set! ID (let* ([str (read-line)] + [num (string->number str)]) + (or num str)))]) (define (basic:GOTO where) where) (define (basic:RETURN) (car (current-return-stack))) (define (basic:END) - 'end) + (raise + (exn:program-end + "" + (current-continuation-marks)))) diff --git a/beautiful-racket/br/demo/basic/parser.rkt b/beautiful-racket/br/demo/basic/parser.rkt index 6830493..152362a 100644 --- a/beautiful-racket/br/demo/basic/parser.rkt +++ b/beautiful-racket/br/demo/basic/parser.rkt @@ -26,10 +26,9 @@ sum : product [("+" | "-") sum] product : value [("*" | "/") product] -expr-list : expr ["," expr-list]* - -value : ID ["(" expr-list ")"] -| "(" expr ")" +@value : ID | id-expr +| /"(" expr /")" | STRING | NUMBER +/id-expr : ID [/"(" expr [/"," expr]* /")"] \ No newline at end of file diff --git a/beautiful-racket/br/demo/bf/bf-expander.rkt b/beautiful-racket/br/demo/bf/bf-expander.rkt index 59fa6e9..b83a5c8 100644 --- a/beautiful-racket/br/demo/bf/bf-expander.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander.rkt @@ -1,36 +1,34 @@ #lang br -(define #'(bf-module-begin _PARSE-TREE ...) +(define-macro (bf-module-begin SRC-EXPR ...) #'(#%module-begin - _PARSE-TREE ...)) -(provide (rename-out [bf-module-begin #%module-begin]) - #%top-interaction) + SRC-EXPR ...)) +(provide (rename-out [bf-module-begin #%module-begin])) -(define #'(bf-program _OP-OR-LOOP ...) - #'(begin _OP-OR-LOOP ...)) +(define-macro (bf-program OP-OR-LOOP ...) + #'(begin OP-OR-LOOP ...)) (provide bf-program) -(define-cases #'op - [#'(op ">") #'(move-pointer 1)] - [#'(op "<") #'(move-pointer -1)] - [#'(op "+") #'(set-current-byte! (add1 (get-current-byte)))] - [#'(op "-") #'(set-current-byte! (sub1 (get-current-byte)))] - [#'(op ".") #'(write-byte (get-current-byte))] - [#'(op ",") #'(set-current-byte! (read-byte))]) +(define-macro op + [(op ">") #'(move-pointer 1)] + [(op "<") #'(move-pointer -1)] + [(op "+") #'(set-current-byte! (add1 (get-current-byte)))] + [(op "-") #'(set-current-byte! (sub1 (get-current-byte)))] + [(op ".") #'(write-byte (get-current-byte))] + [(op ",") #'(set-current-byte! (read-byte))]) (provide op) (define bf-vector (make-vector 30000 0)) (define bf-pointer 0) -(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 (get-current-byte) - (vector-ref bf-vector bf-pointer)) -(define (set-current-byte! val) - (vector-set! bf-vector bf-pointer val)) +(define (get-current-byte) (vector-ref bf-vector bf-pointer)) +(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)) - _OP-OR-LOOP ...)) + LOOP-ARG ...)) (provide loop) + +(provide #%top-interaction) \ No newline at end of file diff --git a/beautiful-racket/br/demo/bf/bf-parser.rkt b/beautiful-racket/br/demo/bf/bf-parser.rkt index ebfb9ba..2792823 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/stacker-test.rkt b/beautiful-racket/br/demo/stacker-test.rkt new file mode 100644 index 0000000..e02fe09 --- /dev/null +++ b/beautiful-racket/br/demo/stacker-test.rkt @@ -0,0 +1,6 @@ +#lang reader br/demo/stacker +push 4 +push 8 ++ +push 3 +* \ No newline at end of file diff --git a/beautiful-racket/br/demo/stacker.rkt b/beautiful-racket/br/demo/stacker.rkt index a226a2f..c19fedd 100644 --- a/beautiful-racket/br/demo/stacker.rkt +++ b/beautiful-racket/br/demo/stacker.rkt @@ -1,33 +1,29 @@ #lang br + (define (read-syntax source-path input-port) (define src-strs (remove-blank-lines (port->lines input-port))) (define (make-datum str) (format-datum '(dispatch ~a) str)) (define src-exprs (map make-datum src-strs)) (strip-context - (inject-syntax ([#'(_SRC-EXPR ...) src-exprs]) - #'(module stacker-mod br/demo/stacker - _SRC-EXPR ...)))) + (with-pattern ([(SRC-EXPR ...) (map make-datum src-strs)]) + #'(module stacker-mod br/demo/stacker + SRC-EXPR ...)))) (provide read-syntax) -(define #'(stacker-module-begin _READER-LINE ...) +(define-macro (stacker-module-begin READER-LINE ...) #'(#%module-begin - _READER-LINE ... + READER-LINE ... (display (first stack)))) (provide (rename-out [stacker-module-begin #%module-begin])) -(provide #%top-interaction) (define stack empty) (define (push num) (set! stack (cons num stack))) (provide push) -(define (dispatch arg-1 [arg-2 #f]) - (cond - [(number? arg-2) (push arg-2)] - [else - (define op arg-1) - (define op-result (op (first stack) (second stack))) - (set! stack (cons op-result (drop stack 2)))])) +(define-cases dispatch + [(_ push num) (push num)] + [(_ op) (define op-result (op (first stack) (second stack))) + (set! stack (cons op-result (drop stack 2)))]) (provide dispatch) -(provide + *) -(provide #%app #%datum) \ No newline at end of file +(provide + * #%app #%datum #%top-interaction) \ No newline at end of file