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

eliminate use of syntax-local-get-shadower

Browse Source 
The old use relied on a more or less accidental correspondence between
the `$` variables introduced by `parser` and get-shadower before those
variables are bound. Get rid of it in favor of normal hygiene bending.
This commit is contained in:
Matthew Flatt 2015-02-27 21:36:03 -07:00
parent ba9948bdd3
commit 97dfccd487
2 changed files with 35 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
macro-debugger-text-lib/macro-debugger/model/yacc-ext.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
(prefix-in yacc: parser-tools/yacc)) (prefix-in yacc: parser-tools/yacc)
(for-syntax racket/pretty))
(provide parser (provide parser
options options
productions productions

68
macro-debugger-text-lib/macro-debugger/model/yacc-interrupted.rkt
View File

@ -49,18 +49,17 @@
(raise-syntax-error 'split "bad grammar option or alternate" #'other)]) (raise-syntax-error 'split "bad grammar option or alternate" #'other)])
(values options (reverse alts))))) (values options (reverse alts)))))
(define-for-syntax (I symbol) (define-for-syntax (mk-name ctx n)
(syntax-local-introduce (datum->syntax ctx (string->symbol (format "~a" n)) ctx))
(syntax-local-get-shadower (datum->syntax #f symbol))))
(define-for-syntax ($name n) (define-for-syntax (mk-$name ctx n)
(I (format-symbol "$~a" n))) (mk-name ctx (format "$~a" n)))
(define-for-syntax (interrupted-name id) (define-for-syntax (interrupted-name id)
(I (format-symbol "~a/Interrupted" (syntax-e id)))) (datum->syntax id (format-symbol "~a/Interrupted" (syntax-e id)) id))
(define-for-syntax (skipped-name id) (define-for-syntax (skipped-name id)
(I (format-symbol "~a/Skipped" (syntax-e id)))) (datum->syntax id (format-symbol "~a/Skipped" (syntax-e id)) id))
(define-for-syntax (elaborate-skipped-tail head tail position args mk-action) (define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
(define-values (new-tail new-arguments) (define-values (new-tail new-arguments)
@ -81,7 +80,7 @@
(loop #'parts-rest (loop #'parts-rest
(add1 position) (add1 position)
(cons (skipped-name #'NT) rtail) (cons (skipped-name #'NT) rtail)
(cons ($name position) arguments))]))) (cons (mk-$name #'NT position) arguments))])))
(define arguments (append (reverse args) new-arguments)) (define arguments (append (reverse args) new-arguments))
(cons #`(#,head . #,new-tail) (cons #`(#,head . #,new-tail)
(mk-action arguments))) (mk-action arguments)))
@ -102,7 +101,7 @@
[(NT . parts-rest) [(NT . parts-rest)
(identifier? #'NT) (identifier? #'NT)
(loop #'parts-rest (cons #'NT rpattern) (loop #'parts-rest (cons #'NT rpattern)
(add1 position) (cons ($name position) args))]))) (add1 position) (cons (mk-$name #'NT position) args))])))
(map (lambda (new-pattern) (map (lambda (new-pattern)
(cons (datum->syntax #f new-pattern pattern) (cons (datum->syntax #f new-pattern pattern)
#`(#,action-function #,(if wrap? okW #'values) #,@arguments))) #`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
@ -122,20 +121,22 @@
[(! . parts-rest) [(! . parts-rest)
(cons (cons
;; Error occurs ;; Error occurs
(elaborate-skipped-tail (I 'syntax-error) (let ([id (mk-name (car (syntax-e parts)) 'syntax-error)])
#'parts-rest (elaborate-skipped-tail id
(add1 position) #'parts-rest
(cons ($name position) args) (add1 position)
int-action) (cons (mk-$name id position) args)
int-action))
;; Error doesn't occur ;; Error doesn't occur
(loop #'parts-rest position (cons #'#f args)))] (loop #'parts-rest position (cons #'#f args)))]
[(!!) [(!!)
(cons (cons
(elaborate-skipped-tail (I 'syntax-error) (let ([id (mk-name (car (syntax-e parts)) 'syntax-error)])
#'() (elaborate-skipped-tail id
(add1 position) #'()
(cons ($name position) args) (add1 position)
int-action) (cons (mk-$name id position) args)
int-action))
null)] null)]
[((? NT) . parts-rest) [((? NT) . parts-rest)
(cons (cons
@ -143,14 +144,15 @@
(elaborate-skipped-tail (interrupted-name #'NT) (elaborate-skipped-tail (interrupted-name #'NT)
#'parts-rest #'parts-rest
(add1 position) (add1 position)
(cons ($name position) args) (cons (mk-$name #'NT position) args)
int-action) int-action)
;; NT is not interrupted ;; NT is not interrupted
(loop #'(NT . parts-rest) position args))] (loop #'(NT . parts-rest) position args))]
[(part0 . parts-rest) [(part0 . parts-rest)
(identifier? #'part0) (identifier? #'part0)
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause))) (map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
(loop #'parts-rest (add1 position) (cons ($name position) args)))]))) (loop #'parts-rest (add1 position) (cons (mk-$name #'part0 position)
args)))])))
(define-for-syntax (generate-action-name nt pos) (define-for-syntax (generate-action-name nt pos)
(syntax-local-get-shadower (syntax-local-get-shadower
@ -159,13 +161,13 @@
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos) (define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
(define pattern (car alt)) (define pattern (car alt))
(define action (cdr alt)) (define action (cdr alt))
(define-values (var-indexes non-var-indexes) (define variables
(let loop ([pattern pattern] [n 1] [vars null] [nonvars null]) (let loop ([pattern pattern] [n 1] [vars null])
(syntax-case pattern () (syntax-case pattern ()
[(first . more) [(first . more)
(syntax-case #'first (! ? !!) (syntax-case #'first (! ? !!)
[! [!
(loop #'more (add1 n) (cons n vars) nonvars)] (loop #'more (add1 n) (cons (mk-$name #'first n) vars))]
[(! . _) [(! . _)
(raise-syntax-error 'split (raise-syntax-error 'split
"misuse of ! grammar form" "misuse of ! grammar form"
@ -175,40 +177,36 @@
(raise-syntax-error 'split (raise-syntax-error 'split
"nothing may follow !!" "nothing may follow !!"
pattern)) pattern))
(loop #'more (add1 n) (cons n vars) nonvars)] (loop #'more (add1 n) (cons (mk-$name #'first n) vars))]
[(!! . _) [(!! . _)
(raise-syntax-error 'split (raise-syntax-error 'split
"misuse of !! grammar form" "misuse of !! grammar form"
pattern #'first)] pattern #'first)]
[(? NT) [(? NT)
(identifier? #'NT) (identifier? #'NT)
(loop #'more (add1 n) (cons n vars) nonvars)] (loop #'more (add1 n) (cons (mk-$name #'NT n) vars))]
[(? . _) [(? . _)
(raise-syntax-error 'split (raise-syntax-error 'split
"misuse of ? grammar form" "misuse of ? grammar form"
pattern #'first)] pattern #'first)]
[NT [NT
(identifier? #'NT) (identifier? #'NT)
(loop #'more (add1 n) (cons n vars) nonvars)] (loop #'more (add1 n) (cons (mk-$name #'NT n) vars))]
[other [other
(raise-syntax-error 'rewrite-pattern (raise-syntax-error 'rewrite-pattern
"invalid grammar pattern" "invalid grammar pattern"
pattern #'first)])] pattern #'first)])]
[() [()
(values (reverse vars) (reverse nonvars))]))) (reverse vars)])))
(define variables (map $name var-indexes))
(define non-var-names (map $name non-var-indexes))
(define action-function (generate-action-name nt pos)) (define action-function (generate-action-name nt pos))
(cons (cons pattern action-function) (cons (cons pattern action-function)
(with-syntax ([(var ...) variables] (with-syntax ([(var ...) variables]
[(nonvar ...) non-var-names]
[action-function action-function] [action-function action-function]
[action action]) [action action])
#`(define (action-function wrap var ...) #`(define (action-function wrap var ...)
(let-syntax ([nonvar invalid-$name-use] ...) #,(if args-spec
#,(if args-spec #`(lambda #,args-spec (wrap action))
#`(lambda #,args-spec (wrap action)) #`(wrap action))))))
#`(wrap action)))))))
(define-for-syntax (invalid-$name-use stx) (define-for-syntax (invalid-$name-use stx)
(raise-syntax-error #f "no value for positional variable" stx)) (raise-syntax-error #f "no value for positional variable" stx))