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

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

@ -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)