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

sync to trunk

Browse Source 
svn: r14653
This commit is contained in:
Sam Tobin-Hochstadt 2009-04-29 14:36:54 +00:00
commit 8b2381e109
14 changed files with 388 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/2htdp/private/check-aux.ss
View File

@ -54,22 +54,29 @@
;; -----------------------------------------------------------------------------
;; MouseEvent -> [List Nat Nat MouseEventType]
;; MouseEvent% -> [List Nat Nat MouseEventType]
;; turn a mouse event into its pieces
(define (mouse-event->parts e)
(define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET))
(values x y (cond [(send e button-down?) 'button-down]
[(send e button-up?) 'button-up]
[(send e dragging?) 'drag]
[(send e moving?) 'move]
[(send e entering?) 'enter]
[(send e leaving?) 'leave]
(values x y
(cond [(send e button-down?) "button-down"]
[(send e button-up?) "button-up"]
[(send e dragging?) "drag"]
[(send e moving?) "move"]
[(send e entering?) "enter"]
[(send e leaving?) "leave"]
[else ; (send e get-event-type)
(error 'on-mouse-event
(format
"Unknown event type: ~a"
(send e get-event-type)))])))
(let ([m (send e get-event-type)])
(error 'on-mouse (format "Unknown event: ~a" m)))])))
;; KeyEvent% -> String
(define (key-event->parts e)
(define x (send e get-key-code))
(cond
[(char? x) (string x)]
[(symbol? x) (symbol->string x)]
[else (error 'on-key (format "Unknown event: ~a" x))]))
;; -----------------------------------------------------------------------------
;; Any -> Symbol

8
collects/2htdp/private/syn-aux.ss
View File

@ -32,8 +32,12 @@
extra
[_ (err tag p)])))]))
(define (err spec p)
(raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p))
(define (err spec p . extra-spec)
(raise-syntax-error (cadr spec)
(if (null? extra-spec)
"illegal specification"
(string-append "illegal specification: " (car extra-spec)))
#`(#,spec . #,p) p))
;; Symbol (Symbol X -> X) -> (X -> X)
(define (check-flat-spec tag coerce>)

2
collects/2htdp/private/world.ss
View File

@ -170,7 +170,7 @@
(super-new)
;; deal with keyboard events
(define/override (on-char e)
(when live (pkey (send e get-key-code))))
(when live (pkey (key-event->parts e))))
;; deal with mouse events if live and within range
(define/override (on-event e)
(define-values (x y me) (mouse-event->parts e))

18
collects/2htdp/universe.ss
View File

@ -117,17 +117,17 @@
(lambda (p)
(syntax-case p ()
[(host) #`(ip> #,tag host)]
[_ (err tag p)])))]
[_ (err tag p "expected a host (ip address)")])))]
[name (lambda (tag)
(lambda (p)
(syntax-case p ()
[(n) #`(symbol> #,tag n)]
[_ (err tag p)])))]
[_ (err tag p "expected a string for the current world")])))]
[record? (lambda (tag)
(lambda (p)
(syntax-case p ()
[(b) #`(bool> #,tag b)]
[_ (err tag p)])))])
[_ (err tag p "expected a boolean (to record or not to record?")])))])
(define-syntax (big-bang stx)
(syntax-case stx ()
@ -195,21 +195,21 @@
(on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
(stop-when empty?))))
(define (mouse-event? a)
(pair? (member a '(button-down button-up drag move enter leave))))
(define ME (map symbol->string '(button-down button-up drag move enter leave)))
(define (mouse-event? a) (and (string? a) (pair? (member a ME))))
(define (mouse=? k m)
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
(eq? k m))
(string=? k m))
(define (key-event? k)
(or (char? k) (symbol? k)))
(define (key-event? k) (string? k))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
(eqv? k m))
(string=? k m))
(define LOCALHOST "127.0.0.1")

5
collects/compiler/decompile.ss
View File

@ -90,7 +90,8 @@
(define (decompile-module mod-form stack)
(match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
[(struct mod (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context))
(let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)])
@ -135,6 +136,8 @@
`(begin ,@(map (lambda (form)
(decompile-form form globs stack closed))
forms))]
[(struct req (reqs dummy))
`(#%require . (#%decode-syntax ,reqs))]
[else
(decompile-expr form globs stack closed)]))

119
collects/compiler/zo-marshal.ss
View File

@ -5,7 +5,7 @@
(provide zo-marshal)
;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compated, and symbols are not written in short form
;; are not compacted, and symbols are not written in short form
(define (zo-marshal top)
(match top
@ -71,23 +71,26 @@
(define (traverse-prefix a-prefix visit)
(match a-prefix
[(struct prefix (num-lifts toplevels stxs))
(for-each (lambda (stx) (traverse-toplevel stx visit)) stxs)
(for-each (lambda (stx) (traverse-toplevel stx visit)) toplevels)
(for-each (lambda (stx) (traverse-stx stx visit)) stxs)]))
(define (traverse-module mod-form visit)
(match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(error "cannot handle modules, yet")
[(struct mod (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context))
(traverse-data name visit)
(traverse-data self-modidx visit)
(traverse-prefix prefix visit)
(for-each (lambda (f) (traverse-form f prefix)) body)
(for-each (lambda (f) (traverse-form f prefix)) syntax-body)]))
(for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires)
(for-each (lambda (f) (traverse-form f visit)) body)
(for-each (lambda (f) (traverse-form f visit)) syntax-body)
(traverse-data lang-info visit)
(traverse-data internal-context visit)]))
(define (traverse-toplevel tl visit)
(match tl
[#f (void)]
[(? symbol?) (visit tl)]
[(? symbol?) (traverse-data tl visit)]
[(struct global-bucket (name))
(void)]
[(struct module-variable (modidx sym pos phase))
@ -180,9 +183,13 @@
(keyword? expr)
(string? expr)
(bytes? expr)
(path? expr)
(module-path-index? expr))
(path? expr))
(visit expr)]
[(module-path-index? expr)
(visit expr)
(let-values ([(name base) (module-path-index-split expr)])
(traverse-data name visit)
(traverse-data base visit))]
[(pair? expr)
(traverse-data (car expr) visit)
(traverse-data (cdr expr) visit)]
@ -213,6 +220,7 @@
(define top-type-num 87)
(define case-lambda-sequence-type-num 96)
(define begin0-sequence-type-num 97)
(define module-type-num 100)
(define prefix-type-num 103)
(define-syntax define-enum
@ -363,10 +371,80 @@
(list->vector stxs)))
out)]))
(define-struct module-decl (content))
(define (out-module mod-form out)
(match mod-form
[(struct mod (name self-modidx prefix provides requires body syntax-body max-let-depth))
(error "cannot write modules, yet")]))
[(struct mod (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context))
(out-syntax MODULE_EXPD
(let* ([lookup-req (lambda (phase)
(let ([a (assq phase requires)])
(if a
(cdr a)
null)))]
[other-requires (filter (lambda (l)
(not (memq (car l) '(#f -1 0 1))))
requires)]
[extract-protects
(lambda (phase)
(let ([a (assq phase provides)])
(and a
(let ([p (map provided-protected? (append (cadr a)
(caddr a)))])
(if (ormap values p)
(list->vector p)
#f)))))]
[list->vector/#f (lambda (default l)
(if (andmap (lambda (x) (equal? x default)) l)
#f
(list->vector l)))]
[l (map cdr other-requires)]
[l (cons (length other-requires) l)]
[l (cons (lookup-req #f) l)] ; dt-requires
[l (cons (lookup-req -1) l)] ; tt-requires
[l (cons (lookup-req 1) l)] ; et-requires
[l (cons (lookup-req 0) l)] ; requires
[l (cons (list->vector body) l)]
[l (cons (list->vector syntax-body) l)]
[l (append (apply
append
(map (lambda (l)
(let ([phase (car l)]
[all (append (cadr l) (caddr l))])
(list phase
(list->vector/#f #f (map provided-insp all))
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p)))
all))
(list->vector/#f #f (map (lambda (p)
(if (eq? (provided-nom-src p)
(provided-src p))
#f ; #f means "same as src"
(provided-nom-src p)))
all))
(list->vector (map provided-src-name all))
(list->vector (map provided-src all))
(list->vector (map provided-name all))
(length (cadr l))
(length all))))
provides))
l)]
[l (cons (length provides) l)] ; number of provide sets
[l (cons (extract-protects 0) l)] ; protects
[l (cons (extract-protects 1) l)] ; et protects
[l (list* (list->vector (car unexported)) (length (car unexported)) l)] ; indirect-provides
[l (list* (list->vector (cadr unexported)) (length (cadr unexported)) l)] ; indirect-syntax-provides
[l (list* (list->vector (caddr unexported)) (length (caddr unexported)) l)] ; indirect-et-provides
[l (cons prefix l)]
[l (cons dummy l)]
[l (cons max-let-depth l)]
[l (cons internal-context l)] ; module->namespace syntax
[l (list* #f #f l)] ; obsolete `functional?' info
[l (cons lang-info l)] ; lang-info
[l (cons self-modidx l)]
[l (cons name l)])
(make-module-decl l))
out)]))
(define (out-toplevel tl out)
(match tl
@ -422,6 +500,9 @@
(out-marshaled sequence-type-num (map protect-quote forms) out)]
[(struct splice (forms))
(out-syntax SPLICE_EXPD (make-seq forms) out)]
[(struct req (reqs dummy))
(error "cannot handle top-level `require', yet")
(out-syntax REQUIRE_EXPD (cons dummy reqs) out)]
[else
(out-expr form out)]))
@ -605,11 +686,12 @@
l)
out))]))
(define (out-as-bytes expr ->bytes CPT out)
(define (out-as-bytes expr ->bytes CPT len2 out)
(out-shared expr out (lambda ()
(let ([s (->bytes expr)])
(out-byte CPT out)
(out-number (bytes-length s) out)
(when len2 (out-number len2 out))
(out-bytes s out)))))
(define (out-data expr out)
@ -625,26 +707,31 @@
(out-as-bytes expr
(compose string->bytes/utf-8 symbol->string)
CPT_SYMBOL
#f
out)]
[(keyword? expr)
(out-as-bytes expr
(compose string->bytes/utf-8 keyword->string)
CPT_KEYWORD
#f
out)]
[(string? expr)
(out-as-bytes expr
string->bytes/utf-8
CPT_CHAR_STRING
(string-length expr)
out)]
[(bytes? expr)
(out-as-bytes expr
values
CPT_BYTE_STRING
#f
out)]
[(path? expr)
(out-as-bytes expr
path->bytes
CPT_PATH
#f
out)]
[(char? expr)
(out-byte CPT_CHAR out)
@ -690,10 +777,16 @@
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
(out-number (vector-ref vec n) out)))]
[(module-path-index? expr)
(out-shared expr out
(lambda ()
(out-byte CPT_MODULE_INDEX out)
(let-values ([(name base) (module-path-index-split expr)])
(out-data name out)
(out-data base out))]
(out-data base out))))]
[(module-decl? expr)
(out-marshaled module-type-num
(module-decl-content expr)
out)]
[else
(out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)])

46
collects/compiler/zo-parse.ss
View File

@ -34,7 +34,8 @@
(define-form-struct form ())
(define-form-struct (expr form) ())
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth))
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported
max-let-depth dummy lang-info internal-context))
(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map max-let-depth body)) ; `lambda'
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
@ -74,6 +75,9 @@
(define-struct indirect ([v #:mutable]) #:prefab)
(provide (struct-out indirect))
;; A provided identifier
(define-form-struct provided (name src src-name nom-src src-phase protected? insp))
;; ----------------------------------------
;; Bytecode unmarshalers for various forms
@ -232,7 +236,37 @@
,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires)
(make-mod name self-modidx
prefix phase-data
prefix (let loop ([l phase-data])
(if (null? l)
null
(let ([num-vars (list-ref l 7)]
[ps (for/list ([name (in-vector (list-ref l 6))]
[src (in-vector (list-ref l 5))]
[src-name (in-vector (list-ref l 4))]
[nom-src (or (list-ref l 3)
(in-cycle (in-value #f)))]
[src-phase (or (list-ref l 2)
(in-cycle (in-value #f)))]
[protected? (or (case (car l)
[(0) protects]
[(1) et-protects]
[else #f])
(in-cycle (in-value #f)))]
[insp (or (list-ref l 1)
(in-cycle (in-value #f)))])
(make-provided name src src-name
(or nom-src src)
(if src-phase 1 0)
protected?
insp))])
(if (null? ps)
(loop (list-tail l 9))
(cons
(list
(car l)
(take ps num-vars)
(drop ps num-vars))
(loop (list-tail l 9)))))))
(list*
(cons 0 requires)
(cons 1 syntax-requires)
@ -248,7 +282,13 @@
make-def-syntaxes)
ids expr prefix max-let-depth)]))
(vector->list syntax-body))
max-let-depth)]))]))
(list (vector->list indirect-provides)
(vector->list indirect-syntax-provides)
(vector->list indirect-et-provides))
max-let-depth
dummy
lang-info
rename)]))]))
(define (read-module-wrap v)
v)

8
collects/profile/render-text.ss
View File

@ -49,11 +49,11 @@
[(pair? x) (loop (car x)) (loop (cdr x))]
[else (display x)]))
(newline))
(define total-time (profile-total-time profile))
(define cpu-time (profile-cpu-time profile))
(define total-time (profile-total-time profile)) ;!! are these two
(define cpu-time (profile-cpu-time profile)) ;!! swapped?
(define sample-number (profile-sample-number profile))
(define granularity (if (zero? sample-number) 0
(/ total-time sample-number)))
(define granularity (if (zero? sample-number) 0 ;!! this might
(/ total-time sample-number))) ;!! be wrong
(define threads+times (profile-thread-times profile))
(define *-node (profile-*-node profile))
(define hidden (get-hidden profile hide-self% hide-subs%))

39
collects/redex/redex.scrbl
View File

@ -1843,8 +1843,8 @@ evaluates expression. If that expression computes any picts,
the unquote rewriter specified is used to remap them.
The @scheme[proc] should be a function of one argument. It receives
a lw struct as an argument and should return
another lw that contains a rewritten version of the
a @scheme[lw] struct as an argument and should return
another @scheme[lw] that contains a rewritten version of the
code.
}
@ -1867,41 +1867,40 @@ new one that rewrites the value of name-symbol via proc,
during the evaluation of expression.
@scheme[name-symbol] is expected to evaluate to a symbol. The value
of proc is called with a (listof lw) -- see below
for details on the shape of lw, and is expected to
return a new (listof (union lw string pict)),
of proc is called with a @scheme[(listof lw)], and is expected to
return a new @scheme[(listof (or/c lw? string? pict?))],
rewritten appropriately.
The list passed to the rewriter corresponds to the
lw for the sequence that has name-symbol's value at
@scheme[lw] for the sequence that has name-symbol's value at
its head.
The result list is constrained to have at most 2 adjacent
non-lws. That list is then transformed by adding
lw structs for each of the non-lws in the
list (see the description of lw below for an
non-@scheme[lw]s. That list is then transformed by adding
@scheme[lw] structs for each of the non-@scheme[lw]s in the
list (see the description of @scheme[lw] below for an
explanation of logical-space):
@itemize[
@item{
If there are two adjacent lws, then the logical
If there are two adjacent @scheme[lw]s, then the logical
space between them is filled with whitespace.}
@item{
If there is a pair of lws with just a single
non-lw between them, a lw will be
created (containing the non-lw) that uses all
of the available logical space between the lws.
If there is a pair of @scheme[lw]s with just a single
non-@scheme[lw] between them, a @scheme[lw] will be
created (containing the non-@scheme[lw]) that uses all
of the available logical space between the @scheme[lw]s.
}
@item{
If there are two adjacent non-lws between two
lws, the first non-lw is rendered
right after the first lw with a logical space
If there are two adjacent non-@scheme[lw]s between two
@scheme[lw]s, the first non-@scheme[lw] is rendered
right after the first @scheme[lw] with a logical space
of zero, and the second is rendered right before the
last lw also with a logical space of zero, and
the logical space between the two lws is
absorbed by a new lw that renders using no
last @scheme[lw] also with a logical space of zero, and
the logical space between the two @scheme[lw]s is
absorbed by a new @scheme[lw] that renders using no
actual space in the typeset version.
}]
}

11
collects/scheme/private/contract.ss
View File

@ -1217,6 +1217,12 @@ improve method arity mismatch contract violation error messages?
[ctrct (syntax-property ctrct 'inferred-name id)]
[external-name (or user-rename-id id)]
[where-stx stx])
(with-syntax ([extra-test
(syntax-case #'ctrct (->)
[(-> dom ... arg)
#`(and (procedure? id)
(procedure-arity-includes? id #,(length (syntax->list #'(dom ...)))))]
[_ #f])])
(with-syntax ([code
(quasisyntax/loc stx
(begin
@ -1234,10 +1240,11 @@ improve method arity mismatch contract violation error messages?
(syntax-local-lift-module-end-declaration
#`(begin
(-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id))
(unless extra-test
(-contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)))
(void)))
(syntax (code id-rename)))))]))
(syntax (code id-rename))))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(signal-dup-syntax-error)

7
collects/scribblings/mzc/decompile.scrbl
View File

@ -3,7 +3,7 @@
"common.ss"
(for-label scheme/base
compiler/decompile
(only-in compiler/zo-parse compilation-top?)
(only-in compiler/zo-parse compilation-top? req)
compiler/zo-marshal))
@title[#:tag "decompile"]{Decompiling Bytecode}
@ -112,5 +112,6 @@ Consumes the result of parsing bytecode and returns an S-expression
@defproc[(zo-marshal [top compilation-top?]) bytes?]{
Consumes a representation of bytecode and generates a byte string for
the marshaled bytecode. Currently, modules and quoted syntax objects
with @scheme[top] are not supported.}
the marshaled bytecode. Currently, syntax objects are not supported,
including in @scheme[req] for a top-level @scheme[#%require].}

94
collects/scribblings/mzc/zo-parse.scrbl
View File

@ -180,34 +180,13 @@ values. The @scheme[max-let-depth] field indicates the maximum size of
the stack that will be created by @scheme[rhs] (not counting
@scheme[prefix]).}
@defstruct+[(req form) ([reqs (listof module-path?)]
@defstruct+[(req form) ([reqs syntax?]
[dummy toplevel?])]{
Represents a top-level @scheme[require] form (but not one in a
@scheme[module] form). The @scheme[dummy] variable is used to access
to the top-level namespace.}
@defstruct+[(mod form) ([name symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof symbol?)]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? indirect? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))]
[max-let-depth exact-nonnegative-integer?])]{
Represents a @scheme[module] declaration. The @scheme[body] forms use
@scheme[prefix], rather than any prefix in place for the module
declaration itself (and each @scheme[syntax-body] has its own
prefix). The @scheme[body] field contains the module's run-time code,
and @scheme[syntax-body] contains the module's compile-time code. The
@scheme[max-let-depth] field indicates the maximum stack depth created
by @scheme[body] forms (not counting the @scheme[prefix] array).
After each form in @scheme[body] is evaluated, the stack is restored
to its depth from before evaluating the form.}
Represents a top-level @scheme[#%require] form (but not one in a
@scheme[module] form) with a sequence of specifications
@scheme[reqs]. The @scheme[dummy] variable is used to access to the
top-level namespace.}
@defstruct+[(seq form) ([forms (listof (or/c form? indirect? any/c))])]{
@ -230,6 +209,69 @@ After each form in @scheme[forms] is evaluated, the stack is restored
to its depth from before evaluating the form.}
@defstruct+[(mod form) ([name symbol?]
[self-modidx module-path-index?]
[prefix prefix?]
[provides (listof (list/c (or/c exact-integer? #f)
(listof provided?)
(listof provided?)))]
[requires (listof (cons/c (or/c exact-integer? #f)
(listof module-path-index?)))]
[body (listof (or/c form? indirect? any/c))]
[syntax-body (listof (or/c def-syntaxes? def-for-syntax?))]
[unexported (list/c (listof symbol?) (listof symbol?)
(listof symbol?))]
[max-let-depth exact-nonnegative-integer?]
[dummy toplevel?]
[lang-info (or/c #f (vector/c module-path? symbol? any/c))]
[internal-context (or/c #f #t syntax?)])]{
Represents a @scheme[module] declaration. The @scheme[body] forms use
@scheme[prefix], rather than any prefix in place for the module
declaration itself (and each @scheme[syntax-body] has its own
prefix).
The @scheme[provides] and @scheme[requires] lists are each an
association list from phases to exports or imports. In the case of
@scheme[provides], each phase maps to two lists: one for exported
variables, and another for exported syntax. In the case of
@scheme[requires], each phase maps to a list of imported module paths.
The @scheme[body] field contains the module's run-time code, and
@scheme[syntax-body] contains the module's compile-time code. After
each form in @scheme[body] or @scheme[syntax-body] is evaluated, the
stack is restored to its depth from before evaluating the form.
The @scheme[unexported] list contains lists of symbols for unexported
definitions that can be accessed through macro expansion. The first
list is phase-0 variables, the second is phase-0 syntax, and the last
is phase-1 variables.
The @scheme[max-let-depth] field indicates the maximum stack depth
created by @scheme[body] forms (not counting the @scheme[prefix]
array). The @scheme[dummy] variable is used to access to the
top-level namespace.
The @scheme[lang-info] value specifies an optional module path that
provides information about the module's implementation language.
The @scheme[internal-module-context] value describes the lexical
context of the body of the module. This value is used by
@scheme[module->namespace]. A @scheme[#f] value means that the context
is unavailable or empty. A @scheme[#t] value means that the context is
computed by re-importing all required modules. A syntax-object value
embeds an arbitrary lexical context.}
@defstruct+[provided ([name symbol?]
[src (or/c module-path-index? #f)]
[src-name symbol?]
[nom-mod (or/c module-path-index? #f)]
[src-phase (or/c 0 1)]
[protected? boolean?]
[insp (or #t #f (void))])]{
Describes an individual provided identifier within a @scheme[mod] instance.}
@; --------------------------------------------------
@section{Expressions}

93
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -217,20 +217,89 @@ current world. The clock ticks at the rate of @scheme[rate-expr].}}
@deftech{KeyEvent} : @scheme[(or/c char? symbol?)]
A character is used to signal that the user has hit an alphanumeric
key. A symbol denotes arrow keys or special events:
A single-character string is used to signal that the user has hit an alphanumeric
key. Some of these one-character strings may look unusual:
@itemize[
@item{@scheme[" "] stands for the space bar (@scheme[#\space]);}
@item{@scheme["\r"] stands for the return key (@scheme[#\return]);}
@item{@scheme["\t"] stands for the tab key (@scheme[#\tab]); and}
@item{@scheme["\b"] stands for the backspace key (@scheme[#\backspace]).}
]
On rare occasions you may also encounter @scheme["\u007F"], which is the
string representing the delete key (aka rubout).
@item{@scheme['left] is the left arrow,}
@item{@scheme['right] is the right arrow,}
@item{@scheme['up] is the up arrow,}
@item{@scheme['down] is the down arrow, and}
@item{@scheme['release] is the event of releasing a key.}
A string with more than one character denotes arrow keys or other special events,
starting with the most important:
@itemize[
@item{@scheme["left"] is the left arrow;}
@item{@scheme["right"] is the right arrow;}
@item{@scheme["up"] is the up arrow;}
@item{@scheme["down"] is the down arrow;}
@item{@scheme["release"] is the event of releasing a key;}
@item{@scheme["start"]}
@item{@scheme["cancel"]}
@item{@scheme["clear"]}
@item{@scheme["shift"]}
@item{@scheme["control"]}
@item{@scheme["menu"]}
@item{@scheme["pause"]}
@item{@scheme["capital"]}
@item{@scheme["prior"]}
@item{@scheme["next"]}
@item{@scheme["end"]}
@item{@scheme["home"]}
@item{@scheme["escape"]}
@item{@scheme["select"]}
@item{@scheme["print"]}
@item{@scheme["execute"]}
@item{@scheme["snapshot"]}
@item{@scheme["insert"]}
@item{@scheme["help"]}
@item{@scheme["numpad0"],
@scheme["numpad1"],
@scheme["numpad2"],
@scheme["numpad3"],
@scheme["numpad4"],
@scheme["numpad5"],
@scheme["numpad6"],
@scheme["numpad7"],
@scheme["numpad8"],
@scheme["numpad9"],
@scheme["numpad-enter"],
@scheme["multiply"],
@scheme["add"],
@scheme["separator"],
@scheme["subtract"],
@scheme["decimal"],
@scheme["divide"]}
@item{@scheme["'f1"],
@scheme["f2"],
@scheme["f3"],
@scheme["f4"],
@scheme["f5"],
@scheme["f6"],
@scheme["f7"],
@scheme["f8"],
@scheme["f9"],
@scheme["f10"],
@scheme["f11"],
@scheme["f12"],
@scheme["f13"],
@scheme["f14"],
@scheme["f15"],
@scheme["f16"],
@scheme["f17"],
@scheme["f18"],
@scheme["f19"],
@scheme["f20"],
@scheme["f21"],
@scheme["f22"],
@scheme["f23"],
@scheme["f24"]}
@item{@scheme["numlock"]}
@item{@scheme["scroll"]}
@item{@scheme["wheel-up"]}
@item{@scheme["wheel-down"]}
]
@defproc[(key-event? [x any]) boolean?]{

12
collects/tests/mzscheme/contract-test.ss
View File

@ -6560,6 +6560,18 @@ so that propagation occurs.
(and (exn? x)
(regexp-match #rx"cannot set!" (exn-message x)))))
(contract-error-test
#'(begin
(eval '(module pce8-bug1 scheme/base
(require scheme/contract)
(define (f x) x)
(provide/contract [f (-> integer? integer? integer?)])))
(eval '(require 'pce8-bug1)))
(λ (x)
(printf ">> ~s\n" (exn-message x))
(and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x)))))
(contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
(report-errs)