merge to trunk a while ago

svn: r14353

collects/2htdp/private/check-aux.ss

@@ -135,7 +135,7 @@
 ;; Symbol Any String -> Void
 (define (check-pos t c r)
   (check-arg 
-   t (and (number? c) (> (number->integer c) 0)) "positive integer" r c))
+   t (and (number? c) (>= (number->integer c) 0)) "positive integer" r c))
 
 ;; Symbol Any String String *-> Void
 (define (check-image tag i rank . other-message)

collects/2htdp/universe.ss

@@ -146,15 +146,18 @@
                                 (syntax-case #'E ()
                                   [(V) (set! rec? #'V)]
                                   [_ (err 'record? stx)]))
-                              (cons (syntax-e #'kw) (syntax E)))]
+                              (cons #'kw #;(syntax-e #'kw) (syntax E)))]
                            [_ (raise-syntax-error
                                'big-bang "not a legal big-bang clause" stx)]))
                        (syntax->list (syntax (s ...))))]
             ;; assert: all bind = (kw . E) and kw is constrained via Bind 
             [args (map (lambda (x) 
                          (define kw (car x))
-                         (define co (assq kw Spec))
+                         (define co ;; patch from Jay to allow rename on import
-                         (list kw ((cadr co) (cdr x))))
+                           (findf (lambda (n) (free-identifier=? kw (car n)))
+                                  (map (lambda (k s) (cons k (cdr s))) 
+                                       kwds Spec)))
+                         (list (syntax-e (car co)) ((cadr co) (cdr x))))
                        spec)])
        #`(send (new (if #,rec? aworld% world%) [world0 w]  #,@args) last))]))
 
@@ -276,7 +279,7 @@
                            [(kw . E)
                             (and (identifier? #'kw) 
                                  (for/or ([n kwds]) (free-identifier=? #'kw n)))
-                            (cons (syntax-e #'kw) (syntax E))]
+                            (cons #'kw (syntax E))]
                            [(kw E)
                             (and (identifier? #'kw) 
                                  (for/or ([n kwds]) (free-identifier=? #'kw n)))
@@ -285,6 +288,15 @@
                                'universe "not a legal universe clause" stx)]))
                        (syntax->list (syntax (bind ...))))]
             ;; assert: all bind = (kw . E) and kw is constrained via Bind 
+            [args (map (lambda (x) 
+                         (define kw (car x))
+                         (define co ;; patch from Jay to allow rename on import
+                           (findf (lambda (n) (free-identifier=? kw (car n)))
+                                  (map (lambda (k s) (cons k (cdr s))) 
+                                       kwds Spec)))
+                         (list (syntax-e (car co)) ((cadr co) (cdr x))))
+                       spec)]
+            #;
             [args (map (lambda (x) 
                          (define kw (car x))
                          (define co (assq kw Spec))

collects/compiler/xform.ss

@@ -1,6 +1,7 @@
 #lang scheme/base
 
 (require dynext/compile
+         setup/dirs
          (prefix-in xform: "private/xform.ss"))
 
 (provide xform)
@@ -11,7 +12,9 @@
                 (current-extension-preprocess-flags))]
         [headers (apply append
                         (map (current-make-compile-include-strings)
-                             header-dirs))])
+                             (append
+                              header-dirs
+                              (list (find-include-dir)))))])
     (xform:xform quiet?
                  (cons exe
                        (append flags headers))

collects/compiler/zo-parse.ss

@@ -927,7 +927,7 @@
 
    (define rst (read-bytes size* port))
 
-   (unless (eof-object? (read port))
+   (unless (eof-object? (read-byte port))
      (error 'not-end))
    
    (unless (= size* (bytes-length rst))

collects/deinprogramm/deinprogramm-langs.ss

@@ -177,6 +177,7 @@
               (run-in-user-thread
                (lambda ()
                  (read-accept-quasiquote (get-accept-quasiquote?))
+                 (ensure-drscheme-secrets-declared drs-namespace)
                  (namespace-attach-module drs-namespace ''drscheme-secrets)
                  (namespace-attach-module drs-namespace deinprogramm-struct-module-name)
                  (error-display-handler teaching-languages-error-display-handler)
@@ -244,6 +245,27 @@
           
           (super-new)))
 
+      ;; this inspector should be powerful enough to see
+      ;; any structure defined in the user's namespace
+      (define drscheme-inspector (current-inspector))
+
+      ;; FIXME: brittle, mimics drscheme-secrets
+      ;; as declared in lang/htdp-langs.ss.
+      ;; Is it even needed for DeinProgramm langs?
+      ;; Only used by htdp/hangman teachpack.
+      (define (ensure-drscheme-secrets-declared drs-namespace)
+        (parameterize ((current-namespace drs-namespace))
+          (define (declare)
+            (eval `(,#'module drscheme-secrets mzscheme
+                     (provide drscheme-inspector)
+                     (define drscheme-inspector ,drscheme-inspector)))
+            (namespace-require ''drscheme-secrets))
+          (with-handlers ([exn:fail? (lambda (e) (declare))])
+            ;; May have been declared by lang/htdp-langs tool, if loaded
+            (dynamic-require ''drscheme-secrets 'drscheme-inspector))
+          (void)))
+
+
       ;; {
       ;;   all this copied from collects/drscheme/private/language.ss
 
@@ -1051,24 +1073,31 @@
         answer)
       
       (define (stepper-settings-language %)
-        (class* % (stepper-language<%>)
+        (if (implementation? % stepper-language<%>)
-	  (init-field stepper:supported)
+            (class* % (stepper-language<%>)
-	  (define/override (stepper:supported?) stepper:supported)
+              (init-field stepper:supported)
-	  (define/override (stepper:render-to-sexp val settings language-level)
+              (define/override (stepper:supported?) stepper:supported)
-	    (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)])
+              (define/override (stepper:render-to-sexp val settings language-level)
-	      (set-print-settings
+                (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)])
-	       language-level
+                  (set-print-settings
-	       settings
+                   language-level
-	       (lambda () 
+                   settings
-		 (stepper-convert-value val settings)))))
+                   (lambda () 
-
+                     (stepper-convert-value val settings)))))
-	  (super-new)))
+              (super-new))
+            (class %
+              (init stepper:supported)
+              (super-new))))
 
       (define (debugger-settings-language %)
-	(class* % (debugger-language<%>)
+        (if (implementation? % debugger-language<%>)
-	  (init-field [debugger:supported #f])
+            (class* % (debugger-language<%>)
-	  (define/override (debugger:supported?) debugger:supported)
+              (init-field [debugger:supported #f])
-	  (super-new)))
+              (define/override (debugger:supported?) debugger:supported)
+              (super-new))
+            (class %
+              (init [debugger:supported #f])
+              (super-new))))
 
       ;; make-print-convert-hook:
       ;;   simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST)

collects/deinprogramm/scribblings/DMdA-lib.scrbl

@@ -10,7 +10,7 @@
                      lang/prim))
 
 @(define DMdA @italic{Die Macht der Abstraktion})
-@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm-langs.scrbl") s])
+@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm.scrbl") s])
 
 Note: This is documentation for the language levels that go with the
 German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die

collects/deinprogramm/scribblings/deinprogramm-langs.scrbl

@@ -1,25 +0,0 @@
-#lang scribble/doc
-@(require scribblings/htdp-langs/common)
-
-@title{Sprachebenen für @italic{Die Macht der Abstraktion}}
-
-Note: This is documentation for the language levels that go with the
-German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die
-Macht der Abstraktion}}.
-
-Die Sprachebenen in diesem Handbuch sind für Verwendung mit dem Buch
-the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der
-Abstraktion}} gedacht.
-
-@table-of-contents[]
-
-@;------------------------------------------------------------------------
-
-@include-section["DMdA-beginner.scrbl"]
-@include-section["DMdA-vanilla.scrbl"]
-@include-section["DMdA-assignments.scrbl"]
-@include-section["DMdA-advanced.scrbl"]
-
-@;------------------------------------------------------------------------
-
-@index-section[]

collects/deinprogramm/scribblings/deinprogramm.scrbl

@@ -0,0 +1,33 @@
+#lang scribble/doc
+
+@(require scribble/manual
+          (for-label scheme))
+
+@title[#:style '(toc) #:tag "deinprogramm"]{Sprachebenen und Material zu @italic{Die Macht der Abstraktion}}
+
+Note: This is documentation for the teachpacks that go with the German
+textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht
+der Abstraktion}}.
+
+Das Material in diesem Handbuch ist für die Verwendung mit dem Buch
+the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der
+Abstraktion}} gedacht.
+
+@table-of-contents[]
+
+@include-section["DMdA-beginner.scrbl"]
+@include-section["DMdA-vanilla.scrbl"]
+@include-section["DMdA-assignments.scrbl"]
+@include-section["DMdA-advanced.scrbl"]
+
+@include-section["ka.scrbl"]
+
+@include-section["image.scrbl"]
+@include-section["world.scrbl"]
+@include-section["turtle.scrbl"]
+@include-section["sound.scrbl"]
+@include-section["line3d.scrbl"]
+
+@include-section["DMdA-lib.scrbl"]
+
+@index-section[]

collects/deinprogramm/scribblings/info.ss

@@ -1,6 +1,4 @@
 #lang setup/infotab
 
-(define scribblings '(("deinprogramm-langs.scrbl" (multi-page) (language -14))
+(define scribblings '(("deinprogramm.scrbl" (multi-page) (language -14))))
-		      ("ka.scrbl" (multi-page) (other -10))
-		      ("DMdA-lib.scrbl")))
 

collects/drscheme/info.ss

@@ -1,6 +1,6 @@
 #lang setup/infotab
 
-(define tools      '("syncheck.ss"))
+(define tools      '("syncheck.ss" #;"sprof.ss"))
-(define tool-names '("Check Syntax"))
+(define tool-names '("Check Syntax" #;"Sampling Profiler"))
 (define mred-launcher-names     '("DrScheme"))
 (define mred-launcher-libraries '("drscheme.ss"))

collects/drscheme/private/language-configuration.ss

@@ -521,9 +521,9 @@
                                                             (send language default-settings)))]
                                                [else (values #f #f)])])
                                  (cond
-                                   [(not vis-lang) (void)]
+                                   [(and vis-lang
-                                   [(equal? (send vis-lang get-language-position)
+                                         (equal? (send vis-lang get-language-position)
-                                            (send language get-language-position))
+                                                 (send language get-language-position)))
                                     (get/set-settings vis-settings)
                                     (send details-panel active-child language-details-panel)]
                                    [else
@@ -761,8 +761,6 @@
         (send revert-to-defaults-outer-panel stretchable-height #f)
         (send outermost-panel set-alignment 'center 'center)
         
-        (update-show/hide-details)
-        
         (for-each add-language-to-dialog languages)
         (send languages-hier-list sort 
               (λ (x y)
@@ -820,6 +818,7 @@
           (get/set-selected-language-settings settings-to-show))
         (when details-shown?
           (do-construct-details))
+        (update-show/hide-details)
         (send languages-hier-list focus)
         (values
          (λ () selected-language)

collects/drscheme/sprof.ss

@@ -0,0 +1,398 @@
+#lang scheme/base
+(require scheme/gui/base
+         framework
+         scheme/class)
+
+;; how long between samples
+(define pause-time 0.1)
+
+;; gui updates occur every 'update-frequency' samples
+(define update-frequency 4)
+
+(define (make-prod-thread get-threads update-gui)
+  (thread (lambda ()
+            (define traces-table (make-hash))
+            (let loop ([i 0])
+              (sleep pause-time)
+              (let ([new-traces
+                     (map (λ (t) (continuation-mark-set->context (continuation-marks t)))
+                          (get-threads))])
+                (for-each
+                 (λ (trace)
+                   (for-each
+                    (λ (line)
+                      (hash-set! traces-table line (cons trace (hash-ref traces-table line '()))))
+                    trace))
+                 new-traces)
+                (cond
+                  [(zero? i)
+                   (update-gui traces-table)
+                   (loop update-frequency)]
+                  [else
+                   (loop (- i 1))]))))))
+
+(define (format-fn-name i)
+  (let ([id (car i)]
+        [src (cdr i)])
+    (cond
+      [id (format "~a" id)]
+      [src
+       (format "~a:~a~a"
+               (cond
+                 [(path? (srcloc-source src))
+                  (let-values ([(base name dir?) (split-path (srcloc-source src))])
+                    name)]
+                 [else (srcloc-source src)])
+               (if (srcloc-line src)
+                   (format "~a:~a"
+                           (srcloc-line src)
+                           (srcloc-column src))
+                   (srcloc-position src))
+               (if id
+                   (format ": ~a" id)
+                   ""))]
+      [else "???"])))
+
+(define (insert-long-fn-name t i)
+  (send t begin-edit-sequence)
+  (send t erase)
+  (let ([id (car i)]
+        [src (cdr i)])
+    (when src
+      (send t insert
+            (format "~a:~a"
+                    (srcloc-source src)
+                    (if (srcloc-line src)
+                        (format "~a:~a"
+                                (srcloc-line src)
+                                (srcloc-column src))
+                        (format ":~a" (srcloc-position src))))))
+    (when (and id src)
+      (send t insert "\n"))
+    (when id
+      (send t insert (format (format "~a" id))))
+    (unless (or id src)
+      (send t insert "???")))
+  (send t end-edit-sequence))
+
+(define (format-percentage n)
+  (let ([trunc (floor (* n 100))])
+    (format "~a%" (pad3 trunc))))
+
+(define (pad3 n)
+  (cond
+    [(< n 10) (format "00~a" n)]
+    [(< n 100) (format "0~a" n)]
+    [else (format "~a" n)]))
+
+(define cumulative-t%
+  (class text:basic%
+    (init-field open-button vp ec1 lp info-editor)
+    (inherit begin-edit-sequence
+             end-edit-sequence
+             erase
+             find-position 
+             get-admin
+             dc-location-to-editor-location
+             position-paragraph
+             insert
+             last-position
+             highlight-range
+             last-paragraph
+             lock)
+    
+    (define gui-display-data '())
+    (define clicked-srcloc-pr #f)
+    (define line-to-source (make-hasheq))
+
+    (define clear-old-pr void)
+    
+    (define/override (on-event event)
+      (cond
+        [(send event button-up? 'left)
+         (let ([admin (get-admin)])
+           (when admin
+             (let ([dc (send admin get-dc)])
+               (let-values ([(x y) (dc-location-to-editor-location (send event get-x)
+                                                                   (send event get-y))])
+                 (let* ([loc (find-position x y)]
+                        [para (position-paragraph loc)])
+                   (set! clicked-srcloc-pr (and (<= 0 para (last-paragraph))
+                                                (car (list-ref gui-display-data para))))
+                   (update-gui-display))))))]
+        [else (void)]))
+
+    (define/public (set-gui-display-data/refresh traces-table)
+      (set! gui-display-data
+            (sort (hash-map traces-table (λ (k v) (cons k v)))
+                  >
+                  #:key (λ (x) (length (cdr x)))))
+      (update-gui-display))
+    
+    (define/public (clear-clicked)
+      (set! clicked-srcloc-pr #f)
+      (update-gui-display))
+    
+    (define/private (update-gui-display)
+      (lock #f)
+      (begin-edit-sequence)
+      (erase)
+      (set! line-to-source (make-hasheq))
+      (clear-old-pr)
+      (set! clear-old-pr void)
+      (let* ([denom-ht (make-hasheq)]
+             [filtered-gui-display-data
+              (map 
+               (λ (pr)
+                 (let ([id (car pr)]
+                       [stacks (filter-stacks (cdr pr))])
+                   (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks)
+                   (cons id stacks)))
+               gui-display-data)]
+             [denom-count (hash-count denom-ht)])
+        (let loop ([prs filtered-gui-display-data]
+                   [first? #t]
+                   [i 0])
+          (cond
+            [(null? prs) (void)]
+            [else
+             (let* ([pr (car prs)]
+                    [fn (car pr)]
+                    [count (length (cdr pr))])
+               (cond
+                 [(zero? count)
+                  (loop (cdr prs) first? i)]
+                 [else
+                  (unless first? (insert "\n"))
+                  (let ([before (last-position)])
+                    (hash-set! line-to-source i pr)
+                    (insert (format-percentage (/ count denom-count)))
+                    (insert (format " ~a" (format-fn-name fn)))
+                    (let ([after (last-position)])
+                      (when (equal? (car pr) clicked-srcloc-pr)
+                        (set! clear-old-pr (highlight-range before after "NavajoWhite")))))
+                  (loop (cdr prs) #f (+ i 1))]))]))
+        (lock #t)
+        (end-edit-sequence)
+        (update-info-editor clicked-srcloc-pr)
+        (send open-button enable (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr)))))))
+    
+    (define/private (filter-stacks stacks)
+      (cond
+        [(not clicked-srcloc-pr) stacks]
+        [else
+         (filter (λ (stack) (ormap (λ (stack-ent) (equal? clicked-srcloc-pr stack-ent))
+                                   stack))
+                 stacks)]))
+         
+    (define/public (open-current-pr)
+      (when clicked-srcloc-pr
+        (let ([src (cdr clicked-srcloc-pr)])
+          (when (path? (srcloc-source src))
+            (printf "open ~s\n" (srcloc-source src))
+            (when (number? (srcloc-position src))
+              (printf "go to ~s\n" (srcloc-position src)))))))
+    
+    (define/private (update-info-editor pr)
+      (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1))))
+      (when pr
+        (insert-long-fn-name info-editor pr)))
+    
+    (super-new)))
+
+(define (construct-gui f)
+  (define info-editor (new text%))
+  (define vp (new vertical-panel% [parent f]))
+  (define ec1 (new editor-canvas% [parent vp]))
+  (define lp (new vertical-panel% [parent vp] [stretchable-height #f]))
+  (define ec2 (new editor-canvas%
+                   [parent lp]
+                   [min-height 100]
+                   [stretchable-height #f]
+                   [editor info-editor]))
+  (define bp (new horizontal-panel% [stretchable-height #f] [parent lp] [alignment '(center center)]))
+  (define open-button (new button%
+                           [parent bp]
+                           [label "Open"]
+                           [callback
+                            (λ (x y)
+                              (send cumulative-t open-current-pr))]))
+  (define unlock (new button%
+                      [label "Show All"]
+                      [parent bp]
+                      [callback
+                       (λ (x y)
+                         (send cumulative-t clear-clicked))]))
+  (define cumulative-t (new cumulative-t% 
+                            [open-button open-button]
+                            [vp vp]
+                            [ec1 ec1]
+                            [lp lp]
+                            [info-editor info-editor]))
+  (send ec1 set-editor cumulative-t)
+  (send vp change-children (λ (l) (list ec1)))
+  (send cumulative-t hide-caret #t)
+  (send cumulative-t lock #t)
+  (send info-editor auto-wrap #t)
+  (values vp cumulative-t))
+
+;; running an example outside of drscheme
+#;
+(begin
+  (define evt (make-eventspace))
+  (define f (parameterize ([current-eventspace evt])
+              (new frame%
+                   [label ""]
+                   [width 400]
+                   [height 800])))
+  (define-values (panel cumulative-t) (construct-gui f))
+  (send f show #t)
+  
+  (void (make-prod-thread (let ([t (current-thread)])
+                            (λ () (list t)))
+                          (λ (traces-table)
+                            (parameterize ([current-eventspace evt])
+                              (queue-callback
+                               (λ () 
+                                 (send cumulative-t set-gui-display-data/refresh traces-table)))))))
+  
+  (time (dynamic-require '(lib "scribblings/reference/reference.scrbl")
+                         #f)))
+
+;; tool code, for integration with drscheme
+(begin
+  (require drscheme/tool
+           scheme/unit
+           string-constants/string-constant)
+  
+  (define sc-show-sprof "Show SProfile")
+  (define sc-hide-sprof "Hide SProfile")
+  
+  (provide tool@)
+  (define tool@
+    (unit
+      (import drscheme:tool^)
+      (export drscheme:tool-exports^)     
+      (define (phase1) (void))
+      (define (phase2) (void))
+      
+      (define-local-member-name
+        show/hide-sprof-panel
+        update-sprof-panel
+        toggle-sprof-visiblity
+        stop-profiling-thread
+        start-profiling-thread
+        get-threads-to-profile)
+      
+      (define unit-frame-mixin
+        (mixin (drscheme:unit:frame<%>) ()
+          (inherit get-current-tab)
+          
+          (define main-panel #f)
+          (define sprof-main-panel #f)
+          (define everything-else #f)
+          (define cumulative-t #f)
+          (define show/hide-menu-item #f)
+          
+          (define/public (show/hide-sprof-panel show?)
+            (let ([main-children (send main-panel get-children)])
+              (send show/hide-menu-item 
+                    set-label
+                    (if show? sc-hide-sprof sc-show-sprof))
+              (unless (or (and show? (= 2 (length main-children)))
+                          (and (not show?) (= 1 (length main-children))))
+                (send main-panel change-children 
+                      (λ (l) 
+                        (if show?
+                            (list everything-else sprof-main-panel)
+                            (list everything-else)))))))
+          
+          (define/override (make-root-area-container cls parent)
+            (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent))
+            (set! everything-else (make-object cls main-panel))
+            (set!-values (sprof-main-panel cumulative-t) (construct-gui main-panel))
+            (send main-panel change-children (λ (l) (list everything-else)))
+            everything-else)
+          
+          (define/augment (on-tab-change from-tab to-tab)
+            (inner (void) on-tab-change from-tab to-tab)
+            (send to-tab update-sprof-panel))
+          
+          (define/override (add-show-menu-items show-menu)
+            (super add-show-menu-items show-menu)
+            (set! show/hide-menu-item
+                  (new menu-item%
+                       [parent show-menu]
+                       [label sc-show-sprof]
+                       [callback 
+                        (λ (x y)
+                          (send (get-current-tab) toggle-sprof-visiblity))])))
+          
+          ;; FIX: the cumulative-t text object shouldn't be handed out like this
+          ;; instead its contents need to be tab specific, so switching tabs
+          ;; (ala the update-sprof-panel method) should change the contents of
+          ;; the cumulative-t, presumably via the set-gui-display-data/refresh method.
+          (define/public (get-cumulative-t) cumulative-t)
+          
+          (super-new)))
+      
+      (define tab-mixin
+        (mixin (drscheme:unit:tab<%>) ()
+          (inherit get-frame get-ints)
+          (define prof-visible? #f)
+          (define/public (toggle-sprof-visiblity)
+            (set! prof-visible? (not prof-visible?))
+            (cond
+              [prof-visible?
+               (start-profiling-thread)]
+              [else
+               (stop-profiling-thread)])
+            (update-sprof-panel))
+          (define/public (update-sprof-panel)
+            (send (get-frame) show/hide-sprof-panel prof-visible?))
+          
+          (define profiling-thread #f)
+          
+          (define/public (stop-profiling-thread)
+            (when profiling-thread
+              (kill-thread profiling-thread))
+            (set! profiling-thread #f))
+          
+          (define current-traces-table #f)
+          
+          (define/public (start-profiling-thread)
+            (stop-profiling-thread)
+            (set! profiling-thread (make-prod-thread 
+                                    (λ () (send (get-ints) get-threads-to-profile))
+                                    (λ (traces-table)
+                                      (queue-callback
+                                       (λ ()
+                                         (send (send (get-frame) get-cumulative-t) set-gui-display-data/refresh traces-table)))))))
+          
+          (super-new)))
+      
+      (define system-custodian (current-custodian))
+      
+      (define repl-mixin
+        (mixin (drscheme:rep:text<%>) ()
+          (inherit get-user-custodian)
+          (define/public (get-threads-to-profile)
+            (let ([thds '()])
+              (let loop ([cust (get-user-custodian)])
+                (for-each
+                 (λ (obj)
+                   (cond 
+                     [(custodian? obj) (loop obj)]
+                     [(thread? obj) (set! thds (cons obj thds))]))
+                 (custodian-managed-list cust system-custodian)))
+              thds))
+
+          ;; FIX
+          ;; something needs to happen here so that the profiling gets shutdown when the repl dies.
+          ;; the right call back isn't obvious, tho. :(
+          
+          (super-new)))
+       
+      (drscheme:get/extend:extend-tab tab-mixin)
+      (drscheme:get/extend:extend-interactions-text repl-mixin)
+      (drscheme:get/extend:extend-unit-frame unit-frame-mixin))))

collects/drscheme/tool-lib.ss

@@ -673,8 +673,8 @@ all of the names in the tools library, for use defining keybindings
   (proc-doc/names
    drscheme:get/extend:extend-tab
    (case->
-    ((make-mixin-contract drscheme:unit:tab%) . -> . void?)
+    ((make-mixin-contract drscheme:unit:tab<%>) . -> . void?)
-    ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?))
+    ((make-mixin-contract drscheme:unit:tab<%>) boolean? . -> . void?))
    ((mixin) (mixin before?))
    
    @{This class implements the tabs in drscheme. One is created for each tab

collects/ffi/objc.scrbl

@@ -14,9 +14,7 @@
 
 @title{@bold{Objective-C} FFI}
 
-@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)]
+@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on
-
-@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on
 @schememodname[scheme/foreign] to support interaction with
 @link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.}
 

collects/ffi/private/objc-doc-unsafe.ss

@@ -6,5 +6,11 @@
 
 (objc-unsafe!)
 
-(provide (protect-out (all-defined-out))
+(provide (protect-out objc_msgSend/typed
+                      objc_msgSendSuper/typed
+                      import-class
+                      get-ivar set-ivar!
+                      selector
+                      tell tellv
+                      define-objc-class)
          (all-from-out ffi/objc))

collects/file/scribblings/tar.scrbl

@@ -1,6 +1,6 @@
 #lang scribble/doc
 @(require "common.ss"
-          (for-label file/tar))
+          (for-label file/tar file/gzip))
 
 @title[#:tag "tar"]{@exec{tar} File Creation}
 
@@ -13,7 +13,7 @@ information is not preserved; the owner that is stored in the archive
 is always ``root.''}
 
 @defproc[(tar [tar-file path-string?][path path-string?] ...) 
-         void?]{
+         exact-nonnegative-integer?]{
 
 Creates @scheme[tar-file], which holds the complete content of all
 @scheme[path]s.  The given @scheme[path]s are all expected to be
@@ -23,12 +23,18 @@ to the current directory).  If a nested path is provided as a
 resulting tar file, up to the current directory (using
 @scheme[pathlist-closure]).}
 
-@defproc[(tar->output [paths (listof path-string?)]
+@defproc[(tar->output [paths (listof path?)]
                       [out output-port? (current-output-port)])
-         void?]{
+         exact-nonnegative-integer?]{
 
 Packages each of the given @scheme[paths] in a @exec{tar} format
 archive that is written directly to the @scheme[out].  The specified
 @scheme[paths] are included as-is; if a directory is specified, its
 content is not automatically added, and nested directories are added
 without parent directories.}
+
+@defproc[(tar-gzip [tar-file path-string?] [paths path-string?] ...)
+         void?]{
+
+Like @scheme[tar], but compresses the resulting file with @scheme[gzip].
+}

collects/gui-debugger/debug-tool.ss

@@ -1006,14 +1006,6 @@
           (define/public (hide-debug)
             (send (get-frame) hide-debug))
           
-          (define/override (enable-evaluation)
-            (send (send (get-frame) get-debug-button) enable #t)
-            (super enable-evaluation))
-          
-          (define/override (disable-evaluation)
-            (send (send (get-frame) get-debug-button) enable #f)
-            (super disable-evaluation))
-          
           (super-new)))
       
       (define debug-bitmap 
@@ -1285,6 +1277,14 @@
           (inherit register-toolbar-button)
           (register-toolbar-button debug-button)
 
+          (define/augment (enable-evaluation)
+            (send debug-button enable #t)
+            (inner (void) enable-evaluation))
+
+          (define/augment (disable-evaluation)
+            (send debug-button enable #f)
+            (inner (void) disable-evaluation))
+
           (define pause-button
             (instantiate button% ()
               [label (make-pause-label this)]

collects/htdp/world.ss

@@ -183,8 +183,8 @@ Matthew
 ;                                                                              
 
 (define (nw:rectangle width height mode color)
-  (check-pos 'rectangle width "first")
+  (check-size/0 'nw:rectangle width "first")
-  (check-pos 'rectangle height "second")
+  (check-size/0 'nw:rectangle height "second")
   (check-mode 'rectangle mode "third")
   (check-color 'rectangle color "fourth")
   (put-pinhole (rectangle width height mode color) 0 0))
@@ -199,8 +199,8 @@ Matthew
     (place-image0 image x y scene)))
 
 (define (empty-scene width height)
-  (check-pos 'empty-scene width "first")
+  (check-size/0 'empty-scene width "first")
-  (check-pos 'empty-scene height "second")    
+  (check-size/0 'empty-scene height "second")    
   (put-pinhole 
    (overlay (rectangle width height 'solid 'white)
             (rectangle width height 'outline 'black))
@@ -253,8 +253,8 @@ Matthew
   (case-lambda 
     [(w h delta world) (big-bang w h delta world #f)]
     [(w h delta world animated-gif) 
-     (check-pos 'big-bang w "first")
+     (check-size/0 'big-bang w "first")
-     (check-pos 'big-bang h "second")
+     (check-size/0 'big-bang h "second")
      ;; ============================================
      ;; WHAT IF THEY ARE NOT INTs?
      ;; ============================================
@@ -361,8 +361,8 @@ Matthew
 (define run-simulation0
   (case-lambda
     [(width height rate f record?)
-     (check-pos 'run-simulation width "first")
+     (check-size/0 'run-simulation width "first")
-     (check-pos 'run-simulation height "second")
+     (check-size/0 'run-simulation height "second")
      (check-arg 'run-simulation (number? rate) 'number "third" rate)
      (check-proc 'run-simulation f 1 "fourth" "one argument")
      (check-arg 'run-simulation (boolean? record?) 'number "fifth [and optional]" record?)
@@ -390,9 +390,9 @@ Matthew
 ;                                     
 
 ;; Symbol Any String -> Void
-(define (check-pos tag c rank)
+(define (check-size/0 tag c rank)
-  (check-arg tag (and (number? c) (> (coerce c) 0))
+  (check-arg tag (and (number? c) (>= (coerce c) 0))
-             "positive integer" rank c))
+             "natural number" rank c))
 
 ;; Symbol Any String String *-> Void
 (define (check-image tag i rank . other-message)

collects/lang/htdp-langs.ss

@@ -864,7 +864,9 @@
               (init-field [debugger:supported #f])
               (define/override (debugger:supported?) debugger:supported)
               (super-new))
-            %))
+            (class %
+              (init [debugger:supported #f])
+              (super-new))))
 
       ;; filter/hide-ids : syntax[list] -> listof syntax
       (define (filter/hide-ids ids)

collects/macro-debugger/model/reductions.ss

@@ -3,7 +3,6 @@
 (require scheme/match
          "stx-util.ss"
          "deriv-util.ss"
-         "context.ss"
          "deriv.ss"
          "reductions-engine.ss")
 
@@ -61,7 +60,7 @@
         [#:when (not (bound-identifier=? e1 e2))
                 [#:walk e2 'resolve-variable]])]
     [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
-     (R ;; [#:hide-check rs] ;; FIXME: test and enable!!!
+     (R [#:hide-check rs]
         [! ?1]
         [#:pattern (?module ?name ?language . ?body-parts)]
         [! ?2]

collects/macro-debugger/syntax-browser/pretty-helper.ss

@@ -89,6 +89,13 @@
                  lp-datum)]
               [(pair? obj)
                (pairloop obj)]
+              [(struct? obj)
+               ;; Only traverse prefab structs
+               (let ([pkey (prefab-struct-key obj)])
+                 (if pkey
+                     (let-values ([(refold fields) (unfold-pstruct obj)])
+                       (refold (map loop fields)))
+                     obj))]
               [(symbol? obj)
                (unintern obj)]
               [(null? obj)
@@ -117,6 +124,14 @@
               flat=>stx
               stx=>flat))))
 
+;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list)
+(define (unfold-pstruct obj)
+  (define key (prefab-struct-key obj))
+  (define fields (cdr (vector->list (struct->vector obj))))
+  (values (lambda (new-fields)
+            (apply make-prefab-struct key new-fields))
+          fields))
+
 ;; check+convert-special-expression : syntax -> #f/syntaxish
 (define (check+convert-special-expression stx)
   (define stx-list (stx->list stx))

collects/macro-debugger/syntax-browser/pretty-printer.ss

@@ -56,7 +56,7 @@
     ;; Printing parameters (mzscheme manual 7.9.1.4)
     [print-unreadable #t]
     [print-graph #f]
-    [print-struct #f]
+    [print-struct #t]
     [print-box #t]
     [print-vector-length #t]
     [print-hash-table #f]

collects/macro-debugger/tool.ss

@@ -79,7 +79,6 @@
     (define drscheme-eventspace (current-eventspace))
 
     (define-local-member-name check-language)
-    (define-local-member-name get-debug-button)
     
     (define macro-debugger-bitmap 
       (make-object bitmap%
@@ -113,6 +112,13 @@
         (inherit register-toolbar-button)
         (register-toolbar-button macro-debug-button)
 
+        (define/augment (enable-evaluation)
+          (send macro-debug-button enable #t)
+          (inner (void) enable-evaluation))
+        (define/augment (disable-evaluation)
+          (send macro-debug-button enable #f)
+          (inner (void) disable-evaluation))
+
         (define/override (execute-callback)
           (execute #f))
 
@@ -120,8 +126,6 @@
           (send (get-interactions-text) enable-macro-debugging debugging?)
           (super execute-callback))
 
-        (define/public (get-debug-button) macro-debug-button)
-
         ;; Hide button for inappropriate languages
 
         (define/augment (on-tab-change old new)
@@ -157,17 +161,6 @@
           (inner (void) after-set-next-settings s))
         (super-new)))
 
-    (define (macro-debugger-tab-mixin %)
-      (class %
-        (inherit get-frame)
-        (define/override (enable-evaluation)
-          (super enable-evaluation)
-          (send (send (get-frame) get-debug-button) enable #t))
-        (define/override (disable-evaluation)
-          (super disable-evaluation)
-          (send (send (get-frame) get-debug-button) enable #f))
-        (super-new)))
-
     (define (macro-debugger-interactions-text-mixin %)
       (class %
         (super-new)
@@ -268,7 +261,5 @@
      macro-debugger-interactions-text-mixin)
     (drscheme:get/extend:extend-definitions-text
      macro-debugger-definitions-text-mixin)
-    (drscheme:get/extend:extend-tab
-     macro-debugger-tab-mixin)
 
     ))

collects/mzlib/deflate.ss

@@ -2062,7 +2062,7 @@
 
   (when header
     (put_short len)
-    (put_short (bitwise-not len))
+    (put_short (bitwise-and (bitwise-not len) #xFFFF))
     (set! bits_sent (+ bits_sent (* 2 16))))
 
   (set! bits_sent (+ bits_sent (<< len 3)))
@@ -2112,7 +2112,7 @@
 ;; /* Output a 32 bit value to the bit stream, lsb first */
 (define (put_long n)
   (put_short (bitwise-and #xFFFF n))
-  (put_short (>> n 16)))
+  (put_short (bitwise-and #xFFFF (>> n 16))))
 
 (define outcnt 0)
 (define bytes_out 0)

collects/mzlib/pretty.ss

@@ -1050,6 +1050,11 @@
 	 (pp-two-up expr extra pp-expr-list depth
                     apair? acar acdr open close))
 
+       (define (pp-module expr extra depth
+                          apair? acar acdr open close)
+         (pp-two-up expr extra pp-expr depth
+                    apair? acar acdr open close))
+
        (define (pp-make-object expr extra depth
                                apair? acar acdr open close)
 	 (pp-one-up expr extra pp-expr-list depth
@@ -1138,8 +1143,10 @@
 	   ((do letrec-syntaxes+values)
             (and (no-sharing? expr 2 apair? acdr)
                  pp-do))
-
+           ((module)
-	   ((send syntax-case instantiate module)
+            (and (no-sharing? expr 2 apair? acdr)
+                 pp-module))
+	   ((send syntax-case instantiate)
             (and (no-sharing? expr 2 apair? acdr)
                  pp-syntax-case))
 	   ((make-object)

collects/net/cgi-unit.ss

@@ -96,32 +96,47 @@
 ;; -- operates on the default input port; the second value indicates whether
 ;; reading stopped because an EOF was hit (as opposed to the delimiter being
 ;; seen); the delimiter is not part of the result
-(define (read-until-char ip delimiter)
+(define (read-until-char ip delimiter?)
   (let loop ([chars '()])
     (let ([c (read-char ip)])
       (cond [(eof-object? c) (values (reverse chars) #t)]
-            [(char=? c delimiter) (values (reverse chars) #f)]
+            [(delimiter? c) (values (reverse chars) #f)]
             [else (loop (cons c chars))]))))
 
+;; delimiter->predicate :
+;; symbol -> (char -> bool)
+;; returns a predicates to pass to read-until-char
+(define (delimiter->predicate delimiter)
+  (case delimiter
+    [(eq) (lambda (c) (char=? c #\=))]
+    [(amp) (lambda (c) (char=? c #\&))]
+    [(semi) (lambda (c) (char=? c #\;))]
+    [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))]))
+
 ;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool
 ;; -- If the first value is false, so is the second, and the third is true,
 ;; indicating EOF was reached without any input seen.  Otherwise, the first
 ;; and second values contain strings and the third is either true or false
 ;; depending on whether the EOF has been reached.  The strings are processed
 ;; to remove the CGI spec "escape"s.  This code is _slightly_ lax: it allows
-;; an input to end in `&'.  It's not clear this is legal by the CGI spec,
+;; an input to end in (current-alist-separator-mode).  
+;; It's not clear this is legal by the CGI spec,
 ;; which suggests that the last value binding must end in an EOF.  It doesn't
 ;; look like this matters.  It would also introduce needless modality and
 ;; reduce flexibility.
 (define (read-name+value ip)
-  (let-values ([(name eof?) (read-until-char ip #\=)])
+  (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))])
     (cond [(and eof? (null? name)) (values #f #f #t)]
           [eof?
            (generate-error-output
             (list "Server generated malformed input for POST method:"
                   (string-append
                    "No binding for `" (list->string name) "' field.")))]
-          [else (let-values ([(value eof?) (read-until-char ip #\&)])
+          [else (let-values ([(value eof?) 
+                              (read-until-char 
+                               ip 
+                               (delimiter->predicate
+                                (current-alist-separator-mode)))])
                   (values (string->symbol (query-chars->string name))
                           (query-chars->string value)
                           eof?))])))

collects/net/head-unit.ss

@@ -33,15 +33,15 @@
           [(and (= (+ offset 2) len)
                 (bytes=? CRLF/bytes (subbytes s offset len)))
            (void)] ; validated
-          [(= offset len) (error 'validate-header/bytes "missing ending CRLF")]
+          [(= offset len) (error 'validate-header "missing ending CRLF")]
           [(or (regexp-match re:field-start/bytes s offset)
                (regexp-match re:continue/bytes s offset))
            (let ([m (regexp-match-positions #rx#"\r\n" s offset)])
              (if m
                (loop (cdar m))
-               (error 'validate-header/bytes "missing ending CRLF")))]
+               (error 'validate-header "missing ending CRLF")))]
-          [else (error 'validate-header/bytes "ill-formed header at ~s"
+          [else (error 'validate-header "ill-formed header at ~s"
-                       (subbytes s offset (string-length s)))])))
+                       (subbytes s offset (bytes-length s)))])))
     ;; otherwise it should be a string:
     (begin
       (let ([m (regexp-match #rx"[^\000-\377]" s)])

collects/net/scribblings/cgi.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require "common.ss"
           (for-label net/cgi
+                     net/uri-codec
                      net/cgi-unit
                      net/cgi-sig))
 
@@ -41,7 +42,10 @@ Returns the bindings that corresponding to the options specified by
 the user.  The @scheme[get-bindings/post] and
 @scheme[get-bindings/get] variants work only when POST and GET forms
 are used, respectively, while @scheme[get-bindings] determines the
-kind of form that was used and invokes the appropriate function.}
+kind of form that was used and invokes the appropriate function.
+
+These functions respect @scheme[current-alist-separator-mode].
+}
 
 
 @defproc[(extract-bindings [key? (or/c symbol? string?)]

collects/parser-tools/lex.ss

@@ -81,7 +81,8 @@
                         (((special) act)
                            (not (ormap
                                  (lambda (x)
-                                   (module-or-top-identifier=? (syntax special) x))
+                                   (and (identifier? #'special)
+                                        (module-or-top-identifier=? (syntax special) x)))
                                  ids)))
                         (_ #t)))
                     spec/re-act-lst))

collects/parser-tools/parser-tools.scrbl

@@ -157,8 +157,8 @@ are a few examples, using @scheme[:] prefixed SRE syntax:
      action:
 
      @itemize{
-       @item{@scheme[start-pos] --- a position struct for the first character matched.}
+       @item{@scheme[start-pos] --- a @scheme[position] struct for the first character matched.}
-       @item{@scheme[end-pos] --- a position struct for the character after the last character in the match.}
+       @item{@scheme[end-pos] --- a @scheme[position] struct for the character after the last character in the match.}
        @item{@scheme[lexeme] --- the matched string.}
        @item{@scheme[input-port] --- the input-port being
             processed (this is useful for matching input with multiple
@@ -526,23 +526,27 @@ the right choice when using @scheme[lexer] in other situations.
 
       Each action is scheme code that has the same scope as its
       parser's definition, except that the variables @scheme[$1], ...,
-      @schemeidfont{$}@math{n} are bound, where @math{n} is the number
+      @schemeidfont{$}@math{i} are bound, where @math{i} is the number
       of @scheme[grammar-id]s in the corresponding production. Each
-      @schemeidfont{$}@math{i} is bound to the result of the action
+      @schemeidfont{$}@math{k} is bound to the result of the action
-      for the @math{i}@superscript{th} grammar symbol on the right of
+      for the @math{k}@superscript{th} grammar symbol on the right of
       the production, if that grammar symbol is a non-terminal, or the
       value stored in the token if the grammar symbol is a terminal.
       If the @scheme[src-pos] option is present in the parser, then
       variables @scheme[$1-start-pos], ...,
-      @schemeidfont{$}@math{n}@schemeidfont{-start-pos} and
+      @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and
       @scheme[$1-end-pos], ...,
-      @schemeidfont{$}@math{n}@schemeidfont{-end-pos} and are also
+      @schemeidfont{$}@math{i}@schemeidfont{-end-pos} and are also
       available, and they refer to the position structures
       corresponding to the start and end of the corresponding
       @scheme[grammar-symbol]. Grammar symbols defined as empty-tokens
-      have no @schemeidfont{$}@math{i} associated, but do have
+      have no @schemeidfont{$}@math{k} associated, but do have
+      @schemeidfont{$}@math{k}@schemeidfont{-start-pos} and
+      @schemeidfont{$}@math{k}@schemeidfont{-end-pos}.
+      Also @schemeidfont{$n-start-pos} and @schemeidfont{$n-end-pos}
+      are bound to the largest start and end positions, (i.e.,
       @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and
-      @schemeidfont{$}@math{i}@schemeidfont{-end-pos}.
+      @schemeidfont{$}@math{i}@schemeidfont{-end-pos}).
 
       All of the productions for a given non-terminal must be grouped
       with it. That is, no @scheme[non-terminal-id] may appear twice

collects/parser-tools/private-lex/actions.ss

@@ -1,19 +1,16 @@
-(module actions mzscheme
+#lang scheme/base
-  (provide (all-defined))
-  (require syntax/stx)
 
-  ;; get-special-action: (syntax-object list) syntax-object syntax-object  -> syntax-object
+(provide (all-defined-out))
-  ;; Returns the first action from a rule of the form ((which-special) action)
+(require syntax/stx)
-  (define (get-special-action rules which-special none)
-    (cond
-      ((null? rules) none)
-      (else
-       (syntax-case (car rules) ()
-         (((special) act)
-          (module-or-top-identifier=? (syntax special) which-special)
-          (syntax act))
-         (_ (get-special-action (cdr rules) which-special none))))))
 
-
+;; get-special-action: (syntax-object list) syntax-object syntax-object  -> syntax-object
-  
+;; Returns the first action from a rule of the form ((which-special) action)
-  )
+(define (get-special-action rules which-special none)
+  (cond
+    ((null? rules) none)
+    (else
+     (syntax-case (car rules) ()
+       (((special) act)
+        (and (identifier? #'special) (module-or-top-identifier=? (syntax special) which-special))
+        (syntax act))
+       (_ (get-special-action (cdr rules) which-special none))))))

collects/parser-tools/private-yacc/input-file-parser.ss

@@ -18,9 +18,10 @@
 
   (define stx-for-original-property (read-syntax #f (open-input-string "original")))
 
-  ;; get-args: ???
+  ;; get-args: ??? -> (values (listof syntax) (or/c #f (cons integer? stx)))
   (define (get-args i rhs src-pos term-defs)
-    (let ((empty-table (make-hash-table)))
+    (let ((empty-table (make-hash-table))
+          (biggest-pos #f))
       (hash-table-put! empty-table 'error #t)
       (for-each (lambda (td)
                   (let ((v (syntax-local-value td)))
@@ -29,24 +30,31 @@
                                     (hash-table-put! empty-table (syntax-object->datum s) #t))
                                   (syntax->list (e-terminals-def-t v))))))
                 term-defs)
-      (let get-args ((i i) 
+      (let ([args
-                     (rhs rhs))
+             (let get-args ((i i) 
-        (cond
+                            (rhs rhs))
-          ((null? rhs) null)
+               (cond
-          (else
+                 ((null? rhs) null)
-           (let ((b (car rhs))
+                 (else
-                 (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
+                  (let ((b (car rhs))
-                           (gensym)
+                        (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f))
-                           (string->symbol (format "$~a" i)))))
+                                  (gensym)
-             (cond
+                                  (string->symbol (format "$~a" i)))))
-               (src-pos
+                    (cond
-                `(,(datum->syntax-object b name b stx-for-original-property)
+                      (src-pos
-                  ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)
+                       (let ([start-pos-id
-                  ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)
+                              (datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)]
-                  ,@(get-args (add1 i) (cdr rhs))))
+                             [end-pos-id
-               (else
+                              (datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)])
-                `(,(datum->syntax-object b name b stx-for-original-property)
+                       (set! biggest-pos (cons start-pos-id end-pos-id))
-                  ,@(get-args (add1 i) (cdr rhs)))))))))))
+                       `(,(datum->syntax-object b name b stx-for-original-property)
+                         ,start-pos-id
+                         ,end-pos-id
+                         ,@(get-args (add1 i) (cdr rhs)))))
+                      (else
+                       `(,(datum->syntax-object b name b stx-for-original-property)
+                         ,@(get-args (add1 i) (cdr rhs)))))))))])
+        (values args biggest-pos))))
     
   ;; Given the list of terminal symbols and the precedence/associativity definitions,
   ;; builds terminal structures (See grammar.ss)
@@ -250,9 +258,18 @@
              ;; parse-action: syntax-object * syntax-object -> syntax-object
              (parse-action 
               (lambda (rhs act)
-                (quasisyntax/loc act
+                (let-values ([(args biggest) (get-args 1 (syntax->list rhs) src-pos term-defs)])
-                  (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs)
+                  (let ([act 
-                    #,act))))
+                         (if biggest
+                             (with-syntax ([$n-start-pos (datum->syntax-object (car biggest) '$n-start-pos)]
+                                           [$n-end-pos (datum->syntax-object (cdr biggest) '$n-end-pos)])
+                               #`(let ([$n-start-pos #,(car biggest)]
+                                       [$n-end-pos #,(cdr biggest)])
+                                   #,act))
+                             act)])
+                    (quasisyntax/loc act
+                      (lambda #,args
+                        #,act))))))
              
 	     ;; parse-prod+action: non-term * syntax-object -> production
 	     (parse-prod+action

collects/parser-tools/private-yacc/table.ss

@@ -1,4 +1,4 @@
-(module table mzscheme
+#lang scheme/base
 
   ;; Routine to build the LALR table
   
@@ -31,14 +31,14 @@
     (list->vector
      (map
       (lambda (state-entry)
-        (let ((ht (make-hash-table 'equal)))
+        (let ((ht (make-hash)))
           (for-each
            (lambda (gs/actions)
-             (let ((group (hash-table-get ht (car gs/actions) (lambda () null))))
+             (let ((group (hash-ref ht (car gs/actions) (lambda () null))))
                (unless (member (cdr gs/actions) group)
-                 (hash-table-put! ht (car gs/actions) (cons (cdr gs/actions) group)))))
+                 (hash-set! ht (car gs/actions) (cons (cdr gs/actions) group)))))
            state-entry)
-          (hash-table-map ht cons)))
+          (hash-map ht cons)))
       (vector->list table))))
   
   ;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) ->
@@ -119,19 +119,23 @@
                  (print-entry sym (car act) port))
                 (else
                  (fprintf port "begin conflict:~n")
-                 (if (> (count reduce? act) 1)
+                 (when (> (count reduce? act) 1)
-                     (set! RR-conflicts (add1 RR-conflicts)))
+                   (set! RR-conflicts (add1 RR-conflicts)))
-                 (if (> (count shift? act) 0)
+                 (when (> (count shift? act) 0)
-                     (set! SR-conflicts (add1 SR-conflicts)))
+                   (set! SR-conflicts (add1 SR-conflicts)))
                  (map (lambda (x) (print-entry sym x port)) act)
                  (fprintf port "end conflict~n")))))
            (vector-ref grouped-table (kernel-index state)))
           (newline port)))
       
       (when (> SR-conflicts 0)
-        (fprintf port "~a shift/reduce conflicts~n" SR-conflicts))
+        (fprintf port "~a shift/reduce conflict~a~n" 
+                 SR-conflicts
+                 (if (= SR-conflicts 1) "" "s")))
       (when (> RR-conflicts 0)
-        (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts))))
+        (fprintf port "~a reduce/reduce conflict~a~n"
+                 RR-conflicts
+                 (if (= RR-conflicts 1) "" "s")))))
   
   ;; resolve-conflict : (listof action?) -> action? bool bool
   (define (resolve-conflict actions)
@@ -176,12 +180,14 @@
       (unless suppress
         (when (> SR-conflicts 0)
           (fprintf (current-error-port) 
-                   "~a shift/reduce conflicts~n" 
+                   "~a shift/reduce conflict~a~n" 
-                   SR-conflicts))
+                   SR-conflicts
+                   (if (= SR-conflicts 1) "" "s")))
         (when (> RR-conflicts 0)
           (fprintf (current-error-port)
-                   "~a reduce/reduce conflicts~n"
+                   "~a reduce/reduce conflict~a~n"
-                   RR-conflicts)))
+                   RR-conflicts
+                   (if (= RR-conflicts 1) "" "s"))))
       table))
   
 
@@ -230,7 +236,7 @@
            (end-terms (send g get-end-terms))
            (table (make-parse-table (send a get-num-states)))
            (get-lookahead (compute-LA a g))
-           (reduce-cache (make-hash-table 'equal)))
+           (reduce-cache (make-hash)))
 
       (for-each
        (lambda (trans-key/state)
@@ -256,17 +262,17 @@
                (bit-vector-for-each 
                 (lambda (term-index)
                   (unless (start-item? item)
-                    (let ((r (hash-table-get reduce-cache item-prod
+                    (let ((r (hash-ref reduce-cache item-prod
                                              (lambda ()
                                                (let ((r (make-reduce item-prod)))
-                                                 (hash-table-put! reduce-cache item-prod r)
+                                                 (hash-set! reduce-cache item-prod r)
                                                  r)))))
                       (table-add! table
                                   (kernel-index state)
                                   (vector-ref term-vector term-index)
                                   r))))
                 (get-lookahead state item-prod))))
-           (append (hash-table-get (send a get-epsilon-trans) state (lambda () null))
+           (append (hash-ref (send a get-epsilon-trans) state (lambda () null))
                    (filter (lambda (item)
                              (not (move-dot-right item)))
                            (kernel-items state))))))
@@ -277,13 +283,12 @@
                            (lambda (e)
                              (fprintf 
                               (current-error-port)
-                              "Cannot write debug output to file \"~a\".~n"
+                              "Cannot write debug output to file \"~a\": ~a\n"
-                              file)))]
+                              file
+                              (exn-message e))))]
             (call-with-output-file file
               (lambda (port)
-                (display-parser a grouped-table (send g get-prods) port)))))
+                (display-parser a grouped-table (send g get-prods) port))
+              #:exists 'truncate)))
         (resolve-conflicts grouped-table suppress))))
   
-  )
-
-

collects/parser-tools/yacc.ss

@@ -1,9 +1,10 @@
-(module yacc mzscheme
+#lang scheme/base
 
-  (require-for-syntax "private-yacc/parser-builder.ss"
+(require (for-syntax scheme/base
-                      "private-yacc/grammar.ss"
+                     "private-yacc/parser-builder.ss"
-                      "private-yacc/yacc-helper.ss"
+                     "private-yacc/grammar.ss"
-                      "private-yacc/parser-actions.ss")
+                     "private-yacc/yacc-helper.ss"
+                     "private-yacc/parser-actions.ss"))
   (require "private-lex/token.ss"
            "private-yacc/parser-actions.ss"
            mzlib/etc
@@ -19,12 +20,12 @@
     (list->vector
      (map
       (lambda (state-entry)
-        (let ((ht (make-hash-table)))
+        (let ((ht (make-hasheq)))
           (for-each
            (lambda (gs/action)
-             (hash-table-put! ht
+             (hash-set! ht
-                              (gram-sym-symbol (car gs/action))
+                        (gram-sym-symbol (car gs/action))
-                              (action->runtime-action (cdr gs/action))))
+                        (action->runtime-action (cdr gs/action))))
            state-entry)
           ht))
       (vector->list table))))
@@ -177,13 +178,14 @@
                                  yacc-output)))]
                (call-with-output-file yacc-output
                  (lambda (port)
-                   (display-yacc (syntax-object->datum grammar) 
+                   (display-yacc (syntax->datum grammar) 
                                  tokens 
-                                 (map syntax-object->datum start)
+                                 (map syntax->datum start)
                                  (if precs
-                                     (syntax-object->datum precs)
+                                     (syntax->datum precs)
                                      #f)
-                                 port)))))
+                                 port))
+                 #:exists 'truncate)))
            (with-syntax ((check-syntax-fix check-syntax-fix)
                          (err error)
                          (ends end)
@@ -245,7 +247,7 @@
   (define (extract-no-src-pos ip)
     (extract-helper ip #f #f))
   
-  (define-struct stack-frame (state value start-pos end-pos) (make-inspector))
+  (define-struct stack-frame (state value start-pos end-pos) #:inspector (make-inspector))
   
   (define (make-empty-stack i) (list (make-stack-frame i #f #f #f)))
   
@@ -304,17 +306,17 @@
                           (remove-states)))))))))
             
             (define (find-action stack tok val start-pos end-pos)
-              (unless (hash-table-get all-term-syms
+              (unless (hash-ref all-term-syms
-                                      tok
+                                tok
-                                      (lambda () #f))
+                                #f)
                 (if src-pos
                     (err #f tok val start-pos end-pos)
                     (err #f tok val))
                 (raise-read-error (format "parser: got token of unknown type ~a" tok)
                                   #f #f #f #f #f))
-              (hash-table-get (vector-ref table (stack-frame-state (car stack)))
+              (hash-ref (vector-ref table (stack-frame-state (car stack)))
-                              tok
+                        tok
-                              (lambda () #f)))
+                        #f))
 
             (define (make-parser start-number)
               (lambda (get-token)
@@ -341,7 +343,7 @@
                                                      src-pos)))
                            (let ((goto 
                                   (runtime-goto-state
-                                   (hash-table-get 
+                                   (hash-ref 
                                     (vector-ref table (stack-frame-state (car new-stack)))
                                     (runtime-reduce-lhs action)))))
                              (parsing-loop 
@@ -378,4 +380,3 @@
            (cond
              ((null? l) null)
              (else (cons (make-parser i) (loop (cdr l) (add1 i))))))))))
-  )

collects/r5rs/main.ss

@@ -1,10 +1,14 @@
 
 (module main scheme/base
   (require scheme/mpair
-           (for-syntax scheme/base syntax/kerncase)
+           (for-syntax scheme/base syntax/kerncase
+                       "private/r5rs-trans.ss")
            (only-in mzscheme transcript-on transcript-off))
 
-  (provide (for-syntax syntax-rules ...)
+  (provide (for-syntax syntax-rules ...
+                       (rename-out [syntax-rules-only #%top]
+                                   [syntax-rules-only #%app]
+                                   [syntax-rules-only #%datum]))
            (rename-out
             [mcons cons]
             [mcar car]

collects/r5rs/private/r5rs-trans.ss

@@ -0,0 +1,11 @@
+#lang scheme/base
+(require (for-syntax scheme/base))
+(provide syntax-rules-only)
+
+(define-syntax (syntax-rules-only stx)
+  (syntax-case stx ()
+    [(_ . form)
+     (raise-syntax-error
+      'macro-transformer
+      "only a `syntax-rules' form is allowed"
+      #'form)]))

collects/r5rs/r5rs.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require scribble/manual
-          (for-label r5rs
+          (for-label (only-meta-in 0 r5rs)
+                     (only-in r5rs syntax-rules ...)
                      (only-in mzscheme #%plain-module-begin)
                      (only-in scheme/mpair mmap)
                      (only-in scheme/contract one-of/c)

collects/redex/private/matcher.ss

@@ -18,8 +18,6 @@ before the pattern compiler is invoked.
 
 (define-struct compiled-pattern (cp))
 
-(define count 0)
-
 (define caching-enabled? (make-parameter #t))
 
 ;; lang = (listof nt)

collects/redex/private/rg-test.ss

@@ -530,6 +530,14 @@
          (decisions #:nt (patterns fourth first first second first first first)
                     #:var (list (λ _ 'x) (λ _ 'y))))
         (term (λ (x) (hole y)))))
+(let ()
+  (define-language L
+    (a ((a ...) ...)))
+  (test (generate-term/decisions
+         L (cross a) 3 0 
+         (decisions #:nt (patterns second first)
+                    #:seq (list (λ _ 0) (λ _ 0) (λ _ 0) (λ _ 0))))
+        (term ((hole)))))
 
 ;; generation failures increase size and attempt
 (let ()

collects/redex/private/rg.ss

@@ -620,7 +620,7 @@ To do a better job of not generating programs with free variables,
   (struct-copy 
    compiled-lang lang
    [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))]
-   [cclang (map (parse-nt 'top-level) (compiled-lang-cclang lang))]))
+   [cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))]))
 
 ;; unparse-pattern: parsed-pattern -> pattern
 (define unparse-pattern

collects/scheme/list.ss

@@ -20,6 +20,7 @@
          add-between
          remove-duplicates
          filter-map
+         count
          partition
 
          argmin
@@ -237,6 +238,27 @@
         (let ([x (f (car l))])
           (if x (cons x (loop (cdr l))) (loop (cdr l))))))))
 
+;; very similar to `filter-map', one more such function will justify some macro
+(define (count f l . ls)
+  (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls))))
+    (raise-type-error
+     'count (format "procedure (arity ~a)" (add1 (length ls))) f))
+  (unless (and (list? l) (andmap list? ls))
+    (raise-type-error
+     'count "proper list"
+     (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls))))
+  (if (pair? ls)
+    (let ([len (length l)])
+      (if (andmap (lambda (l) (= len (length l))) ls)
+        (let loop ([l l] [ls ls] [c 0])
+          (if (null? l)
+            c
+            (loop (cdr l) (map cdr ls)
+                  (if (apply f (car l) (map car ls)) (add1 c) c))))
+        (error 'count "all lists must have same size")))
+    (let loop ([l l] [c 0])
+      (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c))))))
+
 ;; Originally from srfi-1 -- shares common tail with the input when possible
 ;; (define (partition f l)
 ;;   (unless (and (procedure? f) (procedure-arity-includes? f 1))

collects/scheme/local.ss

@@ -1,66 +1,7 @@
 #lang scheme/base
-
+(require (for-syntax scheme/base)
-(require (for-syntax scheme/base
+         "private/local.ss")
-                     syntax/context
-                     syntax/kerncase))
-
 (provide local)
 
 (define-syntax (local stx)
-  (syntax-case stx ()
+  (do-local stx #'letrec-syntaxes+values))
-    [(_ (defn ...) body1 body ...)
-     (let ([defs (let ([expand-context (generate-expand-context)])
-                   (let loop ([defns (syntax->list (syntax (defn ...)))])
-                     (apply
-                      append
-                      (map
-                       (lambda (defn)
-                         (let ([d (local-expand
-                                   defn
-                                   expand-context
-                                   (kernel-form-identifier-list))]
-                               [check-ids (lambda (ids)
-                                            (for-each
-                                             (lambda (id)
-                                               (unless (identifier? id)
-                                                 (raise-syntax-error
-                                                  #f
-                                                  "not an identifier for definition"
-                                                  stx
-                                                  id)))
-                                             ids))])
-                           (syntax-case d (define-values define-syntaxes begin)
-                             [(begin defn ...)
-                              (loop (syntax->list (syntax (defn ...))))]
-                             [(define-values (id ...) body)
-                              (begin
-                                (check-ids (syntax->list (syntax (id ...))))
-                                (list d))]
-                             [(define-values . rest)
-                              (raise-syntax-error
-                               #f "ill-formed definition" stx d)]
-                             [(define-syntaxes (id ...) body)
-                              (begin
-                                (check-ids (syntax->list (syntax (id ...))))
-                                (list d))]
-                             [(define-syntaxes . rest)
-                              (raise-syntax-error
-                               #f "ill-formed definition" stx d)]
-                             [_else
-                              (raise-syntax-error
-                               #f "not a definition" stx defn)])))
-                       defns))))])
-       (let ([ids (apply append
-                         (map
-                          (lambda (d)
-                            (syntax-case d ()
-                              [(_ ids . __) (syntax->list (syntax ids))]))
-                          defs))])
-         (let ([dup (check-duplicate-identifier ids)])
-           (when dup
-             (raise-syntax-error #f "duplicate identifier" stx dup)))
-         (with-syntax ([(def ...) defs])
-           (syntax/loc stx
-             (let () def ... (let () body1 body ...))))))]
-    [(_ x body1 body ...)
-     (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))

collects/scheme/math.ss

@@ -7,7 +7,7 @@
 (provide pi
          sqr
          sgn conjugate
-         sinh cosh)
+         sinh cosh tanh)
 
 (define (sqr z) (* z z))
 
@@ -29,3 +29,5 @@
 
 (define (cosh x)
   (/ (+ (exp x) (exp (- x))) 2.0))
+
+(define (tanh x) (/ (sinh x) (cosh x)))

collects/scheme/private/class-internal.ss

@@ -148,10 +148,12 @@
 
   (define-for-syntax not-in-a-class
     (lambda (stx)
-      (raise-syntax-error
+      (if (eq? (syntax-local-context) 'expression)
-       #f
+          (raise-syntax-error
-       "use of a class keyword is not in a class"
+           #f
-       stx)))
+           "use of a class keyword is not in a class"
+           stx)
+          (quasisyntax/loc stx (#%expression #,stx)))))
 
   (define-syntax define/provide-context-keyword
     (syntax-rules ()

collects/scheme/private/contract-guts.ss

@@ -356,7 +356,9 @@
 (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
 (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
 (define (flat-named-contract name predicate)
-  (coerce-flat-contract 'flat-named-contract predicate)
+  (unless (and (procedure? predicate)
+               (procedure-arity-includes? predicate 1))
+    (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate))
   (make-predicate-contract name predicate))
 
 ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)

collects/scheme/private/local.ss

@@ -0,0 +1,104 @@
+#lang scheme/base
+(require (for-syntax scheme/base)
+         (for-syntax syntax/context)
+         (for-syntax syntax/kerncase))
+(provide (for-syntax do-local))
+
+(define-for-syntax (do-local stx letrec-syntaxes+values-id)
+  (syntax-case stx ()
+    [(_ (defn ...) body1 body ...)
+     (let* ([def-ctx (syntax-local-make-definition-context)]
+            [defs (let ([expand-context (cons (gensym 'intdef)
+                                              (let ([orig-ctx (syntax-local-context)])
+                                                (if (pair? orig-ctx)
+                                                    orig-ctx
+                                                    null)))])
+                    (let loop ([defns (syntax->list (syntax (defn ...)))])
+                      (apply
+                       append
+                       (map
+                        (lambda (defn)
+                          (let ([d (local-expand
+                                    defn
+                                    expand-context
+                                    (kernel-form-identifier-list)
+                                    def-ctx)]
+                                [check-ids (lambda (defn ids)
+                                             (for-each
+                                              (lambda (id)
+                                                (unless (identifier? id)
+                                                  (raise-syntax-error
+                                                   #f
+                                                   "not an identifier for definition"
+                                                   defn
+                                                   id)))
+                                              ids))])
+                            (syntax-case d (define-values define-syntaxes begin)
+                              [(begin defn ...)
+                               (loop (syntax->list (syntax (defn ...))))]
+                              [(define-values (id ...) body)
+                               (let ([ids (syntax->list (syntax (id ...)))])
+                                 (check-ids d ids)
+                                 (syntax-local-bind-syntaxes ids #f def-ctx)
+                                 (list d))]
+                              [(define-values . rest)
+                               (raise-syntax-error
+                                #f "ill-formed definition" stx d)]
+                              [(define-syntaxes (id ...) rhs)
+                               (let ([ids (syntax->list (syntax (id ...)))])
+                                 (check-ids d ids)
+                                 (with-syntax ([rhs (local-transformer-expand
+                                                     #'rhs
+                                                     'expression
+                                                     null)])
+                                   (syntax-local-bind-syntaxes ids #'rhs def-ctx)
+                                   (list (quasisyntax/loc d (define-syntaxes #,ids rhs)))))]
+                              [(define-syntaxes . rest)
+                               (raise-syntax-error
+                                #f "ill-formed definition" stx d)]
+                              [_else
+                               (raise-syntax-error
+                                #f "not a definition" stx defn)])))
+                        defns))))])
+       (internal-definition-context-seal def-ctx)
+       (let ([ids (apply append
+                         (map
+                          (lambda (d)
+                            (syntax-case d ()
+                              [(_ ids . __) (syntax->list (syntax ids))]))
+                          defs))]
+             [vbindings (apply append
+                               (map (lambda (d)
+                                      (syntax-case d (define-values)
+                                        [(define-values ids rhs)
+                                         (list #'(ids rhs))]
+                                        [_ null]))
+                                    defs))]
+             [sbindings (apply append
+                               (map (lambda (d)
+                                      (syntax-case d (define-syntaxes)
+                                        [(define-syntaxes ids rhs)
+                                         (list #'(ids rhs))]
+                                        [_ null]))
+                                    defs))])
+         (let ([dup (check-duplicate-identifier ids)])
+           (when dup
+             (raise-syntax-error #f "duplicate identifier" stx dup)))
+         (with-syntax ([sbindings sbindings]
+                       [vbindings vbindings]
+                       [LSV letrec-syntaxes+values-id]
+                       [(body ...)
+                        (map (lambda (stx)
+                               ;; add def-ctx:
+                               (let ([q (local-expand #`(quote #,stx)
+                                                      'expression
+                                                      (list #'quote)
+                                                      def-ctx)])
+                                 (syntax-case q ()
+                                   [(_ stx) #'stx])))
+                             (syntax->list #'(body1 body ...)))])
+           (syntax/loc stx
+             (LSV sbindings vbindings
+               body ...)))))]
+    [(_ x body1 body ...)
+     (raise-syntax-error #f "not a definition sequence" stx (syntax x))]))

collects/scheme/private/reqprov.ss

@@ -317,12 +317,12 @@
                                (syntax->list #'(elem ...))))]
                   [_ (transform-simple in 0 #| run phase |#)]))])
       (syntax-case stx ()
-        [(_ in ...)
+        [(_ in)
-         (with-syntax ([(new-in ...)
+         (with-syntax ([(new-in ...) (transform-one #'in)])
-                        (apply append
-                               (map transform-one (syntax->list #'(in ...))))])
            (syntax/loc stx
-             (#%require new-in ...)))])))
+             (#%require new-in ...)))]
+        [(_ in ...)
+         (syntax/loc stx (begin (require in) ...))])))
 
   ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;; require transformers
@@ -653,7 +653,16 @@
                      (memq 0 modes))
                  (map (lambda (id)
                         (make-export id (syntax-e id) 0 #f stx))
-                      (filter (same-ctx? free-identifier=?)
+                      (filter (lambda (id)
+                                (and ((same-ctx? free-identifier=?) id)
+                                     (let-values ([(v id) (syntax-local-value/immediate
+                                                           id
+                                                           (lambda () (values #f #f)))])
+                                       (not
+                                        (and (rename-transformer? v)
+                                             (syntax-property 
+                                              (rename-transformer-target v)
+                                              'not-provide-all-defined))))))
                               ids))
                  null)))]))))
 

collects/scheme/sandbox.ss

@@ -627,6 +627,7 @@
   (define user-thread   #t) ; set later to the thread
   (define user-done-evt #t) ; set in the same place
   (define terminated?   #f) ; set to an exception value when the sandbox dies
+  (define breaks-originally-enabled? (break-enabled))
   (define (limit-thunk thunk)
     (let* ([sec (and limits (car limits))]
            [mb  (and limits (cadr limits))]
@@ -665,42 +666,67 @@
   (define (user-break)
     (when user-thread (break-thread user-thread)))
   (define (user-process)
-    (with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
+    (let ([break-paramz (current-break-parameterization)])
-      ;; first set up the environment
+      (parameterize-break
-      (init-hook)
+       #f ;; disable breaks during administrative work
-      ((sandbox-init-hook))
+       (with-handlers ([void (lambda (exn) (channel-put result-ch exn))])
-      ;; now read and evaluate the input program
+         (call-with-break-parameterization
-      (evaluate-program
+          break-paramz
-       (if (procedure? program-maker) (program-maker) program-maker)
+          (lambda ()
-       limit-thunk
+            ;; enable breaks, maybe
-       (and coverage? (lambda (es+get) (set! uncovered es+get))))
+            (when breaks-originally-enabled? (break-enabled #t))
-      (channel-put result-ch 'ok))
+            ;; first set up the environment
-    (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
+            (init-hook)
-    ;; finally wait for interaction expressions
+            ((sandbox-init-hook))
-    (let ([n 0])
+            ;; now read and evaluate the input program
-      (let loop ()
+            (evaluate-program
-        (let ([expr (channel-get input-ch)])
+             (if (procedure? program-maker) (program-maker) program-maker)
-          (when (eof-object? expr)
+             limit-thunk
-            (terminated! 'eof) (channel-put result-ch expr) (user-kill))
+             (and coverage? (lambda (es+get) (set! uncovered es+get))))))
-          (with-handlers ([void (lambda (exn)
+         (channel-put result-ch 'ok))
-                                  (channel-put result-ch (cons 'exn exn)))])
+       (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler
-            (define run
+       ;; finally wait for interaction expressions
-              (if (evaluator-message? expr)
+       (let ([n 0])
-                (case (evaluator-message-msg expr)
+         (let loop ()
-                  [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
+           (let ([expr (channel-get input-ch)])
-                  [(thunk*) (car (evaluator-message-args expr))]
+             (when (eof-object? expr)
-                  [else (error 'sandbox "internal error (bad message)")])
+               (terminated! 'eof) (channel-put result-ch expr) (user-kill))
-                (limit-thunk
+             (with-handlers ([void (lambda (exn)
-                 (lambda ()
+                                     (channel-put result-ch (cons 'exn exn)))])
-                   (set! n (add1 n))
+               (define run
-                   (eval* (map (lambda (expr) (cons '#%top-interaction expr))
+                 (if (evaluator-message? expr)
-                               (input->code (list expr) 'eval n)))))))
+                     (case (evaluator-message-msg expr)
-            (channel-put result-ch (cons 'vals (call-with-values run list))))
+                       [(thunk) (limit-thunk (car (evaluator-message-args expr)))]
-          (loop)))))
+                       [(thunk*) (car (evaluator-message-args expr))]
+                       [else (error 'sandbox "internal error (bad message)")])
+                     (limit-thunk
+                      (lambda ()
+                        (set! n (add1 n))
+                        (eval* (map (lambda (expr) (cons '#%top-interaction expr))
+                                    (input->code (list expr) 'eval n)))))))
+               (channel-put result-ch (cons 'vals 
+                                            (call-with-break-parameterization
+                                             break-paramz
+                                             (lambda ()
+                                               (call-with-values run list))))))
+             (loop)))))))
   (define (get-user-result)
-    (with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f))
+    (if (and (sandbox-propagate-breaks)
-                     (lambda (e) (user-break) (get-user-result))])
+             ;; The following test is weird. We reliably catch breaks if breaks
-      (sync user-done-evt result-ch)))
+             ;; are enabled, except that a break just before or after isn't
+             ;; reliably propagated. A `get-result/enable-breaks' function
+             ;; would make more sense.
+             (break-enabled))
+        ;; The following loop ensures that breaks are disabled while trying
+        ;; to handle a break, which ensures that we don't fail to
+        ;; propagate a break.
+        (parameterize-break
+         #f
+         (let loop ()
+           (with-handlers* ([exn:break? (lambda (e) (user-break) (loop))])
+             (sync/enable-break user-done-evt result-ch))))
+        ;; The simple case doesn't have to deal with breaks:
+        (sync user-done-evt result-ch)))
   (define (user-eval expr)
     ;; the thread will usually be running, but it might be killed outside of
     ;; the sandboxed environment, for example, if you do something like
@@ -856,7 +882,9 @@
     ;; evaluates the program in `run-in-bg') -- so this parameterization
     ;; must be nested in the above (which is what paramaterize* does), or
     ;; it will not use the new namespace.
-    [current-eventspace (make-eventspace)])
+    [current-eventspace (parameterize-break
+                         #f
+                         (make-eventspace))])
    (let ([t (bg-run->thread (run-in-bg user-process))])
      (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t))))
      (set! user-thread t))

collects/scheme/splicing.ss

@@ -2,51 +2,54 @@
 (require (for-syntax scheme/base
                      syntax/kerncase)
          "stxparam.ss"
-         "private/stxparam.ss")
+         "private/stxparam.ss"
+         "private/local.ss")
 
 (provide splicing-let-syntax
          splicing-let-syntaxes
          splicing-letrec-syntax
          splicing-letrec-syntaxes
+         splicing-let
+         splicing-let-values
+         splicing-letrec
+         splicing-letrec-values
+         splicing-letrec-syntaxes+values
+         splicing-local
          splicing-syntax-parameterize)
 
-(define-for-syntax (do-let-syntax stx rec? multi? let-stx-id)
+(define-for-syntax ((check-id stx) id-stx)
+  (unless (identifier? id-stx)
+    (raise-syntax-error #f "expected an identifier" stx id-stx))
+  (list id-stx))
+
+(define-for-syntax ((check-ids stx) ids-stx)
+  (let ([ids (syntax->list ids-stx)])
+    (unless ids
+      (raise-syntax-error 
+       #f
+       "expected a parenthesized sequence of identifiers"
+       stx
+       ids-stx))
+    (for-each (check-id stx) ids)
+    ids))
+
+(define-for-syntax (check-dup-binding stx idss)
+  (let ([dup-id (check-duplicate-identifier (apply append idss))])
+    (when dup-id
+      (raise-syntax-error #f "duplicate binding" stx dup-id))))
+
+(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?)
   (syntax-case stx ()
     [(_ ([ids expr] ...) body ...)
-     (let ([all-ids (map (lambda (ids-stx)
+     (let ([all-ids (map ((if multi? check-ids check-id) stx)
-                           (let ([ids (if multi?
-                                          (syntax->list ids-stx)
-                                          (list ids-stx))])
-                             (unless ids
-                               (raise-syntax-error 
-                                #f
-                                "expected a parenthesized sequence of identifiers"
-                                stx
-                                ids-stx))
-                             (for-each (lambda (id)
-                                         (unless (identifier? id)
-                                           (raise-syntax-error
-                                            #f
-                                            "expected an identifier"
-                                            stx
-                                            id)))
-                                       ids)
-                             ids))
                          (syntax->list #'(ids ...)))])
-       (let ([dup-id (check-duplicate-identifier
+       (check-dup-binding stx all-ids)
-                      (apply append all-ids))])
-         (when dup-id
-           (raise-syntax-error
-            #f
-            "duplicate binding"
-            stx
-            dup-id)))
        (if (eq? 'expression (syntax-local-context))
-           (with-syntax ([let-stx let-stx-id])
+           (with-syntax ([LET let-id])
              (syntax/loc stx
-               (let-stx ([ids expr] ...)
+               (LET ([ids expr] ...)
-                        (#%expression body)
+                 (#%expression body)
-                        ...)))
+                 ...)))
            (let ([def-ctx (syntax-local-make-definition-context)]
                  [ctx (list (gensym 'intdef))])
              (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
@@ -69,23 +72,97 @@
                                     (map add-context exprs)
                                     exprs))]
                              [(body ...)
-                              (map add-context (syntax->list #'(body ...)))])
+                              (map add-context (syntax->list #'(body ...)))]
-                 #'(begin
+                             [DEF def-id])
-                     (define-syntaxes (id ...) expr)
+                 (with-syntax ([(top-decl ...)
-                     ...
+                                (if (and need-top-decl? (equal? 'top-level (syntax-local-context)))
-                     body ...))))))]))
+                                    #'((define-syntaxes (id ... ...) (values)))
+                                    null)])
+                   #'(begin
+                       top-decl ...
+                       (DEF (id ...) expr)
+                       ...
+                       body ...)))))))]))
 
 (define-syntax (splicing-let-syntax stx)
-  (do-let-syntax stx #f #f #'let-syntax))
+  (do-let-syntax stx #f #f #'let-syntax #'define-syntaxes #f))
 
 (define-syntax (splicing-let-syntaxes stx)
-  (do-let-syntax stx #f #t #'let-syntaxes))
+  (do-let-syntax stx #f #t #'let-syntaxes #'define-syntaxes #f))
 
 (define-syntax (splicing-letrec-syntax stx)
-  (do-let-syntax stx #t #f #'letrec-syntax))
+  (do-let-syntax stx #t #f #'letrec-syntax #'define-syntaxes #f))
 
 (define-syntax (splicing-letrec-syntaxes stx)
-  (do-let-syntax stx #t #t #'letrec-syntaxes))
+  (do-let-syntax stx #t #t #'letrec-syntaxes #'define-syntaxes #f))
+
+(define-syntax (splicing-let stx)
+  (do-let-syntax stx #f #f #'let #'define-values #f))
+
+(define-syntax (splicing-let-values stx)
+  (do-let-syntax stx #f #t #'let-values #'define-values #f))
+
+(define-syntax (splicing-letrec stx)
+  (do-let-syntax stx #t #f #'letrec #'define-values #t))
+
+(define-syntax (splicing-letrec-values stx)
+  (do-let-syntax stx #t #t #'letrec-values #'define-values #t))
+
+;; ----------------------------------------
+
+(define-syntax (splicing-letrec-syntaxes+values stx)
+  (syntax-case stx ()
+    [(_ ([sids sexpr] ...) ([vids vexpr] ...) body ...)
+     (let* ([all-sids (map (check-ids stx)
+                           (syntax->list #'(sids ...)))]
+            [all-vids (map (check-ids stx)
+                           (syntax->list #'(vids ...)))]
+            [all-ids (append all-sids all-vids)])
+       (check-dup-binding stx all-ids)
+       (if (eq? 'expression (syntax-local-context))
+           (syntax/loc stx
+             (letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...)
+               (#%expression body) ...))
+           (let ([def-ctx (syntax-local-make-definition-context)]
+                 [ctx (list (gensym 'intdef))])
+             (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
+             (internal-definition-context-seal def-ctx)
+             (let* ([add-context
+                     (lambda (expr)
+                       (let ([q (local-expand #`(quote #,expr)
+                                              ctx
+                                              (list #'quote)
+                                              def-ctx)])
+                         (syntax-case q ()
+                           [(_ expr) #'expr])))]
+                    [add-context-to-idss
+                     (lambda (idss)
+                       (map add-context idss))])
+               (with-syntax ([((sid ...) ...)
+                              (map add-context-to-idss all-sids)]
+                             [((vid ...) ...)
+                              (map add-context-to-idss all-vids)]
+                             [(sexpr ...)
+                              (map add-context (syntax->list #'(sexpr ...)))]
+                             [(vexpr ...)
+                              (map add-context (syntax->list #'(vexpr ...)))]
+                             [(body ...)
+                              (map add-context (syntax->list #'(body ...)))])
+                 (with-syntax ([top-decl
+                                (if (equal? 'top-level (syntax-local-context))
+                                    #'(define-syntaxes (vid ... ...) (values))
+                                    #'(begin))])
+                   (syntax/loc stx
+                     (begin
+                       top-decl
+                       (define-syntaxes (sid ...) sexpr) ...
+                       (define-values (vid ...) vexpr) ...
+                       body ...))))))))]))
+
+
+
+(define-syntax (splicing-local stx)
+  (do-local stx #'splicing-letrec-syntaxes+values))
 
 ;; ----------------------------------------
 

collects/scribble/eval.ss

@@ -238,7 +238,8 @@
     (call-with-trusted-sandbox-configuration
      (lambda ()
        (parameterize ([sandbox-output 'string]
-                      [sandbox-error-output 'string])
+                      [sandbox-error-output 'string]
+                      [sandbox-propagate-breaks #f])
          (make-evaluator '(begin (require scheme/base)))))))
 
   (define (close-eval e)
@@ -246,23 +247,24 @@
     "")
 
   (define (do-plain-eval ev s catching-exns?)
-    (call-with-values (lambda () 
+    (parameterize ([sandbox-propagate-breaks #f])
-                        ((scribble-eval-handler) 
+      (call-with-values (lambda () 
-                         ev
+                          ((scribble-eval-handler) 
-                         catching-exns? 
+                           ev
-                         (let ([s (strip-comments s)])
+                           catching-exns? 
-                           (cond
+                           (let ([s (strip-comments s)])
-                            [(syntax? s)
+                             (cond
-                             (syntax-case s (module)
+                              [(syntax? s)
-                               [(module . _rest)
+                               (syntax-case s (module)
-                                (syntax->datum s)]
+                                 [(module . _rest)
-                               [_else s])]
+                                  (syntax->datum s)]
-                            [(bytes? s)
+                                 [_else s])]
-                             `(begin ,s)]
+                              [(bytes? s)
-                            [(string? s)
+                               `(begin ,s)]
-                             `(begin ,s)]
+                              [(string? s)
-                            [else s]))))
+                               `(begin ,s)]
-      list))
+                              [else s]))))
+        list)))
 
   (define-syntax-rule (quote-expr e) 'e)
 

collects/scribble/html-render.ss

@@ -1076,6 +1076,7 @@
                                [(#f) null]
                                [(top) '((valign "top"))]
                                [(baseline) '((valign "baseline"))]
+                               [(center) '((valign "center"))]
                                [(bottom) '((valign "bottom"))])
                            ,@(if (string? st)
                                  `([class ,st])

collects/scribble/latex-render.ss

@@ -302,12 +302,12 @@
               (let ([flows (car flowss)]
                     [row-style (car row-styles)])
                 (let loop ([flows flows]
-                           [col-v-styles (and (list? row-style)
+                           [col-v-styles (or (and (list? row-style)
-                                              (or (let ([p (assoc 'valignment row-style)])
+                                                  (let ([p (assoc 'valignment row-style)])
-                                                    (and p (cdr p)))
+                                                    (and p (cdr p))))
-                                                  (let ([p (and (list? (table-style t))
+                                             (let ([p (and (list? (table-style t))
-                                                                (assoc 'valignment (table-style t)))])
+                                                           (assoc 'valignment (table-style t)))])
-                                                    (and p (cdr p)))))])
+                                               (and p (cdr p))))])
                   (unless (null? flows)
                     (when index? (printf "\\item "))
                     (unless (eq? 'cont (car flows))
@@ -347,17 +347,20 @@
           (printf "\\begin{tabular}~a{@{}l@{}}\n"
                   (cond
                    [(eq? vstyle 'top) "[t]"]
+                   [(eq? vstyle 'center) "[c]"]
                    [else ""])))
         (let loop ([ps (flow-paragraphs p)])
           (cond
            [(null? ps) (void)]
            [else
-            (let ([minipage? (not (or (paragraph? (car ps))
+            (let ([minipage? (or (not (or (paragraph? (car ps))
-                                      (table? (car ps))))])
+                                          (table? (car ps))))
+                                 (eq? vstyle 'center))])
               (when minipage?
                 (printf "\\begin{minipage}~a{~a\\linewidth}\n"
                         (cond
                          [(eq? vstyle 'top) "[t]"]
+                         [(eq? vstyle 'center) "[c]"]
                          [else ""])
                         (/ 1.0 twidth)))
               (render-block (car ps) part ri #f)

collects/scribble/private/manual-form.ss

@@ -106,6 +106,9 @@
     [(_ #:literals lits [spec ...] desc ...)
      (syntax/loc stx
        (defform*/subs #:literals lits [spec ...] () desc ...))]
+    [(_ #:id id [spec ...] desc ...)
+     (syntax/loc stx
+       (defform*/subs #:id id [spec ...] () desc ...))]
     [(_ [spec ...] desc ...)
      (syntax/loc stx
        (defform*/subs [spec ...] () desc ...))]))

collects/scribble/scheme.ss

@@ -123,7 +123,8 @@
         (make-element style content)))
 
   (define (typeset-atom c out color? quote-depth)
-    (if (var-id? (syntax-e c))
+    (if (and (var-id? (syntax-e c))
+             (zero? quote-depth))
         (out (format "~s" (let ([v (var-id-sym (syntax-e c))])
                             (if (syntax? v)
                                 (syntax-e v)
@@ -135,7 +136,9 @@
                        (let ([sc (syntax-e c)])
                          (let ([s (format "~s" (if (literal-syntax? sc)
                                                    (literal-syntax-stx sc)
-                                                   sc))])
+                                                   (if (var-id? sc)
+                                                       (var-id-sym sc)
+                                                       sc)))])
                            (if (and (symbol? sc)
                                     ((string-length s) . > . 1)
                                     (char=? (string-ref s 0) #\_)

collects/scribble/text/output.ss

@@ -2,7 +2,7 @@
 
 (require scheme/promise)
 
-(provide output splice verbatim unverbatim flush prefix)
+(provide output)
 
 ;; Outputs some value, for the preprocessor langauge.
 ;;
@@ -19,9 +19,11 @@
 ;; system (when line counts are enabled) -- this is used to tell what part of a
 ;; prefix is already displayed.
 ;;
-;; Each prefix is either an integer (for a number of spaces), a string, or #f
+;; Each prefix is either an integer (for a number of spaces) or a
-;; indicating that prefixes are disabled (different from 0 -- they will not be
+;; string.  The prefix mechanism can be disabled by using #f for the
-;; accumulated).
+;; global prefix, and in this case the line prefix can have (cons pfx
+;; lpfx) so it can be restored -- used by `verbatim' and `unverbatim'
+;; resp.  (This is different from 0 -- no prefix will be accumulated).
 ;;
 (define (output x [p (current-output-port)])
   ;; these are the global prefix and the one that is local to the current line
@@ -63,6 +65,37 @@
                  (let ([col (- col len1)]
                        [len2 (if (number? pfx2) pfx2 (string-length pfx2))])
                    (when (< col len2) (write-string (->str pfx2) p col )))])))))
+  ;; the basic printing unit: strings
+  (define (output-string x)
+    (define pfx (mcar pfxs))
+    (if (not pfx) ; verbatim mode?
+      (write-string x p)
+      (let ([len (string-length x)]
+            [nls (regexp-match-positions* #rx"\n" x)])
+        (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)])
+          (cond [(pair? nls)
+                 (let ([nl (car nls)])
+                   (if (regexp-match? #rx"^ *$" x start (car nl))
+                     (newline p) ; only spaces before the end of the line
+                     (begin (output-pfx col pfx lpfx)
+                            (write-string x p start (cdr nl))))
+                   (loop (cdr nl) (cdr nls) 0 0))]
+                ;; last substring from here (always set lpfx state when done)
+                [(start . = . len)
+                 (set-mcdr! pfxs lpfx)]
+                [(col . > . (2pfx-length pfx lpfx))
+                 (set-mcdr! pfxs lpfx)
+                 ;; the prefix was already shown, no accumulation needed
+                 (write-string x p start)]
+                [else
+                 (let ([m (regexp-match-positions #rx"^ +" x start)])
+                   ;; accumulate spaces to lpfx, display if it's not all spaces
+                   (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)])
+                     (set-mcdr! pfxs lpfx)
+                     (unless (and m (= len (cdar m)))
+                       (output-pfx col pfx lpfx)
+                       ;; the spaces were already added to lpfx
+                       (write-string x p (if m (cdar m) start)))))])))))
   ;; main loop
   (define (loop x)
     (cond
@@ -72,16 +105,13 @@
       ;; one, then output the contents recursively (no need to change the
       ;; state, since we pass the values in the loop, and we'd need to restore
       ;; it afterwards anyway)
-      [(pair? x) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
+      [(pair? x) (if (list? x)
-                        [npfx (pfx+col (pfx+ pfx lpfx))])
+                   (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)]
-                   (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
+                          [npfx (pfx+col (pfx+ pfx lpfx))])
-                   (if (list? x)
+                     (set-mcar! pfxs npfx) (set-mcdr! pfxs 0)
                      (for ([x (in-list x)]) (loop x))
-                     (let ploop ([x x])
+                     (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))
-                       (if (pair? x)
+                   (begin (loop (car x)) (loop (cdr x))))]
-                         (begin (loop (car x)) (ploop (cdr x)))
-                         (loop x))))
-                   (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))]
       ;; delayed values
       [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))]
       [(promise? x) (loop (force x))]
@@ -114,41 +144,16 @@
            [else (error 'output "unknown special value flag: ~e"
                         (special-flag x))]))]
       [else
-       (let* ([x (cond [(string? x)  x]
+       (output-string
-                       [(bytes? x)   (bytes->string/utf-8 x)]
+        (cond [(string? x)  x]
-                       [(symbol? x)  (symbol->string      x)]
+              [(bytes? x)   (bytes->string/utf-8 x)]
-                       [(path? x)    (path->string        x)]
+              [(symbol? x)  (symbol->string      x)]
-                       [(keyword? x) (keyword->string     x)]
+              [(path? x)    (path->string        x)]
-                       [(number? x)  (number->string      x)]
+              [(keyword? x) (keyword->string     x)]
-                       [(char? x)    (string              x)]
+              [(number? x)  (number->string      x)]
-                       ;; generic fallback: throw an error
+              [(char? x)    (string              x)]
-                       [else (error 'output "don't know how to render value: ~v"
+              ;; generic fallback: throw an error
-                                    x)])]
+              [else (error 'output "don't know how to render value: ~v" x)]))]))
-              [len (string-length x)]
-              [nls (regexp-match-positions* #rx"\n" x)]
-              [pfx (mcar pfxs)])
-         (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)])
-           (cond [(pair? nls)
-                  (let ([nl (car nls)])
-                    (output-pfx col pfx lpfx)
-                    (write-string x p start (cdr nl))
-                    (loop (cdr nl) (cdr nls) 0 0))]
-                 ;; last substring from here (always set lpfx state when done)
-                 [(start . = . len)
-                  (set-mcdr! pfxs lpfx)]
-                 [(col . > . (2pfx-length pfx lpfx))
-                  (set-mcdr! pfxs lpfx)
-                  ;; the prefix was already shown, no accumulation needed
-                  (write-string x p start)]
-                 [else
-                  (let ([m (regexp-match-positions #rx"^ +" x start)])
-                    ;; accumulate spaces to lpfx, display if it's not all spaces
-                    (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)])
-                      (set-mcdr! pfxs lpfx)
-                      (unless (and m (= len (cdar m)))
-                        (output-pfx col pfx lpfx)
-                        ;; the spaces were already added to lpfx
-                        (write-string x p (if m (cdar m) start)))))])))]))
   ;;
   (port-count-lines! p)
   (loop x)
@@ -164,6 +169,10 @@
             (set! last (cons p s))
             s)))))
 
+;; special constructs
+
+(provide splice verbatim unverbatim flush prefix)
+
 (define-struct special (flag contents))
 
 (define (splice     . contents) (make-special 'splice     contents))
@@ -179,3 +188,25 @@
           (let ([spaces (make-string n #\space)])
             (if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces))
             spaces)))))
+
+;; Convenient utilities
+
+(provide add-newlines)
+(define (add-newlines list #:sep [sep "\n"])
+  (define r
+    (let loop ([list list])
+      (if (null? list)
+        null
+        (let ([1st (car list)])
+          (if (or (not 1st) (void? 1st))
+            (loop (cdr list))
+            (list* sep 1st (loop (cdr list))))))))
+  (if (null? r) r (cdr r)))
+
+(provide split-lines)
+(define (split-lines list)
+  (let loop ([list list] [cur '()] [r '()])
+    (cond
+      [(null? list) (reverse (cons (reverse cur) r))]
+      [(equal? "\n" (car list)) (loop (cdr list) '() (cons (reverse cur) r))]
+      [else (loop (cdr list) (cons (car list) cur) r)])))

collects/scribble/text/syntax-utils.ss

@@ -159,8 +159,10 @@
     (cond [(pair? rest) #`(list* #,@nondefns (begin/collect* #t #,@rest))]
           [(and (not always-list?) (= 1 (length nondefns))) (car nondefns)]
           [else #`(list #,@nondefns)]))
-  (local-expand (if (null? defns) body #`(let () #,@defns #,body))
+  (begin0
-                context stoplist (car context)))
+   (local-expand (if (null? defns) body #`(let () #,@defns #,body))
+                 context stoplist (car context))
+   (internal-definition-context-seal (car context))))
 (define-syntax-rule (begin/collect x ...) (begin/collect* #f x ...))
 
 ;; begin for templates (allowing definition blocks)

collects/scribblings/drscheme/keybindings.scrbl

@@ -1,10 +1,15 @@
 #lang scribble/doc
 @(require "common.ss"
+	  scribble/struct
           scribble/bnf
+          scheme/list
+	  mrlib/tex-table
           (for-label scheme/gui/base))
 
 @(define (keybinding key . desc)
-   (apply item @index[(list (format "~a keybinding" key)) key] " : " desc))
+   (let* ([keys (if (string? key) (list key) key)]
+          [key-str (apply string-append (add-between keys " "))])
+     (apply item @index[(map (lambda (x) (format "~a keybinding" x)) keys) key-str] " : " desc)))
 
 @(define-syntax-rule (def-mod-beg id)
   (begin
@@ -166,6 +171,25 @@ as the @tech{definitions window} plus a few more:
   expression history down to the prompt}
 ]
 
+@section{LaTeX and TeX inspired keybindings}
+
+@itemize[
+@keybinding['("C-\\" "M-\\")]{traces backwards from the insertion
+point, looking for a backslash followed by a @index["LaTeX"]{LaTeX} macro name; if one is
+found, it replaces the backslash and the macro's name with the keybinding.
+These are the currently supported macro names and the keys they map into:
+@(make-table
+  '()
+  (map (lambda (line) 
+	 (let ([macro (list-ref line 0)]
+	       [char (list-ref line 1)])
+	   (list (make-flow (list (make-paragraph (list (index (format "\\~a keyboard shortcut" macro))
+							(tt (format "\\~a" macro))))))
+		 (make-flow (list (make-paragraph (list char)))))))
+       tex-shortcut-table))
+}
+]
+
 @section[#:tag "defining-shortcuts"]{Defining Custom Shortcuts}
 
  The @onscreen{Add User-defined Keybindings...} menu item in the

collects/scribblings/foreign/derived.scrbl

@@ -64,8 +64,6 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.}
 
 @subsection{Unsafe Tagged C Pointer Functions}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
 @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?]
            [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{
 
@@ -157,8 +155,6 @@ Converts the list @scheme[lst] to a C vector of the given
 
 @subsection{Unsafe C Vector Construction}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
 @defproc[(make-cvector* [cptr any/c] [type ctype?]
                         [length exact-nonnegative-integer?])
                         cvector?]{

collects/scribblings/foreign/foreign.scrbl

@@ -5,7 +5,7 @@
 
 @author["Eli Barzilay"]
 
-@defmodule[scheme/foreign]
+@defmodule[scheme/foreign #:use-sources ('#%foreign)]
 
 The @schememodname[scheme/foreign] library enables the direct use of
 C-based APIs within Scheme programs---without writing any new C

collects/scribblings/foreign/libs.scrbl

@@ -19,9 +19,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib],
 
 @section{Unsafe Library Functions}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
-
 @defproc[(ffi-lib [path (or/c path-string? #f)]
                   [version (or/c string? (listof string?) #f) #f]) any]{
 

collects/scribblings/foreign/misc.scrbl

@@ -54,8 +54,6 @@ Like @scheme[list->cblock], but for Scheme vectors.}
 
 @section{Unsafe Miscellaneous Operations}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
 @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?])
          list?]{
 

collects/scribblings/foreign/pointers.scrbl

@@ -50,8 +50,6 @@ offset is always in bytes.}
 
 @section{Unsafe Pointer Operations}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
 @defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte]) 
          void?]{
 
@@ -209,8 +207,6 @@ can contain other information).}
 
 @section{Unsafe Memory Management}
 
-@declare-exporting[scribblings/foreign/unsafe-foreign]
-
 For general information on C-level memory management with PLT Scheme,
 see @|InsideMzScheme|.
 

collects/scribblings/foreign/unsafe-foreign.ss

@@ -1,11 +1,31 @@
 #lang scheme/base
-
+(require scheme/foreign
-(require scheme/foreign)
+         (for-syntax scheme/base
+                     scheme/provide-transform))
 
 (error 'unsafe! "only `for-label' use in the documentation")
 
 (unsafe!)
 
-(provide (protect-out (all-defined-out))
+;; This is like `all-defined-out', but it ignores the 'not-provide-all-defined
+;;  property, so that the bindings introduced by `unsafe!' are exported.
+(define-syntax all-unsafe-defined-out
+  (make-provide-transformer
+   (lambda (stx modes)
+     (syntax-case stx ()
+       [(_) 
+        (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)]
+                     [(same-ctx?) (lambda (free-identifier=?)
+                                      (lambda (id)
+                                        (free-identifier=? id
+                                                           (datum->syntax
+                                                            stx
+                                                            (syntax-e id)))))])
+          (map (lambda (id)
+                 (make-export id (syntax-e id) 0 #f stx))
+               (filter (same-ctx? free-identifier=?)
+                       ids)))]))))
+
+(provide (protect-out (all-unsafe-defined-out))
          (all-from-out scheme/foreign))
 

collects/scribblings/guide/module-basics.scrbl

@@ -67,7 +67,7 @@ scheme
 In addition to the main @tech{collection} directory, which contains
 all collections that are part of the installation, collections can
 also be installed in a user-specific location. Finally, additional
-collection directories can be specified n configuration files or
+collection directories can be specified in configuration files or
 through the @envvar{PLTCOLLECTS} search path. Try running the
 following program to find out where your collections are:
 

collects/scribblings/mzc/cc.scrbl

@@ -1,6 +1,8 @@
 #lang scribble/doc
 @(require scribble/manual
-          (for-label scheme/base)
+          (for-label scheme/base
+                     compiler/xform
+                     dynext/compile)
           "common.ss")
 
 @(define (xflag str) (as-index (DFlag str)))
@@ -55,3 +57,29 @@ loaded into the 3m variant of PLT Scheme. The @as-index{@DFlag{cgc}}
 flag specifies that the extension is to be used with the CGC. The
 default depends on @|mzc|: @DFlag{3m} if @|mzc| itself is running in
 3m, @DFlag{cgc} if @|mzc| itself is running in CGC.
+
+
+@section[#:tag "xform-api"]{Scheme API for 3m Transformation}
+
+@defmodule[compiler/xform]
+
+@defproc[(xform [quiet? any/c]
+                [input-file path-string?]
+                [output-file path-string?]
+                [include-dirs (listof path-string?)]
+                [#:keep-lines? keep-lines? boolean? #f])
+         any/c]{
+
+Transforms C code that is written without explicit GC-cooperation
+hooks to cooperate with PLT Scheme's 3m garbage collector; see
+@secref[#:doc '(lib "scribblings/inside/inside.scrbl") "overview"] in
+@other-manual['(lib "scribblings/inside/inside.scrbl")].
+
+The arguments are as for @scheme[compile-extension]; in addition
+@scheme[keep-lines?] can be @scheme[#t] to generate GCC-style
+annotations to connect the generated C code with the original source
+locations.
+
+The file generated by @scheme[xform] can be compiled via
+@scheme[compile-extension].}
+

collects/scribblings/reference/cont-marks.scrbl

@@ -89,7 +89,7 @@ separated by a prompt tagged with @scheme[prompt-tag]..}
 
 @defproc[(continuation-mark-set->list* 
           [mark-set continuation-mark-set?]
-          [key-v any/c]
+          [key-list (listof any/c)]
           [none-v any/c #f]
           [prompt-tag prompt-tag? (default-continuation-prompt-tag)])
          (listof vector?)]{

collects/scribblings/reference/contracts.scrbl

@@ -367,7 +367,7 @@ The @scheme[case->] contract is a specialized contract,
 designed to match @scheme[case-lambda] and
 @scheme[unconstrained-domain->] allows range checking
 without requiring that the domain have any particular shape
-(see below for an exmaple use).
+(see below for an example use).
 
 @defform*/subs[#:literals (any values)
                [(-> dom ... range)]

collects/scribblings/reference/file-ports.scrbl

@@ -111,7 +111,8 @@ files that already exist:
 
  @item{@indexed-scheme['update] --- open an existing file without
        truncating it; if the file does not exist, the
-       @exnraise[exn:fail:filesystem].}
+       @exnraise[exn:fail:filesystem]. Use @scheme[file-position]
+       to change the current read/write position.}
 
  @item{@indexed-scheme['can-update] --- open an existing file without
        truncating it, or create the file if it does not exist.}

collects/scribblings/reference/module-reflect.scrbl

@@ -256,7 +256,9 @@ the module's explicit imports.}
 Returns two association lists mapping @tech{phase level} values (where
 @scheme[#f] corresponds to the @tech{label phase level}) to exports at
 the corresponding phase. The first association list is for exported
-variables, and the second is for exported syntax.
+variables, and the second is for exported syntax. Beware however, that
+value bindings re-exported though a @tech{rename transformer} are in
+the syntax list instead of the value list.
 
 Each associated list, which is represented by @scheme[list?] in the
 result contracts above, more precisely matches the contract

collects/scribblings/reference/numbers.scrbl

@@ -890,6 +890,10 @@ Returns the hyperbolic sine of @scheme[z].}
 
 Returns the hyperbolic cosine of @scheme[z].}
 
+@defproc[(tanh [z number?]) number?]{
+
+Returns the hyperbolic tangent of @scheme[z].}
+
 @; ----------------------------------------------------------------------
 
 @close-eval[math-eval]

collects/scribblings/reference/pairs.scrbl

@@ -633,6 +633,13 @@ Returns @scheme[(filter (lambda (x) x) (map proc lst ...))], but
 without building the intermediate list.}
 
 
+@defproc[(count [proc procedure?] [lst list?] ...+)
+         list?]{
+
+Returns @scheme[(length (filter proc lst ...))], but
+without building the intermediate list.}
+
+
 @defproc[(partition [pred procedure?] [lst list?])
          (values list? list?)]{
 

collects/scribblings/reference/sandbox.scrbl

@@ -411,12 +411,18 @@ collected by sandbox evaluators.  Use
 
 @defboolparam[sandbox-propagate-breaks propagate?]{
 
-When this boolean parameter is true, breaking while an evaluator is
+When both this boolean parameter and @scheme[(break-enabled)] are true, 
-running evaluator propagates the break signal to the sandboxed
+breaking while an evaluator is
+running propagates the break signal to the sandboxed
 context.  This makes the sandboxed evaluator break, typically, but
 beware that sandboxed evaluation can capture and avoid the breaks (so
 if safe execution of code is your goal, make sure you use it with a
-time limit).  The default is @scheme[#t].}
+time limit).  Also, beware that a break may be received after the
+evaluator's result, in which case the evaluation result is lost. Finally,
+beware that a break may be propagated after an evaluator has produced
+a result, so that the break is visible on the next interaction with
+the evaluator (or the break is lost if the evaluator is not used
+further). The default is @scheme[#t].}
 
 
 @defparam[sandbox-namespace-specs spec (cons/c (-> namespace?) 

collects/scribblings/reference/sequences.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require "mz.ss"
-          (for-syntax scheme/base))
+          (for-syntax scheme/base)
+          scribble/scheme)
 
 @(define-syntax speed
    (syntax-rules ()
@@ -246,23 +247,24 @@ the structure and returns a sequence. If @scheme[v] is an instance of
 a structure type with this property, then @scheme[(sequence? v)]
 produces @scheme[#t].
 
-@examples[
+@let-syntax[([car (make-element-id-transformer (lambda (id) #'@schemeidfont{car}))])
-(define-struct train (car next)
+ @examples[
-  #:property prop:sequence (lambda (t)
+ (define-struct train (car next)
-                             (make-do-sequence 
+   #:property prop:sequence (lambda (t)
-                              (lambda ()
+                              (make-do-sequence 
-                                (values train-car
+                               (lambda ()
-                                        train-next
+                                 (values train-car
-                                        t
+                                         train-next
-                                        (lambda (t) t)
+                                         t
-                                        (lambda (v) #t)
+                                         (lambda (t) t)
-                                        (lambda (t v) #t))))))
+                                         (lambda (v) #t)
-(for/list ([c (make-train 'engine
+                                         (lambda (t v) #t))))))
-                          (make-train 'boxcar
+ (for/list ([c (make-train 'engine
-                                      (make-train 'caboose
+                           (make-train 'boxcar
-                                                  #f)))])
+                                       (make-train 'caboose
-  c)
+                                                   #f)))])
-]}
+   c)
+ ]]}
 
 @section{Sequence Generators}
 

collects/scribblings/reference/splicing.scrbl

@@ -1,7 +1,8 @@
 #lang scribble/doc
 @(require "mz.ss"
           (for-label scheme/splicing
-                     scheme/stxparam))
+                     scheme/stxparam
+                     scheme/local))
 
 @(define splice-eval (make-base-eval))
 @interaction-eval[#:eval splice-eval (require scheme/splicing 
@@ -13,16 +14,24 @@
 @note-lib-only[scheme/splicing]
 
 @deftogether[(
+@defidform[splicing-let]
+@defidform[splicing-letrec]
+@defidform[splicing-let-values]
+@defidform[splicing-letrec-values]
 @defidform[splicing-let-syntax]
 @defidform[splicing-letrec-syntax]
 @defidform[splicing-let-syntaxes]
 @defidform[splicing-letrec-syntaxes]
+@defidform[splicing-letrec-syntaxes+values]
+@defidform[splicing-local]
 )]{
 
-Like @scheme[let-syntax], @scheme[letrec-syntax],
+Like @scheme[let], @scheme[letrec], @scheme[let-values],
-@scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a
+@scheme[letrec-values], @scheme[let-syntax], @scheme[letrec-syntax],
+@scheme[let-syntaxes], @scheme[letrec-syntaxes],
+@scheme[letrec-syntaxes+values], and @scheme[local], except that in a
 definition context, the body forms are spliced into the enclosing
-definition context (in the same as as for @scheme[begin]).
+definition context (in the same way as for @scheme[begin]).
 
 @examples[
 #:eval splice-eval
@@ -30,7 +39,23 @@ definition context (in the same as as for @scheme[begin]).
   (define o one))
 o
 one
-]}
+]
+
+When a splicing binding form occurs in a @tech{top-level context} or
+@tech{module context}, its local bindings are treated similarly to
+definitions. In particular, if a reference to one of the splicing
+form's bound variables is evaluated before the variable is
+initialized, an unbound variable error is raised, instead of the
+variable evaluating to the undefined value.  Also, syntax bindings are
+evaluated every time the module is @tech{visit}ed, instead of only
+once during compilation as in @scheme[let-syntax], etc.
+
+@examples[
+#:eval splice-eval
+(splicing-letrec ([x bad]
+                  [bad 1])
+  x)]
+}
 
 @defidform[splicing-syntax-parameterize]{
 

collects/scribblings/reference/stx-comp.scrbl

@@ -22,15 +22,16 @@ suitable expression context at the @tech{phase level} indicated by
 
 Returns @scheme[#t] if @scheme[a-id] and @scheme[b-id] access the same
 @tech{local binding}, @tech{module binding}, or @tech{top-level
-binding} at the @tech{phase level} indicated by
+binding}---perhaps via @tech{rename transformers}---at the @tech{phase
-@scheme[phase-level]. A @scheme[#f] value for @scheme[phase-level]
+level} indicated by @scheme[phase-level]. A @scheme[#f] value for
-corresponds to the @tech{label phase level}.
+@scheme[phase-level] corresponds to the @tech{label phase level}.
 
 ``Same module binding'' means that the identifiers refer to the same
-original definition site, not necessarily the @scheme[require] or
+original definition site, and not necessarily to the same
-@scheme[provide] site. Due to renaming in @scheme[require] and
+@scheme[require] or @scheme[provide] site. Due to renaming in
-@scheme[provide], the identifiers may return distinct results with
+@scheme[require] and @scheme[provide], or due to a transformer binding
-@scheme[syntax-e].}
+to a @tech{rename transformer}, the identifiers may return distinct
+results with @scheme[syntax-e].}
 
 
 @defproc[(free-transformer-identifier=? [a-id syntax?][b-id syntax?]) boolean?]{
@@ -132,7 +133,13 @@ Returns one of three kinds of values, depending on the binding of
             @tech{top-level binding} (or, equivalently, if it is
             @tech{unbound}).}
 
-      }}
+      }
+
+If @scheme[id-stx] is bound to a @tech{rename-transformer}, the result
+from @scheme[identifier] binding is for the identifier in the
+transformer, so that @scheme[identifier-binding] is consistent with
+@scheme[free-identifier=?].}
+
 
 @defproc[(identifier-transformer-binding [id-stx syntax?])
          (or/c 'lexical

collects/scribblings/reference/stx-trans.scrbl

@@ -16,15 +16,22 @@ expander, otherwise the @exnraise[exn:fail:contract].})
 
 @title[#:tag "stxtrans"]{Syntax Transformers}
 
+@defproc[(set!-transformer? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a value created by
+@scheme[make-set!-transformer] or an instance of a structure type with
+the @scheme[prop:set!-transformer] property, @scheme[#f] otherwise.}
+
+
 @defproc[(make-set!-transformer [proc (syntax? . -> . syntax?)])
          set!-transformer?]{
 
-Creates a @tech{syntax transformer} that cooperates with
+Creates an @tech{assignment transformer} that cooperates with
 @scheme[set!]. If the result of @scheme[make-set!-transformer] is
-bound to @scheme[identifier] as a @tech{transformer binding}, then
+bound to @scheme[_id] as a @tech{transformer binding}, then
-@scheme[proc] is applied as a transformer when @scheme[identifier] is
+@scheme[proc] is applied as a transformer when @scheme[_id] is
 used in an expression position, or when it is used as the target of a
-@scheme[set!] assignment as @scheme[(set! identifier _expr)]. When the
+@scheme[set!] assignment as @scheme[(set! _id _expr)]. When the
 identifier appears as a @scheme[set!] target, the entire @scheme[set!]
 expression is provided to the transformer.
 
@@ -45,17 +52,48 @@ expression is provided to the transformer.
 ]}
 
 
-@defproc[(set!-transformer? [v any/c]) boolean?]{
-
-Returns @scheme[#t] if @scheme[v] is a value created by
-@scheme[make-set!-transformer], @scheme[#f] otherwise.}
-
-
 @defproc[(set!-transformer-procedure [transformer set!-transformer?])
          (syntax? . -> . syntax?)]{
 
 Returns the procedure that was passed to
-@scheme[make-set!-transformer] to create @scheme[transformer].}
+@scheme[make-set!-transformer] to create @scheme[transformer] or that
+is identified by the @scheme[prop:set!-transformer] property of
+@scheme[transformer].}
+
+
+@defthing[prop:set!-transformer struct-type-property?]{
+
+A @tech{structure type property} to indentify structure types that act
+as @tech{assignment transformers} like the ones created by
+@scheme[make-set!-transformer].
+
+The property value must be an exact integer or procedure of one
+argument. In the former case, the integer designates a field within
+the structure that should contain a procedure; the integer must be
+between @scheme[0] (inclusive) and the number of non-automatic fields
+in the structure type (exclusive, not counting supertype fields), and
+the designated field must also be specified as immutable.
+
+If the property value is an procedure, then the procedure serves as a
+@tech{syntax transformer} and for @scheme[set!] transformations. If
+the property value is an integer, the target identifier is extracted
+from the structure instance; if the field value is not a procedure of
+one argument, then a procedure that always calls
+@scheme[raise-syntax-error] is used, instead.
+
+If a value has both the @scheme[prop:set!-transformer] and
+@scheme[prop:rename-transformer] properties, then the latter takes
+precedence. If a structure type has the @scheme[prop:set!-transformer]
+and @scheme[prop:procedure] properties, then the former takes
+precedence for the purposes of macro expansion.}
+
+
+@defproc[(rename-transformer? [v any/c]) boolean?]{
+
+Returns @scheme[#t] if @scheme[v] is a value created by
+@scheme[make-rename-transformer] or an instance of a structure type
+with the @scheme[prop:rename-transformer] property, @scheme[#f]
+otherwise.}
 
 
 @defproc[(make-rename-transformer [id-stx syntax?]
@@ -64,26 +102,55 @@ Returns the procedure that was passed to
          rename-transformer?]{
 
 Creates a @tech{rename transformer} that, when used as a
-@tech{transformer binding}, acts as a transformer that insert the
+@tech{transformer binding}, acts as a transformer that inserts the
 identifier @scheme[id-stx] in place of whatever identifier binds the
-transformer, including in non-application positions, and in
+transformer, including in non-application positions, in @scheme[set!]
-@scheme[set!] expressions. Such a transformer could be written
+expressions.
-manually, but the one created by @scheme[make-rename-transformer]
+
-cooperates specially with @scheme[syntax-local-value] and
+Such a transformer could be written manually, but the one created by
+@scheme[make-rename-transformer] also causes the parser to install a
+@scheme[free-identifier=?] and @scheme[identifier-binding]
+equivalence, as long as @scheme[id-stx] does not have a true value for
+the @indexed-scheme['not-free-identifier=?] @tech{syntax property}.
+Also, if @scheme[id-stx] has a true value for the
+@indexed-scheme['not-provide-all-defined] @tech{syntax property} and
+it is bound as a module-level transformer, the bound identifier is not
+exported by @scheme[all-defined-out]; the @scheme[provide] form
+otherwise uses a symbol-valued @indexed-scheme['nominal-id] property
+of @scheme[id-stx] to specify the ``nominal source identifier'' of the
+binding. Finally, the rename transformer cooperates specially with
+@scheme[syntax-local-value] and
 @scheme[syntax-local-make-delta-introducer].}
 
 
-@defproc[(rename-transformer? [v any/c]) boolean?]{
-
-Returns @scheme[#t] if @scheme[v] is a value created by
-@scheme[make-rename-transformer], @scheme[#f] otherwise.}
-
-
 @defproc[(rename-transformer-target [transformer rename-transformer?])
-         syntax?]{
+         identifier?]{
 
 Returns the identifier passed to @scheme[make-rename-transformer] to
-create @scheme[transformer].}
+create @scheme[transformer] or as indicated by a
+@scheme[prop:rename-transformer] property on @scheme[transformer].}
+
+
+@defthing[prop:rename-transformer struct-type-property?]{
+
+A @tech{structure type property} to indentify structure types that act
+as @tech{rename transformers} like the ones created by
+@scheme[make-rename-transformer].
+
+The property value must be an exact integer or an identifier
+@tech{syntax object}. In the former case, the integer designates a
+field within the structure that should contain an identifier; the
+integer must be between @scheme[0] (inclusive) and the number of
+non-automatic fields in the structure type (exclusive, not counting
+supertype fields), and the designated field must also be specified as
+immutable.
+
+If the property value is an identifier, the identifier serves as the
+target for renaming, just like the first argument to
+@scheme[make-rename-transformer]. If the property value is an integer,
+the target identifier is extracted from the structure instance; if the
+field value is not an identifier, then an identifier @schemeidfont{?}
+with an empty context is used, instead.}
 
 
 @defproc[(local-expand [stx syntax?]
@@ -307,6 +374,28 @@ being expanded for the body of a module, then resolving
 @transform-time[]}
 
 
+@defproc[(syntax-local-value/immediate [id-stx syntax?]
+                                       [failure-thunk (or/c (-> any) #f)
+                                                      #f]
+                                       [intdef-ctx (or/c internal-definition-context?
+                                                         #f)
+                                                   #f])
+         any]{
+
+Like @scheme[syntax-local-value], but the result is normally two
+values. If @scheme[id-stx] is bound to a @tech{rename transformer},
+the results are the rename transformer and the identifier in the
+transformer augmented with certificates from @scheme[id-stx]. If
+@scheme[id-stx] is not bound to a @tech{rename transformer}, then the
+results are the value that @scheme[syntax-local-value] would produce
+and @scheme[#f].
+
+If @scheme[id-stx] has no transformer biding, then
+@scheme[failure-thunk] is called (and it can return any number of
+values), or an exception is raised if @scheme[failure-thunk] is
+@scheme[#f].}
+
+
 @defproc[(syntax-local-lift-expression [stx syntax?])
          identifier?]{
 

collects/scribblings/reference/syntax-model.scrbl

@@ -531,19 +531,28 @@ is the one left with a mark, and the reference @scheme[x] has no mark,
 so the binding @scheme[x] is not @scheme[bound-identifier=?] to the
 body @scheme[x].
 
-The @scheme[set!] form and the @scheme[make-set!-transformer]
+The @scheme[set!] form works with the @scheme[make-set!-transformer]
-procedure work together to support @deftech{assignment transformers}
+and @scheme[prop:set!-transformer] property to support
-that transformer @scheme[set!] expression. @tech{Assignment
+@deftech{assignment transformers} that transform @scheme[set!]
-transformers} are applied by @scheme[set!] in the same way as a normal
+expressions. An @tech{assignment transformer} contains a procedure
+that is applied by @scheme[set!] in the same way as a normal
 transformer by the expander.
 
-The @scheme[make-rename-transformer] procedure creates a value that is
+The @scheme[make-rename-transformer] procedure or
-also handled specially by the expander and by @scheme[set!] as a
+@scheme[prop:rename-transformer] property creates a value that is also
+handled specially by the expander and by @scheme[set!] as a
 transformer binding's value. When @scheme[_id] is bound to a
 @deftech{rename transformer} produced by
-@scheme[make-rename-transformer], it is replaced with the identifier
+@scheme[make-rename-transformer], it is replaced with the target
-passed to @scheme[make-rename-transformer]. Furthermore, the binding
+identifier passed to @scheme[make-rename-transformer]. In addition, as
-is also specially handled by @scheme[syntax-local-value] and
+long as the target identifier does not have a true value for the
+@scheme['not-free-identifier=?] @tech{syntax property}, the lexical information that
+contains the binding of @scheme[_id] is also enriched so that
+@scheme[_id] is @scheme[free-identifier=?] to the target identifier,
+@scheme[identifier-binding] returns the same results for both
+identifiers, and @scheme[provide] exports @scheme[_id] as the target
+identifier. Finally, the binding is treated specially by
+@scheme[syntax-local-value], and
 @scheme[syntax-local-make-delta-introducer] as used by @tech{syntax
 transformer}s.
 

collects/scribblings/reference/syntax.scrbl

@@ -13,11 +13,13 @@
                      scheme/package
                      scheme/splicing))
 
+@(define require-eval (make-base-eval))
 @(define syntax-eval
    (lambda ()
      (let ([the-eval (make-base-eval)])
        (the-eval '(require (for-syntax scheme/base)))
        the-eval)))
+@(define meta-in-eval (syntax-eval))
 
 @(define cvt (schemefont "CVT"))
 @(define unquote-id (scheme unquote))
@@ -202,11 +204,13 @@ be preserved in marshaled bytecode. See also
 See also @secref["module-eval-model"] and @secref["mod-parse"].
 
 @defexamples[#:eval (syntax-eval)
-(module example-module scheme
+(module duck scheme/base
-  (provide foo bar)
+  (provide num-eggs quack)
-  (define foo 2)
+  (define num-eggs 2)
-  (define (bar x)
+  (define (quack n)
-    (+ x 1)))
+    (unless (zero? n)
+      (printf "quack\n")
+      (quack (sub1 n)))))
 ]
 
 @defform[(#%module-begin form ...)]{
@@ -272,8 +276,8 @@ In a @tech{top-level context}, @scheme[require] instantiates modules
 (see @secref["module-eval-model"]). In a @tech{module context},
 @scheme[require] @tech{visits} modules (see @secref["mod-parse"]). In
 both contexts, @scheme[require] introduces bindings into a
-@tech{namespace} or a module (see @secref["intro-binding"]). A
+@tech{namespace} or a module (see @secref["intro-binding"]). 
-@scheme[require] form in a @tech{expression context} or
+A @scheme[require] form in a @tech{expression context} or
 @tech{internal-definition context} is a syntax error.
 
 A @scheme[require-spec] designates a particular set of identifiers to
@@ -284,8 +288,11 @@ identifier. Each identifier also binds at a particular @tech{phase
 level}.
 
 The syntax of @scheme[require-spec] can be extended via
-@scheme[define-require-syntax], but the
+@scheme[define-require-syntax], and when multiple
-pre-defined forms are as follows.
+@scheme[require-spec]s are specified in a @scheme[require], the
+bindings of each @scheme[require-spec] are visible for expanding later
+@scheme[require-spec]s. The pre-defined forms (as exported by
+@scheme[scheme/base]) are as follows:
 
  @specsubform[module-path]{ Imports all exported bindings from the
   named module, using the export identifiers as the local identifiers.
@@ -364,56 +371,34 @@ pre-defined forms are as follows.
   binding that is not for @scheme[phase-level], where @scheme[#f] for
   @scheme[phase-level] corresponds to the @tech{label phase level}.
   
-  This example only imports bindings at @tech{phase level} 1, the
+  The following example imports bindings only at @tech{phase level} 1,
-  transform phase.
+  the transform phase:
 
-  @defexamples[#:eval (syntax-eval)
+  @interaction[#:eval meta-in-eval
-  (module test scheme
+  (module nest scheme
+    (provide (for-syntax meta-eggs)
+             (for-meta 1 meta-chicks)
+             num-eggs)
+    (define-for-syntax meta-eggs 2)
+    (define-for-syntax meta-chicks 3)
+    (define num-eggs 2))
 
-   (provide (for-syntax meta-1a)
+  (require (only-meta-in 1 'nest))
-            (for-meta 1 meta-1b)
-            meta-0)
 
-   (define-for-syntax meta-1a 'a)
+  (define-syntax (desc stx)
-   (define-for-syntax meta-1b 'b)
+    (printf "~s ~s\n" meta-eggs meta-chicks)
-   (define meta-0 2))
+    #'(void))
 
-  (require (only-meta-in 1 'test))
+   (desc)
-
+   num-eggs
-  (define-syntax bar
-   (lambda (stx)
-    (printf "~a\n" meta-1a)
-    (printf "~a\n" meta-1b)
-    #'1))
-
-   (bar)
-   meta-0
   ]
 
-  This example only imports bindings at @tech{phase level} 0, the
+  The following example imports only bindings at @tech{phase level} 0, the
   normal phase.
 
-  @defexamples[#:eval (syntax-eval)
+  @interaction[#:eval meta-in-eval
-  (module test scheme
+   (require (only-meta-in 0 'nest))
-
+   num-eggs
-   (provide (for-syntax meta-1a)
-            (for-meta 1 meta-1b)
-            meta-0)
-
-   (define-for-syntax meta-1a 'a)
-   (define-for-syntax meta-1b 'b)
-   (define meta-0 2))
-
-  (require (only-meta-in 0 'test))
-
-  (define-syntax bar
-   (lambda (stx)
-    (printf "~a\n" meta-1a)
-    (printf "~a\n" meta-1b)
-    #'1))
-
-   meta-0
-   (bar)
   ]}
 
  @specsubform[#:literals (for-meta)
@@ -424,23 +409,15 @@ pre-defined forms are as follows.
   combination that involves @scheme[#f] produces @scheme[#f].
   
   @defexamples[#:eval (syntax-eval)
-  (module test scheme
+  (module nest scheme
-    (provide foo)
+    (provide num-eggs)
-    (define foo 2))
+    (define num-eggs 2))
-  (require (for-meta 0 'test))
+  (require (for-meta 0 'nest))
-  foo
+  num-eggs
-  ]}
+  (require (for-meta 1 'nest))
-
+  (define-syntax (roost stx)
-  @defexamples[#:eval (syntax-eval)
+    (datum->syntax stx num-eggs))
-  (module test scheme
+  (roost)
-    (provide foo)
-    (define foo 2))
-  (require (for-meta 1 'test))
-  (define-syntax bar
-    (lambda (stx)
-      (printf "~a\n" foo)
-      #'1))
-  (bar)
   ]}
 
  @specsubform[#:literals (for-syntax)
@@ -456,7 +433,8 @@ pre-defined forms are as follows.
   @scheme[(for-meta #f require-spec ...)].}
 
  @specsubform[derived-require-spec]{See @scheme[define-require-syntax]
- for information on expanding the set of @scheme[require-spec] forms.}
+ for information on expanding the set of @scheme[require-spec]
+ forms.}
 
 @guideintro["module-paths"]{module paths}
 
@@ -523,8 +501,8 @@ corresponds to the default @tech{module name resolver}.
     @tech{collection}, and @filepath{main.ss} is the library file name.
 
     Example: require swindle
-    @defexamples[#:eval (syntax-eval)
+    @defexamples[#:eval require-eval
-      (require (lib "swindle"))]}
+      (eval:alts (require (lib "swindle")) (void))]}
 
     @item{If a single @scheme[rel-string] is provided, and if it
     consists of multiple @litchar{/}-separated elements, then each
@@ -533,8 +511,8 @@ corresponds to the default @tech{module name resolver}.
     no file suffix, @filepath{.ss} is added.
 
     Example: require a file within the swindle collection
-    @defexamples[#:eval (syntax-eval)
+    @defexamples[#:eval require-eval
-      (require (lib "swindle/turbo"))]}
+      (eval:alts (require (lib "swindle/turbo")) (void))]}
 
     @item{If a single @scheme[rel-string] is provided, and if it
     consists of a single element @italic{with} a file suffix (i.e,
@@ -543,8 +521,8 @@ corresponds to the default @tech{module name resolver}.
     compatibility with older version of PLT Scheme.)
 
     Example: require the tar module from mzlib
-    @defexamples[#:eval (syntax-eval)
+    @defexamples[#:eval require-eval
-      (require (lib "tar.ss"))]}
+      (eval:alts (require (lib "tar.ss")) (void))]}
 
     @item{Otherwise, when multiple @scheme[rel-string]s are provided,
     the first @scheme[rel-string] is effectively moved after the
@@ -555,8 +533,8 @@ corresponds to the default @tech{module name resolver}.
     with older version of PLT Scheme.)
 
     Example: require the tar module from mzlib
-    @defexamples[#:eval (syntax-eval)
+    @defexamples[#:eval require-eval
-      (require (lib "tar.ss" "mzlib"))]}
+      (eval:alts (require (lib "tar.ss" "mzlib")) (void))]}
   }}
 
  @specsubform[id]{A shorthand for a @scheme[lib] form with a single
@@ -564,14 +542,14 @@ corresponds to the default @tech{module name resolver}.
  form of @scheme[id]. In addition to the constraints of a @scheme[lib]
  @scheme[_rel-string], @scheme[id] must not contain @litchar{.}.
 
- @defexamples[#:eval (syntax-eval)
+ @examples[#:eval require-eval
-   (require scheme/tcp)]}
+   (eval:alts (require scheme/tcp) (void))]}
 
  @defsubform[(file string)]{Similar to the plain @scheme[rel-string]
  case, but @scheme[string] is a path---possibly absolute---using the
  current platform's path conventions and @scheme[expand-user-path].
 
- @scheme[(require (file "~/tmp/x.ss"))]}
+ @examples[(eval:alts (require (file "~/tmp/x.ss")) (void))]}
 
  @defsubform*[((planet id)
                (planet string)
@@ -631,27 +609,22 @@ corresponds to the default @tech{module name resolver}.
  identifiers in a minor-version constraint are recognized
  symbolically.
 
- Example: Load main.ss file package foo owned by bar.
+ @examples[
-
+ (code:comment #, @t{@filepath{main.ss} in package @filepath{farm} by @filepath{mcdonald}:})
- @scheme[(require (planet bar/foo))]
+ (eval:alts (require (planet mcdonald/farm)) (void))
- 
+ (code:comment #, @t{@filepath{main.ss} in version >= 2.0 of package @filepath{farm} by @filepath{mcdonald}:})
- Example: Load major version 2 of main.ss file package foo owned by bar.
+ (eval:alts (require (planet mcdonald/farm:2)) (void))
- 
+ (code:comment #, @t{@filepath{main.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:})
- @scheme[(require (planet bar/foo:2))]
+ (eval:alts (require (planet mcdonald/farm:2:5)) (void))
- 
+ (code:comment #, @t{@filepath{duck.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:})
- Example: Load major version 2 and minor version 5 of main.ss file package foo owned by bar.
+ (eval:alts (require (planet mcdonald/farm:2:5/duck)) (void))
- 
+ ]}
- @scheme[(require (planet bar/foo:2:5))]
- 
- Example: Load major version 2 and minor version 5 of buz.ss file package foo owned by bar.
- 
- @scheme[(require (planet bar/foo:2:5/buz))]}
 
 No identifier can be bound multiple times in a given @tech{phase
 level} by an import, unless all of the bindings refer to the same
 original definition in the same module.  In a @tech{module context},
 an identifier can be either imported or defined for a given
-@tech{phase level}, but not both.}
+@tech{phase level}, but not both.}}
 
 
 @guideintro["module-provide"]{@scheme[provide]}
@@ -697,29 +670,37 @@ follows.
  ambiguous).
 
  @defexamples[#:eval (syntax-eval)
-   (module test scheme
+   (module nest scheme
-      (provide foo)
+     (provide num-eggs)
-      (define foo 2))
+     (define num-eggs 2))
-   (require 'test)
+   (require 'nest)
-   foo
+   num-eggs
- ]}
+ ]
+
+ If @scheme[id] has a transformer binding to a @tech{rename
+ transformer}, then the exported binding is the target identifier of
+ the @tech{rename transformer}, instead of @scheme[id], unless the
+ target identifier has a true value for the
+ @scheme['not-free-identifier=?] @tech{syntax property}.}
 
  @defsubform[(all-defined-out)]{ Exports all identifiers that are
  defined at @tech{phase level} 0 or @tech{phase level} 1 within the
  exporting module, and that have the same lexical context as the
- @scheme[(all-defined-out)] form. The external name for each
+ @scheme[(all-defined-out)] form, excluding bindings to @tech{rename
- identifier is the symbolic form of the identifier. Only identifiers
+ transformers} where the target identifier has the
- accessible from the lexical context of the @scheme[(all-defined-out)]
+ @scheme['not-provide-all-defined] @tech{syntax property}. The
- form are included; that is, macro-introduced imports are not
+ external name for each identifier is the symbolic form of the
- re-exported, unless the @scheme[(all-defined-out)] form was
+ identifier. Only identifiers accessible from the lexical context of
- introduced at the same time.
+ the @scheme[(all-defined-out)] form are included; that is,
+ macro-introduced imports are not re-exported, unless the
+ @scheme[(all-defined-out)] form was introduced at the same time.
 
  @defexamples[#:eval (syntax-eval)
-   (module test scheme
+   (module nest scheme
      (provide (all-defined-out))
-     (define foo 2))
+     (define num-eggs 2))
-   (require 'test)
+   (require 'nest)
-   foo
+   num-eggs
  ]}
 
  @defsubform[(all-from-out module-path ...)]{ Exports all identifiers
@@ -734,14 +715,14 @@ follows.
  @scheme[module-path] was introduced at the same time.
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide foo)
+     (provide num-eggs)
-     (define foo 2))
+     (define num-eggs 2))
-   (module b scheme
+   (module hen-house scheme
-     (require 'a)
+     (require 'nest)
-     (provide (all-from-out 'a)))
+     (provide (all-from-out 'nest)))
-   (require 'b)
+   (require 'hen-house)
-   foo
+   num-eggs
  ]}
 
  @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each
@@ -750,12 +731,12 @@ follows.
  @scheme[export-id] instead @scheme[orig-d].
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide (rename-out (foo myfoo)))
+     (provide (rename-out [count num-eggs]))
-     (define foo 2))
+     (define count 2))
-   (require 'a)
+   (require 'nest)
-   foo
+   num-eggs
-   myfoo
+   count
  ]}
 
  @defsubform[(except-out provide-spec provide-spec ...)]{ Like the
@@ -766,14 +747,14 @@ follows.
  @scheme[provide-spec]s is ignored; only the bindings are used.
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
      (provide (except-out (all-defined-out)
-			  bar))
+			  num-chicks))
-     (define foo 2)
+     (define num-eggs 2)
-     (define bar 3))
+     (define num-chicks 3))
-   (require 'a)
+   (require 'nest)
-   foo
+   num-eggs
-   bar
+   num-chicks
  ]}
 
  @defsubform[(prefix-out prefix-id provide-spec)]{
@@ -781,11 +762,11 @@ follows.
  @scheme[provide-spec] prefixed with @scheme[prefix-id].
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide (prefix-out f: foo))
+     (provide (prefix-out chicken: num-eggs))
-     (define foo 2))
+     (define num-eggs 2))
-   (require 'a)
+   (require 'nest)
-   f:foo
+   chicken:num-eggs
  ]}
 
  @defsubform[(struct-out id)]{Exports the bindings associated with a
@@ -803,28 +784,24 @@ follows.
  included by @scheme[struct-out] for export.
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide (struct-out foo))
+     (provide (struct-out egg))
-     (define-struct foo (a b c)))
+     (define-struct egg (color wt)))
-   (require 'a)
+   (require 'nest)
-   make-foo
+   (egg-color (make-egg 'blue 10))
-   foo-a
-   foo-b
-   foo-c
-   foo?
  ]}
 
  @defsubform[(combine-out provide-spec ...)]{ The union of the
  @scheme[provide-spec]s.
 
  @defexamples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide (combine-out foo bar))
+     (provide (combine-out num-eggs num-chicks))
-     (define foo 2)
+     (define num-eggs 2)
-     (define bar 1))
+     (define num-chicks 1))
-   (require 'a)
+   (require 'nest)
-   foo
+   num-eggs
-   bar
+   num-chicks
  ]}
 
  @defsubform[(protect-out provide-spec ...)]{ Like the union of the
@@ -832,31 +809,19 @@ follows.
  @secref["modprotect"]. The @scheme[provide-spec] must specify only
  bindings that are defined within the exporting module.
 
- @defexamples[#:eval (syntax-eval)
+ @examples[#:eval (syntax-eval)
-   (module a scheme
+   (module nest scheme
-     (provide (protect-out foo))
+     (provide num-eggs (protect-out num-chicks))
-     (define foo 1))
+     (define num-eggs 2)
+     (define num-chicks 3))
    (define weak-inspector (make-inspector (current-code-inspector)))
    (define (weak-eval x)
      (parameterize ([current-code-inspector weak-inspector])
        (eval x)))
-   (require 'a)
+   (require 'nest)
-   foo
+   (list num-eggs num-chicks)
-   (weak-eval 'foo)
+   (weak-eval 'num-eggs)
- ]
+   (weak-eval 'num-chicks)
-
- Note that @scheme[require] works within eval as well.
- @defexamples[#:eval (syntax-eval)
-   (module a scheme
-     (provide (protect-out foo))
-     (define foo 1))
-   (define weak-inspector (make-inspector (current-code-inspector)))
-   (define (weak-eval x)
-     (parameterize ([current-code-inspector weak-inspector])
-       (eval x)))
-   (weak-eval '(require 'a))
-   foo
-   (weak-eval 'foo)
  ]}
 
  @specsubform[#:literals (for-meta) 
@@ -1005,21 +970,7 @@ context of the @scheme[phaseless-spec] form.}
 @note-lib-only[scheme/require]
 
 The following forms support more complex selection and manipulation of
-sets of imported identifiers.  Note that a @scheme[require] form is
+sets of imported identifiers.
-expanded before it is used, which means that requiring the library
-itself should be a separate form.  For example, use
-
-@schemeblock[
-  (require scheme/require)
-  (require (matching-identifiers-in #rx"foo" "foo.ss"))
-]
-
-instead of
-
-@schemeblock[
-  (require scheme/require
-           (matching-identifiers-in #rx"foo" "foo.ss"))
-]
 
 @defform[(matching-identifiers-in regexp require-spec)]{ Like
   @scheme[require-spec], but including only imports whose names match
@@ -1047,7 +998,7 @@ instead of
                       #rx"-" (string-titlecase name) "")))
               scheme/base))]
   will get the @scheme[scheme/base] bindings that match the regexp,
-  and renamed to use ``camel case''.}
+  and renamed to use ``camel case.''}
 
 @; --------------------
 
@@ -1489,8 +1440,8 @@ created first and filled with @|undefined-const|, and all
                      (or (zero? n)
                          (is-odd? (sub1 n))))]
          [is-odd? (lambda (n)
-                    (or (= n 1)
+                    (and (not (zero? n))
-                        (is-even? (sub1 n))))])
+                         (is-even? (sub1 n))))])
   (is-odd? 11))
 ]}
 
@@ -2109,14 +2060,19 @@ Equivalent to @scheme[(when (not test-expr) expr ...)].
 
 @defform[(set! id expr)]{
 
-If @scheme[id] has a @tech{transformer binding} to an
+If @scheme[id] has a @tech{transformer binding} to an @tech{assignment
-@tech{assignment transformer}, as produced by
+transformer}, as produced by @scheme[make-set!-transformer] or as an
-@scheme[make-set!-transformer], then this form is expanded by calling
+instance of a structure type with the @scheme[prop:set!-transformer]
-the assignment transformer with the full expressions. If @scheme[id]
+property, then this form is expanded by calling the assignment
-has a @tech{transformer binding} to a @tech{rename transformer} as
+transformer with the full expressions. If @scheme[id] has a
-produced by @scheme[make-rename-transformer], then this form is
+@tech{transformer binding} to a @tech{rename transformer} as produced
-expanded by replacing @scheme[id] with the one provided to
+by @scheme[make-rename-transformer] or as an instance of a structure
-@scheme[make-rename-transformer].
+type with the @scheme[prop:rename-transformer] property, then this
+form is expanded by replacing @scheme[id] with the target identifier
+(e.g., the one provided to @scheme[make-rename-transformer]). If a
+transformer binding has both @scheme[prop:set!-transformer] ad
+@scheme[prop:rename-transformer] properties, the latter takes
+precedence.
 
 Otherwise, evaluates @scheme[expr] and installs the result into the
 location for @scheme[id], which must be bound as a local variable or
@@ -2344,3 +2300,7 @@ than a precise prose description:
     [(nest ([form forms ...] . more) body0 body ...)
      (form forms ... (nest more body0 body ...))]))
 ]}
+
+
+@close-eval[require-eval]
+@close-eval[meta-in-eval]

collects/scribblings/reference/time.scrbl

@@ -72,12 +72,16 @@ Like @scheme[current-milliseconds], but the result never decreases
 (until the machine is turned off).}
 
 
-@defproc[(current-process-milliseconds) exact-integer?]{
+@defproc[(current-process-milliseconds [thread (or/c thread? #f)]) 
+         exact-integer?]{
 
-Returns the amount of processor time in @tech{fixnum} milliseconds
+Returns an amount of processor time in @tech{fixnum} milliseconds
 that has been consumed by the Scheme process on the underlying
 operating system. (Under @|AllUnix|, this includes both user and
-system time.)  The precision of the result is platform-specific, and
+system time.)  If @scheme[thread] is @scheme[#f], the reported time
+is for all Scheme threads, otherwise the result is specific to the
+time while @scheme[thread] ran.
+The precision of the result is platform-specific, and
 since the result is a @tech{fixnum}, the value increases only over a
 limited (though reasonably long) time.}
 

collects/scribblings/scribble/scheme.scrbl

@@ -90,7 +90,8 @@ typically used to typeset results.}
 
 When @scheme[to-paragraph] and variants encounter a @scheme[var-id]
 structure, it is typeset as @scheme[sym] in the variable font, like
-@scheme[schemevarfont].}
+@scheme[schemevarfont]---unless the @scheme[var-id] appears under
+quote or quasiquote, in which case @scheme[sym] is typeset as a symbol.}
 
 
 @defstruct[shaped-parens ([val any/c]
@@ -149,4 +150,5 @@ Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an
 
 Provided @scheme[for-syntax]; like @scheme[element-id-transformer] for
 a transformer that produces @scheme[sym] typeset as a variable (like
-@scheme[schemevarfont]).}
+@scheme[schemevarfont])---unless it appears under quote or quasiquote,
+in which case @scheme[sym] is typeset as a symbol.}

collects/scribblings/scribble/struct.scrbl

@@ -426,7 +426,8 @@ The @scheme[style] can be any of the following:
 
          @item{@scheme['valignment] to a list of symbols and
                @scheme[#f]s (one for each column); each symbol can be
-               @scheme['top], @scheme['baseline], or @scheme['bottom].}
+               @scheme['top], @scheme['baseline], @scheme['center], 
+               or @scheme['bottom].}
 
          @item{@scheme['row-styles] to a list of association lists,
                one for each row in the table. Each of these nested

collects/scribblings/scribble/utils.ss

@@ -1,120 +1,211 @@
+#lang scheme/base
 
-(module utils scheme/base
+(require scribble/struct
-  (require scribble/struct
+         scribble/manual
-           scribble/manual
+         (prefix-in scheme: scribble/scheme)
-           (prefix-in scheme: scribble/scheme)
+         (prefix-in scribble: scribble/reader))
-           (prefix-in scribble: scribble/reader))
 
-  (define-syntax bounce-for-label
+(define-syntax bounce-for-label
-    (syntax-rules (all-except)
+  (syntax-rules (all-except)
-      [(_ (all-except mod (id ...) (id2 ...)))
+    [(_ (all-except mod (id ...) (id2 ...)))
-       (begin
+     (begin (require (for-label (except-in mod id ...)))
-         (require (for-label (except-in mod id ...)))
+            (provide (for-label (except-out (all-from-out mod) id2 ...))))]
-         (provide (for-label (except-out (all-from-out mod) id2 ...))))]
+    [(_ mod) (begin (require (for-label mod))
-      [(_ mod) (begin
+                    (provide (for-label (all-from-out mod))))]
-                 (require (for-label mod))
+    [(_ mod ...) (begin (bounce-for-label mod) ...)]))
-                 (provide (for-label (all-from-out mod))))]
-      [(_ mod ...) (begin (bounce-for-label mod) ...)]))
 
-  (bounce-for-label (all-except scheme (link) ())
+(bounce-for-label (all-except scheme (link) ())
-                    scribble/struct
+                  scribble/struct
-                    scribble/base-render
+                  scribble/base-render
-                    scribble/decode
+                  scribble/decode
-                    scribble/manual
+                  scribble/manual
-                    scribble/scheme
+                  scribble/scheme
-                    scribble/eval
+                  scribble/eval
-                    scribble/bnf)
+                  scribble/bnf)
 
-  (provide scribble-examples litchar/lines)
+(provide scribble-examples litchar/lines)
 
-  (define (litchar/lines . strs)
+(define (as-flow e)
-    (let ([strs (regexp-split #rx"\n" (apply string-append strs))])
+  (make-flow (list (if (block? e) e (make-paragraph (list e))))))
-      (if (= 1 (length strs))
-        (litchar (car strs))
-        (make-table
-         #f
-         (map (lambda (s)
-                (list (make-flow (list (make-paragraph 
-					(if (string=? s "")
-					    '(nbsp) ; needed for IE
-					    (list (litchar s))))))))
-              strs)))))
 
-  (define (as-flow e)
+(define (litchar/lines . strs)
-    (make-flow (list (if (block? e)
+  (let ([strs (regexp-split #rx"\n" (apply string-append strs))])
-                         e
+    (if (= 1 (length strs))
-                         (make-paragraph (list e))))))
+      (litchar (car strs))
+      (make-table
+       #f
+       (map (lambda (s) ; the nbsp is needed for IE
+              (list (as-flow (if (string=? s "") 'nbsp (litchar s)))))
+            strs)))))
 
-  (define spacer (hspace 2))
+(define spacer (hspace 2))
 
-  (define ((norm-spacing base) p)
+(define ((norm-spacing base) p)
-    (cond
+  (cond [(and (syntax->list p) (not (null? (syntax-e p))))
-     [(and (syntax->list p)
+         (let loop ([e (syntax->list p)]
-           (not (null? (syntax-e p))))
+                    [line (syntax-line (car (syntax-e p)))]
-      (let loop ([e (syntax->list p)]
+                    [pos base]
-                 [line (syntax-line (car (syntax-e p)))]
+                    [second #f]
-                 [pos base]
+                    [accum null])
-                 [second #f]
+           (if (null? e)
-                 [accum null])
+             (datum->syntax
-        (cond
+              p (reverse accum)
-         [(null? e)
+              (list (syntax-source p) (syntax-line p) base (add1 base)
-          (datum->syntax
+                    (- pos base))
-           p
+              p)
-           (reverse accum)
+             (let* ([v ((norm-spacing (if (= line (syntax-line (car e)))
-           (list (syntax-source p)
+                                        pos
-                 (syntax-line p)
+                                        (or second pos)))
-                 base
+                        (car e))]
-                 (add1 base)
+                    [next-pos (+ (syntax-column v) (syntax-span v) 1)])
-                 (- pos base))
+               (loop (cdr e)
-           p)]
+                     (syntax-line v)
-         [else
+                     next-pos
-          (let* ([v ((norm-spacing (if (= line (syntax-line (car e)))
+                     (or second next-pos)
-                                       pos
+                     (cons v accum)))))]
-                                       (or second pos)))
+        [else (datum->syntax
-                     (car e))]
+               p (syntax-e p)
-                 [next-pos (+ (syntax-column v) (syntax-span v) 1)])
+               (list (syntax-source p) (syntax-line p) base (add1 base) 1)
-            (loop (cdr e)
+               p)]))
-                  (syntax-line v)
-                  next-pos
-                  (or second next-pos)
-                  (cons v accum)))]))]
-     [else
-      (datum->syntax
-       p
-       (syntax-e p)
-       (list (syntax-source p)
-             (syntax-line p)
-             base
-             (add1 base)
-             1)
-       p)]))
 
-  (define (scribble-examples . lines)
+(define (scribble-examples . lines)
-    (define reads-as (make-paragraph (list spacer "reads as" spacer)))
+  (define reads-as (make-paragraph (list spacer "reads as" spacer)))
-    (let* ([lines (apply string-append lines)]
+  (let* ([lines (apply string-append lines)]
-           [p (open-input-string lines)])
+         [p (open-input-string lines)])
-      (port-count-lines! p)
+    (port-count-lines! p)
-      (let loop ([r '()] [newlines? #f])
+    (let loop ([r '()] [newlines? #f])
-        (regexp-match? #px#"^[[:space:]]*" p)
+      (regexp-match? #px#"^[[:space:]]*" p)
-        (let* ([p1  (file-position p)]
+      (let* ([p1  (file-position p)]
-               [stx (scribble:read-syntax #f p)]
+             [stx (scribble:read-syntax #f p)]
-               [p2  (file-position p)])
+             [p2  (file-position p)])
-          (if (not (eof-object? stx))
+        (if (not (eof-object? stx))
-            (let ([str (substring lines p1 p2)])
+          (let ([str (substring lines p1 p2)])
-              (loop (cons (list str stx) r)
+            (loop (cons (list str stx) r)
-                    (or newlines? (regexp-match? #rx#"\n" str))))
+                  (or newlines? (regexp-match? #rx#"\n" str))))
-            (let* ([r (reverse r)]
+          (let* ([r (reverse r)]
-                   [r (if newlines?
+                 [r (if newlines?
-                        (cdr (apply append (map (lambda (x) (list #f x)) r)))
+                      (cdr (apply append (map (lambda (x) (list #f x)) r)))
-                        r)])
+                      r)])
-              (make-table
+            (make-table
-               #f
+             #f
-               (map (lambda (x)
+             (map (lambda (x)
-                      (let ([@expr (if x (litchar/lines (car x)) "")]
+                    (let ([@expr (if x (litchar/lines (car x)) "")]
-                            [sexpr (if x
+                          [sexpr (if x
-                                     (scheme:to-paragraph
+                                   (scheme:to-paragraph
-                                      ((norm-spacing 0) (cadr x)))
+                                    ((norm-spacing 0) (cadr x)))
-                                     "")]
+                                   "")]
-                            [reads-as (if x reads-as "")])
+                          [reads-as (if x reads-as "")])
-                        (map as-flow (list spacer @expr reads-as sexpr))))
+                      (map as-flow (list spacer @expr reads-as sexpr))))
-                    r)))))))))
+                  r))))))))
+
+;; stuff for the preprocessor examples
+
+(require scheme/list (for-syntax scheme/base scheme/list))
+
+(define max-textsample-width 45)
+
+(define (textsample-verbatim-boxes line in-text out-text more)
+  (define (split str) (regexp-split #rx"\n" str))
+  (define strs1 (split in-text))
+  (define strs2 (split out-text))
+  (define strsm (map (compose split cdr) more))
+  (define (str->elts str)
+    (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)])
+      (if spaces
+        (list* (substring str 0 (caar spaces))
+               (hspace (- (cdar spaces) (caar spaces)))
+               (str->elts (substring str (cdar spaces))))
+        (list (make-element 'tt (list str))))))
+  (define (make-line str)
+    (if (equal? str "")
+      ;;FIXME: this works in html, but in latex it creates a redundant newline
+      (list (as-flow (make-element 'newline '())))
+      (list (as-flow (make-element 'tt (str->elts str))))))
+  (define (small-attr attr)
+    (make-with-attributes attr '([style . "font-size: 82%;"])))
+  (define (make-box strs)
+    (make-table (small-attr 'boxed) (map make-line strs)))
+  (define filenames (map car more))
+  (define indent (let ([d (- max-textsample-width
+                             (for*/fold ([m 0])
+                                        ([s (in-list (cons strs1 strsm))]
+                                         [s (in-list s)])
+                               (max m (string-length s))))])
+                   (if (negative? d)
+                     (error 'textsample-verbatim-boxes
+                            "left box too wide for sample at line ~s" line)
+                     (make-element 'tt (list (hspace d))))))
+  ;; Note: the font-size property is reset for every table, so we need it
+  ;; everywhere there's text, and they don't accumulate for nested tables
+  (values
+   (make-table (make-with-attributes
+                '([alignment right left] [valignment top top])
+                '())
+     (cons (list (as-flow (make-table (small-attr #f)
+                                      (list (list (as-flow indent)))))
+                 (as-flow (make-box strs1)))
+           (map (lambda (file strs)
+                  (let* ([file (make-element 'tt (list file ":" 'nbsp))]
+                         [file (list (make-element 'italic (list file)))])
+                    (list (as-flow (make-element '(bg-color 232 232 255) file))
+                          (as-flow (make-box strs)))))
+                filenames strsm)))
+   (make-box strs2)))
+
+(define (textsample line in-text out-text more)
+  (define-values (box1 box2)
+    (textsample-verbatim-boxes line in-text out-text more))
+  (make-table '([alignment left left left] [valignment center center center])
+    (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2)))))
+
+(define-for-syntax tests-ids #f)
+
+(provide initialize-tests)
+(define-syntax (initialize-tests stx)
+  (set! tests-ids (map (lambda (x) (datum->syntax stx x stx))
+                       '(tests add-to-tests)))
+  (with-syntax ([(tests add-to-tests) tests-ids])
+    #'(begin (provide tests)
+             (define-values (tests add-to-tests)
+               (let ([l '()])
+                 (values (lambda () (reverse l))
+                         (lambda (x) (set! l (cons x l)))))))))
+
+(provide example)
+(define-syntax (example stx)
+  (define sep-rx  #px"^---[*]{3}---(?: +(.*))?$")
+  (define file-rx #rx"^[a-z0-9_.+-]+$")
+  (define-values (body hidden?)
+    (syntax-case stx ()
+      [(_ #:hidden x ...) (values #'(x ...) #t)]
+      [(_          x ...) (values #'(x ...) #f)]))
+  (let loop ([xs body] [text '(#f)] [texts '()])
+    (syntax-case xs ()
+      [("\n" sep "\n" . xs)
+       (and (string? (syntax-e #'sep)) (regexp-match? sep-rx (syntax-e #'sep)))
+       (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr]
+                      [else #f])])
+         (if (and m (not (regexp-match? file-rx m)))
+           (raise-syntax-error #f "bad filename specified" stx #'sep)
+           (loop #'xs
+                 (list (and m (datum->syntax #'sep m #'sep #'sep)))
+                 (cons (reverse text) texts))))]
+      [(x . xs) (loop #'xs (cons #'x text) texts)]
+      [() (let ([texts (reverse (cons (reverse text) texts))]
+                [line  (syntax-line stx)])
+            (define-values (files i/o) (partition car texts))
+            (unless ((length i/o) . = . 2)
+              (raise-syntax-error
+               'example "need at least an input and an output block" stx))
+            (with-syntax ([line  line]
+                          [((in ...) (out ...)) (map cdr i/o)]
+                          [((file text ...) ...) files]
+                          [add-to-tests (cadr tests-ids)])
+              (quasisyntax/loc stx
+                (let* ([in-text  (string-append in ...)]
+                       [out-text (string-append out ...)]
+                       [more (list (cons file (string-append text ...)) ...)])
+                  (add-to-tests (list line in-text out-text more))
+                  #,(if hidden? #'""
+                        #'(textsample line in-text out-text more))))))]
+      [_ (raise-syntax-error #f "no separator found in example text")])))

collects/sirmail/sendr.ss

@@ -6,6 +6,7 @@
   (require scheme/tcp
            scheme/unit
            scheme/class
+           scheme/string
 	   mred/mred-sig
            framework)
 
@@ -133,12 +134,34 @@
       ;;  `body-lines' is a list of strings and byte strings
       ;;  `enclosures' is a list of `enclosure' structs
       (define (enclose header body-lines enclosures)
+        (define qp-body-lines?
+          (ormap (lambda (l)
+                   (or ((string-length l) . > . 1000)
+                       (regexp-match? #rx"[^\0-\177]" l)))
+                 body-lines))
+        (define (encode-body-lines)
+          (if qp-body-lines?
+              (map
+               bytes->string/utf-8
+               (regexp-split #rx"\r\n"
+                             (qp-encode (string->bytes/utf-8 
+                                         (string-join body-lines "\r\n")))))
+              body-lines))
+        (define (add-body-encoding-headers header)
+          (insert-field
+           "Content-Type"
+            "text/plain; charset=UTF-8"
+            (insert-field
+             "Content-Transfer-Encoding"
+             (if qp-body-lines? "quoted-printable" "7bit")
+             header)))
 	(if (null? enclosures)
 	    (values (insert-field
-		     "Content-Type"
+                     "MIME-Version"
-		     "text/plain; charset=UTF-8"
+                     "1.0"
-		     header)
+                     (add-body-encoding-headers
-		    body-lines)
+                      header))
+		    (encode-body-lines))
 	    (let* ([enclosure-datas
                     (map (lambda (e) ((enclosure-data-thunk e))) enclosures)]
                    [boundary
@@ -175,27 +198,22 @@
 			  "This is a multi-part message in MIME format."
 			  (format "--~a" boundary))
 			 (header->lines
-			  (insert-field
+                          (add-body-encoding-headers
-			   "Content-Type"
+                           empty-header))
-			   "text/plain; charset=UTF-8"
+                         (encode-body-lines)
-			   (insert-field
+                         (apply
-			    "Content-Transfer-Encoding"
+                          append
-			    "7bit"
+                          (map
-			    empty-header)))
+                           (lambda (enc data)
-			  body-lines
+                             (cons
-			  (apply
+                              (format "--~a" boundary)
-			   append
+                              (append
-			   (map
+                               (header->lines
-			    (lambda (enc data)
+                                (enclosure-subheader enc))
-			      (cons
+                               data)))
-			       (format "--~a" boundary)
+                           enclosures enclosure-datas))
-			       (append
+                         (list
-				(header->lines
+                          (format "--~a--" boundary))))))))
-				 (enclosure-subheader enc))
-				data)))
-			    enclosures enclosure-datas))
-			  (list
-			   (format "--~a--" boundary))))))))
       
       (define (get-enclosure-type-and-encoding filename mailer-frame auto?)
         (let ([types '("application/postscript"

collects/srfi/1/misc.ss

@@ -39,16 +39,18 @@
          "selector.ss"
          "util.ss"
          (only-in "fold.ss" reduce-right)
-         (rename-in "fold.ss" [map s:map] [for-each s:for-each]))
+         (rename-in "fold.ss" [map s:map] [for-each s:for-each])
+         (only-in scheme/list count append*))
 
 (provide length+
-         concatenate (rename-out [concatenate concatenate!])
+         (rename-out [append* concatenate] [append* concatenate!])
          (rename-out [append append!])
          (rename-out [reverse reverse!])
          append-reverse (rename-out [append-reverse append-reverse!])
          zip unzip1 unzip2 unzip3 unzip4 unzip5
          count)
 
+#; ; reprovided from scheme/list
 ;; count
 ;;;;;;;;
 (define (count pred list1 . lists)
@@ -169,6 +171,7 @@
           (set-cdr! rev-head tail)
           (lp next-rev rev-head)))))
 
+#; ; reprovide scheme/list's `append*' function
 (define (concatenate lists) (reduce-right append '() lists))
 #; ; lists are immutable
 (define (concatenate! lists) (reduce-right my-append! '() lists))

collects/srfi/38/38.ss

@@ -1,8 +1,14 @@
 #lang scheme/base
 
-(provide s:read s:write)
+(define (write-with-shared-structure val [port (current-output-port)] [optarg #f])
+  (parameterize ([print-graph #t]) (write val port)))
+
+(define (read-with-shared-structure [port (current-input-port)] [optarg #f])
+  (parameterize ([read-accept-graph #t])
+    (read port)))
+
+(provide write-with-shared-structure
+         (rename-out [write-with-shared-structure write/ss])
+         read-with-shared-structure
+         (rename-out [read-with-shared-structure read/ss]))
 
-(define (s:write . args)
-  (parameterize ([print-graph #t]) (apply write args)))
-(define (s:read . args)
-  (parameterize ([read-accept-graph #t]) (apply read args)))

collects/stepper/private/xml-snip-helpers.ss

@@ -52,7 +52,7 @@
        (lambda ()
          (let* ([source-name (get-source-name editor)]
                 [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
-                [xml (read-xml port)]
+                [xml (parameterize ([permissive? #t]) (read-xml port))]
                 [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))]
                 [clean-xexpr (if eliminate-whitespace-in-empty-tags?
                                  (eliminate-whitespace-in-empty-tags xexpr)

collects/string-constants/french-string-constants.ss

@@ -191,7 +191,8 @@
   (cs-status-expanding-expression "Vérificateur de syntaxe : expansion d'une expression")
   (cs-status-loading-docs-index "Vérificateur de syntaxe : chargement de l'index de la documentation")
   (cs-mouse-over-import "l'identificateur ~s est importé de ~s")
-  (cs-view-docs "Regarder la documentation pour ~a")
+  (cs-view-docs "Documentation pour ~a")
+  (cs-view-docs-from "~a dans ~a")  ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use
 
   (cs-lexical-variable "variables lexicales")
   (cs-imported-variable "variables importées")
@@ -200,7 +201,7 @@
   (collect-button-label "Ramassage") ; de miettes
   (read-only "Lecture seulement")
   (auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ?
-  (overwrite "Correction") ; vs Insertion ? surimpression ?
+  (overwrite "Écrasement") ; vs Insertion ? surimpression ?
   (running "en cours")
   (not-running "en attente") ; "en attente" ; pause ?
   
@@ -242,6 +243,11 @@
   (erase-log-directory-contents "Effacer le contenu du répertoire d'enregistrement : ~a ?")
   (error-erasing-log-directory "Erreur durant l'effacement du contenu du répertoire d'enregistrement.\n\n~a\n")
   
+  ;; menu items connected to the logger -- also in a button in the planet status line in the drs frame
+  (show-log "Montrer le journa&l") ; "journaux" ne contient pas de "l"...
+  (hide-log "Cacher le journa&l")
+  (logging-all "Tous") ;; in the logging window in drscheme, shows all logs simultaneously
+  
   ;; modes
   (mode-submenu-label "Modes")
   (scheme-mode "Mode scheme")
@@ -676,6 +682,9 @@
   (complete-word "Compléter le mot") ; the complete word menu item in the edit menu
   (no-completions "... pas de complétion connue") ; shows up in the completions menu when there are no completions (in italics)
   
+  (overwrite-mode "Mode d'écrasement")
+  (enable-overwrite-mode-keybindings "Raccourci clavier pour le mode d'écrasement")
+  
   (preferences-info "Configurer vos préférences.")
   (preferences-menu-item "Préférences...")
   
@@ -707,18 +716,21 @@
   
   (wrap-text-item "Replier le texte")
   
+  ;; windows menu
   (windows-menu-label "Fe&nêtres")
   (minimize "Minimiser") ;; minimize and zoom are only used under mac os x
   (zoom "Agrandir") ; Zoomer?
   (bring-frame-to-front "Amener une fenêtre au premier plan")       ;;; title of dialog
   (bring-frame-to-front... "Amener une fenêtre au premier plan...") ;;; corresponding title of menu item
   (most-recent-window "Fenêtre la plus récente")
+  (next-tab "Onglet suivant")
+  (prev-tab "Onglet précédent")
   
   (view-menu-label "&Montrer")
-  (show-overview "Montrer le contour")
+  (show-overview "Montrer le contour du &programme")
-  (hide-overview "Cacher le contour")
+  (hide-overview "Cacher le contour du &programme")
-  (show-module-browser "Montrer le navigateur de modules")
+  (show-module-browser "Montrer le navigateur de &modules")
-  (hide-module-browser "Cacher le navigateur de modules")
+  (hide-module-browser "Cacher le navigateur de &modules")
   
   (help-menu-label "&Aide")
   (about-info "Auteurs et détails concernant ce logiciel.")
@@ -783,7 +795,7 @@
   ;;; file modified warning
   (file-has-been-modified
    "Ce fichier a été modifié depuis sa dernière sauvegarde. Voulez-vous écraser les modifications ?")
-  (overwrite-file-button-label "Ecraser")
+  (overwrite-file-button-label "Écraser")
   
   (definitions-modified 
    "Le texte de la fenêtre de définition a été modifié directement sur le disque dur. Sauvegardez ou retournez à la version sur le disque.")
@@ -842,7 +854,7 @@
   (close-tab "Fermer l'onglet")
   (close-tab-amp "Fermer l'onglet") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item
 
-  ;;; edit-menu
+  ;;; edit menu
   (split-menu-item-label "Di&viser")
   (collapse-menu-item-label "&Rassembler")
   
@@ -859,10 +871,10 @@
   (force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante")
   (limit-memory-menu-item-label "Limiter la mémoire...")
   (limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.")
-  (limit-memory-msg-2 "Elle doit être d'au moins 1 megaoctet.")
+  (limit-memory-msg-2 "Elle doit être d'au moins un megaoctet.")
   (limit-memory-unlimited "Illimitée")
-  (limit-memory-limited "Limitée")
+  (limit-memory-limited "Limitée à")
-  (limit-memory-megabytes "Megaoctets")
+  (limit-memory-megabytes "megaoctets")
   (clear-error-highlight-menu-item-label "Effacer le surlignage d'erreur")
   (clear-error-highlight-item-help-string "Efface le surlignage rose après une erreur")
   (reindent-menu-item-label "&Réindenter")
@@ -996,6 +1008,7 @@
   (decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels")
   (enforce-primitives-group-box-label "Définitions initiales")
   (enforce-primitives-check-box-label "Interdire la redéfinition des définition initiales")
+  (automatically-compile? "Compiler automatiquement les fichiers source ?")
 
   ; used in the bottom left of the drscheme frame as the label
   ; used the popup menu from the just above; greyed out and only
@@ -1033,6 +1046,7 @@
   (no-language-chosen "Aucun langage sélectionné")
   
   (module-language-one-line-summary "Exécuter crée une fenêtre d'interaction dans le contexte du module, incluant le langage du module lui-même")
+  (module-language-auto-text "Ligne #lang automatique") ;; shows up in the details section of the module language
   
   ;;; from the `not a language language' used initially in drscheme.
   (must-choose-language "DrScheme ne peut pas traiter un programme avant que vous aillez sélectionné un langage.")
@@ -1423,5 +1437,18 @@
   (bug-track-forget "Oublier")
   (bug-track-forget-all "Oublier tous")
   
+  ;; planet status messages in the bottom of the drscheme window; the ~a is filled with the name of the package
+  (planet-downloading "PLaneT: téléchargement de ~a...")
+  (planet-installing "PLaneT: installation de ~a...")
+  (planet-finished "PLaneT: ~a à jour.")
+  (planet-no-status "PLaneT") ;; this can happen when there is status shown in a different and then the user switches to a tab where planet hasn't been used
+  
+  ;; string normalization. To see this, paste some text with a ligature into DrScheme
+  ;; the first three strings are in the dialog that appears. The last one is in the preferences dialog
+  (normalize "Normaliser")
+  (leave-alone "Ne pas changer")
+  (normalize-string-info "La chaîne de caractères à coller contient des ligatures ou des caractères non-normalisés. Normaliser la chaîne ?")
+  (normalize-string-preference "Normaliser les chaînes de caractères durant le collage")
+  (ask-about-normalizing-strings "Demander à propos de la normalisation des chaînes de caractères")
 
   ); "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz"