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:
Ryan Culpepper 2006-08-13 03:28:43 +00:00
parent 06aad5203a
commit 3a22aab8af
4 changed files with 28 additions and 9 deletions

View File

@ -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

View File

@ -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]))))
) )

View File

@ -207,11 +207,13 @@
(syntax->list #'(?svars* ...)) (syntax->list #'(?svars* ...))
"Rename bound variables"] "Rename bound variables"]
[Expr (?srhs ...) srhss] [Expr (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename
[#:if vrenames
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**)) [#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
(syntax->list #'(?vvars* ...)) (syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...)) (syntax->list #'(?vvars** ...))
"Rename bound variables"] "Rename bound variables"]]
[Expr (?vrhs ...) vrhss] [Expr (?vrhs ...) vrhss]
[Block ?body body] [Block ?body body]
=> (lambda (mid) => (lambda (mid)

View File

@ -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