Macro stepper:
fixed bugs re: internal define-syntax de-unitized hiding again, disabled extra navigation for now fixed bug in letrec-syntaxes w/o var bindings fixed bugs in block splicing distinguished booleans and keywords in syntax browser svn: r5578
This commit is contained in:
Ryan Culpepper
parent
ad634b20c5
commit
ca3c367aab
|
|
@ -484,7 +484,7 @@
|
|||
(make-b:defvals $3 $4)]
|
||||
[(next NoError renames-block CheckImmediateMacro
|
||||
prim-define-syntaxes (? BindSyntaxes 'bind))
|
||||
(make-b:defstx $3 $4 $5)])
|
||||
(make-b:defstx $3 $4 $6)])
|
||||
|
||||
;; BindSyntaxes Answer = Derivation
|
||||
(BindSyntaxes
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
(module hide mzscheme
|
||||
(require (lib "plt-match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
"deriv.ss"
|
||||
"deriv-util.ss"
|
||||
|
|
@ -10,16 +9,11 @@
|
|||
"context.ss")
|
||||
|
||||
(provide hide/policy
|
||||
seek/syntax
|
||||
macro-policy
|
||||
current-hiding-warning-handler
|
||||
(struct nonlinearity (message paths))
|
||||
(struct localactions ()))
|
||||
|
||||
(define-signature hide^ (hide))
|
||||
(define-signature seek^ (seek/deriv seek subterm-derivations))
|
||||
(define-signature seek-syntax^ (seek/syntax))
|
||||
|
||||
;; hide/policy : Derivation (identifier -> boolean) -> (values Derivation syntax)
|
||||
(define (hide/policy deriv show-macro?)
|
||||
(parameterize ((macro-policy show-macro?))
|
||||
|
|
@ -91,11 +85,6 @@
|
|||
; -$ @- ++ -@- $@- @+ -
|
||||
; -$ @- ++ +@@+@- -@@@@-
|
||||
|
||||
(define hide@
|
||||
(unit
|
||||
(import seek^)
|
||||
(export hide^)
|
||||
|
||||
;; Macro hiding:
|
||||
;; The derivation is "visible" or "active" by default,
|
||||
;; but pieces of it may need to be hidden.
|
||||
|
|
@ -453,7 +442,7 @@
|
|||
[#f (values #f #f)]))
|
||||
|
||||
(for-deriv deriv))
|
||||
))
|
||||
|
||||
|
||||
; -@@@$ -$
|
||||
; @* - -$
|
||||
|
|
@ -466,10 +455,7 @@
|
|||
; +- +@ @+ - @+ - -$ +@
|
||||
; -@@@@- -@@@@- -@@@@- -$ $+
|
||||
|
||||
(define seek@
|
||||
(unit
|
||||
(import hide^)
|
||||
(export seek^)
|
||||
|
||||
|
||||
;; Seek:
|
||||
;; The derivation is "inactive" or "hidden" by default,
|
||||
|
|
@ -711,26 +697,9 @@
|
|||
|
||||
(for-deriv d))
|
||||
|
||||
))
|
||||
|
||||
(define-values/invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(export HIDE SEEK)
|
||||
(link [((HIDE : hide^)) hide@ SEEK]
|
||||
[((SEEK : seek^)) seek@ HIDE]))
|
||||
(import)
|
||||
(export hide^ seek^))
|
||||
|
||||
|
||||
(define trivial-hide@
|
||||
(unit
|
||||
(import)
|
||||
(export hide^)
|
||||
|
||||
(define (hide d)
|
||||
(values d (lift/deriv-e2 d)))))
|
||||
|
||||
#;
|
||||
(define seek-syntax@
|
||||
(unit
|
||||
(import seek^)
|
||||
|
|
@ -745,15 +714,6 @@
|
|||
(let ([subderivs (subterm-derivations deriv)])
|
||||
(map s:subterm-deriv (filter s:subterm? subderivs))))))))
|
||||
|
||||
(define-values/invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(export SEEK-SYNTAX)
|
||||
(link [((HIDE : hide^)) trivial-hide@]
|
||||
[((SEEK : seek^)) seek@ HIDE]
|
||||
[((SEEK-SYNTAX : seek-syntax^)) seek-syntax@ SEEK]))
|
||||
(import)
|
||||
(export seek-syntax^))
|
||||
|
||||
|
||||
; +###+
|
||||
|
|
@ -911,13 +871,14 @@
|
|||
(match deriv
|
||||
[(IntQ p:letrec-syntaxes+values (_ _ _ srenames srhss vrenames vrhss body))
|
||||
;; Assertion: pass1 of the body is always trivial
|
||||
(with-syntax ([(([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body) srenames]
|
||||
[(([?vvars* ?vrhs*] ...) . ?body*) vrenames])
|
||||
(values (map cons
|
||||
(syntax->list #'(?svars ...))
|
||||
srhss)
|
||||
(map cons (syntax->list #'(?vvars* ...)) vrhss)
|
||||
(lderiv-derivs (bderiv-pass2 body))))]
|
||||
(with-syntax ([(([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body) srenames])
|
||||
(with-syntax ([(([?vvars* ?vrhs*] ...) . ?body*)
|
||||
(or vrenames #'(([?vvars ?vrhs] ...) . ?body))])
|
||||
(values (map cons
|
||||
(syntax->list #'(?svars ...))
|
||||
srhss)
|
||||
(map cons (syntax->list #'(?vvars* ...)) vrhss)
|
||||
(lderiv-derivs (bderiv-pass2 body)))))]
|
||||
[(IntQ p:letrec-values (_ _ _ vrenames vrhss body))
|
||||
;; Assertion: pass1 of the body is always trivial
|
||||
(with-syntax ([(([?vars ?rhs] ...) . ?body) vrenames])
|
||||
|
|
@ -981,6 +942,13 @@
|
|||
;; reconstruct-defval : syntax syntax Derivation -> Derivation
|
||||
;; Reconstruct a define-values node from its rhs deriv
|
||||
(define (reconstruct-defval head-e2 dvvars dvrhs)
|
||||
(reconstruct-definition-form head-e2 dvvars dvrhs make-p:define-values))
|
||||
|
||||
;; reconstruct-defstx : syntax syntax Derivation -> Derivation
|
||||
(define (reconstruct-defstx head-e2 dsvars dsrhs)
|
||||
(reconstruct-definition-form head-e2 dsvars dsrhs make-p:define-syntaxes))
|
||||
|
||||
(define (reconstruct-definition-form head-e2 dvvars dvrhs make-Definition)
|
||||
(match dvrhs
|
||||
[(AnyQ deriv (rhs-e1 rhs-e2))
|
||||
(with-syntax ([(?dv ?vars ?rhs) head-e2]
|
||||
|
|
@ -1002,7 +970,7 @@
|
|||
null
|
||||
(cons (cons #'?vars #'?rhs)
|
||||
(cons #'?vars* #'?rhs*))
|
||||
(outer-rewrap dvrhs (make-p:define-values dv1* dv2 null dvrhs))))))]))
|
||||
(outer-rewrap dvrhs (make-Definition dv1* dv2 null dvrhs))))))]))
|
||||
|
||||
;; bderiv->lderiv : BlockDerivation -> ListDerivation
|
||||
;; Combines pass1 and pass2 into a single pass(2) list derivation
|
||||
|
|
@ -1071,14 +1039,19 @@
|
|||
#f))))
|
||||
null #;(loop (sub1 count))))]
|
||||
[(cons (IntQ b:defstx (renames head rhs)) next)
|
||||
(let ([stx (car suffix)])
|
||||
(let ([stx (stx-car suffix)])
|
||||
(set! _dss (cdr _dss))
|
||||
(set! suffix (stx-cdr suffix))
|
||||
(set! brules next)
|
||||
(cons (make-b:defstx renames head rhs)
|
||||
(loop (sub1 count))))]
|
||||
(let* ([svars
|
||||
(with-syntax ([(?ds ?svars . ?body) (cdr renames)])
|
||||
#'?svars)]
|
||||
[finish (reconstruct-defstx (deriv-e2 head) svars rhs)])
|
||||
(cons (make-b:expr renames (combine-derivs head finish))
|
||||
(loop (sub1 count)))))]
|
||||
[(cons (struct b:splice (renames head tail)) next)
|
||||
(let ([n (- (length tail) (length (stx->list (stx-cdr suffix))))])
|
||||
(let ([n (- (length (stx->list tail))
|
||||
(length (stx->list (stx-cdr suffix))))])
|
||||
(set! suffix tail)
|
||||
(set! brules next)
|
||||
(let* ([splice-derivs (loop n)]
|
||||
|
|
|
|||
|
|
@ -375,11 +375,13 @@
|
|||
(cons head-rs rss)))]
|
||||
[(AnyQ b:defstx (renames head rhs))
|
||||
(let* ([estx (deriv-e2 head)]
|
||||
[estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
|
||||
[?rhs* (deriv-e2 rhs)])
|
||||
;;FIXME
|
||||
(datum->syntax-object estx `(,#'?ds ,#'?vars ,#'?rhs*) estx estx))])
|
||||
(loop next (cdr suffix) (cons estx2 prefix)
|
||||
[estx2 (and (deriv? rhs)
|
||||
(with-syntax ([(?ds ?vars ?rhs) estx]
|
||||
[?rhs* (deriv-e2 rhs)])
|
||||
(datum->syntax-object estx
|
||||
`(,#'?ds ,#'?vars ,#'?rhs*)
|
||||
estx estx)))])
|
||||
(loop next (stx-cdr suffix) (cons estx2 prefix)
|
||||
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
|
||||
(cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
|
||||
(reductions rhs))
|
||||
|
|
@ -433,7 +435,10 @@
|
|||
(append (with-context the-context
|
||||
(append (reductions head)
|
||||
(reductions prim)))
|
||||
(let ([estx (and (deriv? head) (deriv-e2 head))])
|
||||
(let ([estx
|
||||
(if prim
|
||||
(lift/deriv-e2 prim)
|
||||
(and (deriv? head) (deriv-e2 head)))])
|
||||
(loop next (stx-cdr suffix) (cons estx prefix))))]
|
||||
[(ErrW mod:splice (head stxs) exn)
|
||||
(append (with-context the-context (reductions head))
|
||||
|
|
|
|||
|
|
@ -77,16 +77,20 @@
|
|||
lp-datum)]
|
||||
[(pair? obj)
|
||||
(pairloop obj)]
|
||||
[(vector? obj)
|
||||
(list->vector (map loop (vector->list obj)))]
|
||||
[(symbol? obj)
|
||||
(unintern obj)]
|
||||
[(number? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(box? obj)
|
||||
(box (loop (unbox obj)))]
|
||||
[(null? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(boolean? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(number? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(keyword? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(vector? obj)
|
||||
(list->vector (map loop (vector->list obj)))]
|
||||
[(box? obj)
|
||||
(box (loop (unbox obj)))]
|
||||
[else obj]))
|
||||
(define (pairloop obj)
|
||||
(cond [(pair? obj)
|
||||
|
|
|
|||
|
|
@ -27,6 +27,8 @@
|
|||
|
||||
catch-errors?)
|
||||
|
||||
(define (seek/syntax d s) (error 'unsupported "Extra navigation stuff currently unsupported"))
|
||||
|
||||
;; Debugging parameters / Not user configurable
|
||||
|
||||
(define catch-errors? (make-parameter #t))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user