sync to trunk

svn: r14978

collects/scheme/match/define-forms.ss

@@ -41,8 +41,11 @@
        (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)
+              (raise-syntax-error 
+               #f "expected a sequence of patterns" stx ps1))
+            (let ([len (length (syntax->list ps1))])
               (for/list ([ps pss])
                 (unless (= (length (syntax->list ps)) len)
                   (raise-syntax-error
@@ -50,7 +53,7 @@
                    stx ps)))
               (with-syntax ([(vars ...) (generate-temporaries (car pss))])
                 (syntax/loc stx
-                (lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
+                  (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,8 +3,15 @@
 (define seed (abs (current-milliseconds)))
 (random-seed seed)
 
+(define use-nested? #t)
+
 (error-print-context-length 100)
 
+;; Don't paste before copying, because that interferes with replay
+(define copied? #f)
+(define copy-len 0)
+
+(define (go pause x-pos)
   (define orig-t (new text%))
 
   (define frame
@@ -13,15 +20,17 @@
            (super-new))
          [label "Test"]
          [width 300]
-       [height 400]))
+         [height 400]
+         [x x-pos]))
+
   (define canvas
     (new editor-canvas% [parent frame] [editor orig-t]))
   
-(send frame show #t)
+  (define _1 (send frame show #t))
   
   (define (init t)
     (send t set-max-undo-history 100))
-(init orig-t)
+  (define _2 (init orig-t))
 
   (define (random-elem v)
     (vector-ref v (random (vector-length v))))
@@ -47,12 +56,26 @@
           (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)
-  (unless (= (send t get-start-position)
+    (let ([len (- (send t get-end-position)
-             (send t get-end-position))
+                  (send t get-start-position))])
-    (set! copied? #t)))
+      (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
@@ -76,12 +99,22 @@
      (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) (when (set-copied?! t) (send t copy) (maybe-convert)))
-   (lambda (t) (set-copied?! t) (send t cut))
+     (lambda (t) (when (set-copied?! t) (send t cut) (maybe-convert)))
-   (lambda (t) (set-copied?! t) (send t kill))
      (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 
@@ -90,15 +123,17 @@
                                                                                           (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))))
+           (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)
@@ -110,4 +145,54 @@
                  (random-elem ts))])
       (printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
       (act t)
-    (loop)))
+      (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)
+

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);