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

underscore prefix for nonliterals

Browse Source
This commit is contained in:
Matthew Butterick 2016-04-22 14:18:46 -07:00
parent d768d518bb
commit d03f253924
4 changed files with 62 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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)))

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

@ -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)))])

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

@ -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)

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

@ -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)