suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix some phase problems in program-processing programs

Browse Source 
svn: r10503
This commit is contained in:
Matthew Flatt 2008-06-29 15:11:20 +00:00
parent f4d5f5c085
commit 44c5a75739
19 changed files with 440 additions and 258 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/drscheme/private/debug.ss
View File

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

87
collects/errortrace/errortrace-lib.ss
View File

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

104
collects/errortrace/stacktrace.ss
View File

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

17
collects/gui-debugger/annotator.ss
View File

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

3
collects/lang/htdp-langs.ss
View File

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

224
collects/mzlib/pretty.ss
View File

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

2
collects/mzlib/private/sandbox-coverage.ss
View File

@ -62,7 +62,7 @@
e
(namespace-syntax-introduce
(datum->syntax-object #f e))))
#f)
(namespace-base-phase))
e)
immediate-eval?))))

25
collects/scribblings/reference/namespaces.scrbl
View File

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

43
collects/syntax/kerncase.ss
View File

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

73
collects/tests/mzscheme/pretty.ss
View File

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

36
src/mzscheme/src/cstartup.inc
View File

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

39
src/mzscheme/src/env.c
View File

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

3
src/mzscheme/src/eval.c
View File

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

22
src/mzscheme/src/module.c
View File

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

4
src/mzscheme/src/portfun.c
View File

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

2
src/mzscheme/src/schminc.h
View File

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

2
src/mzscheme/src/schpriv.h
View File

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

4
src/mzscheme/src/schvers.h
View File

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

5
src/mzscheme/src/syntax.c
View File

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