Fixes CS renaming of pattern occurrences of metafunction names
This commit is contained in:
Casey Klein
parent
8388f28f33
commit
8affb5b13f
|
|
@ -1175,246 +1175,247 @@
|
||||||
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?)])
|
(with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
|
||||||
(with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
|
[(lhs-for-lw ...)
|
||||||
[(lhs-for-lw ...)
|
(with-syntax ([((lhs-for-lw _ ...) ...) pats])
|
||||||
(with-syntax ([((lhs-for-lw _ ...) ...) pats])
|
(map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x)))
|
||||||
(map (λ (x) (to-lw/proc (datum->syntax #f (cdr (syntax-e x)) x)))
|
(syntax->list #'(lhs-for-lw ...))))])
|
||||||
(syntax->list #'(lhs-for-lw ...))))])
|
(with-syntax ([((rhs stuff ...) ...) (if relation?
|
||||||
(with-syntax ([((rhs stuff ...) ...) (if relation?
|
#'((,(and (term raw-rhses) ...)) ...)
|
||||||
#'((,(and (term raw-rhses) ...)) ...)
|
#'((raw-rhses ...) ...))])
|
||||||
#'((raw-rhses ...) ...))])
|
(parameterize ([is-term-fn?
|
||||||
(parameterize ([is-term-fn?
|
(let ([names (syntax->list #'(original-names ...))])
|
||||||
(let ([names (syntax->list #'(original-names ...))])
|
(λ (x) (and (not (null? names))
|
||||||
(λ (x) (and (not (null? names))
|
(identifier? (car names))
|
||||||
(identifier? (car names))
|
(free-identifier=? x (car names)))))])
|
||||||
(free-identifier=? x (car names)))))])
|
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
|
||||||
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
|
[name (let loop ([name (if contract-name
|
||||||
[name (let loop ([name (if contract-name
|
contract-name
|
||||||
contract-name
|
(car (syntax->list #'(original-names ...))))]
|
||||||
(car (syntax->list #'(original-names ...))))]
|
[names (if contract-name
|
||||||
[names (if contract-name
|
(syntax->list #'(original-names ...))
|
||||||
(syntax->list #'(original-names ...))
|
(cdr (syntax->list #'(original-names ...))))])
|
||||||
(cdr (syntax->list #'(original-names ...))))])
|
(cond
|
||||||
(cond
|
[(null? names) name]
|
||||||
[(null? names) name]
|
[else
|
||||||
[else
|
(unless (eq? (syntax-e name) (syntax-e (car names)))
|
||||||
(unless (eq? (syntax-e name) (syntax-e (car names)))
|
(raise
|
||||||
(raise
|
(make-exn:fail:syntax
|
||||||
(make-exn:fail:syntax
|
(if contract-name
|
||||||
(if contract-name
|
"define-metafunction: expected each clause and the contract to use the same name"
|
||||||
"define-metafunction: expected each clause and the contract to use the same name"
|
"define-metafunction: expected each clause to use the same name")
|
||||||
"define-metafunction: expected each clause to use the same name")
|
(current-continuation-marks)
|
||||||
(current-continuation-marks)
|
(list name
|
||||||
(list name
|
(car names)))))
|
||||||
(car names)))))
|
(loop name (cdr names))]))])
|
||||||
(loop name (cdr names))]))])
|
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
|
||||||
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
|
(raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction))
|
||||||
(raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction))
|
(parse-extras #'((stuff ...) ...))
|
||||||
(parse-extras #'((stuff ...) ...))
|
(let-values ([(lhs-namess lhs-namess/ellipsess)
|
||||||
(let-values ([(lhs-namess lhs-namess/ellipsess)
|
(let loop ([lhss (syntax->list (syntax (lhs ...)))])
|
||||||
(let loop ([lhss (syntax->list (syntax (lhs ...)))])
|
(if (null? lhss)
|
||||||
(if (null? lhss)
|
(values null null)
|
||||||
(values null null)
|
(let-values ([(namess namess/ellipsess)
|
||||||
(let-values ([(namess namess/ellipsess)
|
(loop (cdr lhss))]
|
||||||
(loop (cdr lhss))]
|
[(names names/ellipses)
|
||||||
[(names names/ellipses)
|
(extract-names lang-nts syn-error-name #t (car lhss))])
|
||||||
(extract-names lang-nts syn-error-name #t (car lhss))])
|
(values (cons names namess)
|
||||||
(values (cons names namess)
|
(cons names/ellipses namess/ellipsess)))))])
|
||||||
(cons names/ellipses namess/ellipsess)))))])
|
(with-syntax ([(rhs/wheres ...)
|
||||||
(with-syntax ([(rhs/wheres ...)
|
(map (λ (sc/b rhs names names/ellipses)
|
||||||
(map (λ (sc/b rhs names names/ellipses)
|
(bind-withs
|
||||||
(bind-withs
|
syn-error-name '()
|
||||||
syn-error-name '()
|
#'effective-lang lang-nts
|
||||||
#'effective-lang lang-nts
|
sc/b 'flatten
|
||||||
sc/b 'flatten
|
#`(list (term #,rhs))
|
||||||
#`(list (term #,rhs))
|
names names/ellipses))
|
||||||
names names/ellipses))
|
(syntax->list #'((stuff ...) ...))
|
||||||
(syntax->list #'((stuff ...) ...))
|
(syntax->list #'(rhs ...))
|
||||||
(syntax->list #'(rhs ...))
|
lhs-namess lhs-namess/ellipsess)]
|
||||||
lhs-namess lhs-namess/ellipsess)]
|
[(rg-rhs/wheres ...)
|
||||||
[(rg-rhs/wheres ...)
|
(map (λ (sc/b rhs names names/ellipses)
|
||||||
(map (λ (sc/b rhs names names/ellipses)
|
(bind-withs
|
||||||
(bind-withs
|
syn-error-name '()
|
||||||
syn-error-name '()
|
#'effective-lang lang-nts
|
||||||
#'effective-lang lang-nts
|
sc/b 'predicate
|
||||||
sc/b 'predicate
|
#`#t
|
||||||
#`#t
|
names names/ellipses))
|
||||||
names names/ellipses))
|
(syntax->list #'((stuff ...) ...))
|
||||||
(syntax->list #'((stuff ...) ...))
|
(syntax->list #'(rhs ...))
|
||||||
(syntax->list #'(rhs ...))
|
lhs-namess lhs-namess/ellipsess)])
|
||||||
lhs-namess lhs-namess/ellipsess)])
|
(with-syntax ([(side-conditions-rewritten ...)
|
||||||
(with-syntax ([(side-conditions-rewritten ...)
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
lang-nts
|
||||||
lang-nts
|
syn-error-name
|
||||||
syn-error-name
|
#t
|
||||||
#t
|
x))
|
||||||
x))
|
(syntax->list (syntax (lhs ...))))]
|
||||||
(syntax->list (syntax (lhs ...))))]
|
[(rg-side-conditions-rewritten ...)
|
||||||
[(rg-side-conditions-rewritten ...)
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
lang-nts
|
||||||
lang-nts
|
syn-error-name
|
||||||
syn-error-name
|
#t
|
||||||
#t
|
x))
|
||||||
x))
|
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
||||||
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
[(clause-src ...)
|
||||||
[(clause-src ...)
|
(map (λ (lhs)
|
||||||
(map (λ (lhs)
|
(format "~a:~a:~a"
|
||||||
(format "~a:~a:~a"
|
(syntax-source lhs)
|
||||||
(syntax-source lhs)
|
(syntax-line lhs)
|
||||||
(syntax-line lhs)
|
(syntax-column lhs)))
|
||||||
(syntax-column lhs)))
|
pats)]
|
||||||
pats)]
|
[dom-side-conditions-rewritten
|
||||||
[dom-side-conditions-rewritten
|
(and dom-ctcs
|
||||||
(and dom-ctcs
|
(rewrite-side-conditions/check-errs
|
||||||
(rewrite-side-conditions/check-errs
|
lang-nts
|
||||||
lang-nts
|
syn-error-name
|
||||||
syn-error-name
|
#f
|
||||||
#f
|
dom-ctcs))]
|
||||||
dom-ctcs))]
|
[codom-side-conditions-rewritten
|
||||||
[codom-side-conditions-rewritten
|
(rewrite-side-conditions/check-errs
|
||||||
(rewrite-side-conditions/check-errs
|
lang-nts
|
||||||
lang-nts
|
syn-error-name
|
||||||
syn-error-name
|
#f
|
||||||
#f
|
codom-contract)]
|
||||||
codom-contract)]
|
[(rhs-fns ...)
|
||||||
[(rhs-fns ...)
|
(map (λ (names names/ellipses rhs/where)
|
||||||
(map (λ (names names/ellipses rhs/where)
|
(with-syntax ([(names ...) names]
|
||||||
(with-syntax ([(names ...) names]
|
[(names/ellipses ...) names/ellipses]
|
||||||
[(names/ellipses ...) names/ellipses]
|
[rhs/where rhs/where])
|
||||||
[rhs/where rhs/where])
|
(syntax
|
||||||
(syntax
|
(λ (name bindings)
|
||||||
(λ (name bindings)
|
(term-let-fn ((name name))
|
||||||
(term-let-fn ((name name))
|
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
||||||
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
rhs/where))))))
|
||||||
rhs/where))))))
|
lhs-namess lhs-namess/ellipsess
|
||||||
lhs-namess lhs-namess/ellipsess
|
(syntax->list (syntax (rhs/wheres ...))))]
|
||||||
(syntax->list (syntax (rhs/wheres ...))))]
|
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
|
||||||
[(name2 name-predicate) (generate-temporaries (syntax (name name)))]
|
|
||||||
|
|
||||||
;; See "!!" below for information on the `seq-' bindings:
|
;; See "!!" below for information on the `seq-' bindings:
|
||||||
[seq-of-rhs #'(rhs ...)]
|
[seq-of-rhs #'(rhs ...)]
|
||||||
[seq-of-lhs #'(lhs ...)]
|
[seq-of-lhs #'(lhs ...)]
|
||||||
[seq-of-tl-side-cond/binds #'((stuff ...) ...)]
|
[seq-of-tl-side-cond/binds #'((stuff ...) ...)]
|
||||||
[seq-of-lhs-for-lw #'(lhs-for-lw ...)])
|
[seq-of-lhs-for-lw #'(lhs-for-lw ...)])
|
||||||
(with-syntax ([defs #`(begin
|
(with-syntax ([defs #`(begin
|
||||||
(define-values (name2 name-predicate)
|
(define-values (name2 name-predicate)
|
||||||
(let ([sc `(side-conditions-rewritten ...)]
|
(let ([sc `(side-conditions-rewritten ...)]
|
||||||
[dsc `dom-side-conditions-rewritten])
|
[dsc `dom-side-conditions-rewritten])
|
||||||
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
||||||
(make-metafunc-case
|
(make-metafunc-case
|
||||||
(λ (effective-lang) (compile-pattern effective-lang pat #t))
|
(λ (effective-lang) (compile-pattern effective-lang pat #t))
|
||||||
rhs-fn
|
rhs-fn
|
||||||
rg-lhs src (gensym)))
|
rg-lhs src (gensym)))
|
||||||
sc
|
sc
|
||||||
(list (λ (effective-lang) rhs-fns) ...)
|
(list (λ (effective-lang) rhs-fns) ...)
|
||||||
(list (λ (effective-lang) `rg-side-conditions-rewritten) ...)
|
(list (λ (effective-lang) `rg-side-conditions-rewritten) ...)
|
||||||
`(clause-src ...))]
|
`(clause-src ...))]
|
||||||
[parent-cases
|
[parent-cases
|
||||||
#,(if prev-metafunction
|
#,(if prev-metafunction
|
||||||
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
||||||
#'null)])
|
#'null)])
|
||||||
(build-metafunction
|
(build-metafunction
|
||||||
lang
|
|
||||||
cases
|
|
||||||
parent-cases
|
|
||||||
(λ (f/dom)
|
|
||||||
(make-metafunc-proc
|
|
||||||
(let ([name (lambda (x) (f/dom x))]) name)
|
|
||||||
;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
|
|
||||||
;; through `let-syntax' instead of `unsyntax' so that `to-lw' isn't called
|
|
||||||
;; until all metafunction definitions have been processed.
|
|
||||||
;; It gets a little complicated because we want to use sequences from the
|
|
||||||
;; original `define-metafunction' (step 1) and sequences that are generated within
|
|
||||||
;; `let-syntax' (step 2). So we quote all the `...' in the `let-syntax' form ---
|
|
||||||
;; and also have to quote all uses step-1 pattern variables in case they produce
|
|
||||||
;; `...', which should be treated as literals at step 2. Hece the `seq-' bindings
|
|
||||||
;; above and a quoting `...' on each use of a `seq-' binding.
|
|
||||||
(...
|
|
||||||
(let-syntax
|
|
||||||
([generate-lws
|
|
||||||
(lambda (stx)
|
|
||||||
(with-syntax
|
|
||||||
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
|
|
||||||
[(((bind-id/lw . bind-pat/lw) ...) ...)
|
|
||||||
;; Also for pict, extract pattern bindings
|
|
||||||
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
|
|
||||||
(extract-pattern-binds x)))
|
|
||||||
(syntax->list #'(... seq-of-lhs)))]
|
|
||||||
|
|
||||||
[((where/sc/lw ...) ...)
|
|
||||||
;; Also for pict, extract where bindings
|
|
||||||
(map (λ (hm)
|
|
||||||
(map
|
|
||||||
(λ (lst)
|
|
||||||
(syntax-case lst (unquote side-condition where)
|
|
||||||
[(where pat (unquote (f _ _)))
|
|
||||||
(and (or (identifier? #'pat)
|
|
||||||
(andmap identifier? (syntax->list #'pat)))
|
|
||||||
(or (free-identifier=? #'f #'variable-not-in)
|
|
||||||
(free-identifier=? #'f #'variables-not-in)))
|
|
||||||
(with-syntax ([(ids ...)
|
|
||||||
(map to-lw/proc
|
|
||||||
(if (identifier? #'pat)
|
|
||||||
(list #'pat)
|
|
||||||
(syntax->list #'pat)))])
|
|
||||||
#`(make-metafunc-extra-fresh
|
|
||||||
(list ids ...)))]
|
|
||||||
[(where pat exp)
|
|
||||||
#`(make-metafunc-extra-where
|
|
||||||
#,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
|
|
||||||
[(side-condition x)
|
|
||||||
#`(make-metafunc-extra-side-cond
|
|
||||||
#,(to-lw/uq/proc #'x))]))
|
|
||||||
(reverse
|
|
||||||
(filter (λ (lst)
|
|
||||||
(syntax-case lst (where/hidden
|
|
||||||
side-condition/hidden)
|
|
||||||
[(where/hidden pat exp) #f]
|
|
||||||
[(side-condition/hidden x) #f]
|
|
||||||
[_ #t]))
|
|
||||||
(syntax->list hm)))))
|
|
||||||
(syntax->list #'(... seq-of-tl-side-cond/binds)))]
|
|
||||||
|
|
||||||
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
|
|
||||||
;; Also for pict, extract pattern bindings
|
|
||||||
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
|
|
||||||
(extract-term-let-binds x)))
|
|
||||||
(syntax->list #'(... seq-of-rhs)))]
|
|
||||||
|
|
||||||
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)])
|
|
||||||
#'(list (list x-lhs-for-lw
|
|
||||||
(list (make-metafunc-extra-where bind-id/lw bind-pat/lw) ...
|
|
||||||
(make-metafunc-extra-where rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
|
|
||||||
where/sc/lw ...)
|
|
||||||
rhs/lw)
|
|
||||||
...)))])
|
|
||||||
(generate-lws)))
|
|
||||||
lang
|
lang
|
||||||
#t ;; multi-args?
|
cases
|
||||||
'name
|
parent-cases
|
||||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
(λ (f/dom)
|
||||||
|
(make-metafunc-proc
|
||||||
|
(let ([name (lambda (x) (f/dom x))]) name)
|
||||||
|
;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
|
||||||
|
;; through `let-syntax' instead of `unsyntax' so that `to-lw' isn't called
|
||||||
|
;; until all metafunction definitions have been processed.
|
||||||
|
;; It gets a little complicated because we want to use sequences from the
|
||||||
|
;; original `define-metafunction' (step 1) and sequences that are generated within
|
||||||
|
;; `let-syntax' (step 2). So we quote all the `...' in the `let-syntax' form ---
|
||||||
|
;; and also have to quote all uses step-1 pattern variables in case they produce
|
||||||
|
;; `...', which should be treated as literals at step 2. Hece the `seq-' bindings
|
||||||
|
;; above and a quoting `...' on each use of a `seq-' binding.
|
||||||
|
(...
|
||||||
|
(let-syntax
|
||||||
|
([generate-lws
|
||||||
|
(lambda (stx)
|
||||||
|
(with-syntax
|
||||||
|
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
|
||||||
|
[(((bind-id/lw . bind-pat/lw) ...) ...)
|
||||||
|
;; Also for pict, extract pattern bindings
|
||||||
|
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
|
||||||
|
(extract-pattern-binds x)))
|
||||||
|
(syntax->list #'(... seq-of-lhs)))]
|
||||||
|
|
||||||
|
[((where/sc/lw ...) ...)
|
||||||
|
;; Also for pict, extract where bindings
|
||||||
|
(map (λ (hm)
|
||||||
|
(map
|
||||||
|
(λ (lst)
|
||||||
|
(syntax-case lst (unquote side-condition where)
|
||||||
|
[(where pat (unquote (f _ _)))
|
||||||
|
(and (or (identifier? #'pat)
|
||||||
|
(andmap identifier? (syntax->list #'pat)))
|
||||||
|
(or (free-identifier=? #'f #'variable-not-in)
|
||||||
|
(free-identifier=? #'f #'variables-not-in)))
|
||||||
|
(with-syntax ([(ids ...)
|
||||||
|
(map to-lw/proc
|
||||||
|
(if (identifier? #'pat)
|
||||||
|
(list #'pat)
|
||||||
|
(syntax->list #'pat)))])
|
||||||
|
#`(make-metafunc-extra-fresh
|
||||||
|
(list ids ...)))]
|
||||||
|
[(where pat exp)
|
||||||
|
#`(make-metafunc-extra-where
|
||||||
|
#,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
|
||||||
|
[(side-condition x)
|
||||||
|
#`(make-metafunc-extra-side-cond
|
||||||
|
#,(to-lw/uq/proc #'x))]))
|
||||||
|
(reverse
|
||||||
|
(filter (λ (lst)
|
||||||
|
(syntax-case lst (where/hidden
|
||||||
|
side-condition/hidden)
|
||||||
|
[(where/hidden pat exp) #f]
|
||||||
|
[(side-condition/hidden x) #f]
|
||||||
|
[_ #t]))
|
||||||
|
(syntax->list hm)))))
|
||||||
|
(syntax->list #'(... seq-of-tl-side-cond/binds)))]
|
||||||
|
|
||||||
|
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
|
||||||
|
;; Also for pict, extract pattern bindings
|
||||||
|
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
|
||||||
|
(extract-term-let-binds x)))
|
||||||
|
(syntax->list #'(... seq-of-rhs)))]
|
||||||
|
|
||||||
|
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)])
|
||||||
|
#'(list (list x-lhs-for-lw
|
||||||
|
(list (make-metafunc-extra-where bind-id/lw bind-pat/lw) ...
|
||||||
|
(make-metafunc-extra-where rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
|
||||||
|
where/sc/lw ...)
|
||||||
|
rhs/lw)
|
||||||
|
...)))])
|
||||||
|
(generate-lws)))
|
||||||
|
lang
|
||||||
|
#t ;; multi-args?
|
||||||
|
'name
|
||||||
|
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||||
|
dsc
|
||||||
|
(append cases parent-cases)))
|
||||||
dsc
|
dsc
|
||||||
(append cases parent-cases)))
|
`codom-side-conditions-rewritten
|
||||||
dsc
|
'name
|
||||||
`codom-side-conditions-rewritten
|
#,relation?))))
|
||||||
'name
|
(term-define-fn name name2))])
|
||||||
#,relation?))))
|
(syntax-property
|
||||||
(term-define-fn name name2))])
|
(prune-syntax
|
||||||
(syntax-property
|
(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.
|
(syntax
|
||||||
(syntax
|
(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
|
||||||
(map syntax-local-introduce (syntax->list #'(original-names ...))))))))))))))))]
|
(syntax->list #'(original-names ...)))))))))))))))]
|
||||||
[(_ prev-metafunction name lang clauses ...)
|
[(_ prev-metafunction name lang clauses ...)
|
||||||
(begin
|
(begin
|
||||||
(unless (identifier? #'name)
|
(unless (identifier? #'name)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user