From 44c5a757390775f2142a9f1dc2874ee41f285dcd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 29 Jun 2008 15:11:20 +0000 Subject: [PATCH] fix some phase problems in program-processing programs svn: r10503 --- collects/drscheme/private/debug.ss | 3 +- collects/errortrace/errortrace-lib.ss | 87 +++---- collects/errortrace/stacktrace.ss | 104 ++++---- collects/gui-debugger/annotator.ss | 17 +- collects/lang/htdp-langs.ss | 3 +- collects/mzlib/pretty.ss | 224 +++++++++++------- collects/mzlib/private/sandbox-coverage.ss | 2 +- .../scribblings/reference/namespaces.scrbl | 25 +- collects/syntax/kerncase.ss | 43 +++- collects/tests/mzscheme/pretty.ss | 73 ++++-- src/mzscheme/src/cstartup.inc | 36 +-- src/mzscheme/src/env.c | 39 ++- src/mzscheme/src/eval.c | 3 +- src/mzscheme/src/module.c | 22 +- src/mzscheme/src/portfun.c | 4 +- src/mzscheme/src/schminc.h | 2 +- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/syntax.c | 5 +- 19 files changed, 440 insertions(+), 258 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 35bdaec4b4..33c4a8da54 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -245,7 +245,8 @@ profile todo: list))]))] [_else ;; Not `begin', so proceed with normal expand and eval - (let* ([annotated (annotate-top (expand-syntax top-e) #f)]) + (let* ([annotated (annotate-top (expand-syntax top-e) + (namespace-base-phase))]) (oe annotated))])))))]) debug-tool-eval-handler)) diff --git a/collects/errortrace/errortrace-lib.ss b/collects/errortrace/errortrace-lib.ss index f30ada2796..5e545521d4 100644 --- a/collects/errortrace/errortrace-lib.ss +++ b/collects/errortrace/errortrace-lib.ss @@ -2,28 +2,29 @@ ;; Poor man's stack-trace-on-exceptions/profiler. ;; See manual for information. -(module errortrace-lib mzscheme +(module errortrace-lib scheme/base (require "stacktrace.ss" "errortrace-key.ss" mzlib/list mzlib/unit - mzlib/runtime-path) + mzlib/runtime-path + (for-syntax scheme/base)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test coverage run-time support (define test-coverage-enabled (make-parameter #f)) - (define test-coverage-info (make-hash-table)) + (define test-coverage-info (make-hasheq)) (define (initialize-test-coverage-point key expr) - (hash-table-put! test-coverage-info key (mcons expr 0))) + (hash-set! test-coverage-info key (mcons expr 0))) (define (test-covered key) - (let ([v (hash-table-get test-coverage-info key)]) + (let ([v (hash-ref test-coverage-info key)]) (set-mcdr! v (add1 (mcdr v))))) (define (get-coverage-counts) - (hash-table-map test-coverage-info (lambda (k v) (cons (mcar v) (mcdr v))))) + (hash-map test-coverage-info (lambda (k v) (cons (mcar v) (mcdr v))))) (define (annotate-covered-file name . more) (apply annotate-file name (get-coverage-counts) @@ -39,10 +40,10 @@ (define profiling-record-enabled (make-parameter #t)) (define profile-paths-enabled (make-parameter #f)) - (define profile-info (make-hash-table)) + (define profile-info (make-hasheq)) (define (clear-profile-results) - (hash-table-for-each profile-info + (hash-for-each profile-info (lambda (k v) (set-box! (vector-ref v 0) #f) (vector-set! v 1 0) @@ -50,12 +51,12 @@ (vector-set! v 4 null)))) (define (initialize-profile-point key name expr) - (hash-table-put! profile-info key - (vector (box #f) 0 0 (and name (syntax-e name)) expr null))) + (hash-set! profile-info key + (vector (box #f) 0 0 (and name (syntax-e name)) expr null))) (define (register-profile-start key) (and (profiling-record-enabled) - (let ([v (hash-table-get profile-info key)]) + (let ([v (hash-ref profile-info key)]) (let ([b (vector-ref v 0)]) (vector-set! v 1 (add1 (vector-ref v 1))) (when (profile-paths-enabled) @@ -63,10 +64,10 @@ (continuation-mark-set->list (current-continuation-marks) profile-key)]) - (unless (hash-table? (vector-ref v 5)) - (vector-set! v 5 (make-hash-table 'equal))) - (hash-table-put! (vector-ref v 5) cms - (add1 (hash-table-get (vector-ref v 5) cms (lambda () 0)))))) + (unless (hash? (vector-ref v 5)) + (vector-set! v 5 (make-hash))) + (hash-set! (vector-ref v 5) cms + (add1 (hash-ref (vector-ref v 5) cms (lambda () 0)))))) (if (unbox b) #f (begin @@ -75,7 +76,7 @@ (define (register-profile-done key start) (when start - (let ([v (hash-table-get profile-info key)]) + (let ([v (hash-ref profile-info key)]) (let ([b (vector-ref v 0)]) (set-box! b #f) (vector-set! v 2 @@ -83,7 +84,7 @@ (vector-ref v 2))))))) (define (get-profile-results) - (hash-table-map profile-info + (hash-map profile-info (lambda (key val) (let ([count (vector-ref val 1)] [time (vector-ref val 2)] @@ -91,14 +92,14 @@ [expr (vector-ref val 4)] [cmss (vector-ref val 5)]) (list count time name expr - (if (hash-table? cmss) - (hash-table-map cmss (lambda (ks v) - (cons v - (map (lambda (k) - (let ([v (cdr (hash-table-get profile-info k))]) - (list (vector-ref v 2) - (vector-ref v 3)))) - ks)))) + (if (hash? cmss) + (hash-map cmss (lambda (ks v) + (cons v + (map (lambda (k) + (let ([v (cdr (hash-ref profile-info k))]) + (list (vector-ref v 2) + (vector-ref v 3)))) + ks)))) null)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -128,19 +129,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Execute counts - (define execute-info (make-hash-table)) + (define execute-info (make-hasheq)) (define execute-counts-enabled (make-parameter #f)) (define (register-executed-once key) - (let ([i (hash-table-get execute-info key)]) + (let ([i (hash-ref execute-info key)]) (set-mcdr! i (add1 (mcdr i))))) (define (execute-point mark expr) (if (execute-counts-enabled) (let ([key (gensym)]) - (hash-table-put! execute-info key (mcons mark 0)) - (with-syntax ([key (datum->syntax-object #f key (quote-syntax here))] + (hash-set! execute-info key (mcons mark 0)) + (with-syntax ([key (datum->syntax #f key (quote-syntax here))] [expr expr] [register-executed-once register-executed-once]);<- 3D! (syntax @@ -150,8 +151,8 @@ expr)) (define (get-execute-counts) - (hash-table-map execute-info (lambda (k v) (cons (mcar v) - (mcdr v))))) + (hash-map execute-info (lambda (k v) (cons (mcar v) + (mcdr v))))) (define (annotate-executed-file name . more) (apply annotate-file name (get-execute-counts) @@ -266,7 +267,7 @@ [line (format ":~a:~a" line col)] [pos (format "::~a" pos)] [else ""]) - (syntax-object->datum stx)) + (syntax->datum stx)) (loop (- n 1) (cdr l)))]))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -310,14 +311,17 @@ (lambda (top-e) (define (normal e) (let ([ex (expand-syntax e)]) - (annotate-top ex #f))) - (syntax-case top-e (begin module) - [(module name . reste) + (annotate-top ex (namespace-base-phase)))) + (syntax-case top-e () + [(mod name . reste) + (and (identifier? #'mod) + (free-identifier=? #'mod (namespace-module-identifier) + (namespace-base-phase))) (if (eq? (syntax-e #'name) 'errortrace-key) top-e (let ([top-e (expand-syntax top-e)]) - (syntax-case top-e (module #%plain-module-begin) - [(module name init-import (#%plain-module-begin body ...)) + (syntax-case top-e (#%plain-module-begin) + [(mod name init-import (#%plain-module-begin body ...)) (normal #`(module name init-import #,(syntax-recertify @@ -336,11 +340,12 @@ (define errortrace-compile-handler (let ([orig (current-compile)] - [ns (current-namespace)]) + [reg (namespace-module-registry (current-namespace))]) (lambda (e immediate-eval?) (orig (if (and (instrumenting-enabled) - (eq? ns (current-namespace)) + (eq? reg + (namespace-module-registry (current-namespace))) (not (compiled-expression? (if (syntax? e) (syntax-e e) e)))) @@ -348,7 +353,7 @@ (if (syntax? e) e (namespace-syntax-introduce - (datum->syntax-object #f e))))]) + (datum->syntax #f e))))]) e2) e) immediate-eval?)))) @@ -385,7 +390,7 @@ annotate-executed-file ;; use names that are consistent with the above - (rename test-coverage-enabled coverage-counts-enabled) + (rename-out [test-coverage-enabled coverage-counts-enabled]) get-coverage-counts annotate-covered-file diff --git a/collects/errortrace/stacktrace.ss b/collects/errortrace/stacktrace.ss index 747d59b24e..646b067f9e 100644 --- a/collects/errortrace/stacktrace.ss +++ b/collects/errortrace/stacktrace.ss @@ -108,7 +108,7 @@ ;; argument is the source expression, and the fourth argument is #t for ;; a transformer expression and #f for a normal expression. - (define (profile-point bodies name expr trans?) + (define (profile-point bodies name expr phase) (let ([key (gensym 'profile-point)]) (initialize-profile-point key name expr) (with-syntax ([key (datum->syntax #f key (quote-syntax here))] @@ -122,29 +122,29 @@ (insert-at-tail* (syntax (#%plain-app register-profile-done 'key start)) bodies - trans?)]) + phase)]) (syntax (let ([start (#%plain-app register-profile-start 'key)]) (with-continuation-mark 'profile-key 'key (begin . rest)))))))) - (define (insert-at-tail* e exprs trans?) + (define (insert-at-tail* e exprs phase) (let ([new (rebuild exprs (let loop ([exprs exprs]) (if (stx-null? (stx-cdr exprs)) (list (cons (stx-car exprs) (insert-at-tail - e (stx-car exprs) trans?))) + e (stx-car exprs) phase))) (loop (stx-cdr exprs)))))]) (if (syntax? exprs) (certify exprs new) new))) - (define (insert-at-tail se sexpr trans?) + (define (insert-at-tail se sexpr phase) (with-syntax ([expr sexpr] [e se]) - (kernel-syntax-case sexpr trans? + (kernel-syntax-case/phase sexpr phase ;; negligible time to eval [id (identifier? sexpr) @@ -160,14 +160,14 @@ [(set! . _) (syntax (begin0 expr e))] [(let-values bindings . body) - (insert-at-tail* se sexpr trans?)] + (insert-at-tail* se sexpr phase)] [(letrec-values bindings . body) - (insert-at-tail* se sexpr trans?)] + (insert-at-tail* se sexpr phase)] [(begin . _) - (insert-at-tail* se sexpr trans?)] + (insert-at-tail* se sexpr phase)] [(with-continuation-mark . _) - (insert-at-tail* se sexpr trans?)] + (insert-at-tail* se sexpr phase)] [(begin0 body ...) (certify sexpr (syntax (begin0 body ... e)))] @@ -179,29 +179,29 @@ (rebuild sexpr (list - (cons #'then (insert-at-tail se (syntax then) trans?)) - (cons #'else (insert-at-tail se (syntax else) trans?)))))] + (cons #'then (insert-at-tail se (syntax then) phase)) + (cons #'else (insert-at-tail se (syntax else) phase)))))] [(#%plain-app . rest) (if (stx-null? (syntax rest)) ;; null constant (syntax (begin e expr)) ;; application; exploit guaranteed left-to-right evaluation - (insert-at-tail* se sexpr trans?))] + (insert-at-tail* se sexpr phase))] [_else (error 'errortrace "unrecognized (non-top-level) expression form: ~e" (syntax->datum sexpr))]))) - (define (profile-annotate-lambda name expr clause bodys-stx trans?) + (define (profile-annotate-lambda name expr clause bodys-stx phase) (let* ([bodys (stx->list bodys-stx)] - [bodyl (map (lambda (e) (annotate e trans?)) + [bodyl (map (lambda (e) (annotate e phase)) bodys)]) (rebuild clause (if (profiling-enabled) (let ([prof-expr - (profile-point bodyl name expr trans?)]) + (profile-point bodyl name expr phase)]) ;; Tell rebuild to replace first expressions with ;; (void), and replace the last expression with ;; prof-expr: @@ -223,7 +223,7 @@ (syntax-property new 'inferred-name p2) new)))) - (define (annotate-let expr trans? varss-stx rhss-stx bodys-stx) + (define (annotate-let expr phase varss-stx rhss-stx bodys-stx) (let ([varss (syntax->list varss-stx)] [rhss (syntax->list rhss-stx)] [bodys (syntax->list bodys-stx)]) @@ -235,20 +235,20 @@ (syntax id)] [_else #f]) rhs - trans?)) + phase)) varss rhss)] [bodyl (map (lambda (body) - (annotate body trans?)) + (annotate body phase)) bodys)]) (rebuild expr (append (map cons bodys bodyl) (map cons rhss rhsl)))))) - (define (annotate-seq expr bodys-stx annotate trans?) + (define (annotate-seq expr bodys-stx annotate phase) (let* ([bodys (syntax->list bodys-stx)] [bodyl (map (lambda (b) - (annotate b trans?)) + (annotate b phase)) bodys)]) (rebuild expr (map cons bodys bodyl)))) @@ -317,15 +317,12 @@ (car l)))) (define (make-annotate top? name) - (lambda (expr trans?) + (lambda (expr phase) (test-coverage-point - (kernel-syntax-case expr trans? + (kernel-syntax-case/phase expr phase [_ (identifier? expr) - (let ([b ((if trans? - identifier-binding - identifier-transformer-binding) - expr)]) + (let ([b (identifier-binding expr phase)]) (cond [(eq? 'lexical b) ;; lexical variable - no error possile @@ -344,14 +341,14 @@ ;; no error possible expr] - ;; Can't put annotation on the outside [(define-values names rhs) top? + ;; Can't put annotation on the outside (let ([marked (with-mark expr (annotate-named (one-name #'names) (syntax rhs) - trans?))]) + phase))]) (certify expr (rebuild expr (list (cons #'rhs marked)))))] @@ -361,14 +358,14 @@ expr (annotate-seq expr (syntax exprs) - annotate-top trans?))] + annotate-top phase))] [(define-syntaxes (name ...) rhs) top? (let ([marked (with-mark expr (annotate-named (one-name #'(name ...)) (syntax rhs) - #t))]) + (add1 phase)))]) (certify expr (rebuild expr (list (cons #'rhs marked)))))] @@ -379,18 +376,17 @@ (annotate-named (one-name (syntax (name ...))) (syntax rhs) - #t))]) + (add1 phase)))]) (certify expr (rebuild expr (list (cons #'rhs marked)))))] - ;; Just wrap body expressions [(module name init-import (#%plain-module-begin body ...)) - top? + ;; Just wrap body expressions (let ([bodys (syntax->list (syntax (body ...)))] [mb (list-ref (syntax->list expr) 3)]) (let ([bodyl (map (lambda (b) - (annotate-top b trans?)) + (annotate-top b 0)) bodys)]) (certify expr @@ -404,7 +400,7 @@ [(#%expression e) top? - (certify expr #`(#%expression #,(annotate (syntax e) trans?)))] + (certify expr #`(#%expression #,(annotate (syntax e) phase)))] ;; No way to wrap [(#%require i ...) expr] @@ -425,7 +421,7 @@ (keep-lambda-properties expr (profile-annotate-lambda name expr expr (syntax body) - trans?)))] + phase)))] [(case-lambda clause ...) (with-syntax ([([args . body] ...) (syntax (clause ...))]) @@ -433,7 +429,7 @@ [clausel (map (lambda (body clause) (profile-annotate-lambda - name expr clause body trans?)) + name expr clause body phase)) (syntax->list (syntax (body ...))) clauses)]) (certify @@ -447,7 +443,7 @@ (with-mark expr (certify expr - (annotate-let expr trans? + (annotate-let expr phase (syntax (vars ...)) (syntax (rhs ...)) (syntax body))))] @@ -455,7 +451,7 @@ (with-mark expr (certify expr - (annotate-let expr trans? + (annotate-let expr phase (syntax (vars ...)) (syntax (rhs ...)) (syntax body))))] @@ -465,7 +461,7 @@ (let ([new-rhs (annotate-named (syntax var) (syntax rhs) - trans?)]) + (add1 phase))]) ;; set! might fail on undefined variable, or too many values: (with-mark expr (certify @@ -477,21 +473,21 @@ ;; Single expression: no mark (certify expr - #`(begin #,(annotate (syntax e) trans?)))] + #`(begin #,(annotate (syntax e) phase)))] [(begin . body) (with-mark expr (certify expr - (annotate-seq expr #'body annotate trans?)))] + (annotate-seq expr #'body annotate phase)))] [(begin0 . body) (with-mark expr (certify expr - (annotate-seq expr #'body annotate trans?)))] + (annotate-seq expr #'body annotate phase)))] [(if tst thn els) - (let ([w-tst (annotate (syntax tst) trans?)] - [w-thn (annotate (syntax thn) trans?)] - [w-els (annotate (syntax els) trans?)]) + (let ([w-tst (annotate (syntax tst) phase)] + [w-thn (annotate (syntax thn) phase)] + [w-els (annotate (syntax els) phase)]) (with-mark expr (certify expr @@ -499,8 +495,8 @@ (cons #'thn w-thn) (cons #'els w-els))))))] [(if tst thn) - (let ([w-tst (annotate (syntax tst) trans?)] - [w-thn (annotate (syntax thn) trans?)]) + (let ([w-tst (annotate (syntax tst) phase)] + [w-thn (annotate (syntax thn) phase)]) (with-mark expr (certify expr @@ -511,7 +507,7 @@ (certify expr (annotate-seq expr (syntax body) - annotate trans?)))] + annotate phase)))] ;; Wrap whole application, plus subexpressions [(#%plain-app . body) @@ -520,7 +516,7 @@ ;; It's a null: expr] [(syntax-case* expr (#%plain-app void) - (if trans? + (if phase free-transformer-identifier=? free-identifier=?) [(#%plain-app void) #t] @@ -531,7 +527,7 @@ (with-mark expr (certify expr (annotate-seq expr (syntax body) - annotate trans?)))])] + annotate phase)))])] [_else (error 'errortrace "unrecognized expression form~a: ~e" @@ -541,5 +537,5 @@ (define annotate (make-annotate #f #f)) (define annotate-top (make-annotate #t #f)) - (define (annotate-named name expr trans?) - ((make-annotate #t name) expr trans?)))) + (define (annotate-named name expr phase) + ((make-annotate #t name) expr phase)))) diff --git a/collects/gui-debugger/annotator.ss b/collects/gui-debugger/annotator.ss index 7c0a15e400..f8e4f1455d 100644 --- a/collects/gui-debugger/annotator.ss +++ b/collects/gui-debugger/annotator.ss @@ -160,15 +160,16 @@ #'(#%plain-app debugger-local-bindings))) (define (top-level-annotate stx) - (kernel:kernel-syntax-case - stx #f + (kernel:kernel-syntax-case/phase + stx (namespace-base-phase) [(module identifier name (#%plain-module-begin . module-level-exprs)) - (quasisyntax/loc stx (module identifier name - (#%plain-module-begin - #,@(map (lambda (e) (module-level-expr-iterator - e (list (syntax-e #'identifier) - (syntax-source #'identifier)))) - (syntax->list #'module-level-exprs)))))] + (with-syntax ([(module . _) stx]) + (quasisyntax/loc stx (module identifier name + (#%plain-module-begin + #,@(map (lambda (e) (module-level-expr-iterator + e (list (syntax-e #'identifier) + (syntax-source #'identifier)))) + (syntax->list #'module-level-exprs))))))] [else-stx (general-top-level-expr-iterator stx #f)])) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 547bd6618b..0827b92f1a 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -1116,7 +1116,8 @@ [annotated (if is-compiled? exp - (let* ([et-annotated (et:annotate-top (expand exp) #f)] + (let* ([et-annotated (et:annotate-top (expand exp) + (namespace-base-phase))] [tr-annotated (if tracing? (tr:annotate (expand et-annotated)) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index b48d95c0e2..e5ca95bc2d 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -793,6 +793,7 @@ (let* ([can-multi (and width (not (size-hook obj display?)) (or (pair? obj) + (mpair? obj) (vector? obj) (and (box? obj) print-box?) (and (custom-write? obj) @@ -831,7 +832,10 @@ (expr-found pport graph-ref)) (pre-print pport obj) (cond - [(pair? obj) (pp-pair obj extra depth)] + [(pair? obj) (pp-pair obj extra depth + pair? car cdr pair-open pair-close)] + [(mpair? obj) (pp-pair obj extra depth + mpair? mcar mcdr mpair-open mpair-close)] [(vector? obj) (out "#") (when print-vec-length? @@ -858,22 +862,25 @@ ;; Not possible to split obj across lines; so just write directly (wr* pport obj depth display?)))) - (define (pp-expr expr extra depth) - (if (and (read-macro? expr pair? car cdr) - (not (and found (hash-table-get found (cdr expr) #f)))) + (define (pp-expr expr extra depth + apair? acar acdr open close) + (if (and (read-macro? expr apair? acar acdr) + (equal? open "(") + (not (and found (hash-table-get found (acdr expr) #f)))) (begin - (out (read-macro-prefix expr car)) - (pr (read-macro-body expr car cdr) + (out (read-macro-prefix expr acar)) + (pr (read-macro-body expr acar acdr) extra pp-expr depth)) - (let ((head (car expr))) + (let ((head (acar expr))) (if (or (and (symbol? head) (not (size-hook head display?))) ((pretty-print-remap-stylable) head)) - (let ((proc (style head expr))) + (let ((proc (style head expr apair? acar acdr))) (if proc - (proc expr extra depth) + (proc expr extra depth + apair? acar acdr open close) (if (and #f ;; Why this special case? Currently disabled. (> (string-length @@ -882,9 +889,12 @@ head ((pretty-print-remap-stylable) head)))) max-call-head-width)) - (pp-general expr extra #f #f #f pp-expr depth) - (pp-list expr extra pp-expr #t depth)))) - (pp-list expr extra pp-expr #t depth))))) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close)))) + (pp-list expr extra pp-expr #t depth + apair? acar acdr open close))))) (define (wr obj depth) (wr* pport obj depth display?)) @@ -892,44 +902,53 @@ ;; (head item1 ;; item2 ;; item3) - (define (pp-call expr extra pp-item depth) - (out "(") - (wr (car expr) (dsub1 depth)) + (define (pp-call expr extra pp-item depth + apair? acar acdr open close) + (out open) + (wr (acar expr) (dsub1 depth)) (let ([col (+ (ccol) 1)]) - (pp-down ")" (cdr expr) col col extra pp-item #t #t depth))) + (pp-down close (acdr expr) col col extra pp-item #t #t depth + apair? acar acdr open close))) ;; (head item1 item2 ;; item3 ;; item4) - (define (pp-two-up expr extra pp-item depth) - (out "(") + (define (pp-two-up expr extra pp-item depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (wr (car expr) (dsub1 depth)) + (wr (acar expr) (dsub1 depth)) (out " ") - (wr (cadr expr) (dsub1 depth)) - (pp-down ")" (cddr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) + (wr (acar (acdr expr)) (dsub1 depth)) + (pp-down close (acdr (acdr expr)) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close))) ;; (head item1 ;; item2 ;; item3) - (define (pp-one-up expr extra pp-item depth) - (out "(") + (define (pp-one-up expr extra pp-item depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (wr (car expr) (dsub1 depth)) - (pp-down ")" (cdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth))) + (wr (acar expr) (dsub1 depth)) + (pp-down close (acdr expr) (+ (ccol) 1) (+ col 1) extra pp-item #t #t depth + apair? acar acdr open close))) ;; (item1 ;; item2 ;; item3) - (define (pp-list l extra pp-item check? depth) - (out "(") + (define (pp-list l extra pp-item check? depth + apair? acar acdr open close) + (out open) (let ([col (ccol)]) - (pp-down ")" l col col extra pp-item #f check? depth))) + (pp-down close l col col extra pp-item #f check? depth + apair? acar acdr open close))) - (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth) + (define (pp-down closer l col1 col2 extra pp-item check-first? check-rest? depth + apair? acar acdr open close) (let loop ([l l] [icol col1] [check? check-first?]) (check-expr-found - l pport (and check? (pair? l)) + l pport (and check? (apair? l)) (lambda (s) (indent col2) (out ".") @@ -944,11 +963,11 @@ (out closer)) (lambda () (cond - [(pair? l) - (let ([rest (cdr l)]) + [(apair? l) + (let ([rest (acdr l)]) (let ([extra (if (null? rest) (+ extra 1) 0)]) (indent icol) - (pr (car l) extra pp-item (dsub1 depth)) + (pr (acar l) extra pp-item (dsub1 depth)) (loop rest col2 check-rest?)))] [(null? l) (out closer)] @@ -959,12 +978,13 @@ (pr l (+ extra 1) pp-item (dsub1 depth)) (out closer)]))))) - (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth) + (define (pp-general expr extra named? pp-1 pp-2 pp-3 depth + apair? acar acdr open close) (define (tail1 rest col1 col3) - (if (and pp-1 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) + (if (and pp-1 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (indent col3) (pr val1 extra pp-1 depth) @@ -972,9 +992,9 @@ (tail2 rest col1 col3))) (define (tail2 rest col1 col3) - (if (and pp-2 (pair? rest)) - (let* ((val1 (car rest)) - (rest (cdr rest)) + (if (and pp-2 (apair? rest)) + (let* ((val1 (acar rest)) + (rest (acdr rest)) (extra (if (null? rest) (+ extra 1) 0))) (indent col3) (pr val1 extra pp-2 depth) @@ -982,55 +1002,78 @@ (tail3 rest col1))) (define (tail3 rest col1) - (pp-down ")" rest col1 col1 extra pp-3 #f #t depth)) + (pp-down close rest col1 col1 extra pp-3 #f #t depth + apair? acar acdr open close)) - (let* ([head (car expr)] - [rest (cdr expr)] + (let* ([head (acar expr)] + [rest (acdr expr)] [col (ccol)]) - (out "(") + (out open) (wr head (dsub1 depth)) - (if (and named? (pair? rest)) - (let* ((name (car rest)) - (rest (cdr rest))) + (if (and named? (apair? rest)) + (let* ((name (acar rest)) + (rest (acdr rest))) (out " ") (wr name (dsub1 depth)) (tail1 rest (+ col indent-general) (+ (ccol) 1))) (tail1 rest (+ col indent-general) (+ (ccol) 1))))) - (define (pp-expr-list l extra depth) - (pp-list l extra pp-expr #t depth)) + (define (pp-expr-list l extra depth + apair? acar acdr open close) + (pp-list l extra pp-expr #t depth + apair? acar acdr open close)) - (define (pp-lambda expr extra depth) - (pp-general expr extra #f pp-expr-list #f pp-expr depth)) + (define (pp-lambda expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr-list #f pp-expr depth + apair? acar acdr open close)) - (define (pp-if expr extra depth) - (pp-general expr extra #f pp-expr #f pp-expr depth)) + (define (pp-if expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr #f pp-expr depth + apair? acar acdr open close)) - (define (pp-cond expr extra depth) - (pp-list expr extra pp-expr-list #t depth)) + (define (pp-cond expr extra depth + apair? acar acdr open close) + (pp-list expr extra pp-expr-list #t depth + apair? acar acdr open close)) - (define (pp-class expr extra depth) - (pp-two-up expr extra pp-expr-list depth)) + (define (pp-syntax-case expr extra depth + apair? acar acdr open close) + (pp-two-up expr extra pp-expr-list depth + apair? acar acdr open close)) - (define (pp-make-object expr extra depth) - (pp-one-up expr extra pp-expr-list depth)) + (define (pp-make-object expr extra depth + apair? acar acdr open close) + (pp-one-up expr extra pp-expr-list depth + apair? acar acdr open close)) - (define (pp-case expr extra depth) - (pp-general expr extra #f pp-expr #f pp-expr-list depth)) + (define (pp-case expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr #f pp-expr-list depth + apair? acar acdr open close)) - (define (pp-and expr extra depth) - (pp-call expr extra pp-expr depth)) + (define (pp-and expr extra depth + apair? acar acdr open close) + (pp-call expr extra pp-expr depth + apair? acar acdr open close)) - (define (pp-let expr extra depth) - (let* ((rest (cdr expr)) - (named? (and (pair? rest) (symbol? (do-remap (car rest)))))) - (pp-general expr extra named? pp-expr-list #f pp-expr depth))) + (define (pp-let expr extra depth + apair? acar acdr open close) + (let* ((rest (acdr expr)) + (named? (and (apair? rest) (symbol? (do-remap (acar rest)))))) + (pp-general expr extra named? pp-expr-list #f pp-expr depth + apair? acar acdr open close))) - (define (pp-begin expr extra depth) - (pp-general expr extra #f #f #f pp-expr depth)) + (define (pp-begin expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f #f #f pp-expr depth + apair? acar acdr open close)) - (define (pp-do expr extra depth) - (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth)) + (define (pp-do expr extra depth + apair? acar acdr open close) + (pp-general expr extra #f pp-expr-list pp-expr-list pp-expr depth + apair? acar acdr open close)) ;; define formatting style (change these to suit your style) @@ -1038,57 +1081,58 @@ (define max-call-head-width 5) - (define (no-sharing? expr count) - (if (and found (hash-table-get found (cdr expr) #f)) + (define (no-sharing? expr count acdr) + (if (and found (hash-table-get found (acdr expr) #f)) #f (or (zero? count) - (no-sharing? (cdr expr) (sub1 count))))) + (no-sharing? (acdr expr) (sub1 count) acdr)))) - (define (style head expr) + (define (style head expr apair? acar acdr) (case (look-in-style-table head) ((lambda λ define define-macro define-syntax syntax-rules shared unless when) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-lambda)) ((if set! set!-values) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-if)) ((cond case-lambda) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-cond)) - ((case) - (and (no-sharing? expr 1) + ((case class) + (and (no-sharing? expr 1 acdr) pp-case)) ((and or import export require require-for-syntax require-for-template provide link public private override rename inherit field init) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-and)) ((let letrec let* let-values letrec-values let*-values let-syntax letrec-syntax let-syntaxes letrec-syntaxes) (and (no-sharing? expr - (if (and (pair? (cdr expr)) - (symbol? (cadr expr))) + (if (and (apair? (acdr expr)) + (symbol? (acar (acdr expr)))) 2 - 1)) + 1) + acdr) pp-let)) ((begin begin0) - (and (no-sharing? expr 0) + (and (no-sharing? expr 0 acdr) pp-begin)) ((do letrec-syntaxes+values) - (and (no-sharing? expr 2) + (and (no-sharing? expr 2 acdr) pp-do)) - ((send class syntax-case instantiate module) - (and (no-sharing? expr 2) - pp-class)) + ((send syntax-case instantiate module) + (and (no-sharing? expr 2 acdr) + pp-syntax-case)) ((make-object) - (and (no-sharing? expr 1) + (and (no-sharing? expr 1 acdr) pp-make-object)) (else #f))) diff --git a/collects/mzlib/private/sandbox-coverage.ss b/collects/mzlib/private/sandbox-coverage.ss index 3043555190..67167e4089 100644 --- a/collects/mzlib/private/sandbox-coverage.ss +++ b/collects/mzlib/private/sandbox-coverage.ss @@ -62,7 +62,7 @@ e (namespace-syntax-introduce (datum->syntax-object #f e)))) - #f) + (namespace-base-phase)) e) immediate-eval?)))) diff --git a/collects/scribblings/reference/namespaces.scrbl b/collects/scribblings/reference/namespaces.scrbl index 3a3bf7b966..7f93336319 100644 --- a/collects/scribblings/reference/namespaces.scrbl +++ b/collects/scribblings/reference/namespaces.scrbl @@ -95,15 +95,30 @@ A parameter that determines the @techlink{current namespace}.} @defproc[(namespace-symbol->identifier [sym symbol?]) identifier?]{ Similar to @scheme[datum->syntax] restricted to symbols. The -lexical context of the resulting identifier corresponds to the -top-level environment of the current namespace; the identifier has no -source location or properties.} +@tech{lexical information} of the resulting identifier corresponds to +the top-level environment of the current namespace; the identifier has +no source location or properties.} -@defproc[(namespace-module-identifier [namespace namespace? (current-namespace)]) identifier?]{ +@defproc[(namespace-base-phase [namespace namespace? (current-namespace)]) exact-integer?]{ + +Returns the @tech{base phase} of @scheme[namespace].} + + +@defproc[(namespace-module-identifier [where (or/c namespace? exact-integer? false/c) + (current-namespace)]) + identifier?]{ Returns an identifier whose binding is @scheme[module] in the -@tech{base phase} of @scheme[namespace].} +@tech{base phase} of @scheme[where] if it is a namespace, or in the +@scheme[where] @tech{phase level} otherwise. + +The @tech{lexical information} of the identifier includes bindings (in +the same @tech{phase level}) for all syntactic forms that appear in +fully expanded code (see @secref["fully-expanded"]), but using the +name reported by the second element of @scheme[identifier-binding] for +the binding; the @tech{lexical information} may also include other +bindings.} @defproc[(namespace-variable-value [sym symbol?] diff --git a/collects/syntax/kerncase.ss b/collects/syntax/kerncase.ss index 153a18bb1d..89a83112db 100644 --- a/collects/syntax/kerncase.ss +++ b/collects/syntax/kerncase.ss @@ -3,10 +3,14 @@ (require (for-syntax scheme/base) (for-template scheme/base)) + (define-for-syntax anchor #f) + (define-for-syntax (quick-phase?) + (= 1 (variable-reference->phase (#%variable-reference anchor)))) + (define-syntax kernel-syntax-case-internal (lambda (stx) (syntax-case stx () - [(_ stxv trans? (extras ...) kernel-context clause ...) + [(_ stxv phase rel? (extras ...) kernel-context clause ...) (quasisyntax/loc stx (syntax-case* stxv (extras ... @@ -26,7 +30,22 @@ #%plain-module-begin #%require #%provide #%variable-reference))))) - (if trans? free-transformer-identifier=? free-identifier=?) + (let ([p phase]) + (cond + [(and #,(or (syntax-e #'rel?) (quick-phase?)) (= p 0)) + free-identifier=?] + [(and #,(or (syntax-e #'rel?) (quick-phase?)) (= p 1)) + free-transformer-identifier=?] + [else (let ([id (namespace-module-identifier p)]) + (lambda (a b) + (free-identifier=? (datum->syntax id + (let ([s (syntax-e a)]) + (case s + [(#%plain-app) '#%app] + [(#%plain-lambda) 'lambda] + [else s]))) + b + p)))])) clause ...))]))) (define-syntax kernel-syntax-case @@ -34,14 +53,28 @@ (syntax-case stx () [(_ stxv trans? clause ...) (quasisyntax/loc stx - (kernel-syntax-case-internal stxv trans? () #,stx clause ...))]))) + (kernel-syntax-case-internal stxv (if trans? 1 0) #t () #,stx clause ...))]))) (define-syntax kernel-syntax-case* (lambda (stx) (syntax-case stx () [(_ stxv trans? (extras ...) clause ...) (quasisyntax/loc stx - (kernel-syntax-case-internal stxv trans? (extras ...) #,stx clause ...))]))) + (kernel-syntax-case-internal stxv (if trans? 1 0) #t (extras ...) #,stx clause ...))]))) + + (define-syntax kernel-syntax-case/phase + (lambda (stx) + (syntax-case stx () + [(_ stxv phase clause ...) + (quasisyntax/loc stx + (kernel-syntax-case-internal stxv phase #f () #,stx clause ...))]))) + + (define-syntax kernel-syntax-case*/phase + (lambda (stx) + (syntax-case stx () + [(_ stxv phase (extras ...) clause ...) + (quasisyntax/loc stx + (kernel-syntax-case-internal stxv phase #f (extras ...) #,stx clause ...))]))) (define (kernel-form-identifier-list) (syntax-e (quote-syntax @@ -66,4 +99,6 @@ (provide kernel-syntax-case kernel-syntax-case* + kernel-syntax-case/phase + kernel-syntax-case*/phase kernel-form-identifier-list)) diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss index 3bca652aa0..c07ba9cbe8 100644 --- a/collects/tests/mzscheme/pretty.ss +++ b/collects/tests/mzscheme/pretty.ss @@ -103,23 +103,64 @@ (test #t pretty-print-style-table? (pretty-print-extend-style-table #f null null)) (test #t pretty-print-style-table? (pretty-print-extend-style-table (pretty-print-current-style-table) null null)) -(parameterize ([pretty-print-columns 20]) - (test "(1234567890 1 2 3 4)" pretty-format '(1234567890 1 2 3 4)) - (test "(1234567890xx\n 1\n 2\n 3\n 4)" pretty-format '(1234567890xx 1 2 3 4)) - (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) - (let ([table (pretty-print-extend-style-table #f null null)]) - (parameterize ([pretty-print-current-style-table - (pretty-print-extend-style-table table '(lambda) '(list))]) - (test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) +(define (test-indent-variants pretty-format quote-abbrev?) + (parameterize ([pretty-print-columns 20]) + (test "(1234567890 1 2 3 4)" pretty-format '(1234567890 1 2 3 4)) + (test "(1234567890xx\n 1\n 2\n 3\n 4)" pretty-format '(1234567890xx 1 2 3 4)) (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) - (parameterize ([pretty-print-current-style-table table]) - (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) - ;; Make sure special case for lambda, etc, doesn't hide sharing: - (let ([a (read (open-input-string "#0=((x) 1 . #0#)"))]) - (test "(lambda\n .\n #0=((x) 1 . #0#))" pretty-format `(lambda . ,a))) - (let ([a (read (open-input-string "#0=((1 . #0#))"))]) - (test "(quote\n .\n #0=((1 . #0#)))" pretty-format `(quote . ,a)) - (test "'#0=((1 . #0#))" pretty-format `(quote ,a))))) + (test "(if 12345678903333\n a\n b)" pretty-format '(if 12345678903333 a b)) + (test "(cond\n (12345678903333 a)\n (else b))" pretty-format '(cond [12345678903333 a][else b])) + (test "(case x\n ((12345678903) a)\n (else b))" pretty-format '(case x [(12345678903) a][else b])) + (test "(and 12345678903333\n a\n b)" pretty-format '(and 12345678903333 a b)) + (test "(let ((x 12345678))\n x)" pretty-format '(let ([x 12345678]) x)) + (test "(begin\n 1234567890\n a\n b)" pretty-format '(begin 1234567890 a b)) + (parameterize ([pretty-print-columns 35]) + (test "(letrec-syntaxes+values (((a) 1))\n (((b) 2))\n c)" + pretty-format + '(letrec-syntaxes+values ([(a) 1]) ([(b) 2]) c))) + (test "(class object%\n (define x 12)\n (super-new))" pretty-format '(class object% (define x 12) (super-new))) + (test "(syntax-case stx (a)\n ((_ a) 10))" pretty-format '(syntax-case stx (a) [(_ a) 10])) + (test "(make-object foo%\n 1234567890)" pretty-format '(make-object foo% 1234567890)) + (let ([table (pretty-print-extend-style-table #f null null)]) + (parameterize ([pretty-print-current-style-table + (pretty-print-extend-style-table table '(lambda) '(list))]) + (test "(lambda\n 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) + (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4)) + (parameterize ([pretty-print-current-style-table table]) + (test "(lambda 1234567890\n 1\n 2\n 3\n 4)" pretty-format '(lambda 1234567890 1 2 3 4))) + ;; Make sure special case for lambda, etc, doesn't hide sharing: + (let ([a (read (open-input-string "#0=((x) 1 . #0#)"))]) + (test "(lambda\n .\n #0=((x) 1 . #0#))" pretty-format `(lambda . ,a))) + (let ([a (read (open-input-string "#0=((1 . #0#))"))]) + (test "(quote\n .\n #0=((1 . #0#)))" pretty-format `(quote . ,a)) + (when quote-abbrev? + (test "'#0=((1 . #0#))" pretty-format `(quote ,a))))))) +(test-indent-variants pretty-format #t) +(letrec ([to-mpair + (lambda (s) + (let ([ht (make-hasheq)]) + (let to-mpair ([s s]) + (if (pair? s) + (or (hash-ref ht s #f) + (let ([p (mcons #f #f)]) + (hash-set! ht s p) + (set-mcar! p (to-mpair (car s))) + (set-mcdr! p (to-mpair (cdr s))) + p)) + s))))]) + (parameterize ([print-mpair-curly-braces #f]) + (test-indent-variants (lambda (x) + (pretty-format (to-mpair x))) + #t)) + (test-indent-variants (lambda (x) + (regexp-replace* + #rx"}" + (regexp-replace* + #rx"{" + (pretty-format (to-mpair x)) + "(") + ")")) + #f)) (parameterize ([pretty-print-exact-as-decimal #t]) (test "10" pretty-format 10) diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 39a8026381..a6fd025629 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,50,50,0,0,0,1,0,0,6,0,9,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,51,50,0,0,0,1,0,0,6,0,9,0, 16,0,20,0,25,0,38,0,41,0,46,0,53,0,60,0,64,0,69,0,78, 0,84,0,98,0,112,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,68,1,107,1,146, @@ -14,11 +14,11 @@ 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, -10,35,11,8,183,216,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, +10,35,11,8,182,216,94,159,2,16,35,35,159,2,15,35,35,16,20,2,3, 2,2,2,7,2,2,2,4,2,2,2,5,2,2,2,6,2,2,2,9,2, 2,2,8,2,2,2,10,2,2,2,11,2,2,2,12,2,2,97,36,11,8, -183,216,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, -13,97,10,11,11,8,183,216,16,0,97,10,37,11,8,183,216,16,0,13,16, +182,216,93,159,2,15,35,36,16,2,2,13,161,2,2,36,2,13,2,2,2, +13,97,10,11,11,8,182,216,16,0,97,10,37,11,8,182,216,16,0,13,16, 4,35,29,11,11,2,2,11,18,98,64,104,101,114,101,8,31,8,30,8,29, 8,28,8,27,27,248,22,189,3,23,196,1,249,22,182,3,80,158,38,35,251, 22,73,2,17,248,22,88,23,200,2,12,249,22,63,2,1,248,22,90,23,202, @@ -28,14 +28,14 @@ 36,28,248,22,71,248,22,65,23,195,2,248,22,64,193,249,22,182,3,80,158, 38,35,251,22,73,2,17,248,22,64,23,200,2,249,22,63,2,4,248,22,65, 23,202,1,11,18,100,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,55,57,55,55,16,4,11,11,2,19,3,1,7, -101,110,118,55,57,55,56,27,248,22,65,248,22,189,3,23,197,1,28,248,22, +2,18,3,1,7,101,110,118,55,57,55,54,16,4,11,11,2,19,3,1,7, +101,110,118,55,57,55,55,27,248,22,65,248,22,189,3,23,197,1,28,248,22, 71,23,194,2,20,15,159,36,35,36,28,248,22,71,248,22,65,23,195,2,248, 22,64,193,249,22,182,3,80,158,38,35,250,22,73,2,20,248,22,73,249,22, 73,248,22,73,2,21,248,22,64,23,202,2,251,22,73,2,17,2,21,2,21, 249,22,63,2,7,248,22,65,23,205,1,18,100,11,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,55,57,56,48,16,4, -11,11,2,19,3,1,7,101,110,118,55,57,56,49,248,22,189,3,193,27,248, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,55,57,55,57,16,4, +11,11,2,19,3,1,7,101,110,118,55,57,56,48,248,22,189,3,193,27,248, 22,189,3,194,249,22,63,248,22,73,248,22,64,196,248,22,65,195,27,248,22, 65,248,22,189,3,23,197,1,249,22,182,3,80,158,38,35,28,248,22,51,248, 22,183,3,248,22,64,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42, @@ -65,8 +65,8 @@ 251,22,73,2,17,28,249,22,150,8,248,22,183,3,248,22,64,23,201,2,64, 101,108,115,101,10,248,22,64,23,198,2,250,22,74,2,20,9,248,22,65,23, 201,1,249,22,63,2,8,248,22,65,23,203,1,99,8,31,8,30,8,29,8, -28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,48,48,51,16,4, -11,11,2,19,3,1,7,101,110,118,56,48,48,52,18,158,94,10,64,118,111, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,56,48,48,50,16,4, +11,11,2,19,3,1,7,101,110,118,56,48,48,51,18,158,94,10,64,118,111, 105,100,8,47,27,248,22,65,248,22,189,3,196,249,22,182,3,80,158,38,35, 28,248,22,51,248,22,183,3,248,22,64,197,250,22,73,2,26,248,22,73,248, 22,64,199,248,22,88,198,27,248,22,183,3,248,22,64,197,250,22,73,2,26, @@ -99,7 +99,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2031); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,50,59,0,0,0,1,0,0,3,0,16,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,51,59,0,0,0,1,0,0,3,0,16,0, 21,0,38,0,53,0,71,0,87,0,97,0,115,0,135,0,151,0,169,0,200, 0,229,0,251,0,9,1,15,1,29,1,34,1,44,1,52,1,80,1,112,1, 157,1,202,1,226,1,9,2,11,2,68,2,158,3,199,3,33,5,137,5,241, @@ -343,12 +343,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5056); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,50,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,51,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,241,0,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,185,218,97,159,2,2,35,35, +37,107,101,114,110,101,108,11,98,10,35,11,8,184,218,97,159,2,2,35,35, 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, 0,159,35,20,103,159,35,16,1,65,98,101,103,105,110,16,0,83,158,41,20, 100,137,69,35,37,98,117,105,108,116,105,110,29,11,11,10,10,18,96,11,42, @@ -360,7 +360,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 278); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,50,52,0,0,0,1,0,0,3,0,14,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,48,46,49,46,51,52,0,0,0,1,0,0,3,0,14,0, 41,0,47,0,60,0,74,0,96,0,122,0,134,0,152,0,172,0,184,0,200, 0,223,0,3,1,8,1,13,1,18,1,23,1,54,1,58,1,66,1,74,1, 82,1,185,1,230,1,250,1,29,2,64,2,98,2,108,2,155,2,165,2,172, @@ -437,8 +437,8 @@ 2,39,193,87,95,28,248,22,159,4,195,12,250,22,180,8,2,20,6,20,20, 114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197, 28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,133,2, -80,158,41,42,248,22,184,13,247,22,162,11,11,28,23,193,2,192,87,94,23, -193,1,27,247,22,121,87,94,250,22,131,2,80,158,42,42,248,22,184,13,247, +80,158,41,42,248,22,185,13,247,22,162,11,11,28,23,193,2,192,87,94,23, +193,1,27,247,22,121,87,94,250,22,131,2,80,158,42,42,248,22,185,13,247, 22,162,11,195,192,250,22,131,2,195,198,66,97,116,116,97,99,104,251,211,197, 198,199,10,28,192,250,22,179,8,11,196,195,248,22,177,8,194,28,249,22,151, 6,194,6,1,1,46,2,17,28,249,22,151,6,194,6,2,2,46,46,62,117, @@ -505,8 +505,8 @@ 87,95,23,195,1,23,193,1,27,28,248,22,167,7,23,200,2,249,22,172,7, 23,201,2,38,249,80,158,47,52,23,197,2,5,0,27,28,248,22,167,7,23, 201,2,249,22,172,7,23,202,2,39,248,22,160,4,23,200,2,27,27,250,22, -133,2,80,158,51,42,248,22,184,13,247,22,162,11,11,28,23,193,2,192,87, -94,23,193,1,27,247,22,121,87,94,250,22,131,2,80,158,52,42,248,22,184, +133,2,80,158,51,42,248,22,185,13,247,22,162,11,11,28,23,193,2,192,87, +94,23,193,1,27,247,22,121,87,94,250,22,131,2,80,158,52,42,248,22,185, 13,247,22,162,11,195,192,87,95,28,23,209,1,27,250,22,133,2,23,197,2, 197,11,28,23,193,1,12,87,95,27,27,28,248,22,17,80,158,51,45,80,158, 50,45,247,22,19,250,22,25,248,22,23,23,197,2,80,158,53,44,23,196,1, diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 891e9f9f67..ec32652993 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -75,6 +75,7 @@ static Scheme_Env *make_empty_not_inited_env(int toplevel_size); static Scheme_Object *namespace_identifier(int, Scheme_Object *[]); static Scheme_Object *namespace_module_identifier(int, Scheme_Object *[]); +static Scheme_Object *namespace_base_phase(int, Scheme_Object *[]); static Scheme_Object *namespace_variable_value(int, Scheme_Object *[]); static Scheme_Object *namespace_set_variable_value(int, Scheme_Object *[]); static Scheme_Object *namespace_undefine_variable(int, Scheme_Object *[]); @@ -503,6 +504,12 @@ static void make_init_env(void) "namespace-module-identifier", 0, 1), env); + scheme_add_global_constant("namespace-base-phase", + scheme_make_prim_w_arity(namespace_base_phase, + "namespace-base-phase", + 0, 1), + env); + scheme_add_global_constant("namespace-variable-value", scheme_make_prim_w_arity(namespace_variable_value, @@ -3717,19 +3724,45 @@ namespace_identifier(int argc, Scheme_Object *argv[]) static Scheme_Object * namespace_module_identifier(int argc, Scheme_Object *argv[]) +{ + Scheme_Env *genv; + Scheme_Object *phase; + + if (argc > 0) { + if (SCHEME_NAMESPACEP(argv[0])) { + genv = (Scheme_Env *)argv[0]; + phase = scheme_make_integer(genv->phase); + } else if (SCHEME_FALSEP(argv[0])) { + phase = scheme_false; + } else if (SCHEME_INTP(argv[0]) || SCHEME_BIGNUMP(argv[0])) { + phase = argv[0]; + } else { + scheme_wrong_type("namespace-module-identifier", "namespace, #f, or exact integer", 0, argc, argv); + return NULL; + } + } else { + genv = scheme_get_env(NULL); + phase = scheme_make_integer(genv->phase); + } + + return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, + scheme_sys_wraps_phase(phase), 0, 0); +} + +static Scheme_Object * +namespace_base_phase(int argc, Scheme_Object *argv[]) { Scheme_Env *genv; if ((argc > 0) && !SCHEME_NAMESPACEP(argv[0])) - scheme_wrong_type("namespace-module-identifier", "namespace", 0, argc, argv); + scheme_wrong_type("namespace-base-phase", "namespace", 0, argc, argv); if (argc) genv = (Scheme_Env *)argv[0]; else genv = scheme_get_env(NULL); - return scheme_datum_to_syntax(scheme_intern_symbol("module"), scheme_false, - scheme_sys_wraps_phase(genv->phase), 0, 0); + return scheme_make_integer(genv->phase); } static Scheme_Object * diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 8593acbaf2..a8d30c61c3 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -4664,7 +4664,8 @@ static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env if (SCHEME_STX_SYMBOLP(a)) { a = scheme_add_rename(a, genv->rename_set); module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), - scheme_false, scheme_sys_wraps_phase(genv->phase), + scheme_false, + scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), 0, 0); if (scheme_stx_module_eq(a, module_stx, genv->phase)) { /* Don't add renames to the whole module; let the diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 9bd89f4c3b..fda8a8f2e2 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -669,21 +669,25 @@ Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env) else phase = env->genv->phase; - return scheme_sys_wraps_phase(phase); + return scheme_sys_wraps_phase(scheme_make_integer(phase)); } -Scheme_Object *scheme_sys_wraps_phase(long phase) +Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) { Scheme_Object *rn, *w; + long p; - if ((phase == 0) && scheme_sys_wraps0) + if (SCHEME_INTP(phase)) + p = SCHEME_INT_VAL(phase); + else + p = -1; + + if ((p == 0) && scheme_sys_wraps0) return scheme_sys_wraps0; - if ((phase == 1) && scheme_sys_wraps1) + if ((p == 1) && scheme_sys_wraps1) return scheme_sys_wraps1; - rn = scheme_make_module_rename(scheme_make_integer(phase), - mzMOD_RENAME_NORMAL, - NULL); + rn = scheme_make_module_rename(phase, mzMOD_RENAME_NORMAL, NULL); /* Add a module mapping for all kernel provides: */ scheme_extend_module_rename_with_kernel(rn, kernel_modidx); @@ -692,11 +696,11 @@ Scheme_Object *scheme_sys_wraps_phase(long phase) w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); w = scheme_add_rename(w, rn); - if (phase == 0) { + if (p == 0) { REGISTER_SO(scheme_sys_wraps0); scheme_sys_wraps0 = w; } - if (phase == 1) { + if (p == 1) { REGISTER_SO(scheme_sys_wraps1); scheme_sys_wraps1 = w; } diff --git a/src/mzscheme/src/portfun.c b/src/mzscheme/src/portfun.c index 2fb8154b40..979bb80e1b 100644 --- a/src/mzscheme/src/portfun.c +++ b/src/mzscheme/src/portfun.c @@ -4542,7 +4542,9 @@ static Scheme_Object *do_load_handler(void *data) /* Replace `module' in read expression with one bound to #%kernel's `module': */ a = SCHEME_STX_CAR(obj); d = SCHEME_STX_CDR(obj); - a = scheme_datum_to_syntax(module_symbol, a, scheme_sys_wraps_phase(genv->phase), 0, 1); + a = scheme_datum_to_syntax(module_symbol, a, + scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), + 0, 1); d = scheme_make_pair(a, d); obj = scheme_datum_to_syntax(d, obj, scheme_false, 0, 1); as_module = 1; diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 86debf4aca..781276969c 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 916 +#define EXPECTED_PRIM_COUNT 917 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 5e4d2fc29d..81fc3c787e 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2577,7 +2577,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); -Scheme_Object *scheme_sys_wraps_phase(long phase); +Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase); Scheme_Env *scheme_new_module_env(Scheme_Env *env, Scheme_Module *m, int new_exp_module_tree); int scheme_is_module_env(Scheme_Comp_Env *env); diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index ef5ac07c47..0c97f8e6f2 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.0.1.2" +#define MZSCHEME_VERSION "4.0.1.3" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 05d05e0db7..806b9e4a69 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1878,6 +1878,8 @@ static void ref_validate(Scheme_Object *tl, Mz_CPort *port, static Scheme_Object * ref_optimize(Scheme_Object *tl, Optimize_Info *info) { + scheme_optimize_info_used_top(info); + info->preserves_marks = 1; info->single_result = 1; @@ -1887,7 +1889,8 @@ ref_optimize(Scheme_Object *tl, Optimize_Info *info) static Scheme_Object * ref_shift(Scheme_Object *data, int delta, int after_depth) { - return scheme_make_syntax_compiled(REF_EXPD, data); + return scheme_make_syntax_compiled(REF_EXPD, + scheme_optimize_shift(data, delta, after_depth)); } static Scheme_Object *