diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 051a5104b7..30ed22e105 100644 --- a/collects/drscheme/private/language.ss +++ b/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 diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index da8dc8ebc9..d86836ecb0 100644 --- a/collects/drscheme/private/module-language.ss +++ b/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 diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 8d5df632f8..9c8f5112aa 100644 --- a/collects/drscheme/private/rep.ss +++ b/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 - (string->uninterned-symbol "this-is-the-funny-name")) +;; run a thunk, and if an exception is raised, make it possible to cut the +;; 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 -;; so that a new name gets put onto the mzscheme stack. DrScheme's exception -;; 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-syntax-rule (with-stack-checkpoint expr) + (call-with-stack-checkpoint (lambda () expr))) (define no-breaks-break-parameterization - (parameterize-break - #f - (current-break-parameterization))) + (parameterize-break #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 diff --git a/collects/lang/private/todo.ss b/collects/lang/private/todo.ss index 1eda9fb48b..2de7eb166f 100644 --- a/collects/lang/private/todo.ss +++ b/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-error - (beginner-make-string 3 "ab") - (string-append "make-string: " 1-letter " expected, given " - (format "~s" "ab"))) +(check-expect (beginner-replicate 3 "a") "aaa") +(check-expect (beginner-replicate 3 "ab") "ababab") +(check-error (beginner-replicate 3 10) "replicate: string expected, given 10") -(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)) - (unless (1-letter? 'make-string s1) - (error 'make-string "~a expected, given ~e" 1-letter s1)) + (error 'replicate "(exact) natural number expected, given ~e" n)) + (unless (string? 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->int: " 1-letter " expected, not a string: " - "10")) + (string-append "string->int: " 1-letter " expected, not a string: 10")) (check-error (beginner-string->int "AB") - (string-append - "string->int: " 1-letter " expected, given " - (format "~s" "AB"))) + (string-append "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 - (beginner-explode 10) - (string-append - "explode: string expected, given " - "10")) +(check-error (beginner-explode 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 - (beginner-implode 10) - (string-append - "implode: list of " 1-letter* " expected, not a list: " - "10")) -(check-error - (beginner-implode '("he" "l")) - (string-append - "implode: list of " 1-letter* " expected, given " - (format "~s" '("he" "l")))) +(check-error (beginner-implode 10) + (string-append "implode: list of " 1-letter* + " expected, not a list: 10")) +(check-error (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-string1-numeric? "a") false) -(check-error - (beginner-string1-numeric? "ab") - (string-append "string1-numeric?: " 1-letter " expected, given " - (format "~s" "ab"))) +(check-expect (beginner-string-numeric? "0") true) +(check-expect (beginner-string-numeric? "10") true) +(check-expect (beginner-string-numeric? "a") false) +(check-expect (beginner-string-numeric? "ab") false) +(check-error (beginner-string-numeric? 10) + (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) - (error 'string1-numeric? "~a expected, given ~e" 1-letter s1)) - (char-numeric? (string-ref s1 0)))) + (unless (string? s1) + (error 'string-numeric? "string expected, given ~e" s1)) + (andmap char-numeric? (string->list s1)))) ;; ----------------------------------------------------------------------------- ;; I used copying here and I feel awful. -(check-expect (beginner-string1-alphabetic? "0") false) -(check-expect (beginner-string1-alphabetic? "a") true) -(check-error - (beginner-string1-alphabetic? "ab") - (string-append "string1-alphabetic?: " 1-letter " expected, given " - (format "~s" "ab"))) +(check-expect (beginner-string-alphabetic? "a0") false) +(check-expect (beginner-string-alphabetic? "a") true) +(check-expect (beginner-string-alphabetic? "ba") true) +(check-expect (beginner-string-alphabetic? "ab") true) -(define-teach beginner string1-alphabetic? - ;; is this - #; - (andmap (lambda (c) - (or (string<=? "A" x "Z") (string<=? "a" x "z"))) - (string->list s)) - ;; enough? +(define-teach beginner string-alphabetic? (lambda (s1) - (unless (1-letter? 'string1-alphabetic? s1) - (error 'string1-alphabetic? "~a expected, given ~e" 1-letter s1)) - (char-alphabetic? (string-ref s1 0)))) + (unless (string? s1) + (error 'string-alphabetic? "string expected, given ~e" s1)) + (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 , given ~e" - n)) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (error 'build-string - "second argument must be a 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 that produces a ~a, given ~e, which produced ~e for ~e" - 1-letter f r i)) - r))))) - (test) \ No newline at end of file diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 9402788f45..040ef1a484 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/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 diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index a600805fa7..036285e1ca 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/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) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 683503f318..9bdbc11c6b 100644 --- a/collects/redex/redex.scrbl +++ b/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 -in terms of other definitions after the `with' clause or in -terms of the main --> relation. +Each of the clauses after the @scheme[with] define new relations +in terms of other definitions after the @scheme[with] clause or in +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 -documentation explaining text-style/c. One of the more -useful things it can be is one of the symbols 'roman, -'swiss, or 'modern, which are a serif, sans-serif, and +the picts. See @scheme[text] in the texpict collection for +documentation explaining @scheme[text-style/c]. One of the more +useful things it can be is one of the symbols @scheme['roman], +@scheme['swiss], or @scheme['modern], which are a serif, sans-serif, and monospaced font, respectively. (It can also encode style information, too.) diff --git a/collects/scheme/dict.ss b/collects/scheme/dict.ss index e90cf849bb..78001b4b9a 100644 --- a/collects/scheme/dict.ss +++ b/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)))) diff --git a/collects/scribblings/guide/regexp.scrbl b/collects/scribblings/guide/regexp.scrbl index 73c1ae13d6..edd8c344fd 100644 --- a/collects/scribblings/guide/regexp.scrbl +++ b/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. diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl index 13f8e6f5bc..f77f2a6a8d 100644 --- a/collects/scribblings/mzc/zo-parse.scrbl +++ b/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 -each shell's closure using the created shells, and then evaluates -@scheme[body].} +@scheme[procs], installs each onto the stack in previously +allocated slots in reverse order (so that the closure shell for the +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?] diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 9a194b174d..0afe1326f1 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/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?]{ diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index c93aa957ed..7b556c8289 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/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") diff --git a/collects/syntax/private/template-runtime.ss b/collects/syntax/private/template-runtime.ss index 809aa5e125..5270257b45 100644 --- a/collects/syntax/private/template-runtime.ss +++ b/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 diff --git a/collects/syntax/template.ss b/collects/syntax/template.ss index bb35a5ccfd..77e289f9c4 100644 --- a/collects/syntax/template.ss +++ b/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(prefab v map) => templat portion is a prefab +;; - #s(ellipses elem count map) => template portion is an ellipses-generated list +;; - #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 diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index e161246738..d07859fa18 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/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") diff --git a/collects/tests/mzscheme/dict.ss b/collects/tests/mzscheme/dict.ss index 517a68e235..ab2af1f15b 100644 --- a/collects/tests/mzscheme/dict.ss +++ b/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)) ;; ---------------------------------------- diff --git a/collects/tests/r6rs/syntax-case.sls b/collects/tests/r6rs/syntax-case.sls index a06279347d..4241905ce6 100644 --- a/collects/tests/r6rs/syntax-case.sls +++ b/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) diff --git a/src/configure b/src/configure index 295e7b9819..08062f6ff2 100755 --- a/src/configure +++ b/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 diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 69b2775995..78bc3f62af 100644 --- a/src/foreign/foreign.c +++ b/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); - else scheme_signal_error(MYNAME": cannot qualify 'char"); + if (intsize==0 && stars>0) RETSIZE(void); + 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; i0) RETSIZE(void); + 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} */ { @@ -1817,11 +1821,11 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ if (offsets[i] != 0) { - ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; + ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; } } /* 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 "$(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 diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index c4983db75e..6236202a05 100644 --- a/src/mzscheme/configure.ac +++ b/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)