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

Syncing up to trunk.

Browse Source 
svn: r12470
This commit is contained in:
Stevie Strickland 2008-11-17 16:03:30 +00:00
commit 573caad99f
27 changed files with 533 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
collects/games/cards/card-class.ss
View File

@ -2,9 +2,11 @@
(module card-class mzscheme
(require mzlib/class
mzlib/class100
mzlib/shared
(prefix mred: mred)
"snipclass.ss"
"region.ss")
"region.ss"
(only scheme/base for in-range))
(provide card%)
@ -28,18 +30,43 @@
(thunk)
(send dc set-clipping-region r))))
(define (rotate-bm bm cw?)
(let ([w (send bm get-width)]
[h (send bm get-height)])
(let ([bm2 (make-object mred:bitmap% h w)]
[s (make-bytes (* w h 4))]
[s2 (make-bytes (* h w 4))])
(send bm get-argb-pixels 0 0 w h s)
(for ([i (in-range w)])
(for ([j (in-range h)])
(let ([src-pos (* (+ i (* j w)) 4)])
(bytes-copy! s2
(if cw?
(* (+ (- (- h j) 1) (* i h)) 4)
(* (+ j (* (- (- w i) 1) h)) 4))
s src-pos (+ src-pos 4)))))
(let ([dc (make-object mred:bitmap-dc% bm2)])
(send dc set-argb-pixels 0 0 h w s2)
(send dc set-bitmap #f))
bm2)))
(define orientations (shared ([o (list* 'n 'e 's 'w o)]) o))
(define (find-head l s)
(if (eq? (car l) s)
l
(find-head (cdr l) s)))
(define card%
(class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back)
(class100 mred:snip% (-suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms)
(inherit set-snipclass set-count get-admin)
(private-field
[suit-id -suit-id]
[value -value]
[width -width]
[height -height]
[rotated 'n]
[front -front]
[back -back]
[semi-front -semi-front]
[semi-back -semi-back]
[mk-dim-front -mk-dim-front]
[mk-dim-back -mk-dim-back]
[dim-front #f]
@ -51,13 +78,20 @@
[can-move? #t]
[snap-back? #f]
[stay-region #f]
[home-reg #f])
[home-reg #f]
[rotated-bms -rotated-bms])
(private
[refresh
(lambda ()
(let ([a (get-admin)])
(when a
(send a needs-update this 0 0 width height))))]
[refresh-size
(lambda ()
(let ([a (get-admin)])
(when a
(send a resized this #f)))
(refresh))]
[check-dim
(lambda ()
(when is-dim?
@ -65,7 +99,18 @@
(unless dim-back
(set! dim-back (mk-dim-back)))
(unless dim-front
(set! dim-front (mk-dim-front))))))])
(set! dim-front (mk-dim-front))))))]
[get-rotated
(lambda (bm dir)
(if (eq? dir 'n)
bm
(or (hash-table-get rotated-bms (cons dir bm) #f)
(let ([rotated-bm (case dir
[(w) (rotate-bm bm #f)]
[(e) (rotate-bm bm #t)]
[(s) (rotate-bm (rotate-bm bm #t) #t)])])
(hash-table-put! rotated-bms (cons dir bm) rotated-bm)
rotated-bm))))])
(public
[face-down? (lambda () flipped?)]
[flip
@ -84,6 +129,25 @@
(unless (eq? is-dim? (and v #t))
(set! is-dim? (and v #t))
(refresh))])]
[orientation (lambda () (case rotated
[(n) 0]
[(e) 270]
[(w) 90]
[(s) 180]))]
[rotate (lambda (mode)
(let ([delta (case mode
[(0 360) 0]
[(cw -90 270) 1]
[(ccw 90 -270) 3]
[(180 -180) 2]
[else (error 'rotate "bad mode: ~e" mode)])])
(set! rotated (list-ref (find-head orientations rotated) delta))
(if (odd? delta)
(let ([w width])
(set! width height)
(set! height w)
(refresh-size))
(refresh))))]
[get-suit-id
(lambda () suit-id)]
[get-suit
@ -133,26 +197,44 @@
[draw
(lambda (dc x y left top right bottom dx dy draw-caret)
(check-dim)
(if semi-flipped?
(send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y)
(with-card-region
dc x y width height
(lambda ()
(send dc draw-bitmap
(if flipped?
(if is-dim? dim-back back)
(if is-dim? dim-front front))
x y)))))]
[copy (lambda () (make-object card% suit-id value width height
front back semi-front semi-back
(lambda ()
(unless dim-front
(set! dim-front (mk-dim-front)))
dim-front)
(lambda ()
(unless dim-back
(set! dim-back (mk-dim-back)))
dim-back)))])
(let ([do-draw
(lambda (x y)
(with-card-region
dc x y width height
(lambda ()
(send dc draw-bitmap
(let ([bm (if flipped?
(if is-dim? dim-back back)
(if is-dim? dim-front front))])
(get-rotated bm rotated))
x y))))])
(if semi-flipped?
(let-values ([(sx sy) (send dc get-scale)])
(case rotated
[(n s)
(send dc set-scale (/ sx 2) sy)
(do-draw (+ (* 2 x) (/ width 2)) y)
(send dc set-scale sx sy)]
[(e w)
(send dc set-scale sx (/ sy 2))
(do-draw x (+ (* 2 y) (/ height 2)))
(send dc set-scale sx sy)]))
(do-draw x y))))]
[copy (lambda ()
(let ([rotated? (memq rotated '(e w))])
(make-object card% suit-id value
(if rotated? height width)
(if rotated? width height )
front back
(lambda ()
(unless dim-front
(set! dim-front (mk-dim-front)))
dim-front)
(lambda ()
(unless dim-back
(set! dim-back (mk-dim-back)))
dim-back)
rotated-bms)))])
(private-field
[save-x (box 0)]
[save-y (box 0)])

51
collects/games/cards/cards.scrbl
View File

@ -17,8 +17,9 @@ module provides a toolbox for creating cards games.}
table<%>]{
Returns a table. The table is named by @scheme[title], and it is
@scheme[w] cards wide and @scheme[h] cards high. The table is not
initially shown; @scheme[(send table show #t)] shows it.}
@scheme[w] cards wide and @scheme[h] cards high (assuming a standard
card of 71 by 96 pixels). The table is not initially shown;
@scheme[(send table show #t)] shows it.}
@defproc[(make-deck)
(listof card<%>)]{
@ -37,7 +38,7 @@ Returns a single card given a bitmap for the front, an optional bitmap
for the back, and arbitrary values for the card's suit and value
(which are returned by the card's @method[card<%> get-value] and
@method[card<%> get-suit-id] methods). All provided bitmaps should be
71 by 96 pixels.}
the same size.}
@defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?])
list?]{
@ -171,8 +172,9 @@ Create an instance with @scheme[make-table].
void?]{
Adds @scheme[cards] to fill the region @scheme[r], fanning them out
bottom-right to top-left. The region @scheme[r] does not have to be
added to the table.}
bottom-right to top-left, assuming that all cards in @scheme[cards]
have the same width and height. The region @scheme[r] does not have
to be added to the table.}
@defmethod[(remove-card [card (is-a?/c card<%>)])
void?]{
@ -227,6 +229,19 @@ Removes @scheme[card] from the table.}
Like @method[table<%> flip-cards], but only for @scheme[card] or
elements of @scheme[cards] that are currently face down/up.}
@defmethod*[([(rotate-card [card (is-a?/c card<%>)]
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
void?]
[(rotate-cards [cards (listof (is-a?/c card<%>))]
[mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)])
void?])]{
Rotates @scheme[card] or all @scheme[cards] (at once, currently
without animation, but animation may be added in the future).
The center of each card is kept in place, except that the card is
moved as necessary to keep it on the table. See @xmethod[card<%>
rotate] for information on @scheme[mode].}
@defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?]
[(card-to-back [card (is-a?/c card<%>)]) void?])]{
@ -384,13 +399,13 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
@defmethod[(card-width) exact-nonnegative-integer?]{
Returns the width of the card in pixels. All cards have the same
width.}
Returns the width of the card in pixels. If the card is rotated 90 or
270 degrees, the result is the card's original height.}
@defmethod[(card-height) exact-nonnegative-integer?]{
Returns the height of the card in pixels. All cards have the same
height.}
Returns the height of the card in pixels. If the card is rotated 90 or
270 degrees, the result is the card's original width.}
@defmethod[(flip) void?]{
@ -409,6 +424,22 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
Returns @scheme[#t] if the card is currently face down.}
@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{
Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method,
the card's top-left position is kept in place.
If @scheme[mode] is @scheme['cw], the card is
rotated clockwise; if @scheme[mode] is @scheme['ccw], the card is
rotated counter-clockwise; if @scheme[mode] is one of the allowed
numbers, the card is rotated the corresponding amount in degrees
counter-clockwise.}
@defmethod[(orientation) (or/c 0 90 180 270)]{
Returns the orientation of the card, where @scheme[0] corresponds to
its initial state, @scheme[90] is rotated 90 degrees counter-clockwise, and so on.}
@defmethod[(get-suit-id) any/c]{
Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4]
@ -476,7 +507,7 @@ Create instances with @scheme[make-deck] or @scheme[make-card].
@defmethod*[([(dim) boolean?]
[(dim [can? any/c]) void?])]{
Gets/sets a hilite on the card, whichis rendered by drawing it dimmer
Gets/sets a hilite on the card, which is rendered by drawing it dimmer
than normal.}
@defmethod[(copy) (is-a?/c card<%>)]{

64
collects/games/cards/classes.ss
View File

@ -519,6 +519,27 @@
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards)))
(flip-step (lambda () (for-each (lambda (c) (send c flip)) cards)))
(flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))]
[rotate-card
(lambda (card mode) (rotate-cards (list card) mode))]
[rotate-cards
(lambda (cards mode)
(begin-card-sequence)
(let ([tw (table-width)]
[th (table-height)])
(map (lambda (c)
(let ([w (send c card-width)]
[h (send c card-height)])
(send c rotate mode)
(let ([w2 (send c card-width)]
[h2 (send c card-height)]
[x (box 0)]
[y (box 0)])
(send pb get-snip-location c x y)
(send pb move-to c
(min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2))
(min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2))))))
cards)
(end-card-sequence)))]
[card-face-up
(lambda (card)
(cards-face-up (list card)))]
@ -695,27 +716,28 @@
(send pb only-front-selected)))]
[position-cards-in-region
(lambda (cards r set)
(let-values ([(x y w h) (send pb get-region-box r)]
[(len) (sub1 (length cards))]
[(cw ch) (values (send back get-width)
(send back get-height))])
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
[pw (pretty cw)]
[ph (pretty ch)])
(let-values ([(x w) (if (> w pw)
(values (+ x (/ (- w pw) 2)) pw)
(values x w))]
[(y h) (if (> h ph)
(values (+ y (/ (- h ph) 2)) ph)
(values y h))])
(position-cards cards x y
(lambda (p)
(if (zero? len)
(values (/ (- w cw) 2)
(/ (- h ch) 2))
(values (* (- len p) (/ (- w cw) len))
(* (- len p) (/ (- h ch) len)))))
set)))))])
(unless (null? cards)
(let-values ([(x y w h) (send pb get-region-box r)]
[(len) (sub1 (length cards))]
[(cw ch) (values (send (car cards) get-width)
(send (car cards) get-height))])
(let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))]
[pw (pretty cw)]
[ph (pretty ch)])
(let-values ([(x w) (if (> w pw)
(values (+ x (/ (- w pw) 2)) pw)
(values x w))]
[(y h) (if (> h ph)
(values (+ y (/ (- h ph) 2)) ph)
(values y h))])
(position-cards cards x y
(lambda (p)
(if (zero? len)
(values (/ (- w cw) 2)
(/ (- h ch) 2))
(values (* (- len p) (/ (- w cw) len))
(* (- len p) (/ (- h ch) len)))))
set))))))])
(super-new [label title] [style '(metal no-resize-border)])
(begin
(define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll)))

25
collects/games/cards/make-cards.ss
View File

@ -9,15 +9,6 @@
(define (get-bitmap file)
(make-object mred:bitmap% file))
(define (make-semi bm-in w h)
(let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)]
[mdc (make-object mred:bitmap-dc%)])
(send mdc set-bitmap bm)
(send mdc set-scale 0.5 1)
(send mdc draw-bitmap bm-in 0 0)
(send mdc set-bitmap #f)
bm))
(define (make-dim bm-in)
(let ([w (send bm-in get-width)]
[h (send bm-in get-height)])
@ -46,11 +37,6 @@
(define back (get-bitmap (here "card-back.png")))
(define semi-back
(let ([w (send back get-width)]
[h (send back get-height)])
(make-semi back w h)))
(define dim-back
(make-dim back))
@ -74,9 +60,9 @@
value
w h
front back
(make-semi front w h) semi-back
(lambda () (make-dim front))
(lambda () dim-back))
(lambda () dim-back)
(make-hash-table 'equal))
(vloop (sub1 value))))))))))
(define (make-card front-bm back-bm suit-id value)
@ -87,12 +73,9 @@
value
w h
front-bm (or back-bm back)
(make-semi front-bm w h)
(if back-bm
(make-semi back-bm w h)
semi-back)
(lambda () (make-dim front-bm))
(lambda ()
(if back-bm
(make-dim back)
dim-back))))))
dim-back))
(make-hash-table 'equal)))))

7
collects/handin-server/checker.ss
View File

@ -78,7 +78,7 @@
(let ([line (bytes->string/utf-8 line)])
(unless (or (< (string-length line) len)
(< (string-width line) len))
(error* "~a \"~a\" in \"~a\" is longer than ~a characters"
(error* "~a \"~a\" in ~a is longer than ~a characters"
(if n (format "Line #~a" n) "The line")
(regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1")
(currently-processed-file-name)
@ -148,7 +148,8 @@
(define current-processed-file ; set when processing multi-file submissions
(make-parameter #f))
(define (currently-processed-file-name)
(or (current-processed-file) "your code"))
(let ([c (current-processed-file)])
(if c (format "\"~a\"" c) "your code")))
(define (input->process->output maxwidth textualize? untabify? bad-re)
(let loop ([n 1])
@ -164,7 +165,7 @@
[line (if (and untabify? (regexp-match? #rx"\t" line))
(untabify line) line)])
(when (and bad-re (regexp-match? bad-re line))
(error* "You cannot use \"~a\" in \"~a\"!~a"
(error* "You cannot use \"~a\" in ~a!~a"
(if (regexp? bad-re) (object-name bad-re) bad-re)
(currently-processed-file-name)
(if textualize? "" (format " (line ~a)" n))))

10
collects/lang/private/beginner-funs.ss
View File

@ -278,18 +278,18 @@
((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any))
"to create a single list from several, by juxtaposition of the items")
(length (list -> number)
(length ((listof any) -> number)
"to compute the number of items on a list")
(memq (any list -> (union false list))
(memq (any (listof any) -> (union false list))
"to determine whether some value is on some list"
" (comparing values with eq?)")
(memv (any list -> (union false list))
(memv (any (listof any) -> (union false list))
"to determine whether some value is on the list"
" (comparing values with eqv?)")
((beginner-member member) (any list -> boolean)
((beginner-member member) (any (listof any)-> boolean)
"to determine whether some value is on the list"
" (comparing values with equal?)")
(reverse (list -> list)
(reverse ((listof any) -> list)
"to create a reversed version of a list")
(assq (X (listof (cons X Y)) -> (union false (cons X Y)))
"to determine whether some item is the first item of a pair"

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "14nov2008")
#lang scheme/base (provide stamp) (define stamp "17nov2008")

20
collects/rnrs/base-6.ss
View File

@ -76,7 +76,7 @@
[r6rs:string->number string->number])
;; 11.8
not boolean? boolean=?
not boolean? (rename-out [r6rs:boolean=? boolean=?])
;; 11.9
(rename-out [r5rs:pair? pair?]
@ -123,7 +123,7 @@
[r5rs:for-each for-each])
;; 11.10
symbol? symbol=?
symbol? (rename-out [r6rs:symbol=? symbol=?])
string->symbol symbol->string
;; 11.11
@ -349,6 +349,22 @@
(and (regexp-match? rx:number s)
(string->number (regexp-replace* #rx"[|][0-9]+" s "")))))
(define r6rs:symbol=?
(case-lambda
[(a b) (symbol=? a b)]
[(a b . rest) (and (symbol=? a b)
(andmap (lambda (s)
(symbol=? a s))
rest))]))
(define r6rs:boolean=?
(case-lambda
[(a b) (boolean=? a b)]
[(a b . rest) (and (boolean=? a b)
(andmap (lambda (s)
(boolean=? a s))
rest))]))
(define-syntax-rule (make-mapper what for for-each in-val val-length val->list list->result)
(case-lambda
[(proc val) (list->result

7
collects/rnrs/bytevectors-6.ss
View File

@ -311,16 +311,17 @@
(bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size))
(define (int-list->bytevector who signed? set l endianness size)
(unless (list? l)
(unless (mlist? l)
(raise-type-error who "list" l))
(check-endian endianness)
(unless (exact-positive-integer? size)
(raise-type-error who "exact positive integer" size))
(let* ([len (length l)]
(let* ([l (mlist->list l)]
[len (length l)]
[bv (make-bytes (* size len))])
(for ([v (in-list l)]
[k (in-naturals)])
(set l k v endianness size))
(set bv (* k size) v endianness size))
bv))
(define (uint-list->bytevector l endianness size)

6
collects/scribblings/guide/guide.scrbl
View File

@ -92,6 +92,12 @@ downloadable packages contributed by PLT Scheme users.
#:date "2004"
#:url "http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf")
(bib-entry #:key "Flatt02"
#:author "Matthew Flatt"
#:title "Composable and Compilable Macros: You Want it When?"
#:location "International Conference on Functional Programming"
#:date "2002")
(bib-entry #:key "Flatt06"
#:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen"
#:title "Scheme with Classes, Mixins, and Traits (invited tutorial)"

9
collects/scribblings/guide/modules.scrbl
View File

@ -5,12 +5,9 @@
@title[#:tag "modules" #:style 'toc]{Modules}
Scheme definitions and expressions are normally written inside of a
module. Although a @tech{REPL} evaluates definitions and expressions outside
of a module for exploration and debugging purposes, and although
@scheme[load] can evaluate definitions and expressions from a file as
if they appeared in a @tech{REPL} interaction, code that is meant to last for
more than a few seconds belongs in a module.
Modules let you organize Scheme code into multiple files and reusable
libraries.
@local-table-of-contents[]

132
collects/scribblings/guide/namespaces.scrbl
View File

@ -385,3 +385,135 @@ example, since the enclosing module requires
instance of @schememodname[scheme/class]. Moreover, that instance is
the same as the one imported into the module, so the class datatype is
shared.
@; ----------------------------------------------------------------------
@section[#:tag "load"]{Scripting Evaluation and Using @scheme[load]}
Historically, Scheme and Lisp systems did not offer module
systems. Instead, large programs were built by essentially scripting
the @tech{REPL} to evaluate program fragments in a particular order.
While @tech{REPL} scripting turns out to be a bad way to structure
programs and libraries, it is still sometimes a useful capability.
@margin-note{Describing a program via @scheme[load] interacts
especially badly with macro-defined language extensions
@cite["Flatt02"].}
The @scheme[load] function runs a @tech{REPL} script by
@scheme[read]ing S-expressions from a file, one by one, and passing
them to @scheme[eval]. If a file @filepath{place.scm} contains
@schemeblock[
(define city "Salt Lake City")
(define state "Utah")
(printf "~a, ~a\n" city state)
]
then it can be loaded in a @tech{REPL}:
@interaction[
(eval:alts (load "place.scm") (begin (define city "Salt Lake City")
(printf "~a, Utah\n" city)))
city
]
Since @scheme[load] uses @scheme[eval], however, a module like the
following generally will not work---for the same reasons described in
@secref["namespaces"]:
@schememod[
scheme
(define there "Utopia")
(load "here.scm")
]
The current namespace for evaluating the content of
@filepath{here.scm} is likely to be empty; in any case, you cannot get
@scheme[there] from @filepath{here.scm}. Also, any definitions in
@filepath{here.scm} will not become visible for use within the module;
after all, the @scheme[load] happens dynamically, while references to
identifiers within the module are resolved lexically, and therefore
statically.
Unlike @scheme[eval], @scheme[load] does not accept a namespace
argument. To supply a namespace to @scheme[load], set the
@scheme[current-namespace] parameter. The following example evaluates
the expressions in @filepath{here.scm} using the bindings of the
@schememodname[scheme/base] module:
@schememod[
scheme
(parameterize ([current-namespace (make-base-namespace)])
(load "here.scm"))
]
You can even use @scheme[namespace-anchor->namespace] to make the
bindings of the enclosing module accessible for dynamic evaluation. In
the following example, when @filepath{here.scm} is @scheme[load]ed, it
can refer to @scheme[there] as well as the bindings of
@schememodname[scheme]:
@schememod[
scheme
(define there "Utopia")
(define-namespace-anchor a)
(parameterize ([current-namespace (namespace-anchor->namespace a)])
(load "here.scm"))
]
Still, if @filepath{here.scm} defines any identifiers, the definitions
cannot be directly (i.e., statically) referenced by in the enclosing
module.
The @schememodname[scheme/load] module language is different from
@schememodname[scheme] or @schememodname[scheme/base]. A module using
@schememodname[scheme/load] treats all of its content as dynamic,
passing each form in the module body to @scheme[eval] (using a
namespace that is initialized with @schememodname[scheme]). As a
result, uses of @scheme[eval] and @scheme[load] in the module body see
the same dynamic namespace as immediate body forms. For example, if
@filepath{here.scm} contains
@schemeblock[
(define here "Morporkia")
(define (go!) (set! here there))
]
then running
@schememod[
scheme/load
(define there "Utopia")
(load "here.scm")
(go!)
(printf "~a\n" here)
]
prints ``Utopia''.
Drawbacks of using @schememodname[scheme/load] include reduced
error checking, tool support, and performance. For example, with the
program
@schememod[
scheme/load
(define good 5)
(printf "running\n")
good
bad
]
DrScheme's @onscreen{Check Syntax} tool cannot tell that the second
@scheme[good] is a reference to the first, and the unbound reference
to @scheme[bad] is reported only at run time instead of rejected
syntactically.

4
collects/scribblings/guide/welcome.scrbl
View File

@ -198,11 +198,11 @@ tempted to put just
(substring str 0 5))
]
into @filepath{piece.ss} and run @exec{mzscheme} with
into @filepath{piece.scm} and run @exec{mzscheme} with
@interaction[
#:eval piece-eval
(eval:alts (load "piece.ss") (void))
(eval:alts (load "piece.scm") (void))
(piece "howdy universe")
]

8
collects/scribblings/reference/procedures.scrbl
View File

@ -240,7 +240,7 @@ instances can be applied as procedures. In particular, when
an application expression, a procedure is extracted from the instance
and used to complete the procedure call.
If the @scheme[prop:procedure] property value is an integer, it
If the @scheme[prop:procedure] property value is an exact non-negative integer, it
designates a field within the structure that should contain a
procedure. The integer must be between @scheme[0] (inclusive) and the
number of non-automatic fields in the structure type (exclusive, not
@ -317,7 +317,11 @@ is disallowed).
(fish-weight wanda)
(for-each wanda '(1 2 3))
(fish-weight wanda)
]}
]
If the value supplied for the @scheme[prop:procedure] property is not
an exact non-negative integer or a procedure, the
@exnraise[exn:fail:contract].}
@defproc[(procedure-struct-type? [type struct-type?]) boolean?]{

50
collects/tests/mzscheme/struct.ss
View File

@ -927,4 +927,54 @@
;; ----------------------------------------
(let ()
(define-struct foo (a [b #:mutable]) #:transparent)
(define-struct (bar foo) (f g)
#:transparent
#:property
prop:procedure
(struct-field-index f))
(test '(1) (make-bar 1 2 list 4) 1)
(test '(foo 2 0 (0)) call-with-values
(lambda () (struct-type-info struct:foo))
(lambda (name cnt auto-cnt acc mut imm super skipped?)
(list name cnt auto-cnt imm)))
(test '(bar 2 0 (0 1)) call-with-values
(lambda () (struct-type-info struct:bar))
(lambda (name cnt auto-cnt acc mut imm super skipped?)
(list name cnt auto-cnt imm))))
(let ()
(define-struct foo (a [b #:mutable] [z #:auto]) #:transparent)
(define-struct (bar foo) (f g)
#:transparent
#:property
prop:procedure
(struct-field-index f))
(test '#&1 (make-bar 1 2 box 4) 1)
(test '(foo 2 1 (0)) call-with-values
(lambda () (struct-type-info struct:foo))
(lambda (name cnt auto-cnt acc mut imm super skipped?)
(list name cnt auto-cnt imm)))
(test '(bar 2 0 (0 1)) call-with-values
(lambda () (struct-type-info struct:bar))
(lambda (name cnt auto-cnt acc mut imm super skipped?)
(list name cnt auto-cnt imm))))
(let ()
(define-struct foo (a [b #:mutable] [z #:auto]) #:transparent)
(define (try v)
(define-struct (bar foo) ([f #:mutable] g [q #:auto])
#:property
prop:procedure
v)
10)
(err/rt-test (try 0))
(err/rt-test (try 2))
(err/rt-test (try -1))
(err/rt-test (try 'x))
(test 10 try 1))
;; ----------------------------------------
(report-errs)

4
collects/tests/r6rs/base.sls
View File

@ -1005,6 +1005,8 @@
(test (boolean=? #t #t) #t)
(test (boolean=? #t #f) #f)
(test (boolean=? #f #t) #f)
(test (boolean=? #t #t #f) #f)
(test (boolean=? #t #t #t #t) #t)
;; 11.9
(test (pair? '(a . b)) #t)
@ -1126,6 +1128,8 @@
(test (symbol=? 'a 'a) #t)
(test (symbol=? 'a 'A) #f)
(test (symbol=? 'a 'b) #f)
(test (symbol=? 'a 'a 'b) #f)
(test (symbol=? 'a 'a 'a 'a) #t)
(test (symbol->string 'flying-fish)
"flying-fish")

15
collects/tests/r6rs/bytevectors.sls
View File

@ -277,6 +277,21 @@
(test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(bytevector->uint-list b 'little 2))
'(513 65283 513 513))
(test (bytevector->u8-list
(uint-list->bytevector '(513 65283 513 513) 'little 2))
'(1 2 3 255 1 2 1 2))
(test (bytevector->u8-list
(uint-list->bytevector '(513 65283 513 513) 'big 2))
'(2 1 255 3 2 1 2 1))
(test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(bytevector->sint-list b 'little 2))
'(513 -253 513 513))
(test (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1))))
(bytevector->sint-list b 'big 2))
'(513 -253 513 513))
(test (bytevector->u8-list
(sint-list->bytevector '(513 -253 513 513) 'little 2))
'(1 2 3 255 1 2 1 2))
(test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2))))
(bytevector->sint-list b 'little 2))
'(513 -253 513 513))

2
src/mzscheme/src/schpriv.h
View File

@ -576,7 +576,7 @@ typedef struct Scheme_Struct_Type {
int num_props; /* < 0 => props is really a hash table */
Scheme_Object *proc_attr; /* int (position) or proc, only for proc_struct */
char *immutables;
char *immutables; /* for immediate slots, only (not parent) */
Scheme_Object *guard;

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

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "4.1.2.5"
#define MZSCHEME_VERSION "4.1.3.1"
#define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 2
#define MZSCHEME_VERSION_W 5
#define MZSCHEME_VERSION_Z 3
#define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

63
src/mzscheme/src/struct.c
View File

@ -865,28 +865,46 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche
if (SCHEME_INTP(v))
pos = SCHEME_INT_VAL(v);
else
else if (SCHEME_BIGPOS(v))
pos = t->num_slots; /* too big */
else
pos = -1; /* negative bignum */
if (pos >= t->num_islots) {
scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v);
return NULL;
}
if (t->name_pos > 0) {
if (pos >= 0) {
Scheme_Struct_Type *parent_type;
parent_type = t->parent_types[t->name_pos - 1];
pos += parent_type->num_slots;
v = scheme_make_integer(pos);
}
if (t->name_pos > 0)
parent_type = t->parent_types[t->name_pos - 1];
else
parent_type = NULL;
if (pos >= (t->num_islots - (parent_type ? parent_type->num_islots : 0))) {
scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v);
return NULL;
}
if (parent_type) {
/* proc_attr needs to be in terms of the whole field array */
pos += parent_type->num_slots;
v = scheme_make_integer(pos);
}
} else
v = scheme_false; /* complain below */
}
if (SCHEME_INTP(v) || SCHEME_PROCP(v)) {
/* ok */
} else {
scheme_arg_mismatch("make-struct-type",
"prop:procedure value is not a procedure or exact non-negative integer: ",
orig_v);
}
t->proc_attr = v;
if (SCHEME_INTP(v)) {
long pos;
pos = SCHEME_INT_VAL(v);
pos = SCHEME_INT_VAL(orig_v);
if (!t->immutables || !t->immutables[pos]) {
scheme_arg_mismatch("make-struct-type",
"field is not specified as immutable for a prop:procedure index: ",
@ -1676,7 +1694,7 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object
ims = scheme_null;
if (stype->immutables) {
int i;
for (i = stype->num_islots; i--; ) {
for (i = stype->num_islots - (parent ? parent->num_islots : 0); i--; ) {
if (stype->immutables[i])
ims = scheme_make_pair(scheme_make_integer(i), ims);
}
@ -2856,19 +2874,20 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
|| (proc_attr && SCHEME_INTP(proc_attr))) {
Scheme_Object *l, *a;
char *ims;
int n, p;
int n, ni, p;
n = struct_type->num_slots;
if (parent_type)
ni = struct_type->num_islots;
if (parent_type) {
n -= parent_type->num_slots;
ni -= parent_type->num_islots;
}
ims = (char *)scheme_malloc_atomic(n);
memset(ims, 0, n);
if (proc_attr && SCHEME_INTP(proc_attr)) {
p = SCHEME_INT_VAL(proc_attr);
if (parent_type)
p += parent_type->num_slots;
if (p < struct_type->num_slots)
if (p < ni)
ims[p] = 1;
}
@ -2877,12 +2896,14 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base
if (SCHEME_INTP(a))
p = SCHEME_INT_VAL(a);
else
p = struct_type->num_slots; /* too big */
p = n; /* too big */
if (p >= struct_type->num_islots) {
if (p >= n) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"make-struct-type: index %V for immutable field >= initialized-field count %d in list: %V",
a, struct_type->num_islots, immutable_pos_list);
a,
ni,
immutable_pos_list);
return NULL;
}

2
src/worksp/mred/mred.manifest
View File

@ -1,7 +1,7 @@
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
version="4.1.2.5"
version="4.1.3.1"
processorArchitecture="X86"
name="Org.PLT-Scheme.MrEd"
type="win32"

8
src/worksp/mred/mred.rc
View File

@ -20,8 +20,8 @@ APPLICATION ICON DISCARDABLE "mred.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,2,5
PRODUCTVERSION 4,1,2,5
FILEVERSION 4,1,3,1
PRODUCTVERSION 4,1,3,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -39,11 +39,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme GUI application\0"
VALUE "InternalName", "MrEd\0"
VALUE "FileVersion", "4, 1, 2, 5\0"
VALUE "FileVersion", "4, 1, 3, 1\0"
VALUE "LegalCopyright", "Copyright © 1995-2008\0"
VALUE "OriginalFilename", "MrEd.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 2, 5\0"
VALUE "ProductVersion", "4, 1, 3, 1\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/mzcom/mzcom.rc
View File

@ -53,8 +53,8 @@ END
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,2,5
PRODUCTVERSION 4,1,2,5
FILEVERSION 4,1,3,1
PRODUCTVERSION 4,1,3,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -70,12 +70,12 @@ BEGIN
BLOCK "040904b0"
BEGIN
VALUE "FileDescription", "MzCOM Module"
VALUE "FileVersion", "4, 1, 2, 5"
VALUE "FileVersion", "4, 1, 3, 1"
VALUE "InternalName", "MzCOM"
VALUE "LegalCopyright", "Copyright 2000-2008 PLT (Paul Steckler)"
VALUE "OriginalFilename", "MzCOM.EXE"
VALUE "ProductName", "MzCOM Module"
VALUE "ProductVersion", "4, 1, 2, 5"
VALUE "ProductVersion", "4, 1, 3, 1"
END
END
BLOCK "VarFileInfo"

6
src/worksp/mzcom/mzobj.rgs
View File

@ -1,19 +1,19 @@
HKCR
{
MzCOM.MzObj.4.1.2.5 = s 'MzObj Class'
MzCOM.MzObj.4.1.3.1 = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
}
MzCOM.MzObj = s 'MzObj Class'
{
CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
CurVer = s 'MzCOM.MzObj.4.1.2.5'
CurVer = s 'MzCOM.MzObj.4.1.3.1'
}
NoRemove CLSID
{
ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
{
ProgID = s 'MzCOM.MzObj.4.1.2.5'
ProgID = s 'MzCOM.MzObj.4.1.3.1'
VersionIndependentProgID = s 'MzCOM.MzObj'
ForceRemove 'Programmable'
LocalServer32 = s '%MODULE%'

8
src/worksp/mzscheme/mzscheme.rc
View File

@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "mzscheme.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,2,5
PRODUCTVERSION 4,1,2,5
FILEVERSION 4,1,3,1
PRODUCTVERSION 4,1,3,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -48,11 +48,11 @@ BEGIN
VALUE "CompanyName", "PLT Scheme Inc.\0"
VALUE "FileDescription", "PLT Scheme application\0"
VALUE "InternalName", "MzScheme\0"
VALUE "FileVersion", "4, 1, 2, 5\0"
VALUE "FileVersion", "4, 1, 3, 1\0"
VALUE "LegalCopyright", "Copyright <20>© 1995-2008\0"
VALUE "OriginalFilename", "mzscheme.exe\0"
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 2, 5\0"
VALUE "ProductVersion", "4, 1, 3, 1\0"
END
END
BLOCK "VarFileInfo"

8
src/worksp/starters/start.rc
View File

@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico"
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 4,1,2,5
PRODUCTVERSION 4,1,2,5
FILEVERSION 4,1,3,1
PRODUCTVERSION 4,1,3,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
@ -45,7 +45,7 @@ BEGIN
#ifdef MZSTART
VALUE "FileDescription", "PLT Scheme Launcher\0"
#endif
VALUE "FileVersion", "4, 1, 2, 5\0"
VALUE "FileVersion", "4, 1, 3, 1\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
@ -60,7 +60,7 @@ BEGIN
VALUE "OriginalFilename", "MzStart.exe\0"
#endif
VALUE "ProductName", "PLT Scheme\0"
VALUE "ProductVersion", "4, 1, 2, 5\0"
VALUE "ProductVersion", "4, 1, 3, 1\0"
END
END
BLOCK "VarFileInfo"

22
src/wxcommon/wxGC.cxx
View File

@ -374,7 +374,11 @@ char *gc::gcGetName() {
forces a GC more frequently than might otherwise happen as the
total size of bitmaps grows. */
static long total, accum = 1024 * 1024 * 5;
#define INIT_ACCUM_SIZE 1024 * 1024 * 5
#define INIT_ACCUM_COUNT 1000
static long total, accum = INIT_ACCUM_SIZE;
static int total_count, accum_count = INIT_ACCUM_COUNT;
void *GC_malloc_accounting_shadow(long a)
{
@ -383,10 +387,24 @@ void *GC_malloc_accounting_shadow(long a)
a = sizeof(long);
total += a;
accum -= a;
total_count += 1;
accum_count -= 1;
if (accum <= 0) {
GC_gcollect();
accum = total >> 1;
if (accum < INIT_ACCUM_SIZE)
accum = INIT_ACCUM_SIZE;
}
#ifdef wx_msw
/* Under Windows, the number of bitmaps matters, even if
they're small. */
if (accum_count <= 0) {
GC_gcollect();
accum_count = total_count >> 1;
if (accum_count < INIT_ACCUM_COUNT)
accum_count = INIT_ACCUM_COUNT;
}
#endif
p = (long *)GC_malloc_atomic(a);
*p = a;
return (void *)p;
@ -397,5 +415,7 @@ void GC_free_accounting_shadow(void *p)
if (p) {
total -= *(long *)p;
accum += *(long *)p;
total_count -= 1;
accum_count += 1;
}
}