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

31
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 ;; turn a mouse event into its pieces
(define (mouse-event->parts e) (define (mouse-event->parts e)
(define x (- (send e get-x) INSET)) (define x (- (send e get-x) INSET))
(define y (- (send e get-y) INSET)) (define y (- (send e get-y) INSET))
(values x y (cond [(send e button-down?) 'button-down] (values x y
[(send e button-up?) 'button-up] (cond [(send e button-down?) "button-down"]
[(send e dragging?) 'drag] [(send e button-up?) "button-up"]
[(send e moving?) 'move] [(send e dragging?) "drag"]
[(send e entering?) 'enter] [(send e moving?) "move"]
[(send e leaving?) 'leave] [(send e entering?) "enter"]
[else ; (send e get-event-type) [(send e leaving?) "leave"]
(error 'on-mouse-event [else ; (send e get-event-type)
(format (let ([m (send e get-event-type)])
"Unknown event type: ~a" (error 'on-mouse (format "Unknown event: ~a" m)))])))
(send e get-event-type)))])))
;; 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 ;; Any -> Symbol

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

@ -32,8 +32,12 @@
extra extra
[_ (err tag p)])))])) [_ (err tag p)])))]))
(define (err spec p) (define (err spec p . extra-spec)
(raise-syntax-error #f "illegal specification" #`(#,spec . #,p) p)) (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) ;; Symbol (Symbol X -> X) -> (X -> X)
(define (check-flat-spec tag coerce>) (define (check-flat-spec tag coerce>)

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

@ -170,7 +170,7 @@
(super-new) (super-new)
;; deal with keyboard events ;; deal with keyboard events
(define/override (on-char e) (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 ;; deal with mouse events if live and within range
(define/override (on-event e) (define/override (on-event e)
(define-values (x y me) (mouse-event->parts e)) (define-values (x y me) (mouse-event->parts e))

18
collects/2htdp/universe.ss
View File

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

5
collects/compiler/decompile.ss
View File

@ -90,7 +90,8 @@
(define (decompile-module mod-form stack) (define (decompile-module mod-form stack)
(match mod-form (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)] (let-values ([(globs defns) (decompile-prefix prefix)]
[(stack) (append '(#%modvars) stack)] [(stack) (append '(#%modvars) stack)]
[(closed) (make-hasheq)]) [(closed) (make-hasheq)])
@ -135,6 +136,8 @@
`(begin ,@(map (lambda (form) `(begin ,@(map (lambda (form)
(decompile-form form globs stack closed)) (decompile-form form globs stack closed))
forms))] forms))]
[(struct req (reqs dummy))
`(#%require . (#%decode-syntax ,reqs))]
[else [else
(decompile-expr form globs stack closed)])) (decompile-expr form globs stack closed)]))

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

@ -5,7 +5,7 @@
(provide zo-marshal) (provide zo-marshal)
;; Doesn't write as compactly as MzScheme, since list and pair sequences ;; 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) (define (zo-marshal top)
(match top (match top
@ -71,23 +71,26 @@
(define (traverse-prefix a-prefix visit) (define (traverse-prefix a-prefix visit)
(match a-prefix (match a-prefix
[(struct prefix (num-lifts toplevels stxs)) [(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)])) (for-each (lambda (stx) (traverse-stx stx visit)) stxs)]))
(define (traverse-module mod-form visit) (define (traverse-module mod-form visit)
(match mod-form (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
(error "cannot handle modules, yet") max-let-depth dummy lang-info internal-context))
(traverse-data name visit) (traverse-data name visit)
(traverse-data self-modidx visit) (traverse-data self-modidx visit)
(traverse-prefix prefix visit) (traverse-prefix prefix visit)
(for-each (lambda (f) (traverse-form f prefix)) body) (for-each (lambda (f) (map (lambda (v) (traverse-data v visit)) (cdr f))) requires)
(for-each (lambda (f) (traverse-form f prefix)) syntax-body)])) (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) (define (traverse-toplevel tl visit)
(match tl (match tl
[#f (void)] [#f (void)]
[(? symbol?) (visit tl)] [(? symbol?) (traverse-data tl visit)]
[(struct global-bucket (name)) [(struct global-bucket (name))
(void)] (void)]
[(struct module-variable (modidx sym pos phase)) [(struct module-variable (modidx sym pos phase))
@ -180,9 +183,13 @@
(keyword? expr) (keyword? expr)
(string? expr) (string? expr)
(bytes? expr) (bytes? expr)
(path? expr) (path? expr))
(module-path-index? expr))
(visit 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) [(pair? expr)
(traverse-data (car expr) visit) (traverse-data (car expr) visit)
(traverse-data (cdr expr) visit)] (traverse-data (cdr expr) visit)]
@ -213,6 +220,7 @@
(define top-type-num 87) (define top-type-num 87)
(define case-lambda-sequence-type-num 96) (define case-lambda-sequence-type-num 96)
(define begin0-sequence-type-num 97) (define begin0-sequence-type-num 97)
(define module-type-num 100)
(define prefix-type-num 103) (define prefix-type-num 103)
(define-syntax define-enum (define-syntax define-enum
@ -363,10 +371,80 @@
(list->vector stxs))) (list->vector stxs)))
out)])) out)]))
(define-struct module-decl (content))
(define (out-module mod-form out) (define (out-module mod-form out)
(match mod-form (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
(error "cannot write modules, yet")])) 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) (define (out-toplevel tl out)
(match tl (match tl
@ -422,6 +500,9 @@
(out-marshaled sequence-type-num (map protect-quote forms) out)] (out-marshaled sequence-type-num (map protect-quote forms) out)]
[(struct splice (forms)) [(struct splice (forms))
(out-syntax SPLICE_EXPD (make-seq forms) out)] (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 [else
(out-expr form out)])) (out-expr form out)]))
@ -605,11 +686,12 @@
l) l)
out))])) out))]))
(define (out-as-bytes expr ->bytes CPT out) (define (out-as-bytes expr ->bytes CPT len2 out)
(out-shared expr out (lambda () (out-shared expr out (lambda ()
(let ([s (->bytes expr)]) (let ([s (->bytes expr)])
(out-byte CPT out) (out-byte CPT out)
(out-number (bytes-length s) out) (out-number (bytes-length s) out)
(when len2 (out-number len2 out))
(out-bytes s out))))) (out-bytes s out)))))
(define (out-data expr out) (define (out-data expr out)
@ -625,26 +707,31 @@
(out-as-bytes expr (out-as-bytes expr
(compose string->bytes/utf-8 symbol->string) (compose string->bytes/utf-8 symbol->string)
CPT_SYMBOL CPT_SYMBOL
#f
out)] out)]
[(keyword? expr) [(keyword? expr)
(out-as-bytes expr (out-as-bytes expr
(compose string->bytes/utf-8 keyword->string) (compose string->bytes/utf-8 keyword->string)
CPT_KEYWORD CPT_KEYWORD
#f
out)] out)]
[(string? expr) [(string? expr)
(out-as-bytes expr (out-as-bytes expr
string->bytes/utf-8 string->bytes/utf-8
CPT_CHAR_STRING CPT_CHAR_STRING
(string-length expr)
out)] out)]
[(bytes? expr) [(bytes? expr)
(out-as-bytes expr (out-as-bytes expr
values values
CPT_BYTE_STRING CPT_BYTE_STRING
#f
out)] out)]
[(path? expr) [(path? expr)
(out-as-bytes expr (out-as-bytes expr
path->bytes path->bytes
CPT_PATH CPT_PATH
#f
out)] out)]
[(char? expr) [(char? expr)
(out-byte CPT_CHAR out) (out-byte CPT_CHAR out)
@ -690,10 +777,16 @@
(for ([n (in-range (sub1 (vector-length vec)) -1 -1)]) (for ([n (in-range (sub1 (vector-length vec)) -1 -1)])
(out-number (vector-ref vec n) out)))] (out-number (vector-ref vec n) out)))]
[(module-path-index? expr) [(module-path-index? expr)
(out-byte CPT_MODULE_INDEX out) (out-shared expr out
(let-values ([(name base) (module-path-index-split expr)]) (lambda ()
(out-data name out) (out-byte CPT_MODULE_INDEX out)
(out-data base out))] (let-values ([(name base) (module-path-index-split expr)])
(out-data name out)
(out-data base out))))]
[(module-decl? expr)
(out-marshaled module-type-num
(module-decl-content expr)
out)]
[else [else
(out-byte CPT_QUOTE out) (out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)]) (let ([s (open-output-bytes)])

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

@ -34,7 +34,8 @@
(define-form-struct form ()) (define-form-struct form ())
(define-form-struct (expr 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 (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) (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) (define-struct indirect ([v #:mutable]) #:prefab)
(provide (struct-out indirect)) (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 ;; Bytecode unmarshalers for various forms
@ -232,7 +236,37 @@
,requires ,syntax-requires ,template-requires ,label-requires ,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires) ,more-requires-count . ,more-requires)
(make-mod name self-modidx (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* (list*
(cons 0 requires) (cons 0 requires)
(cons 1 syntax-requires) (cons 1 syntax-requires)
@ -248,7 +282,13 @@
make-def-syntaxes) make-def-syntaxes)
ids expr prefix max-let-depth)])) ids expr prefix max-let-depth)]))
(vector->list syntax-body)) (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) (define (read-module-wrap v)
v) v)

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

@ -49,11 +49,11 @@
[(pair? x) (loop (car x)) (loop (cdr x))] [(pair? x) (loop (car x)) (loop (cdr x))]
[else (display x)])) [else (display x)]))
(newline)) (newline))
(define total-time (profile-total-time profile)) (define total-time (profile-total-time profile)) ;!! are these two
(define cpu-time (profile-cpu-time profile)) (define cpu-time (profile-cpu-time profile)) ;!! swapped?
(define sample-number (profile-sample-number profile)) (define sample-number (profile-sample-number profile))
(define granularity (if (zero? sample-number) 0 (define granularity (if (zero? sample-number) 0 ;!! this might
(/ total-time sample-number))) (/ total-time sample-number))) ;!! be wrong
(define threads+times (profile-thread-times profile)) (define threads+times (profile-thread-times profile))
(define *-node (profile-*-node profile)) (define *-node (profile-*-node profile))
(define hidden (get-hidden profile hide-self% hide-subs%)) (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 unquote rewriter specified is used to remap them.
The @scheme[proc] should be a function of one argument. It receives The @scheme[proc] should be a function of one argument. It receives
a lw struct as an argument and should return a @scheme[lw] struct as an argument and should return
another lw that contains a rewritten version of the another @scheme[lw] that contains a rewritten version of the
code. code.
} }
@ -1867,41 +1867,40 @@ new one that rewrites the value of name-symbol via proc,
during the evaluation of expression. during the evaluation of expression.
@scheme[name-symbol] is expected to evaluate to a symbol. The value @scheme[name-symbol] is expected to evaluate to a symbol. The value
of proc is called with a (listof lw) -- see below of proc is called with a @scheme[(listof lw)], and is expected to
for details on the shape of lw, and is expected to return a new @scheme[(listof (or/c lw? string? pict?))],
return a new (listof (union lw string pict)),
rewritten appropriately. rewritten appropriately.
The list passed to the rewriter corresponds to the 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. its head.
The result list is constrained to have at most 2 adjacent The result list is constrained to have at most 2 adjacent
non-lws. That list is then transformed by adding non-@scheme[lw]s. That list is then transformed by adding
lw structs for each of the non-lws in the @scheme[lw] structs for each of the non-@scheme[lw]s in the
list (see the description of lw below for an list (see the description of @scheme[lw] below for an
explanation of logical-space): explanation of logical-space):
@itemize[ @itemize[
@item{ @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.} space between them is filled with whitespace.}
@item{ @item{
If there is a pair of lws with just a single If there is a pair of @scheme[lw]s with just a single
non-lw between them, a lw will be non-@scheme[lw] between them, a @scheme[lw] will be
created (containing the non-lw) that uses all created (containing the non-@scheme[lw]) that uses all
of the available logical space between the lws. of the available logical space between the @scheme[lw]s.
} }
@item{ @item{
If there are two adjacent non-lws between two If there are two adjacent non-@scheme[lw]s between two
lws, the first non-lw is rendered @scheme[lw]s, the first non-@scheme[lw] is rendered
right after the first lw with a logical space right after the first @scheme[lw] with a logical space
of zero, and the second is rendered right before the of zero, and the second is rendered right before the
last lw also with a logical space of zero, and last @scheme[lw] also with a logical space of zero, and
the logical space between the two lws is the logical space between the two @scheme[lw]s is
absorbed by a new lw that renders using no absorbed by a new @scheme[lw] that renders using no
actual space in the typeset version. 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)] [ctrct (syntax-property ctrct 'inferred-name id)]
[external-name (or user-rename-id id)] [external-name (or user-rename-id id)]
[where-stx stx]) [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 (with-syntax ([code
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
@ -1234,10 +1240,11 @@ improve method arity mismatch contract violation error messages?
(syntax-local-lift-module-end-declaration (syntax-local-lift-module-end-declaration
#`(begin #`(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))) (void)))
(syntax (code id-rename)))))])) (syntax (code id-rename))))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))]) (with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(signal-dup-syntax-error) (signal-dup-syntax-error)

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

@ -3,7 +3,7 @@
"common.ss" "common.ss"
(for-label scheme/base (for-label scheme/base
compiler/decompile compiler/decompile
(only-in compiler/zo-parse compilation-top?) (only-in compiler/zo-parse compilation-top? req)
compiler/zo-marshal)) compiler/zo-marshal))
@title[#:tag "decompile"]{Decompiling Bytecode} @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?]{ @defproc[(zo-marshal [top compilation-top?]) bytes?]{
Consumes a representation of bytecode and generates a byte string for Consumes a representation of bytecode and generates a byte string for
the marshaled bytecode. Currently, modules and quoted syntax objects the marshaled bytecode. Currently, syntax objects are not supported,
with @scheme[top] 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 the stack that will be created by @scheme[rhs] (not counting
@scheme[prefix]).} @scheme[prefix]).}
@defstruct+[(req form) ([reqs (listof module-path?)] @defstruct+[(req form) ([reqs syntax?]
[dummy toplevel?])]{ [dummy toplevel?])]{
Represents a top-level @scheme[require] form (but not one in a Represents a top-level @scheme[#%require] form (but not one in a
@scheme[module] form). The @scheme[dummy] variable is used to access @scheme[module] form) with a sequence of specifications
to the top-level namespace.} @scheme[reqs]. 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.}
@defstruct+[(seq form) ([forms (listof (or/c form? indirect? any/c))])]{ @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.} 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} @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?)] @deftech{KeyEvent} : @scheme[(or/c char? symbol?)]
A character is used to signal that the user has hit an alphanumeric A single-character string is used to signal that the user has hit an alphanumeric
key. A symbol denotes arrow keys or special events: key. Some of these one-character strings may look unusual:
@itemize[ @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,} A string with more than one character denotes arrow keys or other special events,
starting with the most important:
@item{@scheme['right] is the right arrow,} @itemize[
@item{@scheme["left"] is the left arrow;}
@item{@scheme['up] is the up 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["down"] is the down arrow;}
@item{@scheme["release"] is the event of releasing a key;}
@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?]{ @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) (and (exn? x)
(regexp-match #rx"cannot set!" (exn-message 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)))) (contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
(report-errs) (report-errs)