improved redex's expansion to work better with check syntax (and noted a few other recent changes in the HISTORY.txt file)
svn: r13944
This commit is contained in:
Robby Findler
parent
dfe1e8740d
commit
e8a47051f7
|
|
@ -975,7 +975,7 @@
|
|||
(raise-syntax-error syn-error-name "no clauses" orig-stx))
|
||||
(let-values ([(contract-name dom-ctcs codom-contract pats)
|
||||
(split-out-contract orig-stx syn-error-name #'rest)])
|
||||
(with-syntax ([(((name lhs-clauses ...) rhs stuff ...) ...) pats]
|
||||
(with-syntax ([(((original-names lhs-clauses ...) rhs stuff ...) ...) pats]
|
||||
[(lhs-for-lw ...)
|
||||
(with-syntax ([((lhs-for-lw _ _ ...) ...) pats])
|
||||
(map (λ (x) (datum->syntax #f (cdr (syntax-e x)) x))
|
||||
|
|
@ -983,10 +983,10 @@
|
|||
(with-syntax ([(lhs ...) #'((lhs-clauses ...) ...)]
|
||||
[name (let loop ([name (if contract-name
|
||||
contract-name
|
||||
(car (syntax->list #'(name ...))))]
|
||||
(car (syntax->list #'(original-names ...))))]
|
||||
[names (if contract-name
|
||||
(syntax->list #'(name ...))
|
||||
(cdr (syntax->list #'(name ...))))])
|
||||
(syntax->list #'(original-names ...))
|
||||
(cdr (syntax->list #'(original-names ...))))])
|
||||
(cond
|
||||
[(null? names) name]
|
||||
[else
|
||||
|
|
@ -1063,50 +1063,53 @@
|
|||
[(((where-id where-pat) ...) ...)
|
||||
;; Also for pict, extract where bindings
|
||||
#'(tl-bindings ...)])
|
||||
#`(begin
|
||||
(define-values (name2 name-predicate)
|
||||
(let ([sc `(side-conditions-rewritten ...)]
|
||||
[dsc `dom-side-conditions-rewritten])
|
||||
(build-metafunction
|
||||
lang
|
||||
sc
|
||||
(list rhs-fns ...)
|
||||
#,(if prev-metafunction
|
||||
(let ([term-fn (syntax-local-value prev-metafunction)])
|
||||
#`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
|
||||
#''())
|
||||
#,(if prev-metafunction
|
||||
(let ([term-fn (syntax-local-value prev-metafunction)])
|
||||
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
|
||||
#''())
|
||||
(λ (f/dom cps rhss)
|
||||
(make-metafunc-proc
|
||||
(let ([name (lambda (x) (f/dom x))]) name)
|
||||
(list (list (to-lw lhs-for-lw)
|
||||
(list (to-lw/uq side-cond) ...)
|
||||
(list (cons (to-lw bind-id)
|
||||
(to-lw bind-pat))
|
||||
...
|
||||
(cons (to-lw rhs-bind-id)
|
||||
(to-lw/uq rhs-bind-pat))
|
||||
...
|
||||
(cons (to-lw where-id)
|
||||
(to-lw where-pat))
|
||||
...)
|
||||
(to-lw rhs))
|
||||
...)
|
||||
lang
|
||||
#t ;; multi-args?
|
||||
'name
|
||||
cps
|
||||
rhss
|
||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||
dsc
|
||||
sc))
|
||||
dsc
|
||||
'codom-side-conditions-rewritten
|
||||
'name)))
|
||||
(term-define-fn name name2)))))))))]
|
||||
(syntax-property
|
||||
#`(begin
|
||||
(define-values (name2 name-predicate)
|
||||
(let ([sc `(side-conditions-rewritten ...)]
|
||||
[dsc `dom-side-conditions-rewritten])
|
||||
(build-metafunction
|
||||
lang
|
||||
sc
|
||||
(list rhs-fns ...)
|
||||
#,(if prev-metafunction
|
||||
(let ([term-fn (syntax-local-value prev-metafunction)])
|
||||
#`(metafunc-proc-cps #,(term-fn-get-id term-fn)))
|
||||
#''())
|
||||
#,(if prev-metafunction
|
||||
(let ([term-fn (syntax-local-value prev-metafunction)])
|
||||
#`(metafunc-proc-rhss #,(term-fn-get-id term-fn)))
|
||||
#''())
|
||||
(λ (f/dom cps rhss)
|
||||
(make-metafunc-proc
|
||||
(let ([name (lambda (x) (f/dom x))]) name)
|
||||
(list (list (to-lw lhs-for-lw)
|
||||
(list (to-lw/uq side-cond) ...)
|
||||
(list (cons (to-lw bind-id)
|
||||
(to-lw bind-pat))
|
||||
...
|
||||
(cons (to-lw rhs-bind-id)
|
||||
(to-lw/uq rhs-bind-pat))
|
||||
...
|
||||
(cons (to-lw where-id)
|
||||
(to-lw where-pat))
|
||||
...)
|
||||
(to-lw rhs))
|
||||
...)
|
||||
lang
|
||||
#t ;; multi-args?
|
||||
'name
|
||||
cps
|
||||
rhss
|
||||
(let ([name (lambda (x) (name-predicate x))]) name)
|
||||
dsc
|
||||
sc))
|
||||
dsc
|
||||
'codom-side-conditions-rewritten
|
||||
'name)))
|
||||
(term-define-fn name name2))
|
||||
'disappeared-use
|
||||
(map syntax-local-introduce (syntax->list #'(original-names ...)))))))))))]
|
||||
[(_ prev-metafunction name lang clauses ...)
|
||||
(begin
|
||||
(unless (identifier? #'name)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base "term-fn.ss")
|
||||
(require (for-syntax scheme/base
|
||||
"term-fn.ss"
|
||||
stxclass/util/misc)
|
||||
"matcher.ss")
|
||||
|
||||
(provide term term-let term-let/error-name term-let-fn term-define-fn)
|
||||
|
|
@ -37,7 +39,7 @@
|
|||
(and (identifier? (syntax metafunc-name))
|
||||
(term-fn? (syntax-local-value (syntax metafunc-name) (λ () #f))))
|
||||
(let-values ([(rewritten has-term-let-bound-id?) (loop (syntax (arg ...)) depth)])
|
||||
(let ([term-fn (syntax-local-value (syntax metafunc-name) (λ () #f))])
|
||||
(let ([term-fn (syntax-local-value/catch (syntax metafunc-name) (λ (x) #t))])
|
||||
(with-syntax ([f (term-fn-get-id term-fn)])
|
||||
(cond
|
||||
[has-term-let-bound-id?
|
||||
|
|
@ -76,7 +78,7 @@
|
|||
[x
|
||||
(and (identifier? (syntax x))
|
||||
(term-id? (syntax-local-value (syntax x) (λ () #f))))
|
||||
(values (term-id-id (syntax-local-value (syntax x) (λ () #f))) #t)]
|
||||
(values (term-id-id (syntax-local-value/catch (syntax x) (λ (x) #t))) #t)]
|
||||
[(unquote x)
|
||||
(values (syntax (unsyntax x)) #f)]
|
||||
[(unquote . x)
|
||||
|
|
@ -122,14 +124,15 @@
|
|||
|
||||
(syntax-case orig-stx ()
|
||||
[(_ arg)
|
||||
(with-syntax ([rewritten (rewrite (syntax arg))])
|
||||
(let loop ([bs (reverse outer-bindings)])
|
||||
(cond
|
||||
[(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))]
|
||||
[else (with-syntax ([rec (loop (cdr bs))]
|
||||
[fst (car bs)])
|
||||
(syntax (with-syntax (fst)
|
||||
rec)))])))]))
|
||||
(with-disappeared-uses
|
||||
(with-syntax ([rewritten (rewrite (syntax arg))])
|
||||
(let loop ([bs (reverse outer-bindings)])
|
||||
(cond
|
||||
[(null? bs) (syntax (syntax->datum (quasisyntax rewritten)))]
|
||||
[else (with-syntax ([rec (loop (cdr bs))]
|
||||
[fst (car bs)])
|
||||
(syntax (with-syntax (fst)
|
||||
rec)))]))))]))
|
||||
|
||||
(define-syntax (term-let-fn stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -196,6 +199,8 @@
|
|||
|
||||
(define-syntax (term-let stx)
|
||||
(syntax-case stx ()
|
||||
[(_ () body1)
|
||||
#'body1]
|
||||
[(_ ([x rhs] ...) body1 body2 ...)
|
||||
(syntax
|
||||
(term-let/error-name term-let ((x rhs) ...) body1 body2 ...))]
|
||||
|
|
|
|||
|
|
@ -1,10 +1,21 @@
|
|||
v4.1.5
|
||||
|
||||
- initial-char-width now accepts functions to give finer grained
|
||||
* define-metafunction and reduction-relation now work better with
|
||||
Check Syntax, as
|
||||
|
||||
* added the #:arrow keyword to reduction-relation, which lets you use
|
||||
a different main arrow (mostly useful for the typesetting)
|
||||
|
||||
* added domain specifications to reduction relations via
|
||||
the #:domain keyword
|
||||
|
||||
* 'traces' copes better with errors during reduction
|
||||
|
||||
* initial-char-width now accepts functions to give finer grained
|
||||
control of the initial widths of the terms.
|
||||
|
||||
- traces & traces/ps: added the ability to specify a mixin
|
||||
to be mixed into the graph pasteboard
|
||||
* traces & traces/ps: added the ability to specify a mixin
|
||||
to be mixed into the graph pasteboard
|
||||
|
||||
v4.1.4
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user