Merged 4023:4047 from /branches/ryanc/md1
- Fixed macro hiding for letrec-syntaxes+values - Fixed module tracing (prevented required modules from being traced) - Better auto-scroll in gui - Fixed reductions bug in letrec-syntaxes+values - Added hide library syntax option svn: r4048 original commit: adb230f3c3f6bbd7915c5cebc8797158a209d523
This commit is contained in:
parent
06aad5203a
commit
3a22aab8af
|
@ -347,8 +347,6 @@
|
||||||
[(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
|
[(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
|
||||||
(make-p:letrec-values e1 e2 rs $3 $4 $6)])
|
(make-p:letrec-values e1 e2 rs $3 $4 $6)])
|
||||||
|
|
||||||
;; Might have to deal with let*-values
|
|
||||||
|
|
||||||
(PrimLetrecSyntaxes+Values
|
(PrimLetrecSyntaxes+Values
|
||||||
(#:args e1 e2 rs)
|
(#:args e1 e2 rs)
|
||||||
[(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes
|
[(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes
|
||||||
|
|
|
@ -5,17 +5,23 @@
|
||||||
(provide (all-defined))
|
(provide (all-defined))
|
||||||
|
|
||||||
(define-struct hiding-policy
|
(define-struct hiding-policy
|
||||||
(opaque-modules opaque-ids opaque-kernel transparent-ids))
|
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
|
||||||
|
|
||||||
(define (policy-hide-module p m)
|
(define (policy-hide-module p m)
|
||||||
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
|
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
|
||||||
(define (policy-unhide-module p m)
|
(define (policy-unhide-module p m)
|
||||||
(hash-table-remove! (hiding-policy-opaque-modules p) m))
|
(hash-table-remove! (hiding-policy-opaque-modules p) m))
|
||||||
|
|
||||||
(define (policy-hide-kernel p)
|
(define (policy-hide-kernel p)
|
||||||
(set-hiding-policy-opaque-kernel! p #t))
|
(set-hiding-policy-opaque-kernel! p #t))
|
||||||
(define (policy-unhide-kernel p)
|
(define (policy-unhide-kernel p)
|
||||||
(set-hiding-policy-opaque-kernel! p #f))
|
(set-hiding-policy-opaque-kernel! p #f))
|
||||||
|
|
||||||
|
(define (policy-hide-libs p)
|
||||||
|
(set-hiding-policy-opaque-libs! p #t))
|
||||||
|
(define (policy-unhide-libs p)
|
||||||
|
(set-hiding-policy-opaque-libs! p #f))
|
||||||
|
|
||||||
(define (policy-hide-id p id)
|
(define (policy-hide-id p id)
|
||||||
(policy-unshow-id p id)
|
(policy-unshow-id p id)
|
||||||
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
|
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
|
||||||
|
@ -32,11 +38,13 @@
|
||||||
(make-hiding-policy (make-hash-table)
|
(make-hiding-policy (make-hash-table)
|
||||||
(make-module-identifier-mapping)
|
(make-module-identifier-mapping)
|
||||||
#f
|
#f
|
||||||
|
#f
|
||||||
(make-module-identifier-mapping)))
|
(make-module-identifier-mapping)))
|
||||||
|
|
||||||
(define (new-standard-hiding-policy)
|
(define (new-standard-hiding-policy)
|
||||||
(let ([p (new-hiding-policy)])
|
(let ([p (new-hiding-policy)])
|
||||||
(policy-hide-kernel p)
|
(policy-hide-kernel p)
|
||||||
|
(policy-hide-libs p)
|
||||||
p))
|
p))
|
||||||
|
|
||||||
;; ---
|
;; ---
|
||||||
|
@ -57,6 +65,7 @@
|
||||||
[(struct hiding-policy (opaque-modules
|
[(struct hiding-policy (opaque-modules
|
||||||
opaque-identifiers
|
opaque-identifiers
|
||||||
opaque-kernel
|
opaque-kernel
|
||||||
|
opaque-libs
|
||||||
transparent-identifiers))
|
transparent-identifiers))
|
||||||
(let ([binding (identifier-binding id)])
|
(let ([binding (identifier-binding id)])
|
||||||
(if (list? binding)
|
(if (list? binding)
|
||||||
|
@ -67,6 +76,8 @@
|
||||||
[in-kernel?
|
[in-kernel?
|
||||||
(and (symbol? srcmod)
|
(and (symbol? srcmod)
|
||||||
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
|
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
|
||||||
|
[in-lib-module?
|
||||||
|
(lib-module? srcmod)]
|
||||||
[not-opaque-id
|
[not-opaque-id
|
||||||
(not (module-identifier-mapping-get opaque-identifiers id /false))]
|
(not (module-identifier-mapping-get opaque-identifiers id /false))]
|
||||||
[transparent-id
|
[transparent-id
|
||||||
|
@ -75,7 +86,14 @@
|
||||||
(and (not opaque-srcmod)
|
(and (not opaque-srcmod)
|
||||||
(not opaque-nommod)
|
(not opaque-nommod)
|
||||||
(not (and in-kernel? opaque-kernel))
|
(not (and in-kernel? opaque-kernel))
|
||||||
|
(not (and in-lib-module? opaque-libs))
|
||||||
not-opaque-id))))
|
not-opaque-id))))
|
||||||
#f))]))
|
#f))]))
|
||||||
|
|
||||||
|
(define (lib-module? mpi)
|
||||||
|
(and (module-path-index? mpi)
|
||||||
|
(let-values ([(path rel) (module-path-index-split mpi)])
|
||||||
|
(cond [(pair? path) (memq (car path) '(lib planet))]
|
||||||
|
[(string? path) (lib-module? rel)]
|
||||||
|
[else #f]))))
|
||||||
)
|
)
|
|
@ -207,11 +207,13 @@
|
||||||
(syntax->list #'(?svars* ...))
|
(syntax->list #'(?svars* ...))
|
||||||
"Rename bound variables"]
|
"Rename bound variables"]
|
||||||
[Expr (?srhs ...) srhss]
|
[Expr (?srhs ...) srhss]
|
||||||
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
|
;; If vrenames is #f, no var bindings to rename
|
||||||
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
|
[#:if vrenames
|
||||||
(syntax->list #'(?vvars* ...))
|
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
|
||||||
(syntax->list #'(?vvars** ...))
|
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
|
||||||
"Rename bound variables"]
|
(syntax->list #'(?vvars* ...))
|
||||||
|
(syntax->list #'(?vvars** ...))
|
||||||
|
"Rename bound variables"]]
|
||||||
[Expr (?vrhs ...) vrhss]
|
[Expr (?vrhs ...) vrhss]
|
||||||
[Block ?body body]
|
[Block ?body body]
|
||||||
=> (lambda (mid)
|
=> (lambda (mid)
|
||||||
|
|
|
@ -13,6 +13,7 @@
|
||||||
trace
|
trace
|
||||||
trace/result
|
trace/result
|
||||||
trace+reductions
|
trace+reductions
|
||||||
|
current-expand-observe
|
||||||
(all-from "reductions.ss"))
|
(all-from "reductions.ss"))
|
||||||
|
|
||||||
(define current-expand-observe
|
(define current-expand-observe
|
||||||
|
|
Loading…
Reference in New Issue
Block a user