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

Fixes CS renaming of pattern occurrences of metafunction names

Browse Source
This commit is contained in:
Casey Klein 2010-12-03 15:47:03 -06:00
parent 8388f28f33
commit 8affb5b13f
1 changed files with 239 additions and 238 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/redex/private/reduction-semantics.rkt
View File

@ -1175,7 +1175,6 @@
prev-metafunction prev-metafunction
(λ () (λ ()
(raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction)))) (raise-syntax-error syn-error-name "expected a previously defined metafunction" orig-stx prev-metafunction))))
(prune-syntax
(let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) ;; keep this near the beginning, so it signals the first error (PR 10062) (let ([lang-nts (language-id-nts #'lang 'define-metafunction)]) ;; keep this near the beginning, so it signals the first error (PR 10062)
(let-values ([(contract-name dom-ctcs codom-contract pats) (let-values ([(contract-name dom-ctcs codom-contract pats)
(split-out-contract orig-stx syn-error-name #'rest relation?)]) (split-out-contract orig-stx syn-error-name #'rest relation?)])
@ -1405,6 +1404,7 @@
#,relation?)))) #,relation?))))
(term-define-fn name name2))]) (term-define-fn name name2))])
(syntax-property (syntax-property
(prune-syntax
(if (eq? 'top-level (syntax-local-context)) (if (eq? 'top-level (syntax-local-context))
; Introduce the names before using them, to allow ; Introduce the names before using them, to allow
; metafunction definition at the top-level. ; metafunction definition at the top-level.
@ -1412,9 +1412,10 @@
(begin (begin
(define-syntaxes (name2 name-predicate) (values)) (define-syntaxes (name2 name-predicate) (values))
defs)) defs))
(syntax defs)) (syntax defs)))
'disappeared-use 'disappeared-use
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))))))] (map syntax-local-introduce
(syntax->list #'(original-names ...)))))))))))))))]
[(_ prev-metafunction name lang clauses ...) [(_ prev-metafunction name lang clauses ...)
(begin (begin
(unless (identifier? #'name) (unless (identifier? #'name)