From bac292acc68a16622a51af64dee72edb5c65bb3a Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 8 May 2009 21:55:05 +0000 Subject: [PATCH 01/20] second draft of char/string svn: r14755 --- collects/lang/private/todo.ss | 124 ++++++++++------------------------ 1 file changed, 36 insertions(+), 88 deletions(-) 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 From b48be0464584cc38fdb0afd1df122cdbbc397728 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 9 May 2009 01:01:37 +0000 Subject: [PATCH 02/20] typo from Dorai svn: r14759 --- collects/scribblings/guide/regexp.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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. From 04d274f894472c90d727b7d19c9b7c09cc0903e0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 9 May 2009 07:50:20 +0000 Subject: [PATCH 03/20] Welcome to a new PLT day. svn: r14760 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 48438023f6..78590eee86 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "8may2009") +#lang scheme/base (provide stamp) (define stamp "9may2009") From 99c19a552c94030f6e91b2d018ad4bf73ee1f65c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 May 2009 13:37:04 +0000 Subject: [PATCH 04/20] fix doc typo svn: r14761 --- collects/scribblings/reference/stx-ops.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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?]{ From 440a60c8ad91e0a08bf2615784d319831e5f7329 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 9 May 2009 13:37:28 +0000 Subject: [PATCH 05/20] fix make-custom-weak-hash (PR 10232) svn: r14762 --- collects/scheme/dict.ss | 19 ++++++++++++++----- collects/tests/mzscheme/dict.ss | 14 ++++++++++++++ 2 files changed, 28 insertions(+), 5 deletions(-) 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/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)) ;; ---------------------------------------- From 248fb510b9c2a6e3e80cda67af666dcf54908159 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 9 May 2009 13:46:38 +0000 Subject: [PATCH 06/20] Synch German string constants with latest. svn: r14763 --- collects/string-constants/german-string-constants.ss | 2 ++ 1 file changed, 2 insertions(+) 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") From cd6fbedfa81db1f763b73af5ba461f7b895422fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 9 May 2009 19:39:17 +0000 Subject: [PATCH 07/20] dont take sizeof(void), fix function typecase (both PR10234), fix error message svn: r14764 --- src/foreign/foreign.c | 8 +++++--- src/foreign/foreign.ssc | 8 +++++--- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 69b2775995..900596ba5a 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); @@ -2417,7 +2419,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, (void(*)())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); @@ -1821,7 +1823,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, (void(*)())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 Date: Sat, 9 May 2009 21:09:14 +0000 Subject: [PATCH 08/20] ignore errors from strip, such as those resulting from using the solaris version (PR10072) svn: r14765 --- src/mzscheme/Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index a05a4c07fc..4fbb03e68d 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -275,7 +275,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 -S "$(DESTDIR)$(libpltdir)/starter" cd ..; echo 'CC=@CC@' > "$(BUILDINFO)" cd ..; echo 'CFLAGS=@CFLAGS@ @PREFLAGS@ @COMPFLAGS@' >> "$(BUILDINFO)" cd ..; echo 'OPTIONS=@OPTIONS@' >> "$(BUILDINFO)" From e9bcf8b15fd98f00611fd94e2b19f68eb34605ff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 9 May 2009 23:21:13 +0000 Subject: [PATCH 09/20] work around xform parsing issue svn: r14766 --- src/foreign/foreign.c | 4 +++- src/foreign/foreign.ssc | 6 ++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 900596ba5a..78bc3f62af 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2333,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} */ { @@ -2419,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 Date: Sun, 10 May 2009 07:50:16 +0000 Subject: [PATCH 10/20] Welcome to a new PLT day. svn: r14767 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 78590eee86..ea0d44cd81 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "9may2009") +#lang scheme/base (provide stamp) (define stamp "10may2009") From 01af9995566a674f91628255e9b766bfbff24c8b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 10 May 2009 21:53:09 +0000 Subject: [PATCH 11/20] svn: r14768 --- collects/tests/mzscheme/contract-test.ss | 1 + 1 file changed, 1 insertion(+) 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") From 0c0aa26e6f8916e8ca5968d9ce36f49a65e23290 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 10 May 2009 21:59:13 +0000 Subject: [PATCH 12/20] PR 10231 svn: r14769 --- collects/redex/private/reduction-semantics.ss | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) 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) From a7580f9c606ed76eb5cd3ae24dd1f1b1fdca7a7c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 11 May 2009 07:50:08 +0000 Subject: [PATCH 13/20] Welcome to a new PLT day. svn: r14773 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index ea0d44cd81..29fc1096b1 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "10may2009") +#lang scheme/base (provide stamp) (define stamp "11may2009") From fd09fd9a336b4707af8bfc6f365aac693d4699af Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 May 2009 15:43:19 +0000 Subject: [PATCH 14/20] STRIP_DEBUG configuration svn: r14774 --- src/configure | 12 ++++++++++-- src/mred/Makefile.in | 4 ++-- src/mzscheme/Makefile.in | 8 +++++--- src/mzscheme/configure.ac | 6 ++++++ 4 files changed, 23 insertions(+), 7 deletions(-) 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/mred/Makefile.in b/src/mred/Makefile.in index cd56ba0b72..785664c3a1 100644 --- a/src/mred/Makefile.in +++ b/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)/ diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index 4fbb03e68d..4655d9f585 100644 --- a/src/mzscheme/Makefile.in +++ b/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 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) From 9375b49d1baf715567ef51b0011b066705d0a52a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 11 May 2009 20:13:54 +0000 Subject: [PATCH 15/20] let-rec clarifications svn: r14776 --- collects/scribblings/mzc/zo-parse.scrbl | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) 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?] From f51c6bbe64bc320e9a315ba6a49357c2e83023a2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 12 May 2009 02:12:49 +0000 Subject: [PATCH 16/20] Fix the leaking of internal drscheme filenames in error messages when debugging is disabled: * got rid of the `stacktrace-runtime-name' hack in "rep.ss", replace it by a more reliable capture of the context, and later cut the stack according to that specific context. * the cutting is done if possible, no need for the "ACK!" error message if no cutting point is found. * rename `with-stacktrace-name' -> `with-stack-checkpoint' * add this to "module-language.ss" too, to avoid including it in error messages. svn: r14777 --- collects/drscheme/private/language.ss | 2 +- collects/drscheme/private/module-language.ss | 3 +- collects/drscheme/private/rep.ss | 90 ++++++++------------ 3 files changed, 39 insertions(+), 56 deletions(-) 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 From da6e35bf98ced4d73cc223070b2dddf6208f9dd2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 12 May 2009 07:50:18 +0000 Subject: [PATCH 17/20] Welcome to a new PLT day. svn: r14778 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 29fc1096b1..923a5855e3 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "11may2009") +#lang scheme/base (provide stamp) (define stamp "12may2009") From 5df29ea906da6606aa22bb72569072ae7734b6f1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 May 2009 12:52:55 +0000 Subject: [PATCH 18/20] fix bug with editor-snip% in pasteboard% in editor-canvas% on Windows or X11 (i.e., platforms that use the offscreen bitmap for drawing editors) svn: r14779 --- collects/mred/private/wxme/pasteboard.ss | 1 + 1 file changed, 1 insertion(+) 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 From 1809d9286ee6d16aecc58ed541c200240908cb46 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 May 2009 13:44:04 +0000 Subject: [PATCH 19/20] fix r6rs template problem with quoting ellipses svn: r14780 --- collects/syntax/private/template-runtime.ss | 3 +++ collects/syntax/template.ss | 14 +++++++++++--- collects/tests/r6rs/syntax-case.sls | 19 +++++++++++++++++++ 3 files changed, 33 insertions(+), 3 deletions(-) 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/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) From 0f1fc2d6640d2e3514b31adb4fb3cc97d18574b7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 12 May 2009 21:30:28 +0000 Subject: [PATCH 20/20] redex doc corrections svn: r14789 --- collects/redex/redex.scrbl | 48 ++++++++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 18 deletions(-) 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.)