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

Fix to allow metafunction definition at the top-level.

Browse Source 
svn: r16218
This commit is contained in:
Casey Klein 2009-10-02 16:54:44 +00:00
parent 1003c22061
commit 0520a50f3e
1 changed files with 94 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

180
collects/redex/private/reduction-semantics.ss
View File

@ -1207,92 +1207,100 @@
[seq-of-lhs #'(lhs ...)] [seq-of-lhs #'(lhs ...)]
[seq-of-tl-side-cond/binds #'(tl-side-cond/binds ...)] [seq-of-tl-side-cond/binds #'(tl-side-cond/binds ...)]
[seq-of-lhs-for-lw #'(lhs-for-lw ...)]) [seq-of-lhs-for-lw #'(lhs-for-lw ...)])
(syntax-property (with-syntax ([defs #`(begin
#`(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] cp-let-bindings ... ...
cp-let-bindings ... ... rg-cp-let-bindings ... ...)
rg-cp-let-bindings ... ...) (let ([cases (map (λ (pat rhs-fn rg-lhs src)
(let ([cases (map (λ (pat rhs-fn rg-lhs src) (make-metafunc-case
(make-metafunc-case (compile-pattern lang pat #t) rhs-fn rg-lhs src (gensym)))
(compile-pattern lang pat #t) rhs-fn rg-lhs src (gensym))) sc
sc (list rhs-fns ...)
(list rhs-fns ...) `(rg-side-conditions-rewritten ...)
`(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
lang cases
cases parent-cases
parent-cases (λ (f/dom)
(λ (f/dom) (make-metafunc-proc
(make-metafunc-proc (let ([name (lambda (x) (f/dom x))]) name)
(let ([name (lambda (x) (f/dom x))]) name) ;; !! This code goes back to phase 1 to call `to-lw', but it's delayed
;; !! 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
;; through `let-syntax' instead of `unsyntax' so that `to-lw' isn't called ;; until all metafunction definitions have been processed.
;; until all metafunction definitions have been processed. ;; It gets a little complicated because we want to use sequences from the
;; It gets a little complicated because we want to use sequences from the ;; original `define-metafunction' (step 1) and sequences that are generated within
;; 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 ---
;; `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
;; 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
;; `...', which should be treated as literals at step 2. Hece the `seq-' bindings ;; above and a quoting `...' on each use of a `seq-' binding.
;; above and a quoting `...' on each use of a `seq-' binding. (...
(... (let-syntax
(let-syntax ([generate-lws
([generate-lws (lambda (stx)
(lambda (stx) (with-syntax
(with-syntax ([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))]
([(rhs/lw ...) (map to-lw/proc (syntax->list #'(... seq-of-rhs)))] [(((bind-id/lw . bind-pat/lw) ...) ...)
[(((bind-id/lw . bind-pat/lw) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract pattern bindings (map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x))))
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/proc (cdr x)))) (extract-pattern-binds x)))
(extract-pattern-binds x))) (syntax->list #'(... seq-of-lhs)))]
(syntax->list #'(... seq-of-lhs)))]
[((where/sc/lw ...) ...)
[((where/sc/lw ...) ...) ;; Also for pict, extract where bindings
;; Also for pict, extract where bindings (map (λ (hm)
(map (λ (hm) (map
(map (λ (lst)
(λ (lst) (syntax-case lst (side-condition where)
(syntax-case lst (side-condition where) [(where pat exp)
[(where pat exp) #`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))]
#`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))] [(side-condition x)
[(side-condition x) (to-lw/uq/proc #'x)]))
(to-lw/uq/proc #'x)])) (reverse (syntax->list hm))))
(reverse (syntax->list hm)))) (syntax->list #'(... seq-of-tl-side-cond/binds)))]
(syntax->list #'(... seq-of-tl-side-cond/binds)))]
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...)
[(((rhs-bind-id/lw . rhs-bind-pat/lw/uq) ...) ...) ;; Also for pict, extract pattern bindings
;; Also for pict, extract pattern bindings (map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x))))
(map (λ (x) (map (λ (x) (cons (to-lw/proc (car x)) (to-lw/uq/proc (cdr x)))) (extract-term-let-binds x)))
(extract-term-let-binds x))) (syntax->list #'(... seq-of-rhs)))]
(syntax->list #'(... seq-of-rhs)))]
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)])
[(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)]) #'(list (list x-lhs-for-lw
#'(list (list x-lhs-for-lw (list (cons bind-id/lw bind-pat/lw) ...
(list (cons bind-id/lw bind-pat/lw) ... (cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ...
(cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ... where/sc/lw ...)
where/sc/lw ...) rhs/lw)
rhs/lw) ...)))])
...)))]) (generate-lws)))
(generate-lws))) lang
lang #t ;; multi-args?
#t ;; multi-args? 'name
'name (let ([name (lambda (x) (name-predicate x))]) name)
(let ([name (lambda (x) (name-predicate x))]) name) dsc
dsc (append cases parent-cases)))
(append cases parent-cases))) dsc
dsc `codom-side-conditions-rewritten
`codom-side-conditions-rewritten 'name
'name #,relation?))))
#,relation?)))) (term-define-fn name name2))])
(term-define-fn name name2)) (syntax-property
'disappeared-use (if (eq? 'top-level (syntax-local-context))
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))))))] ; Introduce the names before using them, to allow
; metafunction definition at the top-level.
(syntax
(begin
(define-syntaxes (name2 name-predicate) (values))
defs))
(syntax defs))
'disappeared-use
(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)