Moves metafunction construction to later expansion step
This commit is contained in:
Casey Klein
parent
2b4f604776
commit
ac7856a377
|
|
@ -1373,9 +1373,8 @@
|
||||||
(if prev-metafunction
|
(if prev-metafunction
|
||||||
'define-metafunction/extension
|
'define-metafunction/extension
|
||||||
'define-metafunction))])
|
'define-metafunction))])
|
||||||
(define lang-nts
|
;; keep this near the beginning, so it signals the first error (PR 10062)
|
||||||
;; keep this near the beginning, so it signals the first error (PR 10062)
|
(definition-nts #'lang orig-stx syn-error-name)
|
||||||
(definition-nts #'lang orig-stx syn-error-name))
|
|
||||||
(when (null? (syntax-e #'rest))
|
(when (null? (syntax-e #'rest))
|
||||||
(raise-syntax-error syn-error-name "no clauses" orig-stx))
|
(raise-syntax-error syn-error-name "no clauses" orig-stx))
|
||||||
(when prev-metafunction
|
(when prev-metafunction
|
||||||
|
|
@ -1386,145 +1385,167 @@
|
||||||
(let*-values ([(contract-name dom-ctcs codom-contracts pats)
|
(let*-values ([(contract-name dom-ctcs codom-contracts pats)
|
||||||
(split-out-contract orig-stx syn-error-name #'rest relation?)]
|
(split-out-contract orig-stx syn-error-name #'rest relation?)]
|
||||||
[(name _) (defined-name (list contract-name) pats orig-stx)])
|
[(name _) (defined-name (list contract-name) pats orig-stx)])
|
||||||
(with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
|
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
|
||||||
[(lhs-for-lw ...) (lhs-lws pats)])
|
(raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction))
|
||||||
(with-syntax ([((rhs stuff ...) ...) (if relation?
|
(with-syntax ([(name2 name-predicate) (generate-temporaries (list name name))]
|
||||||
#'((,(and (term raw-rhses) ...)) ...)
|
[name name])
|
||||||
#'((raw-rhses ...) ...))])
|
(with-syntax ([defs #`(begin
|
||||||
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
|
(define-values (name2 name-predicate)
|
||||||
[name name])
|
(generate-metafunction #,orig-stx
|
||||||
(when (and prev-metafunction (eq? (syntax-e #'name) (syntax-e prev-metafunction)))
|
lang
|
||||||
(raise-syntax-error syn-error-name "the extended and extending metafunctions cannot share a name" orig-stx prev-metafunction))
|
#,prev-metafunction
|
||||||
(parse-extras #'((stuff ...) ...))
|
name
|
||||||
(let-values ([(lhs-namess lhs-namess/ellipsess)
|
name-predicate
|
||||||
(lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)])
|
#,dom-ctcs
|
||||||
(with-syntax ([(rhs/wheres ...)
|
#,codom-contracts
|
||||||
(map (λ (sc/b rhs names names/ellipses)
|
#,pats
|
||||||
(bind-withs
|
#,relation?
|
||||||
syn-error-name '()
|
#,syn-error-name))
|
||||||
#'effective-lang lang-nts
|
(term-define-fn name name2))])
|
||||||
sc/b 'flatten
|
(if (eq? 'top-level (syntax-local-context))
|
||||||
#`(list (term #,rhs))
|
; Introduce the names before using them, to allow
|
||||||
names names/ellipses))
|
; metafunction definition at the top-level.
|
||||||
(syntax->list #'((stuff ...) ...))
|
(syntax
|
||||||
(syntax->list #'(rhs ...))
|
(begin
|
||||||
lhs-namess lhs-namess/ellipsess)]
|
(define-syntaxes (name2 name-predicate) (values))
|
||||||
[(rg-rhs/wheres ...)
|
defs))
|
||||||
(map (λ (sc/b rhs names names/ellipses)
|
(syntax defs))))))]))
|
||||||
(bind-withs
|
|
||||||
syn-error-name '()
|
(define-syntax (generate-metafunction stx)
|
||||||
#'effective-lang lang-nts
|
(syntax-case stx ()
|
||||||
sc/b 'predicate
|
[(_ orig-stx lang prev-metafunction name name-predicate dom-ctcs codom-contracts pats relation? syn-error-name)
|
||||||
#`#t
|
(let ([prev-metafunction (and (syntax-e #'prev-metafunction) #'prev-metafunction)]
|
||||||
names names/ellipses))
|
[dom-ctcs (syntax-e #'dom-ctcs)]
|
||||||
(syntax->list #'((stuff ...) ...))
|
[codom-contracts (syntax-e #'codom-contracts)]
|
||||||
(syntax->list #'(rhs ...))
|
[pats (syntax-e #'pats)]
|
||||||
lhs-namess lhs-namess/ellipsess)])
|
[relation? (syntax-e #'relation?)]
|
||||||
(with-syntax ([(side-conditions-rewritten ...)
|
[syn-error-name (syntax-e #'syn-err-name)])
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
(define lang-nts
|
||||||
lang-nts
|
(definition-nts #'lang #'orig-stx syn-error-name))
|
||||||
syn-error-name
|
(with-syntax ([(((original-names lhs-clauses ...) raw-rhses ...) ...) pats]
|
||||||
#t
|
[(lhs-for-lw ...) (lhs-lws pats)])
|
||||||
x))
|
(with-syntax ([((rhs stuff ...) ...) (if relation?
|
||||||
(syntax->list (syntax (lhs ...))))]
|
#'((,(and (term raw-rhses) ...)) ...)
|
||||||
[(rg-side-conditions-rewritten ...)
|
#'((raw-rhses ...) ...))]
|
||||||
(map (λ (x) (rewrite-side-conditions/check-errs
|
[(lhs ...) #'((lhs-clauses ...) ...)])
|
||||||
lang-nts
|
(parse-extras #'((stuff ...) ...))
|
||||||
syn-error-name
|
(let-values ([(lhs-namess lhs-namess/ellipsess)
|
||||||
#t
|
(lhss-bound-names (syntax->list (syntax (lhs ...))) lang-nts syn-error-name)])
|
||||||
x))
|
(with-syntax ([(rhs/wheres ...)
|
||||||
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
(map (λ (sc/b rhs names names/ellipses)
|
||||||
[(clause-src ...)
|
(bind-withs
|
||||||
(map (λ (lhs)
|
syn-error-name '()
|
||||||
(format "~a:~a:~a"
|
#'effective-lang lang-nts
|
||||||
(syntax-source lhs)
|
sc/b 'flatten
|
||||||
(syntax-line lhs)
|
#`(list (term #,rhs))
|
||||||
(syntax-column lhs)))
|
names names/ellipses))
|
||||||
pats)]
|
(syntax->list #'((stuff ...) ...))
|
||||||
[dom-side-conditions-rewritten
|
(syntax->list #'(rhs ...))
|
||||||
(and dom-ctcs
|
lhs-namess lhs-namess/ellipsess)]
|
||||||
(rewrite-side-conditions/check-errs
|
[(rg-rhs/wheres ...)
|
||||||
lang-nts
|
(map (λ (sc/b rhs names names/ellipses)
|
||||||
syn-error-name
|
(bind-withs
|
||||||
#f
|
syn-error-name '()
|
||||||
dom-ctcs))]
|
#'effective-lang lang-nts
|
||||||
[(codom-side-conditions-rewritten ...)
|
sc/b 'predicate
|
||||||
(map (λ (codom-contract)
|
#`#t
|
||||||
(rewrite-side-conditions/check-errs
|
names names/ellipses))
|
||||||
lang-nts
|
(syntax->list #'((stuff ...) ...))
|
||||||
syn-error-name
|
(syntax->list #'(rhs ...))
|
||||||
#f
|
lhs-namess lhs-namess/ellipsess)])
|
||||||
codom-contract))
|
(with-syntax ([(side-conditions-rewritten ...)
|
||||||
codom-contracts)]
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
[(rhs-fns ...)
|
lang-nts
|
||||||
(map (λ (names names/ellipses rhs/where)
|
syn-error-name
|
||||||
(with-syntax ([(names ...) names]
|
#t
|
||||||
[(names/ellipses ...) names/ellipses]
|
x))
|
||||||
[rhs/where rhs/where])
|
(syntax->list (syntax (lhs ...))))]
|
||||||
(syntax
|
[(rg-side-conditions-rewritten ...)
|
||||||
(λ (name bindings)
|
(map (λ (x) (rewrite-side-conditions/check-errs
|
||||||
(term-let-fn ((name name))
|
lang-nts
|
||||||
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
syn-error-name
|
||||||
rhs/where))))))
|
#t
|
||||||
lhs-namess lhs-namess/ellipsess
|
x))
|
||||||
(syntax->list (syntax (rhs/wheres ...))))]
|
(syntax->list (syntax ((side-condition lhs rg-rhs/wheres) ...))))]
|
||||||
[(name2 name-predicate) (generate-temporaries (syntax (name name)))])
|
[(clause-src ...)
|
||||||
(with-syntax ([defs #`(begin
|
(map (λ (lhs)
|
||||||
(define-values (name2 name-predicate)
|
(format "~a:~a:~a"
|
||||||
(let ([sc `(side-conditions-rewritten ...)]
|
(syntax-source lhs)
|
||||||
[dsc `dom-side-conditions-rewritten])
|
(syntax-line lhs)
|
||||||
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
(syntax-column lhs)))
|
||||||
(make-metafunc-case
|
pats)]
|
||||||
(λ (effective-lang) (compile-pattern effective-lang pat #t))
|
[dom-side-conditions-rewritten
|
||||||
rhs-fn
|
(and dom-ctcs
|
||||||
rg-lhs src (gensym)))
|
(rewrite-side-conditions/check-errs
|
||||||
sc
|
lang-nts
|
||||||
(list (λ (effective-lang) rhs-fns) ...)
|
syn-error-name
|
||||||
(list (λ (effective-lang) `rg-side-conditions-rewritten) ...)
|
#f
|
||||||
`(clause-src ...))]
|
dom-ctcs))]
|
||||||
[parent-cases
|
[(codom-side-conditions-rewritten ...)
|
||||||
#,(if prev-metafunction
|
(map (λ (codom-contract)
|
||||||
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
(rewrite-side-conditions/check-errs
|
||||||
#'null)])
|
lang-nts
|
||||||
(build-metafunction
|
syn-error-name
|
||||||
lang
|
#f
|
||||||
cases
|
codom-contract))
|
||||||
parent-cases
|
codom-contracts)]
|
||||||
(λ (f/dom)
|
[(rhs-fns ...)
|
||||||
(make-metafunc-proc
|
(map (λ (names names/ellipses rhs/where)
|
||||||
(let ([name (lambda (x) (f/dom x))]) name)
|
(with-syntax ([(names ...) names]
|
||||||
(generate-lws #,relation?
|
[(names/ellipses ...) names/ellipses]
|
||||||
(lhs ...)
|
[rhs/where rhs/where])
|
||||||
(lhs-for-lw ...)
|
(syntax
|
||||||
((stuff ...) ...)
|
(λ (name bindings)
|
||||||
#,(if relation?
|
(term-let-fn ((name name))
|
||||||
#'((raw-rhses ...) ...)
|
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
|
||||||
#'(rhs ...)))
|
rhs/where))))))
|
||||||
lang
|
lhs-namess lhs-namess/ellipsess
|
||||||
#t ;; multi-args?
|
(syntax->list (syntax (rhs/wheres ...))))])
|
||||||
'name
|
(syntax-property
|
||||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
(prune-syntax
|
||||||
dsc
|
#`(let ([sc `(side-conditions-rewritten ...)]
|
||||||
(append cases parent-cases)
|
[dsc `dom-side-conditions-rewritten])
|
||||||
#,relation?))
|
(let ([cases (map (λ (pat rhs-fn rg-lhs src)
|
||||||
dsc
|
(make-metafunc-case
|
||||||
`(codom-side-conditions-rewritten ...)
|
(λ (effective-lang) (compile-pattern effective-lang pat #t))
|
||||||
'name
|
rhs-fn
|
||||||
#,relation?))))
|
rg-lhs src (gensym)))
|
||||||
(term-define-fn name name2))])
|
sc
|
||||||
(syntax-property
|
(list (λ (effective-lang) rhs-fns) ...)
|
||||||
(prune-syntax
|
(list (λ (effective-lang) `rg-side-conditions-rewritten) ...)
|
||||||
(if (eq? 'top-level (syntax-local-context))
|
`(clause-src ...))]
|
||||||
; Introduce the names before using them, to allow
|
[parent-cases
|
||||||
; metafunction definition at the top-level.
|
#,(if prev-metafunction
|
||||||
(syntax
|
#`(metafunc-proc-cases #,(term-fn-get-id (syntax-local-value prev-metafunction)))
|
||||||
(begin
|
#'null)])
|
||||||
(define-syntaxes (name2 name-predicate) (values))
|
(build-metafunction
|
||||||
defs))
|
lang
|
||||||
(syntax defs)))
|
cases
|
||||||
'disappeared-use
|
parent-cases
|
||||||
(map syntax-local-introduce
|
(λ (f/dom)
|
||||||
(syntax->list #'(original-names ...)))))))))))))]))
|
(make-metafunc-proc
|
||||||
|
(let ([name (lambda (x) (f/dom x))]) name)
|
||||||
|
(generate-lws #,relation?
|
||||||
|
(lhs ...)
|
||||||
|
(lhs-for-lw ...)
|
||||||
|
((stuff ...) ...)
|
||||||
|
#,(if relation?
|
||||||
|
#'((raw-rhses ...) ...)
|
||||||
|
#'(rhs ...)))
|
||||||
|
lang
|
||||||
|
#t ;; multi-args?
|
||||||
|
'name
|
||||||
|
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||||
|
dsc
|
||||||
|
(append cases parent-cases)
|
||||||
|
#,relation?))
|
||||||
|
dsc
|
||||||
|
`(codom-side-conditions-rewritten ...)
|
||||||
|
'name
|
||||||
|
#,relation?))))
|
||||||
|
'disappeared-use
|
||||||
|
(map syntax-local-introduce
|
||||||
|
(syntax->list #'(original-names ...))))))))))]))
|
||||||
|
|
||||||
(define-syntax (define-judgment-form stx)
|
(define-syntax (define-judgment-form stx)
|
||||||
(not-expression-context stx)
|
(not-expression-context stx)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user