mbutterick
/
beautiful-racket
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

fixes

Browse Source
pull/2/head
Matthew Butterick 8 years ago
parent 2d5db8afb5
commit 51ff735f7d
2 changed files with 26 additions and 26 deletions
Show Stats Download Patch File Download Diff File

22
beautiful-racket-lib/br/eopl.rkt
Unescape Escape View File

@ -61,18 +61,18 @@
(define-syntax (cases stx) (define-syntax (cases stx)
(syntax-case stx (else) (syntax-case stx (else)
[(_ <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?> ...) (map-syntax (λ(s) (format-datum '~a? s)) #'(<subtype> ...))]) (inject-syntax ([#'(_subtype? ...) (suffix-ids #'(_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)] ...
[else <else-body> ...]))] [else . _else-body]))]
[(_ <base-type> <input-var> [(_ _base-type _input-var
<subtype-case> ...) _subtype-case ...)
#'(cases <base-type> <input-var> #'(cases _base-type _input-var
<subtype-case> ... _subtype-case ...
[else (void)])])) [else (void)])]))

30
beautiful-racket-lib/br/subscope.rkt
Unescape Escape View File

@ -3,12 +3,12 @@
(define #'(introduce-scope _color . _parents) (define #'(introduce-scope _color . _parents)
(with-syntax ([color #'_color] (with-syntax ([color #'_color]
[color-string (format "~a" (syntax->datum #'_color))] [color-string (format-string "~a" #'_color)]
[color:define (format-id #f "~a:define" #'_color)] [color:define (suffix-id #'_color ":define")]
[color:id (format-id #f "~a:id" #'_color)] [color:id (suffix-id #'_color ":id")]
[color-binding-id (format-id #f "~a-binding-id" #'_color)] [color-binding-id (suffix-id #'_color "-binding-id")]
[color-binding-form (format-id #f "~a-binding-form" #'_color)] [color-binding-form (suffix-id #'_color "-binding-form")]
[color-id (format-id #f "~a-id" #'_color)] [color-id (suffix-id #'_color "-id")]
[module-name (generate-temporary)] [module-name (generate-temporary)]
[parents (if (pair? (syntax->list #'_parents)) [parents (if (pair? (syntax->list #'_parents))
(car (syntax->list #'_parents)) (car (syntax->list #'_parents))
@ -16,19 +16,19 @@
(replace-context #'_color (replace-context #'_color
#'(begin #'(begin
(module module-name br (module module-name br
(require (for-syntax br/datum br/syntax)) (require (for-syntax br/datum br/scope))
(provide (for-syntax (all-defined-out)) (all-defined-out)) (provide (for-syntax (all-defined-out)) (all-defined-out))
(begin-for-syntax (begin-for-syntax
(define-scope color parents)) (define-scope color parents))
(define #'(color:define _id-in _expr) (define #'(color:define _id-in _expr)
(with-syntax* ([color:id (shared-syntax (format-datum "~a:~a" color-string #'_id-in))] (inject-syntax* ([#'color:id (shared-syntax (prefix-id color-string ":" #'_id-in))]
[color-binding-id (color-binding-form #'_id-in)] [#'color-binding-id (color-binding-form #'_id-in)]
[color-id (color #'color-binding-id)]) [#'color-id (color #'color-binding-id)])
#'(begin #'(begin
(define color-binding-id _expr) (define color-binding-id _expr)
(define-syntax color:id (define-syntax color:id
(syntax-id-rules () (syntax-id-rules ()
[_ color-id])))))) [_ color-id]))))))
(require 'module-name))))) (require 'module-name)))))

Write Preview
Loading…
Cancel
Save