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

add vars

Browse Source
This commit is contained in:
Matthew Butterick 2016-04-20 15:52:55 -07:00
parent 99b9422593
commit 5d43ee6d3f
2 changed files with 25 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
beautiful-racket-lib/br/stxparam.rkt
View File

@ -3,28 +3,35 @@
(provide splicing-syntax-parameterize
define-syntax-parameters
define-language-variables
define-language-variable
inject-language-variables
(rename-out [br:define-syntax-parameter define-syntax-parameter]))
(define-syntax (br:define-syntax-parameter stx)
(syntax-case stx ()
[(_ ID STX)
#'(define-syntax-parameter ID STX)]
[(_ ID)
#'(define-syntax-parameter ID (λ (stx)
(raise-syntax-error (syntax-e stx) "parameter not set")))]))
[(_ ID STX) #'(define-syntax-parameter ID STX)]
[(_ [ID VAL]) #'(define-syntax-parameter ID (λ (stx) #'VAL))]
[(_ ID) #'(define-syntax-parameter ID
(λ (stx) (raise-syntax-error (syntax-e stx) "parameter not set")))]))
(define-syntax-rule (define-syntax-parameters ID ...)
(begin (br:define-syntax-parameter ID) ...))
(define-syntax define-language-variables (make-rename-transformer #'define-syntax-parameters))
(define-syntax-rule (define-language-variable ID VAL)
(br:define-syntax-parameter [ID VAL]))
(define-syntax-rule (define-language-variables [ID VAL] ...)
(begin (define-language-variable ID VAL) ...))
(define-syntax (inject-language-variables stx)
(syntax-case stx ()
[(_ ([VAR-PARAM INITIAL-VALUE] ...) LANG-CODE ...)
(with-syntax ([(INTERNAL-NAME ...) (generate-temporaries #'(VAR-PARAM ...))])
#'(splicing-syntax-parameterize ;; need to use splicing version in a module-begin to compose with requires etc. that might be in lang code
([VAR-PARAM (make-rename-transformer #'INTERNAL-NAME)] ...)
(define INTERNAL-NAME INITIAL-VALUE) ...
(provide (rename-out [INTERNAL-NAME VAR-PARAM] ...))
LANG-CODE ...))]))
[(_ (VAR-PARAM ...) LANG-CODE ...)
(with-syntax ([(HOLDS-ORIG-PARAM-VALUE ...) (generate-temporaries #'(VAR-PARAM ...))]
[(INTERNAL-NAME ...) (generate-temporaries #'(VAR-PARAM ...))])
;; need to use splicing expressions in a module-begin to compose with requires etc. that might be in lang code
#'(splicing-let ([HOLDS-ORIG-PARAM-VALUE VAR-PARAM] ...)
(splicing-syntax-parameterize
([VAR-PARAM (make-rename-transformer #'INTERNAL-NAME)] ...)
(define INTERNAL-NAME HOLDS-ORIG-PARAM-VALUE) ...
(provide (rename-out [INTERNAL-NAME VAR-PARAM] ...))
LANG-CODE ...)))]))

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

@ -3,20 +3,13 @@
(rename-out [basic-module-begin #%module-begin])
(rename-out [basic-top #%top])
(all-defined-out))
(require (for-syntax racket/syntax racket/list br/datum)
br/stxparam)
(require br/stxparam)
(define-language-variables A B C D E F A$)
(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 ...)
#'(#%module-begin
(inject-language-variables ([A 0]
[B 0]
[C 0]
[D 0]
[E 0]
[F 0]
[A$ "foo"])
(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 ...)))
@ -24,7 +17,7 @@
(define #'(basic-top . id)
#'(begin
(displayln (format "got unbound identifier: ~a" 'id))
(procedure-rename (λ xs (cons 'id xs)) (format-datum "undefined:~a" 'id))))
(procedure-rename (λ xs (cons 'id xs)) (string->symbol (format "undefined:~a" 'id)))))
(define #'(program LINE ...) #'(run (list LINE ...)))
@ -61,9 +54,7 @@
[#'(value ID-OR-DATUM) #'ID-OR-DATUM])
(define-cases expr
[(_ lexpr op rexpr) (if (op lexpr rexpr)
1
0)]
[(_ lexpr op rexpr) (if (op lexpr rexpr) 1 0)]
[(_ expr) expr])
(provide < > <= >=)