sync to trunk

svn: r14795

collects/drscheme/private/language.ss

@@ -116,7 +116,7 @@
                   (documentation-reference #f)
                   (reader (λ (src port)
                             (let ([v (parameterize ([read-accept-reader #t])
-                                        (with-stacktrace-name 
+                                        (with-stack-checkpoint
                                          (read-syntax src port)))])
                               (if (eof-object? v)
                                   v

collects/drscheme/private/module-language.ss

@@ -11,6 +11,7 @@
          framework
          string-constants
          "drsig.ss"
+         "rep.ss"
          scheme/contract)
 
 (define op (current-output-port))
@@ -234,7 +235,7 @@
           (parameterize ([current-namespace (current-namespace)])
             ;; the prompt makes it continue after an error
             (call-with-continuation-prompt
-             (λ () (dynamic-require modspec #f))))
+             (λ () (with-stack-checkpoint (dynamic-require modspec #f)))))
           (current-namespace (module->namespace modspec))
           (check-interactive-language))
         ;; here's where they're all combined with the module expression

collects/drscheme/private/rep.ss

@@ -38,31 +38,43 @@ TODO
          ;; tho nothing is used from this module.
          planet/terse-info)
 
-(provide rep@ with-stacktrace-name)
+(provide rep@ with-stack-checkpoint)
 
-(define stacktrace-runtime-name
+;; run a thunk, and if an exception is raised, make it possible to cut the
-  (string->uninterned-symbol "this-is-the-funny-name"))
+;; stack so that the surrounding context is hidden
+(define stack-checkpoint (make-parameter #f))
+(define checkpoints (make-weak-hasheq))
+(define (call-with-stack-checkpoint thunk)
+  (define checkpoint (current-continuation-marks))
+  (with-handlers ([exn? (lambda (exn)
+                          ;; nested ones take precedence
+                          (unless (hash-has-key? checkpoints exn)
+                            (hash-set! checkpoints exn checkpoint))
+                          (raise exn))])
+    (thunk)))
+;; returns the stack of the input exception, cutting off any tail that was
+;; registered as a checkpoint
+(define (cut-stack-at-checkpoint exn)
+  (define stack (continuation-mark-set->context (exn-continuation-marks exn)))
+  (define checkpoint
+    (cond [(hash-ref checkpoints exn #f) => continuation-mark-set->context]
+          [else #f]))
+  (if (not checkpoint)
+    stack
+    (let loop ([st stack]
+               [sl (length stack)]
+               [cp checkpoint]
+               [cl (length checkpoint)])
+      (cond [(sl . > . cl) (cons (car st) (loop (cdr st) (sub1 sl) cp cl))]
+            [(sl . < . cl) (loop st sl (cdr cp) (sub1 cl))]
+            [(equal? st cp) '()]
+            [else (loop st sl (cdr cp) (sub1 cl))]))))
 
-;; this function wraps its argument expression in some code in a non-tail manner
+(define-syntax-rule (with-stack-checkpoint expr)
-;; so that a new name gets put onto the mzscheme stack. DrScheme's exception
+  (call-with-stack-checkpoint (lambda () expr)))
-;; handlers trims the stack starting at this point to avoid showing drscheme's
-;; internals on the stack in the REPL.
-(define call-with-stacktrace-name
-  (eval `(let ([,stacktrace-runtime-name
-                (lambda (thunk)
-                  (begin0
-                    (thunk)
-                    (void)))])
-           ,stacktrace-runtime-name)
-        (make-base-namespace)))
-
-(define-syntax-rule (with-stacktrace-name expr)
-  (call-with-stacktrace-name (lambda () expr)))
 
 (define no-breaks-break-parameterization
-  (parameterize-break 
+  (parameterize-break #f (current-break-parameterization)))
-   #f
-   (current-break-parameterization)))
 
 (define-unit rep@
   (import (prefix drscheme:init: drscheme:init^)
@@ -193,7 +205,7 @@ TODO
   (define (drscheme-error-display-handler msg exn)
     (let* ([cut-stack (if (and (exn? exn)
                                (main-user-eventspace-thread?))
-                          (cut-out-top-of-stack exn)
+                          (cut-stack-at-checkpoint exn)
                           '())]
            [srclocs-stack (filter values (map cdr cut-stack))]
            [stack 
@@ -220,7 +232,6 @@ TODO
          (λ (frame) (printf " ~s\n" frame))
          (continuation-mark-set->context (exn-continuation-marks exn)))
         (printf "\n"))
-      
       (drscheme:debug:error-display-handler/stacktrace msg exn stack)))
   
   (define (main-user-eventspace-thread?)
@@ -229,35 +240,6 @@ TODO
            (eq? (eventspace-handler-thread (send rep get-user-eventspace))
                 (current-thread)))))
   
-  (define (cut-out-top-of-stack exn)
-    (let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
-      initial-stack ;; just give up on trying to trim out DrScheme's frame's from the stack for now.
-      #;
-      (let loop ([stack initial-stack])
-        (cond
-          [(null? stack) 
-           (unless (exn:break? exn)
-             ;; give break exn's a free pass on this one.
-             ;; sometimes they get raised in a funny place. 
-             ;; (see call-with-break-parameterization below)
-             (unless (null? initial-stack)
-               ;; sometimes, mzscheme just doesn't have any backtrace all. in that case,
-               ;; don't print anything either.
-               (fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n")))
-           initial-stack]
-          [else 
-           (let ([top (car stack)])
-             (cond
-               [(cut-here? top) null]
-               [else (cons top (loop (cdr stack)))]))]))))
-  
-  ;; is-cut? : any symbol -> boolean
-  ;; determines if this stack entry is drscheme's barrier in the stacktrace
-  (define (cut-here? top)
-    (and (pair? top)
-         (let ([fn-name (car top)])
-           (eq? fn-name stacktrace-runtime-name))))
-  
   (define drs-bindings-keymap (make-object keymap:aug-keymap%))
 
   (let* ([get-frame
@@ -1120,12 +1102,12 @@ TODO
                  user-break-parameterization
                  (λ ()
                    (let loop ()
-                     (let ([sexp/syntax/eof (with-stacktrace-name (get-sexp/syntax/eof))])
+                     (let ([sexp/syntax/eof (with-stack-checkpoint (get-sexp/syntax/eof))])
                        (unless (eof-object? sexp/syntax/eof)
                          (call-with-values
                           (λ () 
                             (call-with-continuation-prompt
-                             (λ () (with-stacktrace-name (eval-syntax sexp/syntax/eof)))
+                             (λ () (with-stack-checkpoint (eval-syntax sexp/syntax/eof)))
                              (default-continuation-prompt-tag)
                              (and complete-program?
                                   (λ args

collects/lang/private/todo.ss

@@ -1,10 +1,5 @@
 #lang scheme
 
-;; If we eliminate char from HtDP/I, we need to add re-think 
-;; the following functions. Concrete proposals attached. 
-
-;; If you're in a hurry, look for QQQ. 
-
 #| QQQ: okay?
 char-upcase:   use string-upcase instead
 char-downcase: use string-downcase instead 
@@ -83,20 +78,17 @@ substring consumes 2 or 3 arguments
     (string (string-ref s n))))
 
 ;; -----------------------------------------------------------------------------
-;; QQQ: this would be a re-definition of a Scheme function. Should we rename? 
 
-(check-expect (beginner-make-string 3 "a") "aaa")
+(check-expect (beginner-replicate 3 "a") "aaa")
-(check-error
+(check-expect (beginner-replicate 3 "ab") "ababab")
- (beginner-make-string 3 "ab")
+(check-error (beginner-replicate 3 10) "replicate: string expected, given 10")
- (string-append "make-string: " 1-letter " expected, given " 
-                (format "~s" "ab")))
 
-(define-teach beginner make-string 
+(define-teach beginner replicate 
   (lambda (n s1)
     (unless (and (number? n) (exact-integer? n) (>= n 0))
-      (error 'make-string "(exact) natural number expected, given ~e" n))
+      (error 'replicate "(exact) natural number expected, given ~e" n))
-    (unless (1-letter? 'make-string s1)
+    (unless (string? s1)
-      (error 'make-string "~a expected, given ~e" 1-letter s1))
+      (error 'replicate "string expected, given ~e" s1))
     (apply string-append (build-list n (lambda (i) s1)))))
 
 ;; -----------------------------------------------------------------------------
@@ -126,14 +118,10 @@ substring consumes 2 or 3 arguments
 (check-expect (beginner-string->int "A") 65)
 (check-error 
  (beginner-string->int 10) 
- (string-append 
+ (string-append "string->int: " 1-letter " expected, not a string: 10"))
-  "string->int: " 1-letter " expected, not a string: "
-  "10"))
 (check-error 
  (beginner-string->int "AB") 
- (string-append 
+ (string-append "string->int: " 1-letter " expected, given " (format "~s" "AB")))
-  "string->int: " 1-letter " expected, given "
-  (format "~s" "AB")))
 
 (define-teach beginner string->int 
   (lambda (s) 
@@ -144,11 +132,8 @@ substring consumes 2 or 3 arguments
 ;; -----------------------------------------------------------------------------
 
 (check-expect (beginner-explode "hello") (list "h" "e" "l" "l" "o"))
-(check-error
+(check-error (beginner-explode 10) 
- (beginner-explode 10)
+             (string-append "explode: string expected, given " "10"))
- (string-append
-  "explode: string expected, given " 
-  "10"))
 
 (define-teach beginner explode 
   (lambda (s)
@@ -159,60 +144,48 @@ substring consumes 2 or 3 arguments
 ;; -----------------------------------------------------------------------------
 
 (check-expect (beginner-implode (list "h" "e" "l" "l" "o")) "hello")
-(check-error 
+(check-error (beginner-implode 10)
- (beginner-implode 10)
+             (string-append "implode: list of " 1-letter* 
- (string-append 
+                            " expected, not a list: 10"))
-  "implode: list of " 1-letter* " expected, not a list: " 
+(check-error (beginner-implode '("he" "l"))
-  "10"))
+             (string-append "implode: list of " 1-letter* " expected, given " 
-(check-error 
+                            (format "~s" '("he" "l"))))
- (beginner-implode '("he" "l"))
- (string-append 
-  "implode: list of " 1-letter* " expected, given " 
-  (format "~s" '("he" "l"))))
 
 (define-teach beginner implode
   (lambda (los)
     (unless (1-letter*? 'implode los)
       (error 'implode "list of ~a expected, given ~e" 1-letter* los))
-    (list->string (map (lambda (s) (string-ref s 0)) los))))
+    (apply string-append los)))
 
 ;; -----------------------------------------------------------------------------
 
-(check-expect (beginner-string1-numeric? "0") true)
+(check-expect (beginner-string-numeric? "0") true)
-(check-expect (beginner-string1-numeric? "a") false)
+(check-expect (beginner-string-numeric? "10") true)
-(check-error
+(check-expect (beginner-string-numeric? "a") false)
- (beginner-string1-numeric? "ab")
+(check-expect (beginner-string-numeric? "ab") false)
- (string-append "string1-numeric?: " 1-letter " expected, given " 
+(check-error (beginner-string-numeric? 10)
-                (format "~s" "ab")))
+             (string-append "string-numeric?: string expected, given 10"))
 
-(define-teach beginner string1-numeric? 
+(define-teach beginner string-numeric? 
   ;; is this: (number? (string->number s)) enough?
   (lambda (s1)
-    (unless (1-letter? 'string1-numeric? s1)
+    (unless (string? s1)
-      (error 'string1-numeric? "~a expected, given ~e" 1-letter s1))   
+      (error 'string-numeric? "string expected, given ~e" s1))   
-    (char-numeric? (string-ref s1 0))))
+    (andmap char-numeric? (string->list s1))))
 
 ;; -----------------------------------------------------------------------------
 
 ;; I used copying here and I feel awful. 
-(check-expect (beginner-string1-alphabetic? "0") false)
+(check-expect (beginner-string-alphabetic? "a0") false)
-(check-expect (beginner-string1-alphabetic? "a") true)
+(check-expect (beginner-string-alphabetic? "a") true)
-(check-error
+(check-expect (beginner-string-alphabetic? "ba") true)
- (beginner-string1-alphabetic? "ab")
+(check-expect (beginner-string-alphabetic? "ab") true)
- (string-append "string1-alphabetic?: " 1-letter " expected, given " 
-                (format "~s" "ab")))
 
-(define-teach beginner string1-alphabetic? 
+(define-teach beginner string-alphabetic? 
-  ;; is this
-  #;
-  (andmap (lambda (c) 
-            (or (string<=? "A" x "Z") (string<=? "a" x "z")))
-          (string->list s))
-  ;; enough?
   (lambda (s1)
-    (unless (1-letter? 'string1-alphabetic? s1)
+    (unless (string? s1)
-      (error 'string1-alphabetic? "~a expected, given ~e" 1-letter s1))
+      (error 'string-alphabetic? "string expected, given ~e" s1))
-    (char-alphabetic? (string-ref s1 0))))
+    (andmap char-alphabetic? (string->list s1))))
 
 ;; -----------------------------------------------------------------------------
 
@@ -252,29 +225,4 @@ substring consumes 2 or 3 arguments
 
 ;; -----------------------------------------------------------------------------
 
-;; !!! redefinition !!! (and copy from teachprims.ss)
-;; QQQ: do we need a new name????
-(check-expect (intermediate-build-string 3 (lambda (x) "x")) "xxx")
-
-(define-teach intermediate build-string
-  (lambda (n f)
-    (unless (and (number? n) (integer? n) (>= n 0))
-      (error 'build-string
-             "first argument must be of type <natural number>, given ~e" 
-             n))
-    (unless (and (procedure? f) (procedure-arity-includes? f 1))
-      (error 'build-string
-             "second argument must be a <procedure> that accepts one argument, given ~e"
-             f))
-    (apply string-append 
-           (build-list
-            n
-            (lambda (i)
-              (define r (f i))
-              (unless (1-letter? 'build-string r)
-                (error 'build-string
-                       "second argument must be a <procedure> that produces a ~a, given ~e, which produced ~e for ~e"
-                       1-letter f r i))
-              r)))))
-
 (test)

collects/mred/private/wxme/pasteboard.ss

@@ -1299,6 +1299,7 @@
                        (not ps?))
                   ;; draw to offscreen
                   (begin
+                    (send s-offscreen set-in-use #t)
                     (draw (send s-offscreen get-dc) (- left) (- top) left top width height show-caret bg-color)
                     
                     (send dc draw-bitmap-section 

collects/redex/private/reduction-semantics.ss

@@ -192,12 +192,12 @@
 (define-syntax (-reduction-relation stx)
   (syntax-case stx ()
     [(_ lang args ...)
-     #'(do-reduction-relation reduction-relation empty-reduction-relation #f lang args ...)]))
+     (syntax/loc stx (do-reduction-relation reduction-relation empty-reduction-relation #f lang args ...))]))
 
 (define-syntax (extend-reduction-relation stx)
   (syntax-case stx ()
     [(_ orig-reduction-relation lang args ...)
-     #'(do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...)]))
+     (syntax/loc stx (do-reduction-relation extend-reduction-relation orig-reduction-relation #t lang args ...))]))
 
 ;; the withs, freshs, and side-conditions come in backwards order
 (define-for-syntax (bind-withs orig-name main stx body)
@@ -258,10 +258,9 @@
               (syntax-e #'allow-zero-rules?)
               domain-pattern
               main-arrow))))]
-      [(_ id orig-reduction-relation lang args ...)
+      [(_ id orig-reduction-relation allow-zero-rules? lang args ...)
        (raise-syntax-error (syntax-e #'id) 
                            "expected an identifier for the language name"
-                           stx 
                            #'lang)]))
   
   (define (parse-keywords stx id args)

collects/redex/redex.scrbl

@@ -1,6 +1,7 @@
 #lang scribble/doc
 @(require scribble/manual
           scribble/bnf
+          scribble/struct
           scribble/eval
           (for-syntax scheme/base)
           (for-label scheme/base
@@ -48,6 +49,12 @@
      #'((tech "term") args ...)]
     [x (identifier? #'x) #'(tech "term")]))
 
+@(define-syntax-rule (arrows a0 a ...)
+   (make-blockquote #f 
+    (list (make-paragraph 
+           (list (schemeidfont (make-element #f (list (symbol->string 'a0))))
+                 (make-element #f (list " " (hspace 1) " " (schemeidfont (symbol->string 'a)))) ...)))))
+
 @(define redex-eval (make-base-eval))
 @(interaction-eval #:eval redex-eval (require redex/reduction-semantics))
 
@@ -228,7 +235,7 @@ matches the first @|ttpattern|. This match must include exactly one match
 against the second @|ttpattern|. If there are zero matches or more
 than one match, an exception is raised.
 
-When matching the first argument of in-hole, the `hole' @pattern
+When matching the first argument of in-hole, the @scheme[hole] @pattern
 matches any sexpression. Then, the sexpression that matched the hole
 @pattern is used to match against the second @|pattern|.
 }
@@ -243,7 +250,7 @@ that @|ttpattern|.
 matches what the embedded @ttpattern matches, and then the guard
 expression is evaluated. If it returns @scheme[#f], the @pattern fails
 to match, and if it returns anything else, the @pattern matches. Any
-occurrences of `name' in the @pattern (including those implicitly
+occurrences of @scheme[name] in the @pattern (including those implicitly
 there via @tt{_} pattersn) are bound using @scheme[term-let] in the
 guard. 
 }
@@ -578,7 +585,7 @@ all non-GUI portions of Redex) and also exported by
 This form defines the grammar of a language. It allows the
 definition of recursive @|pattern|s, much like a BNF, but for
 regular-tree grammars. It goes beyond their expressive
-power, however, because repeated `name' @|pattern|s and
+power, however, because repeated @scheme[name] @|pattern|s and
 side-conditions can restrict matches in a context-sensitive
 way.
 
@@ -651,7 +658,7 @@ defined by this language.
 
 @defproc[(compiled-lang? [l any/c]) boolean?]{
 
-Returns #t if its argument was produced by `language', #f
+Returns @scheme[#t] if its argument was produced by @scheme[language], @scheme[#f]
 otherwise.
 }
 
@@ -739,15 +746,15 @@ defines a reduction relation for the lambda-calculus above.
 
 Defines a reduction relation with shortcuts. As above, the
 first section defines clauses of the reduction relation, but
-instead of using -->, those clauses can use any identifier
+instead of using @scheme[-->], those clauses can use any identifier
 for an arrow, as long as the identifier is bound after the
-`with' clause. 
+@scheme[with] clause. 
 
-Each of the clauses after the `with' define new relations
+Each of the clauses after the @scheme[with] define new relations
-in terms of other definitions after the `with' clause or in
+in terms of other definitions after the @scheme[with] clause or in
-terms of the main --> relation.
+terms of the main @scheme[-->] relation.
 
-@scheme[fresh] is always fresh with respect to the entire
+A @scheme[fresh] variable is always fresh with respect to the entire
 term, not just with respect to the part that matches the
 right-hand-side of the newly defined arrow.
 
@@ -778,7 +785,7 @@ where the @tt{==>} relation is defined by reducing in the context
 
 This form extends the reduction relation in its first
 argument with the rules specified in @scheme[more]. They should
-have the same shape as the rules (including the `with'
+have the same shape as the rules (including the @scheme[with]
 clause) in an ordinary @scheme[reduction-relation].
 
 If the original reduction-relation has a rule with the same
@@ -815,7 +822,7 @@ closure of the reduction for the specified non-terminal.
 
 This accepts a reduction, a language, a pattern representing
 a context (ie, that can be used as the first argument to
-`in-hole'; often just a non-terminal) in the language and
+@scheme[in-hole]; often just a non-terminal) in the language and
 returns the closure of the reduction in that context.
 }
 
@@ -1184,7 +1191,7 @@ Like @scheme[check-reduction-relation] but for metafunctions.}
 
 It is easy to write grammars and reduction rules that are
 subtly wrong and typically such mistakes result in examples
-that just get stuck when viewed in a `traces' window.
+that just get stuck when viewed in a @scheme[traces] window.
 
 The best way to debug such programs is to find an expression
 that looks like it should reduce but doesn't and try to find
@@ -1583,6 +1590,11 @@ relevant dc: a @scheme[bitmap-dc%] or a @scheme[post-script-dc%], depending on
 whether @scheme[file] is a path. See also
 @scheme[reduction-relation->pict].
 
+The following forms of arrows can be typeset: 
+
+@arrows[--> -+> ==> -> => ..> >-> ~~> ~> :-> :--> c->
+        -->> >-- --< >>-- --<<]
+
 }
 
 @defproc[(reduction-relation->pict (r reduction-relation?)
@@ -1650,7 +1662,7 @@ This function sets @scheme[dc-for-text-size]. See also
 
 If this is #t, then a language constructed with
 extend-language is shown as if the language had been
-constructed directly with `language'. If it is #f, then only
+constructed directly with @scheme[language]. If it is #f, then only
 the last extension to the language is shown (with
 four-period ellipses, just like in the concrete syntax).
 
@@ -1725,10 +1737,10 @@ the results are displayed below the arguments.
 @defparam[default-style style text-style/c]{}]]{
 
 These parameters determine the font used for various text in
-the picts. See `text' in the texpict collection for
+the picts. See @scheme[text] in the texpict collection for
-documentation explaining text-style/c. One of the more
+documentation explaining @scheme[text-style/c]. One of the more
-useful things it can be is one of the symbols 'roman,
+useful things it can be is one of the symbols @scheme['roman],
-'swiss, or 'modern, which are a serif, sans-serif, and
+@scheme['swiss], or @scheme['modern], which are a serif, sans-serif, and
 monospaced font, respectively. (It can also encode style
 information, too.)
 

collects/scheme/dict.ss

@@ -499,7 +499,7 @@
                 create-immutable-custom-hash
                 make-weak-custom-hash)
   (let ([mk
-         (lambda (hash hash2 =? who make-custom-hash table)
+         (lambda (hash hash2 =? who make-custom-hash table wrap-make-box)
            (unless (and (procedure? =?)
                         (procedure-arity-includes? =? 2))
              (raise-type-error who "procedure (arity 2)" =?))
@@ -518,16 +518,25 @@
                                              (hash (hash-box-key v)))
                                            (lambda (v recur)
                                              (hash2 (hash-box-key v)))))
-             (make-custom-hash table make-box)))])
+             (make-custom-hash table (wrap-make-box make-box))))])
     (let ([make-custom-hash 
            (lambda (=? hash [hash2 (lambda (v) 10001)])
-             (mk hash hash2 =? 'make-custom-hash make-custom-hash (make-hash)))]
+             (mk hash hash2 =? 'make-custom-hash make-custom-hash (make-hash) values))]
           [make-immutable-custom-hash 
            (lambda (=? hash [hash2 (lambda (v) 10001)])
-             (mk hash hash2 =? 'make-immutable-custom-hash make-immutable-custom-hash #hash()))]
+             (mk hash hash2 =? 'make-immutable-custom-hash make-immutable-custom-hash #hash() values))]
           [make-weak-custom-hash 
            (lambda (=? hash [hash2 (lambda (v) 10001)])
-             (mk hash hash2 =? 'make-immutable-custom-hash make-immutable-custom-hash (make-weak-hash)))])
+             (mk hash hash2 =? 'make-weak-custom-hash make-custom-hash (make-weak-hash)
+                 (lambda (make-box)
+                   (let ([ht (make-weak-hasheq)])
+                     (lambda (v)
+                       (let ([e (hash-ref ht v #f)])
+                         (if e
+                             (ephemeron-value e)
+                             (let ([b (make-box v)])
+                               (hash-set! ht v (make-ephemeron v b))
+                               b))))))))])
       (values make-custom-hash 
               make-immutable-custom-hash
               make-weak-custom-hash))))

collects/scribblings/guide/regexp.scrbl

@@ -749,7 +749,7 @@ the call
 (regexp-match #rx"a*aa" "aaaa")
 ]
 
-the matcher backtracks even further.  Overall, failure is conceded
+the matcher backtracks even further.  Overall failure is conceded
 only when all possible backtracking has been tried with no success.
 
 Backtracking is not restricted to greedy quantifiers.

collects/scribblings/mzc/zo-parse.scrbl

@@ -380,9 +380,13 @@ from before evaluating @scheme[rhs].}
 
 Represents a @scheme[letrec] form with @scheme[lambda] bindings. It
 allocates a closure shell for each @scheme[lambda] form in
-@scheme[procs], pushes them onto the stack in reverse order, fills out
+@scheme[procs], installs each onto the stack in previously
-each shell's closure using the created shells, and then evaluates
+allocated slots in reverse order (so that the closure shell for the
-@scheme[body].}
+last element of @scheme[procs] is installed at stack position
+@scheme[0]), fills out each shell's closure (where each closure
+normally references some other just-created closures, which is
+possible because the shells have been installed on the stack), and
+then evaluates @scheme[body].}
 
 
 @defstruct+[(boxenv expr) ([pos exact-nonnegative-integer?]

collects/scribblings/reference/stx-ops.scrbl

@@ -151,7 +151,8 @@ needed to strip lexical and source-location information recursively.}
                                                (or/c exact-positive-integer? #f)
                                                (or/c exact-nonnegative-integer? #f)
                                                (or/c exact-nonnegative-integer? #f)
-                                               (or/c exact-positive-integer? #f)))]
+                                               (or/c exact-positive-integer? #f)))
+                                #f]
                         [prop (or/c syntax? #f) #f]
                         [cert (or/c syntax? #f) #f])
           syntax?]{

collects/string-constants/german-string-constants.ss

@@ -1196,6 +1196,8 @@
   (profj-java "Java")
   (profj-java-mode "Java-Modus")
 
+  (profj-java-coverage "Java-Abdeckung") ;; shows up in the preferences dialog under 'Color'
+
   (profj-beginner-lang "Anfänger")
   (profj-beginner-lang-one-line-summary "Java-ähnliche Lehrsprache für Anfänger")
   (profj-full-lang "Voller Sprachumfang")

collects/syntax/private/template-runtime.ss

@@ -4,6 +4,7 @@
 (provide template-map-apply)
 
 (define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes)
+(define-struct ellipses-quote (rest) #:prefab #:omit-define-syntaxes)
 (define-struct prefab (key fields) #:prefab #:omit-define-syntaxes)
 
 (define (stx-list->vector l)
@@ -74,6 +75,8 @@
                     stx
                     appended)
               appended)))]
+     [(ellipses-quote? tmap)
+      (loop (ellipses-quote-rest tmap) data stx local-pcons)]
      [(prefab? tmap)
       (d->s (car data)
             stx

collects/syntax/template.ss

@@ -19,10 +19,12 @@
 ;; - (vector map) => template portion is a vector,
 ;;                   contents like the list in map
 ;; - (box map) => template portion is a box with substition
-;; - #s(ellipses count map) => template portion is an ellipses-generated list
+;; - #s(ellipses elem count map) => template portion is an ellipses-generated list
-;; - #s(prefab v map) => templat portion is a prefab
+;; - #s(ellipses-quote map) => template has a quoting ellipses
+;; - #s(prefab v map) => template portion is a prefab
 
 (define-struct ellipses (elem count rest) #:prefab #:omit-define-syntaxes)
+(define-struct ellipses-quote (rest) #:prefab #:omit-define-syntaxes)
 (define-struct prefab (key fields) #:prefab #:omit-define-syntaxes)
 
 (define (datum->syntax* stx d)
@@ -36,7 +38,7 @@
        (and (not in-ellipses?)
             (identifier? #'ellipses)
             (free-identifier=? #'ellipses #'(... ...)))
-       (loop #'expr #t)]
+       (make-ellipses-quote (loop #'expr #t))]
       [(expr ellipses . rest)
        (and (not in-ellipses?)
             (identifier? #'ellipses)
@@ -108,6 +110,8 @@
                     (loop (ellipses-rest tmap) rest))
             (cons (loop (ellipses-elem tmap) (stx-car template))
                   (loop (ellipses-rest tmap) rest))))]
+     [(ellipses-quote? tmap)
+      (loop (ellipses-quote-rest tmap) (stx-car (stx-cdr template)))]
      [(prefab? tmap)
       (cons (s->d template)
             (loop (prefab-fields tmap)
@@ -149,6 +153,10 @@
           (if (syntax? template)
               (datum->syntax* template new)
               new)))]
+     [(ellipses-quote? tmap)
+      (datum->syntax* template
+                      (list (stx-car template)
+                           (loop (ellipses-quote-rest tmap) (stx-car (stx-cdr template)))))]
      [(prefab? tmap)
       (datum->syntax* 
        template

collects/tests/mzscheme/contract-test.ss

@@ -5092,6 +5092,7 @@ so that propagation occurs.
   (test-flat-contract '(string-len/c 3) "ab" "abc")
   (test-flat-contract 'natural-number/c 5 -1)
   (test-flat-contract 'natural-number/c #e3 #i3.0)
+  (test-flat-contract 'natural-number/c 0 -1)
   (test-flat-contract 'false/c #f #t)
   
   (test-flat-contract #t #t "x")

collects/tests/mzscheme/dict.ss

@@ -103,6 +103,20 @@
               h)
             #f #t #t
             "1")
+(let ([s1 (make-string 1 #\1)]
+      [s2 (make-string 1 #\2)])
+  (try-simple (let ([h (make-weak-custom-hash (lambda (a b)
+                                                (string=? (format "~a" a)
+                                                          (format "~a" b)))
+                                              (lambda (a)
+                                                (equal-hash-code (format "~a" a))))])
+                (dict-set! h s1 'one)
+                (dict-set! h s2 'two)
+                h)
+              #t #t #f
+              "1")
+  ;; preserve from GC:
+  (list s1 s2))
 
 ;; ----------------------------------------
 

collects/tests/r6rs/syntax-case.sls

@@ -209,6 +209,25 @@
              (map syntax->datum #'(x ... ...))])
           '(a b c))
 
+    (test (syntax-case #'(... x) ()
+            [a (syntax->datum #'a)])
+          'x)
+    (test (syntax-case #'(... ...) ()
+            [a (syntax->datum #'a)])
+          '...)
+    (test (syntax-case #'(... (other ...)) ()
+            [a (syntax->datum #'a)])
+          '(other ...))
+    (test (syntax-case #'(1 2 3) ()
+            [(a ...) (syntax->datum #'((a (... ...)) ...))])
+          '((1 ...) (2 ...) (3 ...)))
+    (test (syntax-case #'(1 2 3) ()
+            [(a b c) (syntax->datum #'(... (a ...)))])
+          '(1 ...))
+    (test (syntax-case #'(1 2 3) ()
+            [(a b c) (syntax->datum #'(... (... (a) b)))])
+          '(... (1) 2))
+
     (test (identifier? 'x) #f)
     (test (identifier? #'x) #t)
     (test (bound-identifier=? #'x #'x) #t)

src/configure

@@ -680,6 +680,7 @@ AS
 AR
 STATIC_AR
 ARFLAGS
+STRIP_DEBUG
 WBUILD
 CC_FOR_BUILD
 REZ
@@ -2286,6 +2287,8 @@ CGC_INSTALLED=cgc
 CGC_CAP_INSTALLED=CGC
 MAIN_VARIANT=3m
 
+STRIP_DEBUG=":"
+
 ###### OSKit stuff #######
 
 if test "${enable_oskit}" = "yes" ; then
@@ -5801,6 +5804,7 @@ case $OS in
     LIBS="$LIBS -ldl -lm -rdynamic"
     DYN_CFLAGS="-fPIC"
     GC_THREADS_FLAG="-DGC_LINUX_THREADS"
+    STRIP_DEBUG="strip -S"
     # PPC: X11 librares are not found
     case `$UNAME -m` in
       #Required for CentOS 4.6
@@ -5872,6 +5876,8 @@ case $OS in
 
     PREFLAGS="$PREFLAGS -DOS_X -D_DARWIN_UNLIMITED_SELECT"
 
+    STRIP_DEBUG="/usr/bin/strip -S"
+
     # zlib comes with the OS
     ZLIB_A=""
     ZLIB_INC=""
@@ -11931,6 +11937,7 @@ LIBS="$LIBS $EXTRALIBS"
 
 
 
+
 
 
 mk_needed_dir()
@@ -12787,6 +12794,7 @@ AS!$AS$ac_delim
 AR!$AR$ac_delim
 STATIC_AR!$STATIC_AR$ac_delim
 ARFLAGS!$ARFLAGS$ac_delim
+STRIP_DEBUG!$STRIP_DEBUG$ac_delim
 WBUILD!$WBUILD$ac_delim
 CC_FOR_BUILD!$CC_FOR_BUILD$ac_delim
 REZ!$REZ$ac_delim
@@ -12817,7 +12825,6 @@ MREDLINKER!$MREDLINKER$ac_delim
 LIBSFX!$LIBSFX$ac_delim
 WXLIBS!$WXLIBS$ac_delim
 WXVARIANT!$WXVARIANT$ac_delim
-ICP!$ICP$ac_delim
 _ACEOF
 
   if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 97; then
@@ -12859,6 +12866,7 @@ _ACEOF
 ac_delim='%!_!# '
 for ac_last_try in false false false false false :; do
   cat >conf$$subs.sed <<_ACEOF
+ICP!$ICP$ac_delim
 MRLIBINSTALL!$MRLIBINSTALL$ac_delim
 LIBFINISH!$LIBFINISH$ac_delim
 MAKE_MRED!$MAKE_MRED$ac_delim
@@ -12900,7 +12908,7 @@ LIBOBJS!$LIBOBJS$ac_delim
 LTLIBOBJS!$LTLIBOBJS$ac_delim
 _ACEOF
 
-  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 39; then
+  if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 40; then
     break
   elif $ac_last_try; then
     { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5

src/foreign/foreign.c

@@ -1752,8 +1752,10 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[])
     else scheme_signal_error(MYNAME": cannot qualify 'char");
     break;
   case 3: /* void */
-    if (intsize==0) RETSIZE(void);
+    if (intsize==0 && stars>0) RETSIZE(void);
-    else scheme_signal_error(MYNAME": cannot qualify 'char");
+    else if (stars==0)
+      scheme_signal_error(MYNAME": cannot use 'void without a '*");
+    else scheme_signal_error(MYNAME": cannot qualify 'void");
     break;
   case 4: /* float */
     if (intsize==0) RETSIZE(float);
@@ -2331,6 +2333,8 @@ void do_ptr_finalizer(void *p, void *finalizer)
 
 #define MAX_QUICK_ARGS 16
 
+typedef void(*VoidFun)();
+
 Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
 /* data := {name, c-function, itypes, otype, cif} */
 {
@@ -2417,7 +2421,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     }
   }
   /* Finally, call the function */
-  ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
+  ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
   if (ivals != stack_ivals) free(ivals);
   ivals = NULL; /* no need now to hold on to this */
   for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */

src/foreign/foreign.ssc

@@ -1224,8 +1224,10 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
     else scheme_signal_error(MYNAME": cannot qualify 'char");
     break;
   case 3: /* void */
-    if (intsize==0) RETSIZE(void);
+    if (intsize==0 && stars>0) RETSIZE(void);
-    else scheme_signal_error(MYNAME": cannot qualify 'char");
+    else if (stars==0)
+      scheme_signal_error(MYNAME": cannot use 'void without a '*");
+    else scheme_signal_error(MYNAME": cannot qualify 'void");
     break;
   case 4: /* float */
     if (intsize==0) RETSIZE(float);
@@ -1735,6 +1737,8 @@ cdefine[register-finalizer 2 3]{
 
 #define MAX_QUICK_ARGS 16
 
+typedef void(*VoidFun)();
+
 Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
 /* data := {name, c-function, itypes, otype, cif} */
 {
@@ -1821,7 +1825,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[])
     }
   }
   /* Finally, call the function */
-  ffi_call(cif, (void *)W_OFFSET(c_func, cfoff), p, avalues);
+  ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues);
   if (ivals != stack_ivals) free(ivals);
   ivals = NULL; /* no need now to hold on to this */
   for (i=0; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */

src/mred/Makefile.in

@@ -350,7 +350,7 @@ install-wx_mac-cgc:
 	$(ICP) -r PLT_MrEd.framework/Versions/$(FWVERSION)/Resources $(MRFWDIR)/Versions/$(FWVERSION)/Resources
 	/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)/PLT_MrEd" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
 	$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@" ../../../collects
-	/usr/bin/strip -S "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
+	@STRIP_DEBUG@ "$(prefix)/MrEd@CGC_CAP_INSTALLED@.app/Contents/MacOS/MrEd@CGC_CAP_INSTALLED@"
 
 install-wx_mac-cgc-final:
 	ln -s Versions/$(FWVERSION)/PLT_MrEd $(MRFWDIR)/
@@ -364,7 +364,7 @@ install-wx_mac-3m:
 	$(ICP) -r "PLT_MrEd.framework/Versions/$(FWVERSION)_3m/Resources" "$(MRFWDIR)/Versions/$(FWVERSION)_3m/Resources"
 	/usr/bin/install_name_tool -change "@executable_path/../../../PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "@FRAMEWORK_PREFIX@PLT_MrEd.framework/Versions/$(FWVERSION)_3m/PLT_MrEd" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
 	$(MZSCHEME) -cu "$(srcdir)/../mzscheme/collects-path.ss" "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@" "../../../collects"
-	/usr/bin/strip -S "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
+	@STRIP_DEBUG@ "$(prefix)/MrEd@MMM_CAP_INSTALLED@.app/Contents/MacOS/MrEd@MMM_CAP_INSTALLED@"
 
 install-wx_mac-3m-final:
 	ln -s Versions/$(FWVERSION)_3m/PLT_MrEd $(MRFWDIR)/

src/mzscheme/Makefile.in

@@ -25,6 +25,8 @@ AR = @AR@
 ARFLAGS = @ARFLAGS@
 RANLIB = @RANLIB@
 
+STRIP_DEBUG = @STRIP_DEBUG@
+
 ARLIBFLAGS = @LDFLAGS@ @LIBS@
 
 MZSRC = $(srcdir)/src
@@ -275,7 +277,7 @@ unix-install:
 	cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@CGC_INSTALLED@"
 	cd ..; rm -f "$(DESTDIR)$(bindir)/mzscheme@MMM_INSTALLED@"
 	cd ..; cp mzscheme/starter "$(DESTDIR)$(libpltdir)/starter"
-	cd ..; strip -S "$(DESTDIR)$(libpltdir)/starter"
+	cd ..; $(STRIP_DEBUG) "$(DESTDIR)$(libpltdir)/starter"
 	cd ..; echo 'CC=@CC@' > "$(BUILDINFO)"
 	cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)"
 	cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)"
@@ -321,7 +323,7 @@ osx-install-cgc:
 	mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)"
 	cp $(MZFW) $(MZFWDIR)/Versions/$(FWVERSION)/
 	/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)/PLT_MzScheme" "$(bindir)/mzscheme@CGC_INSTALLED@"
-	/usr/bin/strip -S "$(bindir)/mzscheme@CGC_INSTALLED@"
+	$(STRIP_DEBUG) "$(bindir)/mzscheme@CGC_INSTALLED@"
 
 osx-install-cgc-final:
 	$(MAKE) unix-install-cgc-final
@@ -332,7 +334,7 @@ osx-install-3m:
 	mkdir -p "$(MZFWDIR)/Versions/$(FWVERSION)_3m"
 	cp $(MZFWMMM) $(MZFWDIR)/Versions/$(FWVERSION)_3m/
 	/usr/bin/install_name_tool -change "@executable_path/PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "@FRAMEWORK_PREFIX@PLT_MzScheme.framework/Versions/$(FWVERSION)_3m/PLT_MzScheme" "$(bindir)/mzscheme@MMM_INSTALLED@"
-	/usr/bin/strip -S "$(bindir)/mzscheme@MMM_INSTALLED@"
+	$(STRIP_DEBUG) "$(bindir)/mzscheme@MMM_INSTALLED@"
 
 osx-install-3m-final:
 	$(MAKE) unix-install-3m-final

src/mzscheme/configure.ac

@@ -349,6 +349,8 @@ CGC_INSTALLED=cgc
 CGC_CAP_INSTALLED=CGC
 MAIN_VARIANT=3m
 
+STRIP_DEBUG=":"
+
 ###### OSKit stuff #######
 
 if test "${enable_oskit}" = "yes" ; then
@@ -536,6 +538,7 @@ case $OS in
     LIBS="$LIBS -ldl -lm -rdynamic"
     DYN_CFLAGS="-fPIC"
     GC_THREADS_FLAG="-DGC_LINUX_THREADS"
+    STRIP_DEBUG="strip -S"
     # PPC: X11 librares are not found
     case `$UNAME -m` in
       #Required for CentOS 4.6
@@ -607,6 +610,8 @@ case $OS in
     
     PREFLAGS="$PREFLAGS -DOS_X -D_DARWIN_UNLIMITED_SELECT"
 
+    STRIP_DEBUG="/usr/bin/strip -S"
+
     # zlib comes with the OS
     ZLIB_A=""
     ZLIB_INC=""
@@ -1318,6 +1323,7 @@ AC_SUBST(RANLIB)
 AC_SUBST(AR)
 AC_SUBST(STATIC_AR)
 AC_SUBST(ARFLAGS)
+AC_SUBST(STRIP_DEBUG)
 AC_SUBST(WBUILD)
 AC_SUBST(CC_FOR_BUILD)
 AC_SUBST(REZ)