sync to trunk

svn: r14978

collects/scheme/match/define-forms.ss

@@ -41,16 +41,19 @@
        (syntax-case stx ()
          [(k [pats . rhs] ...)
           (let* ([pss (syntax->list #'(pats ...))]
-                 [ps1 (car pss)]
+                 [ps1 (car pss)])
-                 [len (length (syntax->list ps1))])
+            (unless (syntax->list ps1)
-            (for/list ([ps pss])
+              (raise-syntax-error 
-              (unless (= (length (syntax->list ps)) len)
+               #f "expected a sequence of patterns" stx ps1))
-                (raise-syntax-error
+            (let ([len (length (syntax->list ps1))])
-                 #f "unequal number of patterns in match clauses"
+              (for/list ([ps pss])
-                 stx ps)))
+                (unless (= (length (syntax->list ps)) len)
-            (with-syntax ([(vars ...) (generate-temporaries (car pss))])
+                  (raise-syntax-error
-              (syntax/loc stx
+                   #f "unequal number of patterns in match clauses"
-                (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
+                   stx ps)))
+              (with-syntax ([(vars ...) (generate-temporaries (car pss))])
+                (syntax/loc stx
+                  (lambda (vars ...) (match* (vars ...) [pats . rhs] ...))))))]))
 
      ;; there's lots of duplication here to handle named let
      ;; some factoring out would do a lot of good

collects/scribblings/inside/values.scrbl

@@ -472,7 +472,7 @@ Like @cpp{scheme_make_sized_byte_string}, except the @var{len}
  non-zero, then @var{copy} must be non-zero.}
 
 @function[(Scheme_Object* scheme_alloc_byte_string
-           [int size]
+           [long size]
            [char fill])]{
 
 Allocates a new Scheme byte string.}
@@ -555,7 +555,7 @@ Like @cpp{scheme_make_sized_char_string}, except the @var{len}
  non-zero, then @var{copy} must be non-zero.}
 
 @function[(Scheme_Object* scheme_alloc_char_string
-           [int size]
+           [long size]
            [mzchar fill])]{
 
 Allocates a new Scheme string.}
@@ -636,7 +636,7 @@ Like @cpp{scheme_intern_exact_keyword}, but given a character array
  instead of a UTF-8-encoding byte array.}
 
 @function[(Scheme_Object* scheme_make_vector
-           [int size]
+           [long size]
            [Scheme_Object* fill])]{
 
 Allocates a new vector.}

collects/scribblings/reference/bytes.scrbl

@@ -90,13 +90,13 @@ positions are initialized with the given @scheme[b]s.
 
 
 @defproc[(subbytes [bstr bytes?] [start exact-nonnegative-integer?]
- [end exact-nonnegative-integer? (bytes-length str)]) bytes?]{
+ [end exact-nonnegative-integer? (bytes-length str)]) bytes?]{ Returns
- Returns a new mutable byte string that is @scheme[(- end start)]
+ a new mutable byte string that is @scheme[(- end start)] bytes long,
- bytes long, and that contains the same bytes
+ and that contains the same bytes as @scheme[bstr] from @scheme[start]
- as @scheme[bstr] from @scheme[start] inclusive to @scheme[end] exclusive.  The
+ inclusive to @scheme[end] exclusive.  The @scheme[start] and
- @scheme[start] and @scheme[end] arguments must be less than the length of
+ @scheme[end] arguments must be less than or equal to the length of
- @scheme[bstr], and @scheme[end] must be greater than or equal to @scheme[bstr],
+ @scheme[bstr], and @scheme[end] must be greater than or equal to
- otherwise the @exnraise[exn:fail:contract].
+ @scheme[start], otherwise the @exnraise[exn:fail:contract].
 
 @mz-examples[(subbytes #"Apple" 1 3)
              (subbytes #"Apple" 1)]}

collects/scribblings/reference/strings.scrbl

@@ -85,11 +85,12 @@ Returns an immutable string with the same content as
 @defproc[(substring [str string?] [start exact-nonnegative-integer?]
  [end exact-nonnegative-integer? (string-length str)]) string?]{
  Returns a new mutable string that is @scheme[(- end start)]
- characters long, and that contains the same characters
+ characters long, and that contains the same characters as
- as @scheme[str] from @scheme[start] inclusive to @scheme[end] exclusive.  The
+ @scheme[str] from @scheme[start] inclusive to @scheme[end] exclusive.
- @scheme[start] and @scheme[end] arguments must be less than the length of
+ The @scheme[start] and @scheme[end] arguments must be less than or
- @scheme[str], and @scheme[end] must be greater than or equal to @scheme[str],
+ equal to the length of @scheme[str], and @scheme[end] must be greater
- otherwise the @exnraise[exn:fail:contract].
+ than or equal to @scheme[start], otherwise the
+ @exnraise[exn:fail:contract].
 
 @mz-examples[(substring "Apple" 1 3)
              (substring "Apple" 1)]}

collects/tests/mred/wxme-random.ss

@@ -3,111 +3,196 @@
 (define seed (abs (current-milliseconds)))
 (random-seed seed)
 
+(define use-nested? #t)
+
 (error-print-context-length 100)
 
-(define orig-t (new text%))
-
-(define frame
-  (new (class frame% 
-         (define/augment (on-close) (exit))
-         (super-new))
-       [label "Test"]
-       [width 300]
-       [height 400]))
-(define canvas
-  (new editor-canvas% [parent frame] [editor orig-t]))
-
-(send frame show #t)
-
-(define (init t)
-  (send t set-max-undo-history 100))
-(init orig-t)
-
-(define (random-elem v)
-  (vector-ref v (random (vector-length v))))
-
-(define (random-string)
-  (random-elem '#("a" "x\ny\nz\n" "(define (f x)\n  (+ x x))\n" "hello there")))
-
-(define seqs (make-hasheq))
-
-(define ts-length 64)
-(define ts-pos 0)
-(define ts (make-vector ts-length orig-t))
-(define (add-t! t2)
-  (if (= ts-pos ts-length)
-      (let ([v ts])
-        (set! ts (make-vector ts-length orig-t))
-        (set! ts-pos 0)
-        (for ([t3 (in-vector v)])
-          (when (zero? (random 2))
-            (add-t! t3)))
-        (add-t! t2))
-      (begin
-        (vector-set! ts ts-pos t2)
-        (set! ts-pos (add1 ts-pos)))))
-
 ;; Don't paste before copying, because that interferes with replay
 (define copied? #f)
-(define (set-copied?! t)
+(define copy-len 0)
-  (unless (= (send t get-start-position)
-             (send t get-end-position))
-    (set! copied? #t)))
 
-(define actions
+(define (go pause x-pos)
-  (vector
+  (define orig-t (new text%))
-   (lambda (t) (send t undo))
-   (lambda (t) (send t redo))
-   (lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
-   (lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
-   (lambda (t) 
-     (let ([pos (random (add1 (send t last-position)))])
-       (send t delete pos (random (max 1 (- (send t last-position) pos))))))
-   (lambda (t)
-     (send t begin-edit-sequence)
-     (hash-update! seqs t add1 0))
-   (lambda (t) 
-     (let loop ()
-       (when (positive? (hash-ref seqs t 0))
-         (send t end-edit-sequence)
-         (hash-update! seqs t sub1)
-         (when (zero? (random 2))
-           (loop)))))
-   (lambda (t) 
-     (let ([pos (random (add1 (send t last-position)))])
-       (send t set-position pos (random (max 1 (- (send t last-position) pos))))))
-   (lambda (t) (set-copied?! t) (send t copy))
-   (lambda (t) (set-copied?! t) (send t cut))
-   (lambda (t) (set-copied?! t) (send t kill))
-   (lambda (t) (when copied? 
-                 (send t paste)
-                 (when (zero? (random 4))
-                   (send t paste-next))))
-   (lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
-   (lambda (t) (send t change-style 
-                     (send (make-object style-delta%) set-delta-foreground (make-object color%
-                                                                                        (random 256)
-                                                                                        (random 256)
-                                                                                        (random 256)))))
-   (lambda (t) 
-     (let ([t2 (new text%)])
-       (add-t! t2)
-       (init t2)
-       (send t insert (make-object editor-snip% t2))))
-   (lambda (t)
-     (send t set-max-width (if (zero? (random 2)) 
-                               (+ 50.0 (/ (random 500) 10.0))
-                               'none)))
-   (lambda (t) (yield (system-idle-evt)))
-   ))
 
-(send canvas focus)
+  (define frame
+    (new (class frame% 
+           (define/augment (on-close) (exit))
+           (super-new))
+         [label "Test"]
+         [width 300]
+         [height 400]
+         [x x-pos]))
+
+  (define canvas
+    (new editor-canvas% [parent frame] [editor orig-t]))
+  
+  (define _1 (send frame show #t))
+  
+  (define (init t)
+    (send t set-max-undo-history 100))
+  (define _2 (init orig-t))
+
+  (define (random-elem v)
+    (vector-ref v (random (vector-length v))))
+
+  (define (random-string)
+    (random-elem '#("a" "x\ny\nz\n" "(define (f x)\n  (+ x x))\n" "hello there")))
+
+  (define seqs (make-hasheq))
+
+  (define ts-length 64)
+  (define ts-pos 0)
+  (define ts (make-vector ts-length orig-t))
+  (define (add-t! t2)
+    (if (= ts-pos ts-length)
+        (let ([v ts])
+          (set! ts (make-vector ts-length orig-t))
+          (set! ts-pos 0)
+          (for ([t3 (in-vector v)])
+            (when (zero? (random 2))
+              (add-t! t3)))
+          (add-t! t2))
+        (begin
+          (vector-set! ts ts-pos t2)
+          (set! ts-pos (add1 ts-pos)))))
+
+  (define (set-copied?! t)
+    (let ([len (- (send t get-end-position)
+                  (send t get-start-position))])
+      (if (zero? len)
+          #f
+          (begin
+            (set! copy-len len)
+            (set! copied? #t)
+            #t))))
+
+  (define (maybe-convert)
+    (when (zero? (random 4))
+      (let ([data (send the-clipboard get-clipboard-data "WXME" 0)])
+        (send the-clipboard set-clipboard-client
+              (new (class clipboard-client%
+                     (inherit add-type)
+                     (super-new)
+                     (add-type "WXME")
+                     (define/override (get-data format) data)))
+              0))))
+
+  (define actions
+    (vector
+     (lambda (t) (send t undo))
+     (lambda (t) (send t redo))
+     (lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
+     (lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
+     (lambda (t) 
+       (let ([pos (random (add1 (send t last-position)))])
+         (send t delete pos (random (max 1 (- (send t last-position) pos))))))
+     (lambda (t)
+       (send t begin-edit-sequence)
+       (hash-update! seqs t add1 0))
+     (lambda (t) 
+       (let loop ()
+         (when (positive? (hash-ref seqs t 0))
+           (send t end-edit-sequence)
+           (hash-update! seqs t sub1)
+           (when (zero? (random 2))
+             (loop)))))
+     (lambda (t) 
+       (let ([pos (random (add1 (send t last-position)))])
+         (send t set-position pos (random (max 1 (- (send t last-position) pos))))))
+     (lambda (t) (when (set-copied?! t) (send t copy) (maybe-convert)))
+     (lambda (t) (when (set-copied?! t) (send t cut) (maybe-convert)))
+     (lambda (t) (when copied? 
+                   (let ([s (send t get-start-position)]
+                         [e (send t get-end-position)]
+                         [l (send t last-position)])
+                     (send t paste)
+                     (when copy-len
+                       (unless (= (send t last-position)
+                                  (+ (- l (- e s)) copy-len))
+                         (error 'paste "length mismatch: [~s, ~s) in ~s + ~s ~s -> ~s"
+                                s e l copy-len 
+                                (send the-clipboard get-clipboard-data "TEXT" 0)
+                                (send t last-position)))))
+                   (when (zero? (random 4))
+                     (set! copy-len #f)
+                     (send t paste-next))))
+     (lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
+     (lambda (t) (send t change-style 
+                       (send (make-object style-delta%) set-delta-foreground (make-object color%
+                                                                                          (random 256)
+                                                                                          (random 256)
+                                                                                          (random 256)))))
+     (lambda (t) 
+       (when use-nested?
+         (let ([t2 (new text%)])
+           (add-t! t2)
+           (init t2)
+           (send t insert (make-object editor-snip% t2)))))
+     (lambda (t)
+       (send t set-max-width (if (zero? (random 2)) 
+                                 (+ 50.0 (/ (random 500) 10.0))
+                                 'none)))
+     (lambda (t) (yield (system-idle-evt)))
+     (lambda (t) (pause))
+     ))
+  
+  (send canvas focus)
+  
+  (let loop ()
+    (let ([act (random-elem actions)]
+          [t (if (zero? (random 2))
+                 orig-t
+                 (random-elem ts))])
+      (printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
+      (act t)
+      (loop))))
+
+(define (run-one)
+  (go void 50))
+
+(define (run-two-concurrent)
+  (define sema-one (make-semaphore))
+  (define sema-two (make-semaphore))
+  
+  (define (make sema-this sema-other x-pos)
+    (parameterize ([current-eventspace (make-eventspace)])
+      (queue-callback
+       (lambda ()
+         (semaphore-wait sema-this)
+         (go (lambda ()
+               (semaphore-post sema-other)
+               (semaphore-wait sema-this))
+             x-pos)))
+      (current-eventspace)))
+
+  (define e1 (make sema-one sema-two 50))
+  (define e2 (make sema-two sema-one 350))
+  (semaphore-post sema-one)
+  (application-quit-handler (lambda args (exit)))
+  (yield never-evt))
+
+(define (run-two)
+  (define one-box (box #f))
+  (define two-box (box #f))
+  (define (make box-this box-other x-pos)
+    (let/ec esc
+      (call-with-continuation-prompt
+       (lambda ()
+         (begin
+           (let/cc k
+             (set-box! box-this k)
+             (esc))
+           (go (lambda ()
+                 (let/cc k
+                   (set-box! box-this k)
+                   ((unbox box-other))))
+               x-pos))))))
+
+  (make one-box two-box 50)
+  (make two-box one-box 350)
+  (call-with-continuation-prompt
+   (lambda ()
+     ((unbox one-box)))))
+
+(run-two)
 
-(let loop ()
-  (let ([act (random-elem actions)]
-        [t (if (zero? (random 2))
-               orig-t
-               (random-elem ts))])
-    (printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
-    (act t)
-    (loop)))

doc/release-notes/mred/HISTORY.txt

@@ -1,3 +1,10 @@
+Version 4.2, May 2009
+
+Ported the editor classes (text%, snip%, editor-canvas%, etc.) from
+ C++ to Scheme
+
+----------------------------------------------------------------------
+
 Version 4.1.5, March 2009
 
 Minor bug fixes

doc/release-notes/mzscheme/HISTORY.txt

@@ -1,11 +1,11 @@
-Version 4.1.5.6
+Version 4.2.0.2
 Added identifier-prune-lexical-context and quote-syntax/prune
 
-Version 4.1.5.4
+Version 4.2, May 2009
 Changed visiting of modules at phase N to happen only when compilation
  at phase N starts
-
+Changed expander to detect a reaname transformer and install a
-Version 4.1.5.3
+ free-identifier=? syntax-object equivalence
 Changed provide to convert an exported rename transformer to its
  free-identifier=? target
 Added 'not-free-identifier=? syntax property to disable free-identifier=? 
@@ -17,10 +17,6 @@ Changed current-process-milliseconds to accept a thread argument
 Added hash-hash-key?, hash-ref!
 Added in-sequences, in-cycle
 
-Version 4.1.5.2
-Changed expander to detect a reaname transformer and install a
- free-identifier=? syntax-object equivalence
-
 Version 4.1.5, March 2009
 Allow infix notation for prefab structure literals
 Change quasiquote so that unquote works in value positions of #hash

doc/release-notes/stepper/HISTORY.txt

@@ -1,6 +1,11 @@
 Stepper
 -------
 
+Changes for v4.2:
+
+It's now possible to jump to the evaluation of a selected expression in
+the stepper.
+
 Changes for v4.1.5:
 
 Minor bug fixes.

src/mzscheme/src/schemef.h

@@ -516,7 +516,7 @@ MZ_EXTERN Scheme_Object *scheme_make_sized_byte_string(char *chars, long len, in
 MZ_EXTERN Scheme_Object *scheme_make_sized_offset_byte_string(char *chars, long d, long len, int copy);
 MZ_EXTERN Scheme_Object *scheme_make_immutable_sized_byte_string(char *chars, long len, int copy);
 MZ_EXTERN Scheme_Object *scheme_make_byte_string_without_copying(char *chars);
-MZ_EXTERN Scheme_Object *scheme_alloc_byte_string(int size, char fill);
+MZ_EXTERN Scheme_Object *scheme_alloc_byte_string(long size, char fill);
 MZ_EXTERN Scheme_Object *scheme_append_byte_string(Scheme_Object *, Scheme_Object *);
 
 MZ_EXTERN Scheme_Object *scheme_make_utf8_string(const char *chars);
@@ -538,12 +538,12 @@ MZ_EXTERN Scheme_Object *scheme_make_sized_char_string(mzchar *chars, long len,
 MZ_EXTERN Scheme_Object *scheme_make_sized_offset_char_string(mzchar *chars, long d, long len, int copy);
 MZ_EXTERN Scheme_Object *scheme_make_immutable_sized_char_string(mzchar *chars, long len, int copy);
 MZ_EXTERN Scheme_Object *scheme_make_char_string_without_copying(mzchar *chars);
-MZ_EXTERN Scheme_Object *scheme_alloc_char_string(int size, mzchar fill);
+MZ_EXTERN Scheme_Object *scheme_alloc_char_string(long size, mzchar fill);
 MZ_EXTERN Scheme_Object *scheme_append_char_string(Scheme_Object *, Scheme_Object *);
 
 MZ_EXTERN mzchar *scheme_string_recase(mzchar *s, int d, int len, int mode, int inplace, int *_len);
 
-MZ_EXTERN Scheme_Object *scheme_make_vector(int size, Scheme_Object *fill);
+MZ_EXTERN Scheme_Object *scheme_make_vector(long size, Scheme_Object *fill);
 MZ_EXTERN Scheme_Object *scheme_make_integer_value(long i);
 MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_unsigned(unsigned long i);
 MZ_EXTERN Scheme_Object *scheme_make_integer_value_from_long_long(mzlonglong i);

src/mzscheme/src/schemex.h

@@ -425,7 +425,7 @@ Scheme_Object *(*scheme_make_sized_byte_string)(char *chars, long len, int copy)
 Scheme_Object *(*scheme_make_sized_offset_byte_string)(char *chars, long d, long len, int copy);
 Scheme_Object *(*scheme_make_immutable_sized_byte_string)(char *chars, long len, int copy);
 Scheme_Object *(*scheme_make_byte_string_without_copying)(char *chars);
-Scheme_Object *(*scheme_alloc_byte_string)(int size, char fill);
+Scheme_Object *(*scheme_alloc_byte_string)(long size, char fill);
 Scheme_Object *(*scheme_append_byte_string)(Scheme_Object *, Scheme_Object *);
 Scheme_Object *(*scheme_make_utf8_string)(const char *chars);
 Scheme_Object *(*scheme_make_sized_utf8_string)(char *chars, long len);
@@ -443,10 +443,10 @@ Scheme_Object *(*scheme_make_sized_char_string)(mzchar *chars, long len, int cop
 Scheme_Object *(*scheme_make_sized_offset_char_string)(mzchar *chars, long d, long len, int copy);
 Scheme_Object *(*scheme_make_immutable_sized_char_string)(mzchar *chars, long len, int copy);
 Scheme_Object *(*scheme_make_char_string_without_copying)(mzchar *chars);
-Scheme_Object *(*scheme_alloc_char_string)(int size, mzchar fill);
+Scheme_Object *(*scheme_alloc_char_string)(long size, mzchar fill);
 Scheme_Object *(*scheme_append_char_string)(Scheme_Object *, Scheme_Object *);
 mzchar *(*scheme_string_recase)(mzchar *s, int d, int len, int mode, int inplace, int *_len);
-Scheme_Object *(*scheme_make_vector)(int size, Scheme_Object *fill);
+Scheme_Object *(*scheme_make_vector)(long size, Scheme_Object *fill);
 Scheme_Object *(*scheme_make_integer_value)(long i);
 Scheme_Object *(*scheme_make_integer_value_from_unsigned)(unsigned long i);
 Scheme_Object *(*scheme_make_integer_value_from_long_long)(mzlonglong i);

src/mzscheme/src/strops.inc

@@ -59,11 +59,11 @@ X(scheme_make, _string)(const Xchar *chars)
 }
 
 Scheme_Object *
-X(scheme_alloc, _string)(int size, Xchar fill)
+X(scheme_alloc, _string)(long size, Xchar fill)
 {
   Scheme_Object *str;
   Xchar *s;
-  int i;
+  long i;
   
   if (size < 0) {
     str = scheme_make_integer(size);

src/mzscheme/src/vector.c

@@ -123,10 +123,10 @@ scheme_init_vector (Scheme_Env *env)
 }
 
 Scheme_Object *
-scheme_make_vector (int size, Scheme_Object *fill)
+scheme_make_vector (long size, Scheme_Object *fill)
 {
   Scheme_Object *vec;
-  int i;
+  long i;
 
   if (size < 0) {
     vec = scheme_make_integer(size);
@@ -331,7 +331,7 @@ list_to_vector (int argc, Scheme_Object *argv[])
 Scheme_Object *
 scheme_list_to_vector (Scheme_Object *list)
 {
-  int len, i;
+  long len, i;
   Scheme_Object *vec, *orig = list;
 
   len = scheme_proper_list_length(list);