From d03f2539242ba20ff7fe6350610c4de51d2c7dd9 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 22 Apr 2016 14:18:46 -0700 Subject: [PATCH] underscore prefix for nonliterals --- beautiful-racket-lib/br/define.rkt | 20 ++--- beautiful-racket/br/demo/basic/expander.rkt | 88 ++++++++++----------- beautiful-racket/br/demo/bf/bf-expander.rkt | 12 +-- beautiful-racket/br/demo/stacker.rkt | 4 +- 4 files changed, 62 insertions(+), 62 deletions(-) diff --git a/beautiful-racket-lib/br/define.rkt b/beautiful-racket-lib/br/define.rkt index 8660397..aae6578 100644 --- a/beautiful-racket-lib/br/define.rkt +++ b/beautiful-racket-lib/br/define.rkt @@ -5,13 +5,13 @@ ;; everything is prefixed br: whether it needs it or not so it can be stripped by #lang br (define-for-syntax (generate-literals pats) - ;; generate literals for any symbols that are not ... or _ or UPPERCASE + ;; generate literals for any symbols that are not ... or _ or _underscore-prefixed (for*/list ([pat-arg (in-list (flatten (map (λ(stx) (or (syntax->list stx) stx)) (syntax->list pats))))] [pat-datum (in-value (syntax->datum pat-arg))] #:when (and (symbol? pat-datum) (not (eq? pat-datum '...)) (not (eq? pat-datum '_)) (not (let ([str (symbol->string pat-datum)]) - (equal? (string-upcase str) str))))) + (regexp-match #rx"^_" str))))) pat-arg)) ;; todo: support `else` case @@ -62,7 +62,7 @@ (define (foo-func) 'got-foo-func) (br:define-cases #'op [#'(_ "+") #''got-plus] - [#'(_ ARG) #''got-something-else] + [#'(_ _ARG) #''got-something-else] [#'(_) #'(foo-func)] [#'_ #'foo-val]) @@ -129,20 +129,20 @@ (br:define #'plusser #'plus) (check-equal? (plusser 42) +) (check-equal? plusser +) - (br:define #'(times ARG) #'(* ARG ARG)) + (br:define #'(times _ARG) #'(* _ARG _ARG)) (check-equal? (times 10) 100) (br:define #'timeser #'times) (check-equal? (timeser 12) 144) (br:define #'fortytwo #'42) (check-equal? fortytwo 42) (check-equal? (let () - (br:define #'(foo X) + (br:define #'(foo _X) (with-syntax ([zam +]) - #'(zam X X))) (foo 42)) 84) + #'(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) #'*))) (begin - (br:define #'(redefine ID) #'(define ID 42)) + (br:define #'(redefine _id) #'(define _id 42)) (redefine zoombar) (check-equal? zoombar 42))) @@ -164,11 +164,11 @@ (require rackunit racket/port) (parameterize ([current-output-port (open-output-nowhere)]) (check-equal? (let () - (br:debug-define #'(foo X Y Z) - #'(apply + (list X Y Z))) + (br:debug-define #'(foo _X _Y _Z) + #'(apply + (list _X _Y _Z))) (foo 1 2 3)) 6) (check-equal? (let () - (br:debug-define #'(foo X ...) #'(apply * (list X ...))) + (br:debug-define #'(foo _X ...) #'(apply * (list _X ...))) (foo 10 11 12)) 1320))) diff --git a/beautiful-racket/br/demo/basic/expander.rkt b/beautiful-racket/br/demo/basic/expander.rkt index 23283d2..26a6f22 100644 --- a/beautiful-racket/br/demo/basic/expander.rkt +++ b/beautiful-racket/br/demo/basic/expander.rkt @@ -10,11 +10,11 @@ (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 #'(basic-module-begin _parse-tree ...) #'(#%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 _parse-tree ...)) + _parse-tree ...))) ; #%app and #%datum have to be present to make #%top work (define #'(basic-top . id) @@ -22,7 +22,7 @@ (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 #'(program _line ...) #'(run (list _line ...))) (struct exn:line-not-found exn:fail ()) @@ -53,50 +53,50 @@ (add1 program-counter))]))) (void)) -(define #'(cr-line ARG ...) #'(begin ARG ...)) +(define #'(cr-line _arg ...) #'(begin _arg ...)) (define current-return-stack (make-parameter empty)) (define-cases #'line - [#'(_ NUMBER (statement-list (statement "GOSUB" WHERE))) - #'(cons NUMBER + [#'(_ _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))]) + [#'(_ _NUMBER _STATEMENT-LIST) #'(cons _NUMBER (λ _ _STATEMENT-LIST))]) (define-cases #'statement-list - [#'(_ STATEMENT) #'(begin STATEMENT)] - [#'(_ STATEMENT ":" STATEMENT-LIST) #'(begin STATEMENT STATEMENT-LIST)]) + [#'(_ _STATEMENT) #'(begin _STATEMENT)] + [#'(_ _STATEMENT ":" _STATEMENT-LIST) #'(begin _STATEMENT _STATEMENT-LIST)]) (define-cases #'statement - [#'(statement ID "=" EXPR) #'(set! ID EXPR)] + [#'(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 ...))]) + [#'(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) + [#'(_ _COND "THEN" _TRUE-RESULT "ELSE" _FALSE-RESULT) + #'(if (true? _COND) + _TRUE-RESULT + _FALSE-RESULT)] + [#'(_ _COND "THEN" _TRUE-RESULT) #'(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]) + [#'(value "(" _EXPR ")") #'_EXPR] + [#'(value _ID "(" _ARG ... ")") #'(_ID _ARG ...)] + [#'(value _ID-OR-DATUM) #'_ID-OR-DATUM]) (define true? (compose1 not zero?)) (define (cond->int cond) (if cond 1 0)) @@ -104,26 +104,26 @@ (define (basic:or . args) (cond->int (ormap true? args))) (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]) + [#'(_ _COMP-EXPR "AND" _SUBEXPR) #'(basic:and _COMP-EXPR _SUBEXPR)] + [#'(_ _COMP-EXPR "OR" _SUBEXPR) #'(basic:or _COMP-EXPR _SUBEXPR)] + [#'(_ _COMP-EXPR) #'_COMP-EXPR]) (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]) + [#'(_ _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]) + [#'(_ _TERM "+" _SUM) #'(+ _TERM _SUM)] + [#'(_ _TERM "-" _SUM) #'(- _TERM _SUM)] + [#'(_ _TERM) #'_TERM]) (define-cases #'product - [#'(_ FACTOR "*" PRODUCT) #'(* FACTOR PRODUCT)] - [#'(_ FACTOR "/" PRODUCT) #'(/ FACTOR PRODUCT)] - [#'(_ FACTOR) #'FACTOR]) + [#'(_ _FACTOR "*" _PRODUCT) #'(* _FACTOR _PRODUCT)] + [#'(_ _FACTOR "/" _PRODUCT) #'(/ _FACTOR _PRODUCT)] + [#'(_ _FACTOR) #'_FACTOR]) (define print-list list) @@ -136,17 +136,17 @@ [(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 #'(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) + [#'(_ _PRINT-LIST ";" _ID) #'(begin - (basic:PRINT (append PRINT-LIST (list ";"))) - (basic:INPUT ID))] - [#'(_ ID) #'(set! ID (let* ([str (read-line)] + (basic:PRINT (append _PRINT-LIST (list ";"))) + (basic:INPUT _ID))] + [#'(_ _ID) #'(set! _ID (let* ([str (read-line)] [num (string->number str)]) (if num num str)))]) diff --git a/beautiful-racket/br/demo/bf/bf-expander.rkt b/beautiful-racket/br/demo/bf/bf-expander.rkt index 6794d6a..59fa6e9 100644 --- a/beautiful-racket/br/demo/bf/bf-expander.rkt +++ b/beautiful-racket/br/demo/bf/bf-expander.rkt @@ -1,13 +1,13 @@ #lang br -(define #'(bf-module-begin PARSE-TREE ...) +(define #'(bf-module-begin _PARSE-TREE ...) #'(#%module-begin - PARSE-TREE ...)) + _PARSE-TREE ...)) (provide (rename-out [bf-module-begin #%module-begin]) #%top-interaction) -(define #'(bf-program OP-OR-LOOP ...) - #'(begin OP-OR-LOOP ...)) +(define #'(bf-program _OP-OR-LOOP ...) + #'(begin _OP-OR-LOOP ...)) (provide bf-program) (define-cases #'op @@ -30,7 +30,7 @@ (define (set-current-byte! val) (vector-set! bf-vector bf-pointer val)) -(define #'(loop "[" OP-OR-LOOP ... "]") +(define #'(loop "[" _OP-OR-LOOP ... "]") #'(until (zero? (get-current-byte)) - OP-OR-LOOP ...)) + _OP-OR-LOOP ...)) (provide loop) diff --git a/beautiful-racket/br/demo/stacker.rkt b/beautiful-racket/br/demo/stacker.rkt index c1aea6d..4808737 100644 --- a/beautiful-racket/br/demo/stacker.rkt +++ b/beautiful-racket/br/demo/stacker.rkt @@ -9,9 +9,9 @@ SRC-EXPR ...)))) (provide read-syntax) -(define #'(stacker-module-begin READER-LINE ...) +(define #'(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)