suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

sync to trunk

Browse Source 
svn: r14978
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-25 13:03:13 +00:00
commit d31926c434
12 changed files with 243 additions and 146 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/scheme/match/define-forms.ss
View File

@ -41,16 +41,19 @@
(syntax-case stx ()
[(k [pats . rhs] ...)
(let* ([pss (syntax->list #'(pats ...))]
[ps1 (car pss)]
[len (length (syntax->list ps1))])
(for/list ([ps pss])
(unless (= (length (syntax->list ps)) len)
(raise-syntax-error
#f "unequal number of patterns in match clauses"
stx ps)))
(with-syntax ([(vars ...) (generate-temporaries (car pss))])
(syntax/loc stx
(lambda (vars ...) (match* (vars ...) [pats . rhs] ...)))))]))
[ps1 (car pss)])
(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
#f "unequal number of patterns in match clauses"
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

6
collects/scribblings/inside/values.scrbl
View File

@ -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.}

14
collects/scribblings/reference/bytes.scrbl
View File

@ -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?]{
Returns a new mutable byte string that is @scheme[(- end start)]
bytes long, and that contains the same bytes
as @scheme[bstr] from @scheme[start] inclusive to @scheme[end] exclusive. The
@scheme[start] and @scheme[end] arguments must be less than the length of
@scheme[bstr], and @scheme[end] must be greater than or equal to @scheme[bstr],
otherwise the @exnraise[exn:fail:contract].
[end exact-nonnegative-integer? (bytes-length str)]) bytes?]{ Returns
a new mutable byte string that is @scheme[(- end start)] bytes long,
and that contains the same bytes as @scheme[bstr] from @scheme[start]
inclusive to @scheme[end] exclusive. The @scheme[start] and
@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[start], otherwise the @exnraise[exn:fail:contract].
@mz-examples[(subbytes #"Apple" 1 3)
(subbytes #"Apple" 1)]}

11
collects/scribblings/reference/strings.scrbl
View File

@ -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
as @scheme[str] from @scheme[start] inclusive to @scheme[end] exclusive. The
@scheme[start] and @scheme[end] arguments must be less than the length of
@scheme[str], and @scheme[end] must be greater than or equal to @scheme[str],
otherwise the @exnraise[exn:fail:contract].
characters long, and that contains the same characters as
@scheme[str] from @scheme[start] inclusive to @scheme[end] exclusive.
The @scheme[start] and @scheme[end] arguments must be less than or
equal to the length of @scheme[str], and @scheme[end] must be greater
than or equal to @scheme[start], otherwise the
@exnraise[exn:fail:contract].
@mz-examples[(substring "Apple" 1 3)
(substring "Apple" 1)]}

289
collects/tests/mred/wxme-random.ss
View File

@ -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)
(unless (= (send t get-start-position)
(send t get-end-position))
(set! copied? #t)))
(define copy-len 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) (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)))
))
(define (go pause x-pos)
(define orig-t (new text%))
(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)
(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)))

7
doc/release-notes/mred/HISTORY.txt
View File

@ -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

12
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -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
Version 4.1.5.3
Changed expander to detect a reaname transformer and install a
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

5
doc/release-notes/stepper/HISTORY.txt
View File

@ -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.

6
src/mzscheme/src/schemef.h
View File

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

6
src/mzscheme/src/schemex.h
View File

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

4
src/mzscheme/src/strops.inc
View File

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

6
src/mzscheme/src/vector.c
View File

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