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

Oh, no! Aliens, bio-duplication, nude conspiracies.. oh my God,

Browse Source 
Lyndon LaRouche was right!

svn: r13037
This commit is contained in:
Stevie Strickland 2009-01-08 14:55:23 +00:00
commit 22ee00b10f
530 changed files with 4234 additions and 3262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -40,4 +40,4 @@
(lambda (p)
(syntax-case p ()
[(b) #'(coerce> tag b)]
[_ (err tag p)])))
[_ (err tag p)])))

0
collects/2htdp/universe.ss Executable file → Normal file
View File

2
collects/compiler/compiler-unit.ss
View File

@ -1,5 +1,5 @@
;; Main compilation procedures
;; (c) 1997-2008 PLT
;; (c) 1997-2009 PLT
;; The various procedures provided by this library are implemented
;; by dynamically linking to code supplied by the MzLib, dynext, and

2
collects/compiler/main.ss
View File

@ -401,7 +401,7 @@
(parse-options (current-command-line-arguments)))
(when (compiler:option:somewhat-verbose)
(printf "mzc v~a [~a], Copyright (c) 2004-2008 PLT Scheme Inc.\n"
(printf "mzc v~a [~a], Copyright (c) 2004-2009 PLT Scheme Inc.\n"
(version)
(system-type 'gc)))

35
collects/ffi/objc.scrbl
View File

@ -3,7 +3,7 @@
scribble/eval
(for-label scheme/base
scheme/foreign
ffi/objc))
"private/objc-doc-unsafe.ss"))
@(define objc-eval (make-base-eval))
@(interaction-eval #:eval objc-eval (define-struct cpointer:id ()))
@ -13,7 +13,9 @@
@title{@bold{Objective-C} FFI}
@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on
@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)]
@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on
@schememodname[scheme/foreign] to support interaction with
@link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.}
@ -26,8 +28,23 @@ relatively low-level compared to normal Scheme libraries, because
argument and result types must be declared in terms of FFI C types
(@seeCtype).
@bold{Important:} Most of the bindings documented here are available
only after an @scheme[(objc-unsafe!)] declaration in the importing
module.
@table-of-contents[]
@; ----------------------------------------------------------------------
@section{Using Unsafe Bindings}
@defform[(objc-unsafe!)]{
Analogous to @scheme[(unsafe!)], makes unsafe bindings of
@schememodname[ffi/objc] available in the importing module.}
@; ----------------------------------------------------------------------
@section{FFI Types and Constants}
@defthing[_id ctype?]{
@ -101,13 +118,13 @@ Defines each @scheme[class-id] to the class (a value with FFI type
(eval:alts (import-class NSString) (void))
]}
@defform/subs[#:literals (+ -)
@defform/subs[#:literals (+ - +a -a)
(define-objc-class class-id superclass-expr
[field-id ...]
method)
([method (mode result-ctype-expr (method-id) body ...+)
(mode result-ctype-expr (arg ...+) body ...+)]
[mode + -]
[mode + - +a -a]
[arg (code:line method-id [ctype-expr arg-id])])]{
Defines @scheme[class-id] as a new, registered Objective-C class (of
@ -121,10 +138,12 @@ directly when the method @scheme[body]s. Outside the object, they can
be referenced and set with @scheme[get-ivar] and @scheme[set-ivar!].
Each @scheme[method] adds or overrides a method to the class (when
@scheme[mode] is @scheme[-]) to be called on instances, or it adds a
method to the meta-class (when @scheme[mode] is @scheme[+]) to be
called on the class itself. All result and argument types must be
declared using FFI C types (@seeCtype).
@scheme[mode] is @scheme[-] or @scheme[-a]) to be called on instances,
or it adds a method to the meta-class (when @scheme[mode] is
@scheme[+] or @scheme[+a]) to be called on the class itself. All
result and argument types must be declared using FFI C types
(@seeCtype). When @scheme[mode] is @scheme[+a] or @scheme[-a], the
method is called in atomic mode (see @scheme[_cprocedure]).
If a @scheme[method] is declared with a single @scheme[method-id] and
no arguments, then @scheme[method-id] must not end with

36
collects/ffi/objc.ss
View File

@ -15,7 +15,7 @@
(define-syntax-rule (define-objc id type)
(begin
(provide id)
(provide* (unsafe id))
(define-objc/private id id type)))
;; ----------------------------------------
@ -86,16 +86,16 @@
(define msgSends (make-hash))
(define (objc_msgSend/typed types)
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
(provide objc_msgSend/typed)
(provide* (unsafe objc_msgSend/typed))
(define msgSendSupers (make-hash))
(define (objc_msgSendSuper/typed types)
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
(provide objc_msgSendSuper/typed)
(provide* (unsafe objc_msgSendSuper/typed))
;; ----------------------------------------
(provide import-class)
(provide* (unsafe import-class))
(define-syntax (import-class stx)
(syntax-case stx ()
[(_ id)
@ -107,7 +107,7 @@
;; ----------------------------------------
;; iget-value and set-ivar! work only with fields that contain Scheme values
(provide get-ivar set-ivar!)
(provide* (unsafe get-ivar) (unsafe set-ivar!))
(define-for-syntax (check-ivar ivar stx)
(unless (identifier? ivar)
@ -161,7 +161,7 @@
(hash-set! method-sels sym id)
id)))
(provide selector)
(provide* (unsafe selector))
(define-syntax (selector stx)
(syntax-case stx ()
[(_ id)
@ -256,7 +256,7 @@
arg)))
(loop (cdr rest))))))))
(provide tell tellv)
(provide* (unsafe tell) (unsafe tellv))
(define-for-syntax (build-send stx result-type send/typed send-args l-stx)
(let ([l (syntax->list l-stx)])
(with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)]
@ -329,7 +329,7 @@
;; ----------------------------------------
(provide define-objc-class self super-tell)
(provide* (unsafe define-objc-class) self super-tell)
(define-syntax (define-objc-class stx)
(syntax-case stx ()
@ -364,7 +364,7 @@
;; Given a dealloc extension:
#'()
;; Need to add one explicitly:
#'((- _void (dealloc) (void)))))])
#'((-a _void (dealloc) (void)))))])
(syntax/loc stx
(begin
(define superclass-id superclass)
@ -454,10 +454,13 @@
(syntax-case #'m ()
[(kind result-type (id arg ...) body0 body ...)
(or (free-identifier=? #'kind #'+)
(free-identifier=? #'kind #'-))
(free-identifier=? #'kind #'-)
(free-identifier=? #'kind #'+a)
(free-identifier=? #'kind #'-a))
(let ([id #'id]
[args (syntax->list #'(arg ...))]
[in-class? (free-identifier=? #'kind #'+)])
[in-class? (or (free-identifier=? #'kind #'+)
(free-identifier=? #'kind #'+a))])
(when (null? args)
(unless (identifier? id)
(raise-syntax-error #f
@ -485,7 +488,9 @@
'())]
[in-cls (if in-class?
#'(object_getClass cls)
#'cls)])
#'cls)]
[atomic? (or (free-identifier=? #'kind #'+a)
(free-identifier=? #'kind #'-a))])
(syntax/loc stx
(let ([rt result-type]
[arg-id arg-type] ...)
@ -498,7 +503,7 @@
[super-tell do-super-tell])
body0 body ...
dealloc-body ...)))
(_fun _id _id arg-type ... -> rt)
(_fun #:atomic? atomic? _id _id arg-type ... -> rt)
(generate-layout rt (list arg-id ...)))))))))]
[else (raise-syntax-error #f
"bad method form"
@ -549,3 +554,8 @@
#'objc_msgSendSuper/typed
#'((make-objc_super self super-class))
#'(method/arg ...))]))
;; --------------------------------------------------
(define-unsafer objc-unsafe!)

10
collects/ffi/private/objc-doc-unsafe.ss Normal file
View File

@ -0,0 +1,10 @@
#lang scheme/base
(require ffi/objc)
(error 'objc-unsafe! "only `for-label' use in the documentation")
(objc-unsafe!)
(provide (protect-out (all-defined-out))
(all-from-out ffi/objc))

2
collects/handin-server/scribblings/quick-start.scrbl
View File

@ -27,7 +27,7 @@
@item{Create a file @filepath{config.ss} with the following content:
@schemeblock[((active-dirs ("test"))
(https-port-number 9780))]}
(https-port-number 7980))]}
@item{In your new directory, run @commandline{mred-text -l handin-server}}

10
collects/handin-server/scribblings/server-setup.scrbl
View File

@ -469,8 +469,11 @@ limited to one whenever possible. When multiple assignments are
active, design a checker to help ensure that the student has selected
the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server
that runs concurrently with the handin server. The starting URL is
A student can download his/her own submissions through the handin
dialog. This can also be done through a web server that runs
concurrently with the handin server if you use the
@scheme[https-port-number] option in the configuration file. The
starting URL is
@commandline{https://SERVER:PORT/}
@ -478,5 +481,4 @@ to obtain a list of all assignments, or
@commandline{https://SERVER:PORT/?handin=ASSIGNMENT}
to start with a specific assignment (named ASSIGNMENT). The default
PORT is 7980.
to start with a specific assignment (named ASSIGNMENT).

10
collects/help/help-utils.ss
View File

@ -14,7 +14,7 @@
scheme/list
"search.ss")
(provide search-for find-help find-help/lib)
(provide search-for find-help find-help/lib go-to-main-page)
(define (search-for strs)
(perform-search (apply string-append (add-between strs " "))))
@ -64,9 +64,15 @@
(printf " ~a\n" (car libs)))
(loop (cdr libs))))))))
(define (report-sending-browser file)
(printf "Sending to web browser...\n file: ~a\n" file))
(define (go-to-main-page)
(send-main-page #:notify report-sending-browser))
(define (go-to-tag xref t)
(let-values ([(file anchor) (xref-tag->path+anchor xref t)])
(printf "Sending to web browser...\n file: ~a\n" file)
(report-sending-browser file)
(when anchor (printf " anchor: ~a\n" anchor))
(unless (send-url/file file #:fragment (and anchor (uri-encode anchor)))
(error 'help "browser launch failed"))))

4
collects/help/search.ss
View File

@ -9,9 +9,11 @@
;; using javascript.
(define (send-main-page #:sub [sub "index.html"]
#:fragment [fragment #f] #:query [query #f])
#:fragment [fragment #f] #:query [query #f]
#:notify [notify void])
(let* ([path (build-path (find-user-doc-dir) sub)]
[path (if (file-exists? path) path (build-path (find-doc-dir) sub))])
(notify path)
(send-url/file path #:fragment fragment #:query query)))
;; This is an example of changing this code to use the online manuals.

99
collects/htdp/image.ss
View File

@ -927,72 +927,83 @@ converting from the computer's coordinates, we get:
(define (color-list->image cl in-w in-h px py)
(check 'color-list->image color-list? cl "list-of-colors" "first")
(check-posi-size 'color-list->image in-w "second")
(check-posi-size 'color-list->image in-h "third")
(check-size/0 'color-list->image in-w "second")
(check-size/0 'color-list->image in-h "third")
(check-coordinate 'color-list->image px "fourth")
(check-coordinate 'color-list->image py "fifth")
(let ([w (inexact->exact in-w)]
[h (inexact->exact in-h)])
(unless (and (< 0 w 10000) (< 0 h 10000))
(error 'color-list->image "cannot make ~a x ~a image" w h))
(unless (= (* w h) (length cl))
(error 'color-list->image
"given width times given height is ~a, but the given color list has ~a items"
(* w h)
(length cl)))
(let* ([bm (make-object bitmap% w h)]
[mask-bm (make-object bitmap% w h)]
[dc (make-object bitmap-dc% bm)]
[mask-dc (make-object bitmap-dc% mask-bm)])
(unless (send bm ok?)
(error (format "cannot make ~a x ~a image" w h)))
(let ([is (make-bytes (* 4 w h) 0)]
[mask-is (make-bytes (* 4 w h) 0)]
[cols (list->vector (map (λ (x)
(or (make-color% x)
(error 'color-list->image "color ~e is unknown" x)))
cl))])
(let yloop ([y 0][pos 0])
(unless (= y h)
(let xloop ([x 0][pos pos])
(if (= x w)
(yloop (add1 y) pos)
(let* ([col (vector-ref cols (+ x (* y w)))]
[r (pk (send col red))]
[g (pk (send col green))]
[b (pk (send col blue))])
(bytes-set! is (+ 1 pos) r)
(bytes-set! is (+ 2 pos) g)
(bytes-set! is (+ 3 pos) b)
(when (= 255 r g b)
(bytes-set! mask-is (+ 1 pos) 255)
(bytes-set! mask-is (+ 2 pos) 255)
(bytes-set! mask-is (+ 3 pos) 255))
(xloop (add1 x) (+ pos 4)))))))
(send dc set-argb-pixels 0 0 w h is)
(send mask-dc set-argb-pixels 0 0 w h mask-is))
(send dc set-bitmap #f)
(send mask-dc set-bitmap #f)
(bitmaps->cache-image-snip bm mask-bm px py))))
(cond
[(or (equal? w 0) (equal? h 0))
(put-pinhole (rectangle w h 'solid 'black) px py)]
[else
(unless (and (< 0 w 10000) (< 0 h 10000))
(error 'color-list->image "cannot make ~a x ~a image" w h))
(let* ([bm (make-object bitmap% w h)]
[mask-bm (make-object bitmap% w h)]
[dc (make-object bitmap-dc% bm)]
[mask-dc (make-object bitmap-dc% mask-bm)])
(unless (send bm ok?)
(error (format "cannot make ~a x ~a image" w h)))
(let ([is (make-bytes (* 4 w h) 0)]
[mask-is (make-bytes (* 4 w h) 0)]
[cols (list->vector (map (λ (x)
(or (make-color% x)
(error 'color-list->image "color ~e is unknown" x)))
cl))])
(let yloop ([y 0][pos 0])
(unless (= y h)
(let xloop ([x 0][pos pos])
(if (= x w)
(yloop (add1 y) pos)
(let* ([col (vector-ref cols (+ x (* y w)))]
[r (pk (send col red))]
[g (pk (send col green))]
[b (pk (send col blue))])
(bytes-set! is (+ 1 pos) r)
(bytes-set! is (+ 2 pos) g)
(bytes-set! is (+ 3 pos) b)
(when (= 255 r g b)
(bytes-set! mask-is (+ 1 pos) 255)
(bytes-set! mask-is (+ 2 pos) 255)
(bytes-set! mask-is (+ 3 pos) 255))
(xloop (add1 x) (+ pos 4)))))))
(send dc set-argb-pixels 0 0 w h is)
(send mask-dc set-argb-pixels 0 0 w h mask-is))
(send dc set-bitmap #f)
(send mask-dc set-bitmap #f)
(bitmaps->cache-image-snip bm mask-bm px py))])))
(define (pk col) (min 255 (max 0 col)))
(define (alpha-color-list->image cl in-w in-h px py)
(check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first")
(check-posi-size 'alpha-color-list->image in-w "second")
(check-posi-size 'alpha-color-list->image in-h "third")
(check-size/0 'alpha-color-list->image in-w "second")
(check-size/0 'alpha-color-list->image in-h "third")
(check-coordinate 'alpha-color-list->image px "fourth")
(check-coordinate 'alpha-color-list->image py "fifth")
(let ([w (inexact->exact in-w)]
[h (inexact->exact in-h)])
(unless (and (< 0 w 10000) (< 0 h 10000))
(error 'alpha-color-list->image format "cannot make ~a x ~a image" w h))
(unless (= (* w h) (length cl))
(error 'alpha-color-list->image
"given width times given height is ~a, but the given color list has ~a items"
(* w h) (length cl)))
(let ([index-list (alpha-colors->ent-list cl)])
(argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))))
(cond
[(or (equal? w 0) (equal? h 0))
(put-pinhole (rectangle w h 'solid 'black) px py)]
[else
(unless (and (< 0 w 10000) (< 0 h 10000))
(error 'alpha-color-list->image format "cannot make ~a x ~a image" w h))
(let ([index-list (alpha-colors->ent-list cl)])
(argb->cache-image-snip (make-argb (list->vector index-list) w h) px py))])))
;; alpha-colors->ent-list : (listof alpha-color) -> (listof number)
(define (alpha-colors->ent-list cl)

5
collects/html/generate-code.ss
View File

@ -2,13 +2,12 @@
(require mzlib/pretty
mzlib/date
mzlib/list
mzlib/etc)
mzlib/etc
"html-spec.ss")
; date-string : -> String
(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please))
(define html-spec (call-with-input-file (build-path (collection-path "html") "html-spec") read))
(define (empty-name? x) (null? (cdr x)))
(define empty-names

1
collects/html/html-spec
View File

@ -1 +0,0 @@
(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var))

6
collects/html/html-spec.ss Normal file
View File

@ -0,0 +1,6 @@
#lang scheme/base
(provide html-spec)
(define html-spec
'(((mzscheme) pcdata) ((html) body head) ((div center blockquote ins del dd li th td iframe noframes noscript) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((style script) cdata) ((basefont br area link img param hr input col isindex base meta)) ((option textarea title) pcdata) ((head) base isindex link meta object script style title) ((tr) td th) ((colgroup) col) ((thead tfoot tbody) tr) ((tt i b u s strike big small em strong dfn code samp kbd var cite abbr acronym sub sup span bdo font p h1 h2 h3 h4 h5 h6 q dt legend caption) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((table) caption col colgroup tbody tfoot thead) ((button) abbr acronym address applet b basefont bdo big blockquote br center cite code dfn dir div dl em font h1 h2 h3 h4 h5 h6 hr i img kbd map menu noframes noscript object ol p pcdata pre q s samp script small span strike strong sub sup table tt u ul var) ((fieldset) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label legend map menu noframes noscript object ol p pcdata pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((optgroup) option) ((select) optgroup option) ((label) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((form) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((ol ul dir menu) li) ((dl) dd dt) ((pre) a abbr acronym b bdo br button cite code dfn em i iframe input kbd label map pcdata q s samp script select span strike strong textarea tt u var) ((object applet) a abbr acronym address applet b basefont bdo big blockquote br button center cite code dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input isindex kbd label map menu noframes noscript object ol p param pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var) ((map) address area blockquote center dir div dl fieldset form h1 h2 h3 h4 h5 h6 hr isindex menu noframes noscript ol p pre table ul) ((a) abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((address) a abbr acronym applet b basefont bdo big br button cite code dfn em font i iframe img input kbd label map object p pcdata q s samp script select small span strike strong sub sup textarea tt u var) ((body) a abbr acronym address applet b basefont bdo big blockquote br button center cite code del dfn dir div dl em fieldset font form h1 h2 h3 h4 h5 h6 hr i iframe img input ins isindex kbd label map menu noframes noscript object ol p pcdata pre q s samp script select small span strike strong sub sup table textarea tt u ul var)))

3
collects/html/html-unit.ss
View File

@ -6,6 +6,7 @@
mzlib/list
mzlib/etc
mzlib/include
"html-spec.ss"
"html-sig.ss"
"sgml-reader-sig.ss"
xml/xml-sig)
@ -118,7 +119,7 @@
;; may-contain : Kid-lister
(define may-contain
(sgml:gen-may-contain (call-with-input-file (find-library "html-spec" "html") read)))
(sgml:gen-may-contain html-spec))
(define may-contain-anything
(sgml:gen-may-contain null))

4
collects/macro-debugger/model/deriv-parser.ss
View File

@ -191,8 +191,8 @@
(NotReallyLocalAction
;; called 'expand' (not 'local-expand') within transformer
[(start (? EE))
#f])
[(start (? EE)) #f]
[(start (? CheckImmediateMacro)) #f])
(Prim
(#:args e1 e2 rs)

4
collects/macro-debugger/stxclass/private/kws.ss
View File

@ -88,9 +88,9 @@
;; A PatternParseResult is one of
;; - (listof value)
;; - (make-failed stx sexpr(Pattern) string)
;; - (make-failed stx sexpr(Pattern) string frontier/#f)
(define (ok? x) (or (pair? x) (null? x)))
(define-struct failed (stx patstx reason)
(define-struct failed (stx patstx reason frontier)
#:transparent)

4
collects/macro-debugger/stxclass/private/lib.ss
View File

@ -14,11 +14,11 @@
(define-syntax-rule (define-pred-stxclass name pred)
(define-basic-syntax-class name
([datum 0])
() ;; ([datum 0])
(lambda (x)
(let ([d (if (syntax? x) (syntax-e x) x)])
(if (pred d)
(list d)
null ;; (list d)
(fail-sc x #:pattern 'name))))))
(define-pred-stxclass identifier symbol?)

29
collects/macro-debugger/stxclass/private/parse.ss
View File

@ -23,10 +23,12 @@
;; - 'fail' stxparameterized to (non-escaping!) failure procedure
(define-struct pk (ps k) #:transparent)
;; A FrontierContext (FC) is ({FrontierIndex stx}*)
;; A FrontierContext (FC) is one of
;; - (list FrontierIndex Syntax)
;; - (list* FrontierIndex Syntax FrontierContext)
;; A FrontierIndex is one of
;; - nat
;; - `(+ ,nat expr ...)
;; - `(+ ,nat Syntax ...)
(define (empty-frontier x)
(list 0 x))
@ -59,7 +61,7 @@
(with-syntax ([(arg ...) args])
#`(lambda (x arg ...)
(define (fail-rhs x expected reason frontier)
(make-failed x expected reason))
(make-failed x expected reason frontier))
#,(parse:pks (list #'x)
(list (empty-frontier #'x))
(rhs->pks rhs relsattrs #'x)
@ -72,7 +74,7 @@
(with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fc)])
#`(let ([failcontext fc-expr])
#;(printf "failing at ~s\n" failcontext)
(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext)
(k x p 'reason failcontext))))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
@ -309,7 +311,7 @@
[sub-parse-expr
#`(#,(ssc-parser-name ssc) #,(car vars) #,@args)])
#'sub-parse-expr)))]
[(struct pk ((cons (struct pat:gseq (orig-stx attrs depth heads tail))
[(struct pk ((cons (and the-pattern (struct pat:gseq (orig-stx attrs depth heads tail)))
rest-ps)
k))
(let* ([xvar (car (generate-temporaries (list #'x)))]
@ -360,11 +362,6 @@
(if maxrep
#`(< #,repvar #,maxrep)
#`#t))]
[(minrepclause ...)
(for/list ([repvar reps] [minrep mins] #:when minrep)
#`[(< #,repvar #,minrep)
#,(fail #'enclosing-fail (car vars)
#:reason "minimum repetition constraint failed")])]
[(occurs-binding ...)
(for/list ([head heads] [rep reps] #:when (head-occurs head))
#`[#,(head-occurs head) (positive? #,rep)])]
@ -376,10 +373,20 @@
(let ([rep (add1 rep)])
(parse-loop x #,@hid-args #,@reps enclosing-fail))
#,(fail #'enclosing-fail #'var0
#:fc (frontier:add-index (car fcs)
#'(calculate-index rep ...))
#:reason "maxiumum repetition constraint failed")))
...]]
[tail-rhs
#`(cond minrepclause ...
#`(cond #,@(for/list ([repvar reps] [minrep mins] #:when minrep)
#`[(< #,repvar #,minrep)
#,(fail #'enclosing-fail (car vars)
#:fc (frontier:add-index
(car fcs)
#'(calculate-index rep ...))
#:pattern (expectation-of-constants
#f '(mininum-rep-constraint-failed) '())
#:reason "minimum repetition constraint failed")])
[else
(let ([hid (finalize hid-arg)] ... ...
occurs-binding ...

101
collects/macro-debugger/stxclass/private/rep.ss
View File

@ -347,7 +347,7 @@
(make pat:datum stx null depth (syntax->datum #'datum))]
[(heads gdots . tail)
(gdots? #'gdots)
(let* ([heads (parse-heads #'heads decls (add1 depth))]
(let* ([heads (parse-heads #'heads decls depth)]
[tail (parse-pattern #'tail decls depth)]
[hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)]
[tattrs (pattern-attrs tail)])
@ -372,40 +372,6 @@
[(struct pattern (orig-stx iattrs depth))
(make head orig-stx iattrs depth (list p) #f #f #t #f #f)]))
(define (parse-heads stx decls depth)
(syntax-case stx ()
[({} . more)
(raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))]
[({p ...} . more)
(let* ([heads
(for/list ([p (syntax->list #'(p ...))])
(parse-pattern p decls depth))]
[heads-attrs
(append-attrs (map pattern-attrs heads) (stx-car stx))])
(parse-heads-k #'more
heads
heads-attrs
depth
(lambda (more min max as-list? occurs-pvar default)
(let ([occurs-attrs
(if occurs-pvar
(list (make-attr occurs-pvar depth null))
null)])
(cons (make head (stx-car stx)
(append-attrs (list occurs-attrs heads-attrs)
(stx-car stx))
depth
heads
min max as-list?
occurs-pvar
default)
(parse-heads more decls depth))))))]
[()
null]
[_
(raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
(if (pair? stx) (car stx) stx))]))
(define head-directive-table
(list (list '#:min check-nat/f)
(list '#:max check-nat/f)
@ -414,9 +380,24 @@
(list '#:opt)
(list '#:mand)))
(define (parse-heads-k stx heads heads-attrs heads-depth k)
(define-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table))
(reject-duplicate-chunks chunks)
(define (parse-heads stx decls enclosing-depth)
(syntax-case stx ()
[({} . more)
(raise-syntax-error 'pattern "empty head sequence not allowed" (stx-car stx))]
[({p ...} . more)
(let-values ([(chunks rest) (chunk-kw-seq/no-dups #'more head-directive-table)])
(reject-duplicate-chunks chunks) ;; FIXME: needed?
(cons (parse-head/chunks (stx-car stx) decls enclosing-depth chunks)
(parse-heads rest decls enclosing-depth)))]
[()
null]
[_
(raise-syntax-error 'pattern "expected sequence of patterns or sequence directive"
(cond [(pair? stx) (car stx)]
[(syntax? stx) stx]
[else #f]))]))
(define (parse-head/chunks pstx decls enclosing-depth chunks)
(let* ([min-row (assq '#:min chunks)]
[max-row (assq '#:max chunks)]
[occurs-row (assq '#:occurs chunks)]
@ -443,20 +424,42 @@
(unless opt-row
(raise-syntax-error #f
"default only allowed for optional patterns"
(cadr default-row)))
(unless (and (pair? head-attrs)
(null? (cdr head-attrs))
(= heads-depth (attr-depth (car head-attrs)))
(null? (attr-inner (car head-attrs))))
(cadr default-row))))
(parse-head/options pstx
decls
enclosing-depth
(cond [opt-row 0] [mand-row 1] [else min])
(cond [opt-row 1] [mand-row 1] [else max])
(not (or opt-row mand-row))
(and occurs-row (caddr occurs-row))
default-row)))
(define (parse-head/options pstx decls enclosing-depth
min max as-list? occurs-pvar default-row)
(let* ([depth (if as-list? (add1 enclosing-depth) enclosing-depth)]
[heads
(for/list ([p (syntax->list pstx)])
(parse-pattern p decls depth))]
[heads-attrs
(append-attrs (map pattern-attrs heads) pstx)])
(when default-row
(unless (and (= (length heads-attrs) 1)
(= enclosing-depth (attr-depth (car heads-attrs)))
(null? (attr-inner (car heads-attrs))))
(raise-syntax-error #f
"default only allowed for patterns with single simple pattern variable"
(cadr default-row))))
(k rest
(cond [opt-row 0] [mand-row 1] [else min])
(cond [opt-row 1] [mand-row 1] [else max])
(not (or opt-row mand-row))
(and occurs-row (caddr occurs-row))
(and default-row (caddr default-row)))))
(let ([occurs-attrs
(if occurs-pvar
(list (make-attr occurs-pvar depth null))
null)])
(make head pstx
(append-attrs (list occurs-attrs heads-attrs) pstx)
depth
heads
min max as-list?
occurs-pvar
(and default-row (caddr default-row))))))
;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr)
(define (append-attrs attrss stx)

4
collects/macro-debugger/stxclass/private/sc.ss
View File

@ -214,7 +214,7 @@
(frontier->syntax rest)]))
(define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f])
(make-failed stx pattern reason))
(make-failed stx pattern reason #f))
(define (syntax-class-fail stx #:reason [reason #f])
(make-failed stx #f reason))
(make-failed stx #f reason #f))

2
collects/macro-debugger/stxclass/private/util.ss
View File

@ -86,7 +86,7 @@
(raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
[(kw . more)
(keyword? (syntax-e #'kw))
(raise-syntax-error #f "unexpected keyword" #'kw ctx)]
(raise-syntax-error #f "unexpected keyword" ctx #'kw)]
[_
(values (reverse rchunks) stx)]))
(loop stx null))

2
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -196,7 +196,7 @@
)
display)))
(define/private (calculate-columns)
(define/public (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))

1
collects/macro-debugger/view/frame.ss
View File

@ -54,6 +54,7 @@
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send config set-columns (send (send widget get-view) calculate-columns))
(send widget update/preserve-view))
(define warning-panel

8
collects/macro-debugger/view/step-display.ss
View File

@ -107,13 +107,13 @@
(show-poststep step binders shift-table)]))
(define/public (add-syntax stx
#:binders binders
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites definites)
#:definites [definites null])
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites (or definites null)))
#:definites definites))
(define/public (add-final stx error
#:binders binders
@ -124,7 +124,7 @@
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites (or definites null)))
#:definites definites))
(when error
(add-error error)))

2
collects/macro-debugger/view/term-record.ss
View File

@ -274,7 +274,7 @@
;; display-initial-term : -> void
(define/public (display-initial-term)
(send displayer add-syntax (wderiv-e1 deriv) #f null))
(send displayer add-syntax (wderiv-e1 deriv)))
;; display-final-term : -> void
(define/public (display-final-term)

41
collects/mzlib/foreign.ss
View File

@ -468,24 +468,28 @@
;; optionally applying a wrapper function to modify the result primitive
;; (callouts) or the input procedure (callbacks).
(define* (_cprocedure itypes otype
#:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
(_cprocedure* itypes otype abi wrapper keep))
#:abi [abi #f]
#:wrapper [wrapper #f]
#:keep [keep #f]
#:atomic? [atomic? #f])
(_cprocedure* itypes otype abi wrapper keep atomic?))
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper keep)
(define (_cprocedure* itypes otype abi wrapper keep atomic?)
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer
(lambda (x)
(let ([cb (ffi-callback (wrap x) itypes otype abi)])
(cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
[(box? keep)
(let ([x (unbox keep)])
(set-box! keep
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)])
cb))
(lambda (x) (wrap (ffi-call x itypes otype abi)))))
(and x
(let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)])
(cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
[(box? keep)
(let ([x (unbox keep)])
(set-box! keep
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)])
cb)))
(lambda (x) (and x (wrap (ffi-call x itypes otype abi))))))
(if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type:
@ -513,6 +517,7 @@
(define xs #f)
(define abi #f)
(define keep #f)
(define atomic? #f)
(define inputs #f)
(define output #f)
(define bind '())
@ -577,9 +582,10 @@
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
...
[else (err "unknown keyword" (car xs))]))
(when (keyword? k) (kwds [#:abi abi] [#:keep keep]))))
(when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?]))))
(unless abi (set! abi #'#f))
(unless keep (set! keep #'#t))
(unless atomic? (set! atomic? #'#f))
;; parse known punctuation
(set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -670,9 +676,9 @@
(string->symbol (string-append "ffi-wrapper:" n)))
body))])
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi (lambda (ffi) #,body) #,keep))
#,abi (lambda (ffi) #,body) #,keep #,atomic?))
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,keep)))
#,abi #f #,keep #,atomic?)))
(syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
@ -689,9 +695,8 @@
;; String types
;; The internal _string type uses the native ucs-4 encoding, also providing a
;; utf-16 type (note: the non-/null variants do not use #f as NULL).
(provide _string/ucs-4 _string/utf-16
_string/ucs-4/null _string/utf-16/null)
;; utf-16 type
(provide _string/ucs-4 _string/utf-16)
;; 8-bit string encodings, #f is NULL
(define ((false-or-op op) x) (and x (op x)))

2
collects/mzlib/md5.ss
View File

@ -2,7 +2,7 @@
(provide md5)
;;; Copyright (c) 2005-2008, PLT Scheme Inc.
;;; Copyright (c) 2005-2009, PLT Scheme Inc.
;;; Copyright (c) 2002, Jens Axel Soegaard
;;;
;;; Permission to copy this software, in whole or in part, to use this

23
collects/mzlib/scribblings/trace.scrbl
View File

@ -56,3 +56,26 @@ end with a newline, but it may contain internal newlines. Each call or
result is converted into a string using @scheme[pretty-print]. The
parameter's default value prints the given string followed by a newline to
@scheme[(current-output-port)].}
@defproc[(trace-apply [id symbol?] [proc procedure?] [kws (listof keyword)] [kw-vals list?] [arg any/c] ...) any/c]{
Calls @scheme[proc] with the arguments supplied in
@scheme[args], @scheme[kws], and @scheme[kw-vals]. Also prints out the
trace information during the call, as described above in the docs for
@scheme[trace], using @scheme[id] as the name of @scheme[proc].
}
@defparam[current-trace-print-args trace-print-args
(-> symbol?
(listof keyword?)
list?
list?
number?)]{
The value of this parameter is invoked to print out the arguments of a
traced call. It receives the name of the function, the function's
ordinary arguments, its keywords, the values of the keywords, and a
number indicating the depth of the call.
}

58
collects/mzlib/trace.ss
View File

@ -4,19 +4,16 @@
(for-syntax scheme/base))
(provide trace untrace
current-trace-print-args trace-apply
current-trace-notify)
(define max-dash-space-depth 10)
(define number-nesting-depth 6)
(define as-spaces
(lambda (s)
(let ((n (string-length s)))
(apply string-append
(let loop ((k n))
(if (zero? k) '("")
(cons " " (loop (sub1 k)))))))))
(define (as-spaces s)
(build-string (string-length s)
(lambda (i) #\space)))
(define-struct prefix-entry (for-first for-rest))
(define prefixes (make-vector 20 #f))
@ -101,28 +98,29 @@
(lambda (name args kws kw-vals level)
(as-trace-notify
(lambda ()
(trace-print-args name args kws kw-vals level)))))
(define trace-print-args
(lambda (name args kws kw-vals level)
(let-values (((first rest)
(build-prefixes level)))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first
(format "~n~a" rest))
(format "~n"))
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(pretty-print (append (cons name args)
(apply append (map list kws kw-vals))))))))
((current-trace-print-args) name args kws kw-vals level)))))
(define current-trace-print-args
(make-parameter
(lambda (name args kws kw-vals level)
(let-values (((first rest)
(build-prefixes level)))
(parameterize ((pretty-print-print-line
(lambda (n port offset width)
(display
(if n
(if (zero? n) first
(format "~n~a" rest))
(format "~n"))
port)
(if n
(if (zero? n)
(string-length first)
(string-length rest))
0))))
(pretty-print (append (cons name args)
(apply append (map list kws kw-vals)))))))))
(define -:trace-print-results
(lambda (name results level)
(as-trace-notify
@ -197,6 +195,8 @@
;; the nesting depth:
(define -:trace-level-key (gensym))
(define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f))
;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls.

18
collects/r5rs/main.ss
View File

@ -151,6 +151,14 @@
;; --------------------------------------------------
(define (to-mutable v)
(cond
[(pair? v) (mcons (to-mutable (car v))
(to-mutable (cdr v)))]
[(vector? v) (list->vector
(map to-mutable (vector->list v)))]
[else v]))
(define-syntax (r5rs:quote stx)
(syntax-case stx ()
[(_ form)
@ -162,15 +170,7 @@
(ormap loop (syntax->list #'(a ...)))]
[_ #f]))
;; quote has to create mpairs:
(syntax-local-lift-expression (let loop ([form #'form])
(syntax-case form ()
[(a ...)
#`(mlist . #,(map loop (syntax->list #'(a ...))))]
[(a . b)
#`(mcons #,(loop #'a) #,(loop #'b))]
[#(a ...)
#`(vector . #,(map loop (syntax->list #'(a ...))))]
[other #'(quote other)])))
(syntax-local-lift-expression #'(to-mutable 'form))
;; no pairs to worry about:
#'(quote form))]))

3
collects/r6rs/private/prelims.ss
View File

@ -6,7 +6,8 @@
(provide
(rename-out [datum #%datum])
#%app #%top #%top-interaction)
(rename-out [#%plain-app #%app])
#%top #%top-interaction)
;; ----------------------------------------
;; Datum

5
collects/redex/HISTORY
View File

@ -1,3 +1,8 @@
- Added tracing to metafunctions (see current-traced-metafunctions)
- added caching-enabled? parameter (changed how set-cache-size!
works)
v4.2
- added white-bracket-sizing to control how the brackets

3120
collects/redex/private/matcher.ss
View File

File diff suppressed because it is too large Load Diff

138
collects/redex/private/reduction-semantics.ss
View File

@ -5,6 +5,7 @@
"term.ss"
"loc-wrapper.ss"
"error.ss"
mzlib/trace
(lib "list.ss")
(lib "etc.ss"))
@ -510,16 +511,13 @@
p)])))))
(define (do-leaf stx orig-name lang name-table from to extras lang-id)
(let ([lang-nts (language-id-nts lang-id orig-name)])
(let* ([lang-nts (language-id-nts lang-id orig-name)]
[rw-sc (λ (pat) (rewrite-side-conditions/check-errs lang-nts orig-name #t pat))])
(let-values ([(name fresh-vars side-conditions/withs) (process-extras stx orig-name name-table extras)])
(let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)])
(with-syntax ([side-conditions-rewritten
(rewrite-side-conditions/check-errs
lang-nts
orig-name
#t
from)]
[to to #;#`,(begin (printf "~s\n" #,name) (term #,to))]
(with-syntax ([side-conditions-rewritten (rw-sc from)]
[lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs side-conditions/withs #'#t)))]
[to to]
[name name]
[lang lang]
[(names ...) names]
@ -550,14 +548,15 @@
#`(do-leaf-match
name
`side-conditions-rewritten
`lhs-w/extras
(λ (main bindings)
;; nested term-let's so that the bindings for the variables
;; show up in the `fresh' side-conditions, the bindings for the variables
;; show up in the withs, and the withs show up in the 'fresh' side-conditions
(term-let ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let (fresh-var-clauses ...)
#,(bind-withs side-conditions/withs
#'(make-successful (term to))))))))))))
(term-let (fresh-var-clauses ...)
#,(bind-withs side-conditions/withs
#'(make-successful (term to))))))))))))
;; the withs and side-conditions come in backwards order
(define (bind-withs stx body)
@ -756,22 +755,40 @@
(rewrite-proc-name child-make-proc)
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
(define (do-leaf-match name pat proc)
(make-rewrite-proc
(λ (lang)
(let ([cp (compile-pattern lang pat #t)])
(λ (main-exp exp f other-matches)
(let ([mtchs (match-pattern cp exp)])
(if mtchs
(map/mt (λ (mtch)
(let ([really-matched (proc main-exp (mtch-bindings mtch))])
(and really-matched
(list name (f (successful-result really-matched))))))
mtchs
other-matches)
other-matches)))))
name
pat))
(define relation-coverage (make-parameter #f))
(define-struct covered-case (name apps) #:inspector (make-inspector))
(define (apply-case c)
(struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
(define (cover-case id name relation-coverage)
(hash-update! relation-coverage id apply-case (make-covered-case name 0)))
(define (covered-cases relation-coverage)
(hash-map relation-coverage (λ (k v) v)))
(define fresh-coverage make-hasheq)
(define (do-leaf-match name pat w/extras proc)
(let ([case-id (gensym)])
(make-rewrite-proc
(λ (lang)
(let ([cp (compile-pattern lang pat #t)])
(λ (main-exp exp f other-matches)
(let ([mtchs (match-pattern cp exp)])
(if mtchs
(map/mt (λ (mtch)
(let ([really-matched (proc main-exp (mtch-bindings mtch))])
(and really-matched
(when (relation-coverage)
(cover-case case-id name (relation-coverage)))
(list name (f (successful-result really-matched))))))
mtchs
other-matches)
other-matches)))))
name
w/extras)))
(define-syntax (test-match stx)
(syntax-case stx ()
@ -1047,25 +1064,35 @@
(define (check-clauses stx syn-error-name rest)
(syntax-case rest ()
[([(lhs ...) roc ...] ...)
[([(lhs ...) roc1 roc2 ...] ...)
rest]
[([(lhs ...) rhs ...] ...)
(begin
(for-each
(λ (clause)
(syntax-case clause ()
[(a b) (void)]
[x (raise-syntax-error syn-error-name "expected a pattern and a right-hand side" stx clause)]))
(syntax->list #'([(lhs ...) rhs ...] ...)))
(raise-syntax-error syn-error-name "error checking failed.3" stx))]
[([x roc ...] ...)
(for-each
(λ (x)
(syntax-case x ()
[(lhs ...) (void)]
[x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.1" stx)]
(begin
(for-each
(λ (x)
(syntax-case x ()
[(lhs ...) (void)]
[x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.1" stx))]
[(x ...)
(for-each
(λ (x)
(syntax-case x ()
[(stuff ...) (void)]
[x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx)]))
(begin
(for-each
(λ (x)
(syntax-case x ()
[(stuff ...) (void)]
[x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)]))
(syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx))]))
(define (extract-side-conditions name stx stuffs)
(let loop ([stuffs (syntax->list stuffs)]
@ -1110,7 +1137,7 @@
(λ (exp)
(let ([cache-ref (hash-ref cache exp not-in-cache)])
(cond
[(eq? cache-ref not-in-cache)
[(or (not (caching-enabled?)) (eq? cache-ref not-in-cache))
(when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp)
(redex-error name
@ -1138,14 +1165,23 @@
`(,name ,@exp)
(length mtchs))]
[else
(let ([ans (rhs metafunc (mtch-bindings (car mtchs)))])
(let ([ans (rhs traced-metafunc (mtch-bindings (car mtchs)))])
(unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
(hash-set! cache exp ans)
ans)])))]))]
[else
cache-ref])))])
metafunc)
cache-ref])))]
[ot (current-trace-print-args)]
[traced-metafunc (lambda (exp)
(if (or (eq? (current-traced-metafunctions) 'all)
(memq name (current-traced-metafunctions)))
(parameterize ([current-trace-print-args
(λ (name args kws kw-args level)
(ot name (car args) kws kw-args level))])
(trace-apply name metafunc '() '() exp))
(metafunc exp)))])
traced-metafunc)
compiled-patterns
rhss)
(if dom-compiled-pattern
@ -1153,6 +1189,8 @@
(λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns)
#t))))))
(define current-traced-metafunctions (make-parameter '()))
(define-syntax (metafunction-form stx)
(syntax-case stx ()
[(_ id)
@ -1762,6 +1800,7 @@
(rename-out [metafunction-form metafunction])
metafunction? metafunction-proc
in-domain?
current-traced-metafunctions
metafunc-proc-lang
metafunc-proc-pict-info
metafunc-proc-name
@ -1793,3 +1832,8 @@
apply-reduction-relation*
variable-not-in
variables-not-in)
(provide relation-coverage
covered-cases
fresh-coverage
(struct-out covered-case))

303
collects/redex/private/rg-test.ss
View File

@ -155,6 +155,12 @@
(define next-any-decision (decision any))
(define next-sequence-decision (decision seq)))))
(define-syntax generate-term/decisions
(syntax-rules ()
[(_ lang pat size attempt decisions)
(parameterize ([generation-decisions decisions])
(generate-term lang pat size #:attempt attempt))]))
(let ()
(define-language lc
(e (e e) x (λ (x) e))
@ -162,7 +168,7 @@
;; Generate (λ (x) x)
(test
(generate-term
(generate-term/decisions
lc e 1 0
(decisions #:var (list (λ _ 'x) (λ _'x))
#:nt (patterns third first first first)))
@ -170,14 +176,14 @@
;; Generate pattern that's not a non-terminal
(test
(generate-term
(generate-term/decisions
lc (x x x_1 x_1) 1 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'(x x y y))
; After choosing (e e), size decremented forces each e to x.
(test
(generate-term
(generate-term/decisions
lc e 1 0
(decisions #:nt (patterns first)
#:var (list (λ _ 'x) (λ _ 'y))))
@ -193,7 +199,9 @@
(let* ([x null]
[prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))])
(test (begin
(generate-term lang a 5 0 (decisions #:var (list (λ _ 'x) prepend! prepend!)))
(generate-term/decisions
lang a 5 0
(decisions #:var (list (λ _ 'x) prepend! prepend!)))
x)
'(x x))))
@ -204,7 +212,7 @@
(x (variable-except λ)))
(test
(exn:fail-message
(generate-term
(generate-term/decisions
postfix e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))
#:nt (patterns third second first first))))
@ -215,7 +223,7 @@
(define-language var
(e (variable-except x y)))
(test
(generate-term
(generate-term/decisions
var e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
'z))
@ -232,26 +240,28 @@
(n number)
(z 4))
(test
(generate-term
(generate-term/decisions
lang a 2 0
(decisions #:num (build-list 3 (λ (n) (λ (_) n)))
#:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1))))
`(0 1 2 "foo" "foo" "foo" "bar" #t))
(test (generate-term lang b 5 0 (decisions #:seq (list (λ (_) 0))))
(test (generate-term/decisions lang b 5 0 (decisions #:seq (list (λ (_) 0))))
null)
(test (generate-term lang c 5 0 (decisions #:seq (list (λ (_) 0))))
(test (generate-term/decisions lang c 5 0 (decisions #:seq (list (λ (_) 0))))
null)
(test (generate-term lang d 5 0 (decisions #:seq (list (λ (_) 2))))
(test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2))))
'(4 4 4 4 (4 4) (4 4)))
(test (exn:fail-message (generate-term lang e 5))
#rx"generate: unable to generate pattern e")
(test (generate-term lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4)
(λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3))))
(test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate-term/decisions
lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4)
(λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3))))
'((0 0 0) (0 0 0 0) (1 1 1)))
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5))))
(test (generate-term/decisions
lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5))))
'((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1))))
(let ()
@ -264,7 +274,7 @@
;; x and y bound in body
(test
(let/ec k
(generate-term
(generate-term/decisions
lc e 10 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
#:nt (patterns first first first third first)
@ -274,7 +284,7 @@
(let ()
(define-language lang (e (variable-prefix pf)))
(test
(generate-term
(generate-term/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x))))
'pfx))
@ -288,7 +298,7 @@
(define-language lang
(e number (e_1 e_2 e e_1 e_2)))
(test
(generate-term
(generate-term/decisions
lang e 5 0
(decisions #:nt (patterns second first first first)
#:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
@ -300,7 +310,7 @@
(x variable))
(test
(let/ec k
(generate-term
(generate-term/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x)))
@ -311,12 +321,12 @@
(b (c_!_1 c_!_1 c_!_1))
(c 1 2))
(test
(generate-term
(generate-term/decisions
lang a 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
(test
(generate-term
(generate-term/decisions
lang (number_!_1 number_!_2 number_!_1) 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2))
@ -330,7 +340,7 @@
(f foo bar))
(test
(let/ec k
(generate-term
(generate-term/decisions
lang e 5 0
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
(cons '(#\a #\b #\f #\o #\r)
@ -350,24 +360,26 @@
#rx"unable to generate")
(test ; binding works for with side-conditions failure/retry
(let/ec k
(generate-term
(generate-term/decisions
lang d 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
'(y))
(test ; mismatch patterns work with side-condition failure/retry
(generate-term
(generate-term/decisions
lang e 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
'(y x y))
(test ; generate compiles side-conditions in pattern
(generate-term lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
(generate-term/decisions
lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'y)
(test ; bindings within ellipses collected properly
(let/ec k
(generate-term lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
(generate-term/decisions
lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
'((0 1 2) (3 4 5 6))))
(let ()
@ -397,7 +409,7 @@
(y variable))
(test
(generate-term
(generate-term/decisions
lang (in-hole A number ) 5 0
(decisions
#:nt (patterns second second first first third first second first first)
@ -406,19 +418,22 @@
(test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5))
(test (generate-term lang (hole 4) 5) (term (hole 4)))
(test (generate-term lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
(test (generate-term/decisions
lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
'(x x))
(test (generate-term lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
(test (generate-term/decisions
lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
'(x y))
(test (let/ec k (generate-term lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
(test (let/ec k
(generate-term/decisions lang d 5 0 (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x))
(test (generate-term lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
(test (generate-term/decisions lang e 5 0 (decisions #:num (list (λ _ 1) (λ _ 2))))
'((2 (1 1)) 1))
(test (generate-term lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
(test (generate-term/decisions lang g 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 1) (λ _ 0))))
'(1 0))
(test (generate-term lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
(test (generate-term/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3))))
'((2 ((3 (2 1)) 3)) 1)))
(let ()
@ -426,7 +441,7 @@
(e (e e) (+ e e) x v)
(v (λ (x) e) number)
(x variable-not-otherwise-mentioned))
(test (generate-term lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
(test (generate-term/decisions lc x 5 0 (decisions #:var (list (λ _ 'λ) (λ _ '+) (λ _ 'x))))
'x))
(let ()
@ -436,19 +451,24 @@
(define-language empty)
;; `any' pattern
(test (call-with-values (λ () (pick-any four (make-random 0 1))) list)
(list four 'f))
(test (call-with-values (λ () (pick-any four (make-random 1))) list)
(list sexp 'sexp))
(test (generate-term four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4)
(test (generate-term four any 5 0
(decisions #:any (list (λ _ (values sexp 'sexp)))
#:nt (patterns fifth second second second)
#:seq (list (λ _ 3))
#:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz"))))
(let ([four (prepare-lang four)]
[sexp (prepare-lang sexp)])
(test (call-with-values (λ () (pick-any four sexp (make-random 0 1))) list)
(list four 'f))
(test (call-with-values (λ () (pick-any four sexp (make-random 1))) list)
(list sexp 'sexp)))
(test (generate-term/decisions
four any 5 0 (decisions #:any (list (λ (lang sexp) (values lang 'e))))) 4)
(test (generate-term/decisions
four any 5 0
(decisions #:any (list (λ (lang sexp) (values sexp 'sexp)))
#:nt (patterns fifth second second second)
#:seq (list (λ _ 3))
#:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz"))))
'("foo" "bar" "baz"))
(test (generate-term empty any 5 0 (decisions #:nt (patterns first)
#:var (list (λ _ 'x))))
(test (generate-term/decisions
empty any 5 0 (decisions #:nt (patterns first)
#:var (list (λ _ 'x))))
'x))
;; `hide-hole' pattern
@ -469,15 +489,16 @@
(e x (e e) v)
(v (λ (x) e))
(x variable-not-otherwise-mentioned))
(test (generate-term lang (cross e) 3 0
(decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y))))
(test (generate-term/decisions
lang (cross e) 3 0
(decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y)))))
;; current-error-port-output : (-> (-> any) string)
(define (current-error-port-output thunk)
;; current-output : (-> (-> any) string)
(define (current-output thunk)
(let ([p (open-output-string)])
(parameterize ([current-error-port p])
(parameterize ([current-output-port p])
(thunk))
(begin0
(get-output-string p)
@ -487,16 +508,78 @@
(let ()
(define-language lang
(d 5)
(e e 4))
(test (current-error-port-output (λ () (check lang d 2 #f)))
"failed after 1 attempts:\n5\n")
(e e 4)
(n number))
(test (current-output (λ () (check lang d #f)))
"counterexample found after 1 attempts:\n5\n")
(test (check lang d #t) #t)
(test (check lang (d e) 2 (and (eq? (term d) 5) (eq? (term e) 4))) #t)
(test (check lang (d ...) 2 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t)
(test (current-error-port-output (λ () (check lang (d e) 2 #f)))
"failed after 1 attempts:\n(5 4)\n")
(test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised))))
"failed after 1 attempts:\n5\n"))
(test (check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-output (λ () (check lang (d e) #f)))
"counterexample found after 1 attempts:\n(5 4)\n")
(test (current-output (λ () (check lang d (error 'pred-raised))))
"counterexample found after 1 attempts:\n5\n")
(test (parameterize ([check-randomness (make-random 0 0)])
(check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 42 x))))
#t)
(test (current-output
(λ ()
(parameterize ([check-randomness (make-random 0 0)])
(check lang n (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found (z) after 1 attempts:\n0\n")
(test (current-output
(λ ()
(parameterize ([check-randomness (make-random 1)])
(check lang d (eq? 42 (term n))
#:attempts 1
#:source (reduction-relation lang (--> 0 x z))))))
"counterexample found after 1 attempts:\n5\n")
(test (let ([r (reduction-relation lang (--> 0 x z))])
(check lang n (number? (term n))
#:attempts 10
#:source r))
#t)
(let ()
(define-metafunction lang
[(mf 0) 0]
[(mf 42) 0])
(test (parameterize ([check-randomness (make-random 0 1)])
(check lang (n) (eq? 42 (term n))
#:attempts 1
#:source mf))
#t))
(let ()
(define-language L)
(test (with-handlers ([exn:fail? exn-message])
(check lang any #t #:source (reduction-relation L (--> 1 1))))
#rx"language for secondary source"))
(let ()
(test (with-handlers ([exn:fail? exn-message])
(check lang n #t #:source (reduction-relation lang (--> x 1))))
#rx"x does not match n"))
(let ([stx-err (λ (stx)
(with-handlers ([exn:fail:syntax? exn-message])
(expand stx)
'no-syntax-error))])
(parameterize ([current-namespace (make-base-namespace)])
(eval '(require "../reduction-semantics.ss"
"rg.ss"))
(eval '(define-language empty))
(test (stx-err '(check empty any #t #:typo 3))
#rx"check: bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts 3 #:attempts 4))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:attempts 3 4))
#rx"bad keyword syntax")
(test (stx-err '(check empty any #t #:source #:attempts))
#rx"bad keyword syntax"))))
;; check-metafunction-contract
(let ()
@ -518,38 +601,48 @@
[(i any ...) (any ...)])
;; Dom(f) < Ctc(f)
(test (current-error-port-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5))))))
"failed after 1 attempts:\n(5)\n")
(test (current-output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 2) (λ _ 5)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(5)\n")
;; Rng(f) > Codom(f)
(test (current-error-port-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3))))))
"failed after 1 attempts:\n(3)\n")
(test (current-output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 3)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(3)\n")
;; LHS matches multiple ways
(test (current-error-port-output
(λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1))
#:seq (list (λ _ 2))))))
"failed after 1 attempts:\n(1 1)\n")
(test (current-output
(λ ()
(parameterize ([generation-decisions
(decisions #:num (list (λ _ 1) (λ _ 1))
#:seq (list (λ _ 2)))])
(check-metafunction-contract g))))
"counterexample found after 1 attempts:\n(1 1)\n")
;; OK -- generated from Dom(h)
(test (check-metafunction-contract h) #t)
;; OK -- generated from pattern (any ...)
(test (check-metafunction-contract i) #t))
(test (check-metafunction-contract i #:attempts 5) #t))
;; check-reduction-relation
(let ()
(define-language L
(e (+ e ...) number)
(E (+ number ... E* e ...))
(E* hole E*))
(define R
(reduction-relation
L
(==> (+ number ...) whatever)
(--> (side-condition number (even? (term number))) whatever)
with
[(--> (in-hole E a) whatever)
(==> a b)]))
(let ([generated null])
(E* hole E*)
(n 4))
(let ([generated null]
[R (reduction-relation
L
(==> (+ number ...) whatever)
(--> (side-condition number (even? (term number))) whatever)
with
[(--> (in-hole E a) whatever)
(==> a b)])])
(test (begin
(check-reduction-relation
R (λ (term) (set! generated (cons term generated)))
@ -558,14 +651,31 @@
#:attempts 1)
generated)
(reverse '((+ (+)) 0))))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
(test (current-error-port-output
(test (current-output
(λ () (check-reduction-relation S (λ (x) #f))))
"checking name failed after 1 attempts:\n1\n")
(test (current-error-port-output
"counterexample found after 1 attempts with name:\n1\n")
(test (current-output
(λ () (check-reduction-relation S (curry eq? 1))))
"checking unnamed failed after 1 attempts:\n3\n")))
"counterexample found after 1 attempts with unnamed:\n3\n"))
(let ([T (reduction-relation
L
(==> number number
(where num number)
(side-condition (eq? (term num) 4))
(where numb num)
(side-condition (eq? (term numb) 4)))
with
[(--> (9 a) b)
(==> a b)])])
(test (check-reduction-relation
T (curry equal? '(9 4))
#:attempts 1
#:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))
#t)))
; check-metafunction
(let ()
@ -575,11 +685,14 @@
[(m 2) whatever])
(let ([generated null])
(test (begin
(check-metafunction m (λ (t) (set! generated (cons t generated))) 1)
(check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)
generated)
(reverse '((1) (2)))))
(test (current-error-port-output (λ () (check-metafunction m (curry eq? 1))))
#rx"checking clause #1 failed after 1 attempt"))
(test (current-output (λ () (check-metafunction m (curry eq? 1))))
#rx"counterexample found after 1 attempts with clause #1")
(test (with-handlers ([exn:fail:contract? exn-message])
(check-metafunction m #t #:attempts 'NaN))
#rx"check-metafunction: expected"))
;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])

364
collects/redex/private/rg.ss
View File

@ -76,10 +76,12 @@ To do a better job of not generating programs with free variables,
(pick-from-list lang-lits random)
(list->string (build-list length (λ (_) (pick-char attempt lang-chars random))))))
(define (pick-any lang [random random])
(if (and (not (null? (compiled-lang-lang lang))) (zero? (random 5)))
(values lang (pick-from-list (map nt-name (compiled-lang-lang lang)) random))
(values sexp (nt-name (car (compiled-lang-lang sexp))))))
(define (pick-any lang sexp [random random])
(let ([c-lang (rg-lang-clang lang)]
[c-sexp (rg-lang-clang sexp)])
(if (and (not (null? (compiled-lang-lang c-lang))) (zero? (random 5)))
(values lang (pick-from-list (map nt-name (compiled-lang-lang c-lang)) random))
(values sexp (nt-name (car (compiled-lang-lang c-sexp)))))))
(define (pick-string lang-chars lang-lits attempt [random random])
(random-string lang-chars lang-lits (random-natural 1/5 random) attempt random))
@ -153,21 +155,24 @@ To do a better job of not generating programs with free variables,
(define (pick-sequence-length attempt)
(random-natural (expected-value->p (attempt->size attempt))))
(define (zip . lists)
(apply (curry map list) lists))
(define (min-prods nt base-table)
(let* ([sizes (hash-ref base-table (nt-name nt))]
[min-size (apply min/f sizes)]
[zip (λ (l m) (map cons l m))])
(map cdr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
[min-size (apply min/f sizes)])
(map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt))))))
(define-struct rg-lang (clang lits chars base-table))
(define (prepare-lang lang)
(let ([lits (map symbol->string (compiled-lang-literals lang))])
(make-rg-lang (parse-language lang) lits (unique-chars lits) (find-base-cases lang))))
(define (generate lang decisions@)
(define-values/invoke-unit decisions@
(import) (export decisions^))
(define lang-lits (map symbol->string (compiled-lang-literals lang)))
(define lang-chars (unique-chars lang-lits))
(define base-table (find-base-cases lang))
(define (generate-nt name fvt-id bound-vars size attempt in-hole state)
(define ((generate-nt lang generate base-table) name fvt-id bound-vars size attempt in-hole state)
(let*-values
([(bound-vars) (append (extract-bound-vars fvt-id state) bound-vars)]
[(term _)
@ -178,8 +183,9 @@ To do a better job of not generating programs with free variables,
(if (zero? size)
(min-prods (nt-by-name lang name) base-table)
((next-non-terminal-decision) name lang bound-vars attempt)))])
(((generate-pat bound-vars (max 0 (sub1 size)) attempt) (rhs-pattern rhs) in-hole)
(make-state (map fvt-entry (rhs-var-info rhs)) #hash()))))
(generate bound-vars (max 0 (sub1 size)) attempt
(make-state (map fvt-entry (rhs-var-info rhs)) #hash())
in-hole (rhs-pattern rhs))))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (extend-found-vars fvt-id term state))))
@ -202,8 +208,7 @@ To do a better job of not generating programs with free variables,
(if (null? envs)
(values null null fvt)
(let*-values
([(term state) ((generate (ellipsis-pattern ellipsis) the-hole)
(make-state fvt (car envs)))]
([(term state) (generate (make-state fvt (car envs)) the-hole (ellipsis-pattern ellipsis))]
[(terms envs fvt) (recur (state-fvt state) (cdr envs))])
(values (cons term terms) (cons (state-env state) envs) fvt))))])
(values seq (make-state fvt (merge-environments envs)))))
@ -241,6 +246,7 @@ To do a better job of not generating programs with free variables,
(hash-set! prior val #t)))))))
(define-struct state (fvt env))
(define new-state (make-state null #hash()))
(define (set-env state name value)
(make-state (state-fvt state) (hash-set (state-env state) name value)))
@ -255,9 +261,12 @@ To do a better job of not generating programs with free variables,
(define (fvt-entry binds)
(make-found-vars (binds-binds binds) (binds-source binds) '() #f))
(define (((generate-pat bound-vars size attempt) pat in-hole) state)
(define recur (generate-pat bound-vars size attempt))
(define (recur/pat pat) ((recur pat in-hole) state))
(define (generate-pat lang sexp bound-vars size attempt state in-hole pat)
(define recur (curry generate-pat lang sexp bound-vars size attempt))
(define recur/pat (recur state in-hole))
(define clang (rg-lang-clang lang))
(define gen-nt (generate-nt clang (curry generate-pat lang sexp) (rg-lang-base-table lang)))
(match pat
[`number (values ((next-number-decision) attempt) state)]
@ -265,17 +274,22 @@ To do a better job of not generating programs with free variables,
(generate/pred 'variable
(λ () (recur/pat 'variable))
(λ (var _) (not (memq var vars))))]
[`variable (values ((next-variable-decision) lang-chars lang-lits bound-vars attempt) state)]
[`variable
(values ((next-variable-decision)
(rg-lang-chars lang) (rg-lang-lits lang) bound-vars attempt)
state)]
[`variable-not-otherwise-mentioned
(generate/pred 'variable
(λ () (recur/pat 'variable))
(λ (var _) (not (memq var (compiled-lang-literals lang)))))]
(λ (var _) (not (memq var (compiled-lang-literals clang)))))]
[`(variable-prefix ,prefix)
(define (symbol-append prefix suffix)
(string->symbol (string-append (symbol->string prefix) (symbol->string suffix))))
(let-values ([(term state) (recur/pat 'variable)])
(values (symbol-append prefix term) state))]
[`string (values ((next-string-decision) lang-chars lang-lits attempt) state)]
[`string
(values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt)
state)]
[`(side-condition ,pat ,(? procedure? condition))
(generate/pred (unparse-pattern pat)
(λ () (recur/pat pat))
@ -286,38 +300,38 @@ To do a better job of not generating programs with free variables,
[`hole (values in-hole state)]
[`(in-hole ,context ,contractum)
(let-values ([(term state) (recur/pat contractum)])
((recur context term) state))]
[`(hide-hole ,pattern) ((recur pattern the-hole) state)]
(recur state term context))]
[`(hide-hole ,pattern) (recur state the-hole pattern)]
[`any
(let*-values ([(lang nt) ((next-any-decision) lang)]
[(term _) (((generate lang decisions@) nt) size attempt)])
(let*-values ([(lang nt) ((next-any-decision) lang sexp)]
[(term _) (generate-pat lang sexp null size attempt new-state the-hole nt)])
(values term state))]
[(? (is-nt? lang))
(generate-nt pat pat bound-vars size attempt in-hole state)]
[(struct binder ((and name (or (? (is-nt? lang) nt) (app (symbol-match named-nt-rx) (? (is-nt? lang) nt))))))
(generate/prior pat state (λ () (generate-nt nt name bound-vars size attempt in-hole state)))]
[(? (is-nt? clang))
(gen-nt pat pat bound-vars size attempt in-hole state)]
[(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))))
(generate/prior pat state (λ () (gen-nt nt name bound-vars size attempt in-hole state)))]
[(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b)))))
(generate/prior pat state (λ () (recur/pat b)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? lang) nt)))))
(let-values ([(term state) (generate-nt nt pat bound-vars size attempt in-hole state)])
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt)))))
(let-values ([(term state) (gen-nt nt pat bound-vars size attempt in-hole state)])
(values term (set-env state pat term)))]
[(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b)))))
(let-values ([(term state) (recur/pat b)])
(values term (set-env state pat term)))]
[`(cross ,(? symbol? cross-nt))
(generate-nt cross-nt #f bound-vars size attempt in-hole state)]
(gen-nt cross-nt #f bound-vars size attempt in-hole state)]
[(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)]
[(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest)
(let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)])
(if prior prior ((next-sequence-decision) attempt)))]
[(seq state) (generate-sequence ellipsis recur state length)]
[(rest state) ((recur rest in-hole)
(set-env (set-env state class length) name length))])
[(rest state) (recur (set-env (set-env state class length) name length)
in-hole rest)])
(values (append seq rest) state))]
[(list-rest pat rest)
(let*-values
([(pat-term state) (recur/pat pat)]
[(rest-term state) ((recur rest in-hole) state)])
[(rest-term state) (recur state in-hole rest)])
(values (cons pat-term rest-term) state))]
[else
(error 'generate "unknown pattern ~s\n" pat)]))
@ -356,17 +370,19 @@ To do a better job of not generating programs with free variables,
(state-fvt state))
(state-env state)))
(λ (pat)
(let ([unparsed (unparse-pattern pat)])
(λ (size attempt)
(let-values ([(term state)
(generate/pred
unparsed
(λ ()
(((generate-pat null size attempt) pat the-hole)
(make-state null #hash())))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state))))))))
(let ([rg-lang (prepare-lang lang)]
[rg-sexp (prepare-lang sexp)])
(λ (pat)
(let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))])
(λ (size attempt)
(let-values ([(term state)
(generate/pred
pat
(λ ()
(generate-pat rg-lang rg-sexp null size attempt
new-state the-hole parsed))
(λ (_ env) (mismatches-satisfied? env)))])
(values term (bindings (state-env state)))))))))
;; find-base-cases : compiled-language -> hash-table
(define (find-base-cases lang)
@ -604,133 +620,198 @@ To do a better job of not generating programs with free variables,
[_ pat]))))
;; used in generating the `any' pattern
(define sexp
(let ()
(define-language sexp (sexp variable string number hole (sexp ...)))
(parse-language sexp)))
(define-language sexp (sexp variable string number hole (sexp ...)))
(define-for-syntax (metafunc name)
(let ([tf (syntax-local-value name (λ () #f))])
(and (term-fn? tf) (term-fn-get-id tf))))
(define-for-syntax (metafunc/err name stx)
(let ([m (metafunc name)])
(if m m (raise-syntax-error #f "not a metafunction" stx name))))
(define (assert-nat name x)
(unless (and (integer? x) (>= x 0))
(raise-type-error name "natural number" x)))
(define-for-syntax (term-generator lang pat decisions what)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts lang what)
what #t pat)]
[lang lang]
[decisions decisions])
(syntax ((generate lang (decisions lang)) `pattern))))
(define-syntax (generate-term stx)
(syntax-case stx ()
[(_ lang pat size #:attempt attempt)
(with-syntax ([generate (term-generator #'lang #'pat #'(generation-decisions) 'generate-term)])
(syntax/loc stx
(let-values ([(term _) (generate size attempt)])
term)))]
[(_ lang pat size)
(syntax/loc stx (generate-term lang pat size #:attempt 1))]))
(define check-randomness (make-parameter random))
(define-syntax (check stx)
(syntax-case stx ()
[(_ lang pat property)
(syntax/loc stx (check lang pat default-check-attempts property))]
[(_ lang pat attempts property)
[(_ lang pat property . kw-args)
(let-values ([(names names/ellipses)
(extract-names (language-id-nts #'lang 'generate) 'check #t #'pat)])
(extract-names (language-id-nts #'lang 'check) 'check #t #'pat)]
[(attempts-stx source-stx)
(let loop ([args (syntax kw-args)]
[attempts #f]
[source #f])
(syntax-case args ()
[() (values attempts source)]
[(#:attempts a . rest)
(not (or attempts (keyword? (syntax-e #'a))))
(loop #'rest #'a source)]
[(#:source s . rest)
(not (or source (keyword? (syntax-e #'s))))
(loop #'rest attempts #'s)]
[else (raise-syntax-error #f "bad keyword syntax" stx args)]))])
(with-syntax ([(name ...) names]
[(name/ellipses ...) names/ellipses])
(syntax/loc stx
(or (check-property
(term-generator lang pat random-decisions)
(λ (_ bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
[(name/ellipses ...) names/ellipses]
[attempts (or attempts-stx #'default-check-attempts)])
(quasisyntax/loc stx
(let ([att attempts])
(assert-nat 'check att)
(or (check-property
(cons (list #,(term-generator #'lang #'pat #'random-decisions 'check) #f)
(let ([lang-gen (generate lang (random-decisions lang))])
#,(if (not source-stx)
#'null
#`(let-values
([(pats srcs src-lang)
#,(cond [(and (identifier? source-stx) (metafunc source-stx))
=>
(λ (m) #`(values (metafunc-proc-lhs-pats #,m)
(metafunc-srcs #,m)
(metafunc-proc-lang #,m)))]
[else
#`(let ([r #,source-stx])
(unless (reduction-relation? r)
(raise-type-error 'check "reduction-relation" r))
(values
(map rewrite-proc-lhs (reduction-relation-make-procs r))
(reduction-relation-srcs r)
(reduction-relation-lang r)))])])
(unless (eq? src-lang lang)
(error 'check "language for secondary source must match primary pattern's language"))
(zip (map lang-gen pats) srcs)))))
#,(and source-stx #'(test-match lang pat))
(λ (generated) (error 'check "~s does not match ~s" generated 'pat))
(λ (_ bindings)
(term-let ([name/ellipses (lookup-binding bindings 'name)] ...)
property)))
attempts)
(void)))))]))
property))
att
(λ (term attempt source port)
(fprintf port "counterexample found~aafter ~a attempts:\n"
(if source (format " (~a) " source) " ") attempt)
(pretty-print term port))
(check-randomness))
(void))))))]))
(define (check-property generate property attempts [source #f])
(define (check-property gens-srcs match match-fail property attempts display [random random])
(let loop ([remaining attempts])
(if (zero? remaining)
#t
(let ([attempt (add1 (- attempts remaining))])
(let-values ([(term bindings)
(generate (attempt->size attempt) attempt)])
(if (property term bindings)
(let*-values ([(generator source)
(apply values
(if (and (not (null? (cdr gens-srcs))) (zero? (random 10)))
(pick-from-list (cdr gens-srcs) random)
(car gens-srcs)))]
[(term bindings)
(generator (attempt->size attempt) attempt)])
(if (andmap (λ (bindings)
(with-handlers ([exn:fail? (λ (_) #f)])
(property term bindings)))
(cond [(and match (match term))
=> (curry map (compose make-bindings match-bindings))]
[match (match-fail term)]
[else (list bindings)]))
(loop (sub1 remaining))
(begin
(when source
(fprintf (current-error-port) "checking ~a " source))
(fprintf (current-error-port) "failed after ~s attempts:\n" attempt)
(pretty-print term (current-error-port))
(display term attempt source (current-output-port))
#f)))))))
(define-syntax generate-term
(syntax-rules ()
[(_ lang pat size attempt decisions)
(let-values ([(term _) ((term-generator lang pat decisions) size attempt)])
term)]
[(_ lang pat size attempt)
(generate-term lang pat size attempt random-decisions)]
[(_ lang pat size)
(generate-term lang pat size 1)]))
(define-syntax (term-generator stx)
(syntax-case stx ()
[(_ lang pat decisions)
(with-syntax ([pattern
(rewrite-side-conditions/check-errs
(language-id-nts #'lang 'generate)
'generate #t #'pat)])
(syntax/loc stx
(let ([lang (parse-language lang)])
((generate lang (decisions lang))
(reassign-classes (parse-pattern `pattern lang 'top-level))))))]))
(define-for-syntax (metafunc name stx)
(let ([tf (syntax-local-value name (λ () #f))])
(if (term-fn? tf)
(term-fn-get-id tf)
(raise-syntax-error #f "not a metafunction" stx name))))
(define-syntax (check-metafunction-contract stx)
(syntax-case stx ()
[(_ name)
(syntax/loc stx (check-metafunction-contract name random-decisions))]
[(_ name decisions)
[(_ name)
(syntax/loc stx
(check-metafunction-contract name #:attempts default-check-attempts))]
[(_ name #:attempts attempts)
(identifier? #'name)
(with-syntax ([m (metafunc #'name stx)])
(with-syntax ([m (metafunc/err #'name stx)])
(syntax/loc stx
(let ([lang (parse-language (metafunc-proc-lang m))]
[dom (metafunc-proc-dom-pat m)])
(let ([lang (metafunc-proc-lang m)]
[dom (metafunc-proc-dom-pat m)]
[decisions (generation-decisions)]
[att attempts])
(assert-nat 'check-metafunction-contract att)
(check-property
((generate lang (decisions lang))
(reassign-classes (parse-pattern (if dom dom '(any (... ...))) lang 'top-level)))
(λ (t _)
(with-handlers ([exn:fail:redex? (λ (_) #f)])
(begin (term (name ,@t)) #t)))
default-check-attempts))))]))
(list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f))
#f
#f
(λ (t _) (begin (term (name ,@t)) #t))
att
(λ (term attempt _ port)
(fprintf port "counterexample found after ~a attempts:\n" attempt)
(pretty-print term port))))))]))
(define (check-property-many lang patterns ids prop decisions attempts)
(let* ([lang-gen (generate lang (decisions lang))]
[pat-gens (map (λ (pat) (lang-gen (reassign-classes (parse-pattern pat lang 'top-level))))
patterns)])
(for/and ([pat patterns]
[id ids])
(define (check-property-many lang pats srcs prop decisions attempts)
(let ([lang-gen (generate lang (decisions lang))])
(for/and ([pat pats] [src srcs])
(check-property
(let ([gen (lang-gen (reassign-classes (parse-pattern pat lang 'top-level)))])
(λ (size attempt) (gen size attempt)))
(let ([gen (lang-gen pat)])
(list (list (λ (size attempt) (gen size attempt)) src)))
#f
#f
(λ (term _) (prop term))
attempts
id))))
(λ (term attempt source port)
(fprintf port "counterexample found after ~a attempts with ~a:\n"
attempt source)
(pretty-print term port))))))
(define (metafunc-srcs m)
(build-list (length (metafunc-proc-lhs-pats m))
(compose (curry format "clause #~s") add1)))
(define-syntax (check-metafunction stx)
(syntax-case stx ()
[(_ name property)
(syntax/loc stx (check-metafunction name property default-check-attempts))]
[(_ name property attempts)
(syntax/loc stx (check-metafunction name property random-decisions attempts))]
[(_ name property decisions attempts)
(with-syntax ([m (metafunc #'name stx)])
(syntax/loc stx (check-metafunction name property #:attempts default-check-attempts))]
[(_ name property #:attempts attempts)
(with-syntax ([m (metafunc/err #'name stx)])
(syntax/loc stx
(or (check-property-many
(parse-language (metafunc-proc-lang m))
(metafunc-proc-lhs-pats m)
(build-list (length (metafunc-proc-lhs-pats m))
(compose (curry format "clause #~s") add1))
property
decisions
attempts)
(void))))]))
(let ([att attempts])
(assert-nat 'check-metafunction att)
(or (check-property-many
(metafunc-proc-lang m)
(metafunc-proc-lhs-pats m)
(metafunc-srcs m)
property
(generation-decisions)
att)
(void)))))]))
(define (reduction-relation-srcs r)
(map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
(reduction-relation-make-procs r)))
(define (check-reduction-relation
relation property
#:decisions [decisions random-decisions]
#:attempts [attempts default-check-attempts])
(or (check-property-many
(parse-language (reduction-relation-lang relation))
(reduction-relation-lang relation)
(map rewrite-proc-lhs (reduction-relation-make-procs relation))
(map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
(reduction-relation-make-procs relation))
(reduction-relation-srcs relation)
property
decisions
attempts)
@ -758,14 +839,17 @@ To do a better job of not generating programs with free variables,
(define (next-any-decision) pick-any)
(define (next-string-decision) pick-string)))
(define generation-decisions (make-parameter random-decisions))
(provide pick-from-list pick-var min-prods decisions^ pick-sequence-length
is-nt? pick-char random-string pick-string check nt-by-name
pick-nt unique-chars pick-any sexp generate-term parse-pattern
class-reassignments reassign-classes unparse-pattern
(struct-out ellipsis) (struct-out mismatch) (struct-out class)
(struct-out binder) check-metafunction-contract
(struct-out binder) check-metafunction-contract prepare-lang
pick-number parse-language check-reduction-relation
preferred-production-threshold check-metafunction)
preferred-production-threshold check-metafunction check-randomness
generation-decisions)
(provide/contract
[find-base-cases (-> compiled-lang? hash?)])

99
collects/redex/private/tl-test.ss
View File

@ -1,5 +1,8 @@
(module tl-test mzscheme
(require "../reduction-semantics.ss"
(only "reduction-semantics.ss"
relation-coverage fresh-coverage covered-cases
make-covered-case covered-case-name)
"test-util.ss"
(only "matcher.ss" make-bindings make-bind)
scheme/match
@ -192,6 +195,45 @@
#t))
;; test caching
(let ()
(define match? #t)
(define-language lang
(x (side-condition any match?)))
(test (pair? (redex-match lang x 1)) #t)
(set! match? #f)
(test (pair? (redex-match lang x 1)) #t)
(parameterize ([caching-enabled? #f])
(test (pair? (redex-match lang x 1)) #f)))
(let ()
(define sc-eval-count 0)
(define-language lang
(x (side-condition any (begin (set! sc-eval-count (+ sc-eval-count 1))
#t))))
(redex-match lang x 1)
(redex-match lang x 1)
(parameterize ([caching-enabled? #f])
(redex-match lang x 1))
(test sc-eval-count 2))
(let ()
(define rhs-eval-count 0)
(define-metafunction empty-language
[(f any) ,(begin (set! rhs-eval-count (+ rhs-eval-count 1))
1)])
(term (f 1))
(term (f 1))
(parameterize ([caching-enabled? #f])
(term (f 1)))
(test rhs-eval-count 2))
;
;
; ;;; ;
@ -465,6 +507,29 @@
'no-exn)
'no-exn))
;; test that tracing works properly
;; note that caching comes into play here (which is why we don't see the recursive calls)
(let ()
(define-metafunction empty-language
[(f 0) 0]
[(f number) (f ,(- (term number) 1))])
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp])
(term (f 1)))
(test (get-output-string sp) ""))
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp]
[current-traced-metafunctions 'all])
(term (f 1)))
(test (get-output-string sp) "|(f 1)\n|0\n"))
(let ([sp (open-output-string)])
(parameterize ([current-output-port sp]
[current-traced-metafunctions '(f)])
(term (f 1)))
(test (get-output-string sp) "|(f 1)\n|0\n")))
;
@ -1156,7 +1221,37 @@
[else #f]))
; test shortcut in terms of shortcut
(test (rewrite-proc-lhs (third (reduction-relation-make-procs r)))
'((5 2) 1)))
(test (match (rewrite-proc-lhs (third (reduction-relation-make-procs r)))
[`(((side-condition 5 ,(? procedure?)) 2) 1) #t]
[else #f])
#t))
(let ([R (reduction-relation
empty-language
(--> number (q ,(add1 (term number)))
(side-condition (odd? (term number)))
side-condition)
(--> 1 4
one)
(==> 2 t
shortcut)
with
[(--> (q a) b)
(==> a b)])]
[c (fresh-coverage)])
(parameterize ([relation-coverage c])
(apply-reduction-relation R 4)
(test (covered-cases c) null)
(apply-reduction-relation R 3)
(test (covered-cases c)
(list (make-covered-case "side-condition" 1)))
(apply-reduction-relation* R 1)
(test (sort (covered-cases c)
(λ (c d) (string<? (covered-case-name c) (covered-case-name d))))
(list (make-covered-case "one" 1)
(make-covered-case "shortcut" 1)
(make-covered-case "side-condition" 2)))))
(print-tests-passed 'tl-test.ss))

29
collects/redex/private/traces.ss
View File

@ -149,10 +149,12 @@
;; only changed on the reduction thread
;; frontier : (listof (is-a?/c graph-editor-snip%))
(define frontier
(map (lambda (expr) (build-snip snip-cache #f expr pred pp
(dark-pen-color) (light-pen-color)
(dark-text-color) (light-text-color) #f))
exprs))
(filter
(λ (x) x)
(map (lambda (expr) (build-snip snip-cache #f expr pred pp
(dark-pen-color) (light-pen-color)
(dark-text-color) (light-text-color) #f))
exprs)))
;; set-font-size : number -> void
;; =eventspace main thread=
@ -516,16 +518,15 @@
(define (build-snip cache parent-snip expr pred pp light-arrow-color dark-arrow-color dark-label-color light-label-color name)
(let-values ([(snip new?)
(let/ec k
(k
(hash-ref
cache
expr
(lambda ()
(let ([new-snip (make-snip parent-snip expr pred pp)])
(hash-set! cache expr new-snip)
(k new-snip #t))))
#f))])
(values (hash-ref
cache
expr
(lambda ()
(let ([new-snip (make-snip parent-snip expr pred pp)])
(hash-set! cache expr new-snip)
(k new-snip #t))))
#f))])
(when parent-snip
(send snip record-edge-label parent-snip name)
(add-links/text-colors parent-snip snip

49
collects/redex/redex.scrbl
View File

@ -79,8 +79,12 @@ All of the exports in this section are provided both by
all non-GUI portions of Redex) and also exported by
@schememodname[redex] (which includes all of Redex).
This section covers Redex's @deftech{pattern} language, used
in various ways:
This section covers Redex's @deftech{pattern} language, used in many
of Redex's forms.
Note that pattern matching is caching (including caching the results
of side-conditions). This means that once a pattern has matched a
given term, Redex assumes that it will always match that term.
@(schemegrammar* #:literals (any number string variable variable-except variable-prefix variable-not-otherwise-mentioned hole name in-hole side-condition cross)
[pattern any
@ -324,16 +328,28 @@ clause is followed by an ellipsis. Nested ellipses produce
nested lists.
}
@defproc[(set-cache-size! [size (or/c false/c positive-integer?)]) void?]{
@defproc[(set-cache-size! [size positive-integer?]) void?]{
Changes the cache size; a #f disables the cache
entirely. The default size is 350.
Changes the cache size; the default size is @scheme[350].
The cache is per-pattern (ie, each pattern has a cache of
size at most 350 (by default)) and is a simple table that
maps expressions to how they matched the pattern. When the
cache gets full, it is thrown away and a new cache is
started.
The cache is per-pattern (ie, each pattern has a cache of size at most
350 (by default)) and is a simple table that maps expressions to how
they matched the pattern (ie, the bindings for the pattern
variables). When the cache gets full, it is thrown away and a new
cache is started.
}
@defparam[caching-enabled? on? boolean?]{
This is a parameter that controls whether or not a cache
is consulted (and updated) while matching and while evaluating
metafunctions.
If it is @scheme[#t], then side-conditions and the right-hand sides
of metafunctions are assumed to only depend on the values of the
pattern variables in scope (and thus not on any other external
state).
Defaults to @scheme[#t].
}
@section{Terms}
@ -855,7 +871,8 @@ no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated.
Note that metafunctions are assumed to always return the same results
for the same inputs, and their results are cached. Accordingly, if a
for the same inputs, and their results are cached, unless
@scheme[caching-enable?] is set to @scheme[#f]. Accordingly, if a
metafunction is called with the same inputs twice, then its body is
only evaluated a single time.
@ -927,6 +944,16 @@ legtimate inputs according to @scheme[metafunction-name]'s contract,
and @scheme[#f] otherwise.
}
@defparam[current-traced-metafunctions traced-metafunctions (or/c 'all (listof symbol?))]{
Controls which metafunctions are currently being traced. If it is
@scheme['all], all of them are. Otherwise, the elements of the list
name the metafunctions to trace.
Defaults to @scheme['()].
}
@section{Testing}
All of the exports in this section are provided both by

4
collects/redex/reduction-semantics.ss
View File

@ -29,7 +29,8 @@
define-metafunction
define-metafunction/extension
metafunction
in-domain?)
in-domain?
caching-enabled?)
(provide (rename-out [test-match redex-match])
term-match
@ -43,6 +44,7 @@
test-results)
(provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
[reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
[language-nts (-> compiled-lang? (listof symbol?))]
[set-cache-size! (-> number? void?)]

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "2jan2009")
#lang scheme/base (provide stamp) (define stamp "8jan2009")

32
collects/scheme/help.ss
View File

@ -33,31 +33,34 @@
(raise-syntax-error
#f
(string-append "expects a single identifer, a #:from clause, or a"
" #:search clause; try just `help' for more information")
" #:search clause; try `(help help)' for more information")
stx)])))
(define (open-help-start)
(find-help #'help))
(go-to-main-page))
;; Autoload utilities from help/help-utils; if it does not exists,
;; suggest using docs.plt-scheme.org.
(define-namespace-anchor anchor)
(define get-binding
(let ([ns #f] [utils #f])
(let ([ns #f])
(lambda (sym)
(unless ns
(set! ns (namespace-anchor->empty-namespace anchor))
(set! utils (resolved-module-path-name
(module-path-index-resolve
(module-path-index-join 'help/help-utils #f)))))
(parameterize ([current-namespace ns])
(if (file-exists? utils)
(dynamic-require utils sym)
(lambda _
(error 'help "documentation system unavailable; ~a\n~a"
"try http://docs.plt-scheme.org/"
(format " (missing file: ~a)" utils))))))))
(set! ns (namespace-anchor->empty-namespace anchor)))
(with-handlers ([exn:fail?
(lambda (exn)
((error-display-handler)
(if (exn? exn)
(exn-message exn)
(format "~s" exn))
exn)
(raise-user-error
'help
(string-append
"documentation system unavailable; "
"try http://docs.plt-scheme.org/")))])
(dynamic-require 'help/help-utils sym)))))
(define-syntax-rule (define-help-autoload id)
(define id
@ -67,3 +70,4 @@
(define-help-autoload find-help)
(define-help-autoload find-help/lib)
(define-help-autoload search-for)
(define-help-autoload go-to-main-page)

107
collects/scheme/private/contract-arrow.ss
View File

@ -916,19 +916,6 @@ v4 todo:
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str)
(loop (cdr args)
(cdr non-kwd-ctcs)))])))))]
[check-and-mark
(λ (marks)
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(if marks
(with-continuation-mark ->d-tail-key (cons this->d-id marks)
(thunk))
(thunk)))]
[rng (let ([rng (->d-range ->d-stct)])
(cond
[(not rng) #f]
@ -937,50 +924,62 @@ v4 todo:
(unbox rng))]
[else rng]))]
[rng-underscore? (box? (->d-range ->d-stct))])
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation")))
(call-with-immediate-continuation-mark
->d-tail-key
(λ (first-mark)
(if (and rng
(not (and first-mark
(member this->d-id first-mark))))
(call-with-values
(λ () (check-and-mark (or first-mark '())))
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))
(check-and-mark #f))))))])
(cond
[(and rng
(not (and first-mark
(eq? this->d-id (car first-mark))
(andmap eq? raw-orig-args (cdr first-mark)))))
(call-with-values
(λ ()
(with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
(thunk)))
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation")))
(unless (= range-count (length orig-results))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str)
(loop (cdr results) (cdr result-contracts)))]))))))]
[else
(thunk)])))))])
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args

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

@ -1149,13 +1149,15 @@ improve method arity mismatch contract violation error messages?
(if candidate-proc
(candidate-proc val)
(raise-contract-error val src-info pos-blame orig-str
"none of the branches of the or/c matched"))]
"none of the branches of the or/c matched, given ~e"
val))]
[((car checks) val)
(if candidate-proc
(error 'or/c "two arguments, ~s and ~s, might both match ~s"
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(raise-contract-error val src-info pos-blame orig-str
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr procs)
(cdr contracts)

14
collects/scribble/base-render.ss
View File

@ -443,7 +443,8 @@
(part-collected-info part ri))))
#t
quiet
depth)))
depth
null)))
(define/public (table-of-contents part ri)
(do-table-of-contents part ri -1 not +inf.0))
@ -456,14 +457,17 @@
(define/public (quiet-table-of-contents part ri)
(do-table-of-contents part ri 1 (lambda (x) #t) +inf.0))
(define/private (generate-toc part ri base-len skip? quiet depth)
(define/private (generate-toc part ri base-len skip? quiet depth prefixes)
(let* ([number (collected-info-number (part-collected-info part ri))]
[prefixes (if (part-tag-prefix part)
(cons (part-tag-prefix part) prefixes)
prefixes)]
[subs
(if (and (quiet (and (part-style? part 'quiet)
(not (= base-len (sub1 (length number))))))
(positive? depth))
(apply append (map (lambda (p)
(generate-toc p ri base-len #f quiet (sub1 depth)))
(generate-toc p ri base-len #f quiet (sub1 depth) prefixes))
(part-parts part)))
null)])
(if skip?
@ -485,7 +489,9 @@
number
(list (make-element 'hspace '(" "))))
(or (part-title-content part) '("???")))
(car (part-tags part))))))))
(for/fold ([t (car (part-tags part))])
([prefix (in-list prefixes)])
(convert-key prefix t))))))))
subs)])
(if (and (= 1 (length number))
(or (not (car number)) ((car number) . > . 1)))

11
collects/scribble/latex-render.ss
View File

@ -4,6 +4,7 @@
mzlib/class
scheme/runtime-path
scheme/port
scheme/path
scheme/string
setup/main-collects)
(provide render-mixin)
@ -18,6 +19,11 @@
(define-runtime-path scribble-tex "scribble.tex")
(define (gif-to-png p)
(if (equal? (filename-extension p) #"gif")
(path-replace-suffix p #".png")
p))
(define (render-mixin %)
(class %
(init-field [style-file #f]
@ -193,8 +199,9 @@
(if (disable-images)
(void)
(let ([fn (install-file
(main-collects-relative->path
(image-file-path style)))])
(gif-to-png
(main-collects-relative->path
(image-file-path style))))])
(printf "\\includegraphics[scale=~a]{~a}"
(image-file-scale style) fn)))]
[else (super render-element e part ri)])))

135
collects/scribble/private/manual-form.ss
View File

@ -32,6 +32,7 @@
(syntax-case stx ()
[(_ #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ([contract-nonterm contract-expr] ...)
desc ...)
(with-syntax ([new-spec
(let loop ([spec #'spec])
@ -65,57 +66,83 @@
(lambda () (schemeblock0/form non-term-form))
...)
...)
(list (list (lambda () (scheme contract-nonterm))
(lambda () (schemeblock0 contract-expr)))
...)
(lambda () (list desc ...)))))]
[(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(syntax/loc stx
(fm #:id defined-id #:literals (lit ...) [spec spec1 ...]
([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...))]
[(fm #:id id [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...)
#'(fm #:id id #:literals () [spec spec1 ...]
(syntax/loc stx
(fm #:id id #:literals () [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)]
#:contracts ()
desc ...))]
[(fm #:literals lits [(spec-id . spec-rest) spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...)
(with-syntax ([(_ _ _ [spec . _] . _) stx])
#'(fm #:id spec-id #:literals lits [spec spec1 ...]
(syntax/loc stx
(fm #:id spec-id #:literals lits [spec spec1 ...]
([non-term-id non-term-form ...] ...)
desc ...))]
desc ...)))]
[(fm [spec spec1 ...] ([non-term-id non-term-form ...] ...) desc ...)
#'(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...)]))
(syntax/loc stx
(fm #:literals () [spec spec1 ...] ([non-term-id non-term-form ...] ...)
desc ...))]))
(define-syntax (defform* stx)
(syntax-case stx ()
[(_ #:id id #:literals lits [spec ...] desc ...)
#'(defform*/subs #:id id #:literals lits [spec ...] () desc ...)]
(syntax/loc stx
(defform*/subs #:id id #:literals lits [spec ...] () desc ...))]
[(_ #:literals lits [spec ...] desc ...)
#'(defform*/subs #:literals lits [spec ...] () desc ...)]
(syntax/loc stx
(defform*/subs #:literals lits [spec ...] () desc ...))]
[(_ [spec ...] desc ...)
#'(defform*/subs [spec ...] () desc ...)]))
(syntax/loc stx
(defform*/subs [spec ...] () desc ...))]))
(define-syntax (defform stx)
(syntax-case stx ()
[(_ #:id id #:literals (lit ...) spec desc ...)
#'(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...)]
(syntax/loc stx
(defform*/subs #:id id #:literals (lit ...) [spec] () desc ...))]
[(_ #:id id spec desc ...)
#'(defform*/subs #:id id #:literals () [spec] () desc ...)]
(syntax/loc stx
(defform*/subs #:id id #:literals () [spec] () desc ...))]
[(_ #:literals (lit ...) spec desc ...)
#'(defform*/subs #:literals (lit ...) [spec] () desc ...)]
(syntax/loc stx
(defform*/subs #:literals (lit ...) [spec] () desc ...))]
[(_ spec desc ...)
#'(defform*/subs [spec] () desc ...)]))
(syntax/loc stx
(defform*/subs [spec] () desc ...))]))
(define-syntax (defform/subs stx)
(syntax-case stx ()
[(_ #:id id #:literals lits spec subs desc ...)
#'(defform*/subs #:id id #:literals lits [spec] subs desc ...)]
(syntax/loc stx
(defform*/subs #:id id #:literals lits [spec] subs desc ...))]
[(_ #:id id spec subs desc ...)
#'(defform*/subs #:id id #:literals () [spec] subs desc ...)]
(syntax/loc stx
(defform*/subs #:id id #:literals () [spec] subs desc ...))]
[(_ #:literals lits spec subs desc ...)
#'(defform*/subs #:literals lits [spec] subs desc ...)]
(syntax/loc stx
(defform*/subs #:literals lits [spec] subs desc ...))]
[(_ spec subs desc ...)
#'(defform*/subs [spec] subs desc ...)]))
(syntax/loc stx
(defform*/subs [spec] subs desc ...))]))
(define-syntax (defform/none stx)
(syntax-case stx ()
[(_ #:literals (lit ...) spec desc ...)
[(_ #:literals (lit ...) spec #:contracts ([contract-id contract-expr] ...) desc ...)
(begin
(for-each (lambda (id)
(unless (identifier? id)
@ -130,9 +157,16 @@
(*defforms #f
'(spec) (list (lambda (ignored) (schemeblock0/form spec)))
null null
(list (list (lambda () (scheme contract-id))
(lambda () (schemeblock0 contract-expr)))
...)
(lambda () (list desc ...)))))]
[(_ spec desc ...)
#'(defform/none #:literals () spec desc ...)]))
[(fm #:literals (lit ...) spec desc ...)
(syntax/loc stx
(fm #:literals (lit ...) spec #:contracts () desc ...))]
[(fm spec desc ...)
(syntax/loc stx
(fm #:literals () spec desc ...))]))
(define-syntax (defidform stx)
(syntax-case stx ()
@ -145,6 +179,7 @@
(list (lambda (x) (make-omitable-paragraph (list x))))
null
null
null
(lambda () (list desc ...))))]))
(define (into-blockquote s)
@ -164,6 +199,7 @@
(define-syntax spec?form/subs
(syntax-rules ()
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
#:contracts ([contract-nonterm contract-expr] ...)
desc ...)
(with-scheme-variables
(lit ...)
@ -175,7 +211,15 @@
(lambda () (schemeblock0/form non-term-form))
...)
...)
(lambda () (list desc ...))))]))
(list (list (lambda () (scheme contract-nonterm))
(lambda () (schemeblock0 contract-expr)))
...)
(lambda () (list desc ...))))]
[(_ has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
desc ...)
(spec?form/subs has-kw? #:literals (lit ...) spec ([non-term-id non-term-form ...] ...)
#:contracts ()
desc ...)]))
(define-syntax specsubform
(syntax-rules ()
@ -220,7 +264,7 @@
(with-scheme-variables
()
([form/maybe (#f spec)])
(*specsubform 'spec null #f null null (lambda () (list desc ...)))))
(*specsubform 'spec null #f null null null (lambda () (list desc ...)))))
(define-syntax schemegrammar
(syntax-rules ()
@ -258,7 +302,7 @@
(define (meta-symbol? s) (memq s '(... ...+ ?)))
(define (*defforms kw-id forms form-procs subs sub-procs content-thunk)
(define (*defforms kw-id forms form-procs subs sub-procs contract-procs content-thunk)
(parameterize ([current-meta-list '(... ...+)])
(make-box-splice
(cons
@ -307,10 +351,11 @@
sub-procs)])
(*schemerawgrammars "specgrammar"
(map car l)
(map cdr l))))))))))
(map cdr l))))))))
(make-contracts-table contract-procs)))
(content-thunk)))))
(define (*specsubform form lits form-thunk subs sub-procs content-thunk)
(define (*specsubform form lits form-thunk subs sub-procs contract-procs content-thunk)
(parameterize ([current-meta-list '(... ...+)])
(make-blockquote
"leftindent"
@ -324,16 +369,18 @@
(if form-thunk
(form-thunk)
(make-omitable-paragraph (list (to-element form)))))))
(if (null? sub-procs)
null
(list (list flow-empty-line)
(list (make-flow
(list (let ([l (map (lambda (sub)
(map (lambda (f) (f)) sub))
sub-procs)])
(*schemerawgrammars "specgrammar"
(map car l)
(map cdr l))))))))))
(append
(if (null? sub-procs)
null
(list (list flow-empty-line)
(list (make-flow
(list (let ([l (map (lambda (sub)
(map (lambda (f) (f)) sub))
sub-procs)])
(*schemerawgrammars "specgrammar"
(map car l)
(map cdr l))))))))
(make-contracts-table contract-procs))))
(flow-paragraphs (decode-flow (content-thunk)))))))
(define (*schemerawgrammars style nonterms clauseses)
@ -374,3 +421,21 @@
(define (*var-sym id)
(string->symbol (format "_~a" id)))
(define (make-contracts-table contract-procs)
(if (null? contract-procs)
null
(append
(list (list flow-empty-line))
(list (list (make-flow
(map (lambda (c)
(make-table
"argcontract"
(list
(list (to-flow (hspace 2))
(to-flow ((car c)))
flow-spacer
(to-flow ":")
flow-spacer
(make-flow (list ((cadr c))))))))
contract-procs)))))))

2
collects/scribblings/foreign/pointers.scrbl
View File

@ -7,7 +7,7 @@
Returns @scheme[#t] if @scheme[v] is a C pointer or a value that can
be used as a pointer: @scheme[#f] (used as a @cpp{NULL} pointer), byte
strings (used as memory blocks), some additional internal objects
strings (used as memory blocks), or some additional internal objects
(@scheme[ffi-obj]s and callbacks, see @secref["foreign:c-only"]).
Returns @scheme[#f] for other values.}

38
collects/scribblings/foreign/types.scrbl
View File

@ -165,27 +165,25 @@ pointer.
@deftogether[(
@defthing[_string/ucs-4 ctype?]
@defthing[_string/ucs-4/null ctype?]
)]{
A type for Scheme's native Unicode strings, which are in UCS-4 format.
These correspond to the C @cpp{mzchar*} type used by PLT Scheme. The
@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and
vice-versa.}
These correspond to the C @cpp{mzchar*} type used by PLT Scheme. As usual, the types
treat @scheme[#f] as @cpp{NULL} and vice-versa.}
@deftogether[(
@defthing[_string/utf-16 ctype?]
@defthing[_string/utf-16/null ctype?]
)]{
Unicode strings in UTF-16 format. The @schemeidfont{/null} variant
treats @scheme[#f] as @cpp{NULL} and vice-versa.}
Unicode strings in UTF-16 format. As usual, the types treat
@scheme[#f] as @cpp{NULL} and vice-versa.}
@defthing[_path ctype?]{
Simple @cpp{char*} strings, corresponding to Scheme's paths.}
Simple @cpp{char*} strings, corresponding to Scheme's paths. As usual,
the types treat @scheme[#f] as @cpp{NULL} and vice-versa.}
@defthing[_symbol ctype?]{
@ -282,9 +280,9 @@ PLT Scheme's C API.}
Similar to @scheme[_pointer], except that when an @scheme[_fpointer]
is extracted from a pointer produced by @scheme[ffi-obj-ref], then a
level of indirection is skipped. A level of indirection is similarly
skipped when extracting a pointer via @scheme[get-ffi-obj]. Also
unlike @scheme[_pointer], @scheme[_fpointer] does not convert
@scheme[#f] to @cpp{NULL}.
skipped when extracting a pointer via @scheme[get-ffi-obj]. Like
@scheme[_pointer], @scheme[_fpointer] treats @scheme[#f] as @cpp{NULL}
and vice-versa.
A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
and normally @scheme[_cprocedure] should be used instead of
@ -297,6 +295,7 @@ and normally @scheme[_cprocedure] should be used instead of
@defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?]
[#:abi abi (or/c symbol/c #f) #f]
[#:atomic? atomic? any/c #f]
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
#f]
[#:keep keep (or/c boolean? box? (any/c . -> . any/c))
@ -312,6 +311,8 @@ The resulting type can be used to reference foreign functions (usually
@scheme[ffi-obj]s, but any pointer object can be referenced with this type),
generating a matching foreign callout object. Such objects are new primitive
procedure objects that can be used like any other Scheme procedure.
As with other pointer types, @scheme[#f] is treated as a @cpp{NULL}
function pointer and vice-versa.
A type created with @scheme[_cprocedure] can also be used for passing
Scheme procedures to foreign functions, which will generate a foreign
@ -326,6 +327,18 @@ platform-dependent default; other possible values are
``cdecl''). This is especially important on Windows, where most
system functions are @scheme['stdcall], which is not the default.
If @scheme[atomic?] is true, then when a Scheme procedure is given
this procedure type and called from foreign code, then the PLT Scheme
process is put into atomic mode while evaluating the Scheme procedure
body. In atomic mode, other Scheme threads do not run, so the Scheme
code must not call any function that potentially synchronizes with
other threads, or else it may deadlock. In addition, the Scheme code
must not perform any potentially blocking operation (such as I/O), it
must not raise an uncaught exception, it must not perform any escaping
continuation jumps, and its non-tail recursion must be minimal to
avoid C-level stack overflow; otherwise, the process may crash or
misbehave.
The optional @scheme[wrapper], if provided, is expected to be a
function that can change a callout procedure: when a callout is
generated, the wrapper is applied on the newly created primitive
@ -392,7 +405,8 @@ values: @itemize[
(_fun fun-option ... maybe-args type-spec ... -> type-spec
maybe-wrapper)
([fun-option (code:line #:abi abi-expr)
(code:line #:keep keep-expr)]
(code:line #:keep keep-expr)
(code:line #:atomic? atomic?-expr)]
[maybe-args code:blank
(code:line (id ...) ::)
(code:line id ::)

3
collects/scribblings/foreign/unexported.scrbl
View File

@ -62,7 +62,8 @@ especially important on Windows, where most system functions are
@defproc[(ffi-callback [proc any/c] [in-types any/c] [out-type any/c]
[abi (or/c symbol/c #f) #f])
[abi (or/c symbol/c #f) #f]
[atomic? any/c #f])
ffi-callback?]{
The symmetric counterpart of @scheme[ffi-call]. It receives a Scheme

8
collects/scribblings/guide/dialects.scrbl
View File

@ -45,9 +45,9 @@ does not define a module system. Typical single-file @|r5rs| programs
can be converted to PLT Scheme programs by prefixing them with
@scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme
systems do not recognize @scheme[#, @hash-lang[] #,
@schememodname[r5rs]] (which is not part of the @|r5rs| standard). The
@exec{plt-r5rs} executable more directly conforms to the @|r5rs|
standard.
@schememodname[r5rs]]. The @exec{plt-r5rs} executable (see
@secref[#:doc '(lib "r5rs/r5rs.scrbl") "plt-r5rs"]) more directly
conforms to the @|r5rs| standard.
Aside from the module system, the syntactic forms and functions of
@|r5rs| and PLT Scheme differ. Only simple @|r5rs| become PLT Scheme
@ -118,7 +118,7 @@ including the following:
]
Each of these languages is used by starting module with the language
name after @hash-lang[]. For example, this source of this very
name after @hash-lang[]. For example, this source of this
document starts with @scheme[#, @hash-lang[] scribble/doc].
PLT Scheme users can define their own languages. A language name maps

8
collects/scribblings/main/license.scrbl
View File

@ -28,7 +28,7 @@ for more information.
@copyright{
PLT Scheme
Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc.
Copyright (c) 2004-2009 PLT Scheme Inc.
}
PLT software includes or extends the following copyrighted material:
@ -36,21 +36,21 @@ PLT software includes or extends the following copyrighted material:
@copyright{
DrScheme
Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc.
Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved.
}
@copyright{
MrEd
Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc.
Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved.
}
@copyright{
MzScheme
Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc.
Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved.
}

2
collects/scribblings/quick/quick.scrbl
View File

@ -410,7 +410,7 @@ Modules are named and distributed in various ways:
@item{Some modules live relative to other modules, without
necessarily belonging to any particular collection or package.
For example, in DrScheme, if save your definitions so far in a
For example, in DrScheme, if you save your definitions so far in a
file @filepath{quick.ss} and add the line
@schemeblock[(provide rainbow square)]

4
collects/scribblings/reference/booleans.scrbl
View File

@ -128,7 +128,9 @@ type. The property value must be a list of three procedures:
@scheme[equal?] to ensure that data cycles are handled
properly and to work with @scheme[equal?/recur] (but beware
that an arbitrary function can be provided to
@scheme[equal?/recur]).
@scheme[equal?/recur] for recursive checks, which means that
arguments provided to the predicate might be exposed to
arbitrary code).
The @scheme[_equal-proc] is called for a pair of structures
only when they are not @scheme[eq?], and only when they both

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

@ -405,14 +405,15 @@ Windows and Mac OS X.
@filepath{iconv.dll} is included with @filepath{libmzsch@italic{VERS}.dll}.}
The set of available encodings and combinations varies by platform,
depending on the @exec{iconv} library that is installed. Under
Windows, @filepath{iconv.dll} or @filepath{libiconv.dll} must be in the same
directory as @filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is
a version number), in the user's path, in the system directory, or in
the current executable's directory at run time, and the DLL must
either supply @tt{_errno} or link to @filepath{msvcrt.dll} for
@tt{_errno}; otherwise, only the guaranteed combinations are
available.}
depending on the @exec{iconv} library that is installed; the
@scheme[from-name] and @scheme[to-name] arguments are passed on to
@tt{iconv_open}. Under Windows, @filepath{iconv.dll} or
@filepath{libiconv.dll} must be in the same directory as
@filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is a version
number), in the user's path, in the system directory, or in the
current executable's directory at run time, and the DLL must either
supply @tt{_errno} or link to @filepath{msvcrt.dll} for @tt{_errno};
otherwise, only the guaranteed combinations are available.}
@defproc[(bytes-close-converter [converter bytes-converter?]) void]{

4
collects/scribblings/reference/class.scrbl
View File

@ -158,6 +158,8 @@ interface is not an object (i.e., there are no ``meta-classes'' or
@section[#:tag "createinterface"]{Creating Interfaces}
@guideintro["classes"]{classes, objects, and interfaces}
@defform[(interface (super-interface-expr ...) id ...)]{
Produces an interface. The @scheme[id]s must be mutually distinct.
@ -207,6 +209,8 @@ structure type property's guard, if any).}
@section[#:tag "createclass"]{Creating Classes}
@guideintro["classes"]{classes and objects}
@defthing[object% class?]{
A built-in class that has no methods fields, implements only its own

24
collects/scribblings/reference/contracts.scrbl
View File

@ -81,6 +81,13 @@ Takes any number of predicates and higher-order contracts and returns
a contract that accepts any value that any one of the contracts
accepts, individually.
The @scheme[or/c] result tests any value by applying the contracts in
order, from left to right, with the exception that it always moves the
non-@tech{flat contracts} (if any) to the end, checking them
last. Thus, a contract such as @scheme[(or/c (not/c real?)
positive?)] is guaranteed to only invoke the @scheme[positive?]
predicate on real numbers.
If all of the arguments are procedures or @tech{flat contracts}, the
result is a @tech{flat contract}. If only one of the arguments is a
higher-order contract, the result is a contract that just checks the
@ -94,12 +101,17 @@ checks all of the @tech{flat contracts}. If none of them pass, it
calls @scheme[contract-first-order-passes?] with each of the
higher-order contracts. If only one returns true, @scheme[or/c] uses
that contract. If none of them return true, it signals a contract
violation. If more than one returns true, it signals an error
indicating that the @scheme[or/c] contract is malformed.
The @scheme[or/c] result tests any value by applying the contracts in
order, from left to right, with the exception that it always moves the
non-@tech{flat contracts} (if any) to the end, checking them last.}
violation. If more than one returns true, it also signals a contract
violation.
For example, this contract
@schemeblock[
(or/c (-> number? number?)
(-> string? string? string?))
]
does not accept a function like this one: @scheme[(lambda args ...)]
since it cannot tell which of the two arrow contracts should be used
with the function.
}
@defproc[(and/c [contract (or/c contract? (any/c . -> . any/c))] ...)
contract?]{

9
collects/scribblings/reference/for.scrbl
View File

@ -14,7 +14,8 @@ The @scheme[for] iteration forms are based on SRFI-42
@defform/subs[(for (for-clause ...) body ...+)
([for-clause [id seq-expr]
[(id ...) seq-expr]
(code:line #:when guard-expr)])]{
(code:line #:when guard-expr)])
#:contracts ([seq-expr sequence?])]{
Iteratively evaluates @scheme[body]. The @scheme[for-clause]s
introduce bindings whose scope includes @scheme[body] and that
@ -242,7 +243,11 @@ Like @scheme[for*/fold], but the extra @scheme[orig-datum] is used as the source
@defform[(define-sequence-syntax id
expr-transform-expr
clause-transform-expr)]{
clause-transform-expr)
#:contracts
([expr-transform-expr (or/c (-> identifier?)
(syntax? . -> . syntax?))]
[clause-transform-expr (syntax? . -> . syntax?)])]{
Defines @scheme[id] as syntax. An @scheme[(id . _rest)] form is
treated specially when used to generate a sequence in a

3
collects/scribblings/reference/help.scrbl
View File

@ -32,7 +32,8 @@ browser (using the user's selected browser) to display the results.
@margin-note{See @schememodname[net/sendurl] for information on how
the user's browser is launched to display help information.}
A simple @scheme[help] or @scheme[(help)] form opens this page.
A simple @scheme[help] or @scheme[(help)] form opens the main
documentation page.
A @scheme[(help id)] form looks for documentation specific to the
current binding of @scheme[id]. For example,

4
collects/scribblings/reference/parameters.scrbl
View File

@ -45,7 +45,9 @@ reject a change to the parameter's value. The @scheme[guard] is not
applied to the initial @scheme[v].}
@defform[(parameterize ((parameter-expr value-expr) ...)
body ...+)]{
body ...+)
#:contracts
([parameter-expr parameter?])]{
@guideintro["parameterize"]{@scheme[parameterize]}

7
collects/scribblings/reference/ports.scrbl
View File

@ -7,6 +7,13 @@
a character-based operation, the port's bytes are decoded; see
@secref["encodings"].
When a port corresponds to a file, network connection, or some other
system resource, is must be explicitly closed via
@scheme[close-input-port] or @scheme[close-output-port] (or indirectly
via @scheme[custodian-shutdown-all]) to release low-level resources
associated with the port. For any kind of port, after it is closed,
attempting to read from or write to the port raises @scheme[exn:fail].
The global variable @scheme[eof] is bound to the end-of-file value,
and @scheme[eof-object?] returns @scheme[#t] only when applied to this
value. Reading from a port produces an end-of-file result when the

25
collects/scribblings/reference/syntax.scrbl
View File

@ -28,9 +28,11 @@ See @secref["fully-expanded"] for the core grammar.
Each syntactic form is described by a BNF-like notation that describes
a combination of (syntax-wrapped) pairs, symbols, and other data (not
a sequence of characters). These grammatical specifications are shown
as follows:
as in the following specification of a @schemekeywordfont{something}
form:
@specsubform[(#, @schemekeywordfont{some-form} id ...)]
@specsubform[(#, @schemekeywordfont{something} id thing-expr ...)
#:contracts ([thing-expr number?])]
Within such specifications,
@ -42,26 +44,31 @@ Within such specifications,
@item{@scheme[...+] indicates one or
more repetitions of the preceding datum.}
@item{italic meta-identifiers play the role of non-terminals; in
particular,
@item{Italic meta-identifiers play the role of non-terminals. Some
meta-identifier names imply syntactic constraints:
@itemize{
@item{a meta-identifier that ends in @scheme[_id] stands for an
@item{A meta-identifier that ends in @scheme[_id] stands for an
identifier.}
@item{a meta-identifier that ends in @scheme[_keyword] stands
@item{A meta-identifier that ends in @scheme[_keyword] stands
for a keyword.}
@item{a meta-identifier that ends with @scheme[_expr] stands
for a sub-form that is expanded as an expression.}
@item{A meta-identifier that ends with @scheme[_expr] (such as
@scheme[_thing-expr]) stands for a sub-form that is
expanded as an expression.}
@item{A meta-identifier that ends with @scheme[_body] stands
for a sub-form that is expanded in an
internal-definition context (see
@secref["intdef-body"]).}
}} }
}}
@item{Contracts indicate constraints on sub-expression results. For
example, @scheme[_thing-expr #, @elem{:} number?] indicates that
the expression @scheme[_thing-expr] must produce a number.}}
@;------------------------------------------------------------------------
@section[#:tag "module"]{Modules: @scheme[module], ...}

45
collects/scribblings/scribble/manual.scrbl
View File

@ -387,15 +387,19 @@ can also be defined by a single @scheme[defproc*], for the case that
it's best to document a related group of procedures at once.}
@defform/subs[(defform maybe-id maybe-literals form-datum pre-flow ...)
@defform/subs[(defform maybe-id maybe-literals form-datum maybe-contracts
pre-flow ...)
([maybe-id code:blank
(code:line #:id id)]
[maybe-literals code:blank
(code:line #:literals (literal-id ...))])]{
(code:line #:literals (literal-id ...))]
[maybe-contracts code:blank
(code:line #:contracts ([subform-datum contract-expr-datum]
...))])]{
Produces a sequence of flow elements (encapsulated in a
@scheme[splice]) to document a syntatic form named by @scheme[id]
whose syntax described by @scheme[form-datum]. If no @scheme[#:id] is used
whose syntax is described by @scheme[form-datum]. If no @scheme[#:id] is used
to specify @scheme[id], then @scheme[form-datum] must have the form
@scheme[(id . _datum)].
@ -414,16 +418,24 @@ non-terminal. If @scheme[#:literals] clause is provided, however,
instances of the @scheme[literal-id]s are typeset normally (i.e., as
determined by the enclosing context).
The typesetting of @scheme[form-datum] preserves the source layout,
like @scheme[schemeblock].}
If a @scheme[#:contracts] clause is provided, each
@scheme[subform-datum] (typically an identifier that serves as a
meta-variable in @scheme[form-datum]) is shown as producing a value
that must satisfy the contract described by @scheme[contract-expr-datum].
@defform[(defform* maybe-id maybe-literals [form-datum ...+] pre-flow ...)]{
The typesetting of @scheme[form-datum], @scheme[subform-datum], and
@scheme[contract-expr-datum] preserves the source layout, like
@scheme[schemeblock].}
@defform[(defform* maybe-id maybe-literals [form-datum ...+] maybe-contracts
pre-flow ...)]{
Like @scheme[defform], but for multiple forms using the same
@scheme[_id].}
@defform[(defform/subs maybe-id maybe-literals form-datum
([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{
Like @scheme[defform], but including an auxiliary grammar of
@ -434,12 +446,14 @@ non-terminals shown with the @scheme[_id] form. Each
@defform[(defform*/subs maybe-id maybe-literals [form-datum ...]
maybe-contracts
pre-flow ...)]{
Like @scheme[defform/subs], but for multiple forms for @scheme[_id].}
@defform[(defform/none maybe-literal form-datum pre-flow ...)]{
@defform[(defform/none maybe-literal form-datum maybe-contracts
pre-flow ...)]{
Like @scheme[defform], but without registering a definition.}
@ -449,14 +463,16 @@ Like @scheme[defform], but without registering a definition.}
Like @scheme[defform], but with a plain @scheme[id] as the form.}
@defform[(specform maybe-literals datum pre-flow ...)]{
@defform[(specform maybe-literals datum maybe-contracts
pre-flow ...)]{
Like @scheme[defform], but without indexing or registering a
definition, and with indenting on the left for both the specification
and the @scheme[pre-flow]s.}
@defform[(specsubform maybe-literals datum pre-flow ...)]{
@defform[(specsubform maybe-literals datum maybe-contracts
pre-flow ...)]{
Similar to @scheme[defform], but without any specific identifier being
defined, and the table and flow are typeset indented. This form is
@ -472,13 +488,15 @@ procedure. In this description, a reference to any identifier in
@defform[(specsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{
Like @scheme[specsubform], but with a grammar like
@scheme[defform/subs].}
@defform[(specspecsubform maybe-literals datum pre-flow ...)]{
@defform[(specspecsubform maybe-literals datum maybe-contracts
pre-flow ...)]{
Like @scheme[specsubform], but indented an extra level. Since using
@scheme[specsubform] within the body of @scheme[specsubform] already
@ -488,6 +506,7 @@ without nesting a description.}
@defform[(specspecsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{
Like @scheme[specspecsubform], but with a grammar like
@ -943,7 +962,11 @@ combination of @scheme[envvar] and @scheme[as-index].}
The path is relative to the current directory, which is set by
@exec{setup-plt} and @exec{scribble} to the directory of the main
document file.}
document file.
When generating Latex output, if the filename has a @filepath{.gif}
suffix, then the suffix is changed to @filepath{.png} (so a PNG file
must exist in addition to the GIF file).}
@defproc[(image/plain [filename-relative-to-source string?]
[pre-element any/c] ...)

5
collects/scribblings/scribble/struct.scrbl
View File

@ -666,7 +666,10 @@ layer is a style for the hyperlink.}
Used as a style for an @scheme[element] to inline an image. The
@scheme[path] field can be a result of
@scheme[path->main-collects-relative].}
@scheme[path->main-collects-relative].
For Latex output, a @filepath{.gif} suffix on @scheme[path] is
replaced with a @filepath{.png} suffix.}
@defproc[(block? [v any/c]) boolean?]{

2
collects/sgl/sgl.ss
View File

@ -1,6 +1,6 @@
;; sgl -- An OpenGL extension of MzScheme
;;
;; Copyright (C) 2003-2008 Scott Owens <sowens@cs.utah.edu>
;; Copyright (C) 2003-2009 Scott Owens <sowens@cs.utah.edu>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License

2
collects/srfi/43/vector-lib.ss
View File

@ -1,4 +1,4 @@
;;; Copyright (C) 2005-2008 by Chongkai Zhu.
;;; Copyright (C) 2005-2009 by Chongkai Zhu.
(module vector-lib mzscheme

2
collects/srfi/63/63.ss
View File

@ -1,6 +1,6 @@
;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT
;; Scheme.
;; Copyright (C) 2007-2008 Chongkai Zhu
;; Copyright (C) 2007-2009 Chongkai Zhu
;; Released under the same terms as the SRFI reference implementation.

2
collects/swindle/readme.txt
View File

@ -137,7 +137,7 @@ Swindle environment.
====< Copyright Notice >================================================
Copyright (C) 1998-2008 Eli Barzilay (eli@barzilay.org)
Copyright (C) 1998-2009 Eli Barzilay (eli@barzilay.org)
This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as

10
collects/teachpack/2htdp/scribblings/2htdp.scrbl Normal file
View File

@ -0,0 +1,10 @@
#lang scribble/doc
@(require scribble/manual
(for-label scheme))
@title[#:style '(toc) #:tag "2htdp" #:tag-prefix "2htdp"]{HtDP/2e Teachpacks}
@local-table-of-contents[]
@include-section["universe.scrbl"]

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

@ -1,16 +1,16 @@
#lang scribble/doc
@(require scribble/manual "shared.ss"
(for-label scheme ; lang/htdp-beginner
(for-label scheme
(only-in lang/htdp-beginner check-expect)
"../universe.ss"
teachpack/2htdp/universe
teachpack/htdp/image))
@(require scribble/struct)
@(define (table* . stuff)
;; (list paragraph paragraph) *-> Table
(define (flow* x) (make-flow (list x)))
(make-blockquote 'blockquote
(make-blockquote #f
(list
(make-table (make-with-attributes 'boxed
'((cellspacing . "6")))
@ -25,11 +25,16 @@
@author{Matthias Felleisen}
@;{FIXME: the following paragraph uses `defterm' instead of `deftech',
because the words "world" and "universe" are used as datatypes, and
datatypes are currently linked as technical terms --- which is a hack.
Fix the paragraph when we have a better way to link datatype names.}
This @tt{universe.ss} teachpack implements and provides the functionality
for creating interactive, graphical programs that consist of plain
mathematical functions. We refer to such programs as @deftech{world}
mathematical functions. We refer to such programs as @defterm{world}
programs. In addition, world programs can also become a part of a
@deftech{universe}, a collection of worlds that can exchange messages.
@defterm{universe}, a collection of worlds that can exchange messages.
The purpose of this documentation is to give experienced Schemers and HtDP
teachers a concise overview for using the library. The first part of the
@ -47,7 +52,7 @@ The purpose of this documentation is to give experienced Schemers and HtDP
have a series of projects available as a small booklet on
@link["http://world.cs.brown.edu/"]{How to Design Worlds}.
@declare-exporting["../universe.ss" #:use-sources (teachpack/htdp/image)]
@declare-exporting[teachpack/2htdp/universe #:use-sources (teachpack/htdp/image)]
@; -----------------------------------------------------------------------------
@ -55,8 +60,8 @@ The purpose of this documentation is to give experienced Schemers and HtDP
The teachpack assumes working knowledge of the basic image manipulation
primitives and supports several functions that require a special kind of
image, called a @deftech{scene}, , which are images whose pinholes are at
position @scheme[(0,0)]. For example, the teachpack displays only
image, called a @deftech{scene}, which is an image whose pinholes are at
position @math{(0, 0)}. For example, the teachpack displays only
@tech{scene}s in its canvas.
@defproc[(scene? [x any/c]) boolean?]{
@ -70,9 +75,10 @@ The teachpack assumes working knowledge of the basic image manipulation
@defproc[(place-image [img image?] [x number?] [y number?]
[s scene?])
scene?]{
creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s];
@scheme[(x,y)] are computer graphics coordinates, i.e., they count right and
down from the upper-left corner.}
creates a scene by placing @scheme[img] at
@math{(@scheme[x], @scheme[y])} into @scheme[s];
@math{(@scheme[x], @scheme[y])} are computer graphics coordinates,
i.e., they count right and down from the upper-left corner.}
@; -----------------------------------------------------------------------------
@section[#:tag "simulations"]{Simple Simulations}
@ -85,8 +91,8 @@ The simplest kind of animated @tech{world} program is a time-based
@defproc[(run-simulation [create-image (-> natural-number/c scene)])
true]{
opens a canvas and starts a clock that tick 28 times per second
seconds. Every time the clock ticks, drscheme applies
opens a canvas and starts a clock that tick 28 times per second.
Every time the clock ticks, DrScheme applies
@scheme[create-image] to the number of ticks passed since this function
call. The results of these applications are displayed in the canvas.
}
@ -108,7 +114,7 @@ Example:
The step from simulations to interactive programs is relatively
small. Roughly speaking, a simulation designates one function,
@emph{create-image}, as a handler for one kind of event: clock ticks. In
@scheme[_create-image], as a handler for one kind of event: clock ticks. In
addition to clock ticks, @tech{world} programs can also deal with two
other kinds of events: keyboard events and mouse events. A keyboard event
is triggered when a computer user presses or releases a key on the
@ -119,8 +125,8 @@ Your program may deal with such events via the @emph{designation} of
@emph{handler} functions. Specifically, the teachpack provides for the
installation of three event handlers: @scheme[on-tick], @scheme[on-key],
and @scheme[on-mouse]. In addition, a @tech{world} program may specify a
@emph{draw} function, which is called every time your program should
visualize the current world, and a @emph{stop?} predicate, which is used
@scheme[_dra]} function, which is called every time your program should
visualize the current world, and a @scheme[_stop?] predicate, which is used
to determine when the @tech{world} program should shut down.
Each handler function consumes the current state of the @tech{world} and
@ -132,20 +138,22 @@ The following picture provides an intuitive overview of the workings of a
@image["nuworld.png"]
The @scheme[big-bang] form installs @emph{World_0} as the initial
world. The handlers @emph{tock}, @emph{react}, and @emph{click} transform
one world into another one; each time an event is handled, @emph{done} is
The @scheme[big-bang] form installs @scheme[World_0] as the initial
world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
one world into another one; each time an event is handled, @scheme[done] is
used to check whether the world is final, in which case the program is
shut down; and finally, @emph{draw} renders each world as a scene, which
shut down; and finally, @scheme[draw] renders each world as a scene, which
is then displayed on an external canvas.
@deftech{World} : @scheme[any/c] The design of a world program demands that
you come up with a data definition of all possible states. We use
@tech{World} to refer to this collection of data, using a capital W to
distinguish it from the program. In principle, there are no constraints
on this data definition though it mustn't be an instance of the
@tech{Package} structure (see below). You can even keep it implicit, even
if this violates the Design Recipe.
@deftech{World} : @scheme[any/c]
The design of a world program demands that you come up with a data
definition of all possible states. We use @tech{World} to refer to
this collection of data, using a capital W to distinguish it from the
program. In principle, there are no constraints on this data
definition though it mustn't be an instance of the @tech{Package}
structure (see below). You can even keep it implicit, even if this
violates the Design Recipe.
@defform/subs[#:id big-bang
#:literals
@ -180,28 +188,30 @@ The following picture provides an intuitive overview of the workings of a
@itemize[
@item{
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{
@defform[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{
tell DrScheme to call the @scheme[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
current world. The clock ticks at the rate of 28 times per second.}}
@item{
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))]
[rate-expr natural-number/c])]{
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))]
[rate-expr natural-number/c])]{
tell DrScheme to call the @scheme[tick-expr] function on the current
world every time the clock ticks. The result of the call becomes the
current world. The clock ticks at the rate of @scheme[rate-expr].}}
@item{An @tech{KeyEvent} represents key board events, e.g., keys pressed or
@item{A @tech{KeyEvent} represents key board events, e.g., keys pressed or
released.
@deftech{KeyEvent} : @scheme[(or/c char? symbol?)]
A @tech{Char} is used to signal that the user has hit an alphanumeric
key. A @tech{Symbol} denotes arrow keys or special events:
A character is used to signal that the user has hit an alphanumeric
key. A symbol denotes arrow keys or special events:
@itemize[
@ -222,8 +232,9 @@ A @tech{Char} is used to signal that the user has hit an alphanumeric
@defproc[(key=? [x key-event?][y key-event?]) boolean?]{
compares two @tech{KeyEvent} for equality}
@defform[(on-key
[change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{
@defform[(on-key change-expr)
#:contracts
([change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{
tell DrScheme to call @scheme[change-expr] function on the current world and a
@tech{KeyEvent} for every keystroke the user of the computer makes. The result
of the call becomes the current world.
@ -271,11 +282,12 @@ All @tech{MouseEvent}s are represented via symbols:
@defproc[(mouse-event? [x any]) boolean?]{
determines whether @scheme[x] is a @tech{KeyEvent}}
@defproc[(key=? [x mouse-event?][y mouse-event?]) boolean?]{
@defproc[(mouse=? [x mouse-event?][y mouse-event?]) boolean?]{
compares two @tech{KeyEvent} for equality}
@defform[(on-mouse
[clack-expr
@defform[(on-mouse clack-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{
tell DrScheme to call @scheme[clack-expr] on the current world, the current
@scheme[x] and @scheme[y] coordinates of the mouse, and and a
@ -289,18 +301,20 @@ All @tech{MouseEvent}s are represented via symbols:
@item{
@defform[(on-draw
[render-expr (-> (unsyntax @tech{World}) scene?)])]{
@defform[(on-draw render-expr)
#:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)])]{
tell DrScheme to call the function @scheme[render-expr] whenever the
canvas must be drawn. The external canvas is usually re-drawn after DrScheme has
dealt with an event. Its size is determined by the size of the first
generated @tech{scene}.}
@defform[(on-draw
[render-expr (-> (unsyntax @tech{World}) scene?)]
[width-expr natural-number/c]
[height-expr natural-number/c])]{
@defform/none[(on-draw render-expr width-expr height-expr)
#:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)]
[width-expr natural-number/c]
[height-expr natural-number/c])]{
tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr]
canvas instead of one determine by the first generated @tech{scene}.
@ -309,8 +323,9 @@ All @tech{MouseEvent}s are represented via symbols:
@item{
@defform[(stop-when
[last-world? (-> (unsyntax @tech{World}) boolean?)])]{
@defform[(stop-when last-world?)
#:contracts
([last-world? (-> (unsyntax @tech{World}) boolean?)])]{
tell DrScheme to call the @scheme[last-world?] function whenever the canvas is
drawn. If this call produces @scheme[true], the world program is shut
down. Specifically, the clock is stopped; no more
@ -320,8 +335,9 @@ All @tech{MouseEvent}s are represented via symbols:
@item{
@defform[(record?
[boolean-expr boolean?])]{
@defform[(record? boolean-expr)
#:contracts
([boolean-expr boolean?])]{
tell DrScheme to record all events and to enable a replay of the entire
interaction. The replay action also generates one png image per scene and
an animated gif for the entire sequence.
@ -363,12 +379,12 @@ are highly useful for creating scenes.
corner.}
@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{
creates a scene by placing a line of color @scheme[c] from @scheme[(x0,y0)] to
@scheme[(x1,y1)] into @scheme[scene];
@scheme[(x,y)] are computer graphics coordinates.
In contrast to the @scheme[add-line] function, @scheme[scene+line] cuts
off those portions of the line that go beyond the boundaries of
the given @scheme[s].}
creates a scene by placing a line of color @scheme[c] from
@math{(@scheme[x0], @scheme[y0])} to @math{(@scheme[x1],
@scheme[y1])} using computer graphics coordinates. In contrast to
the @scheme[add-line] function, @scheme[scene+line] cuts off those
portions of the line that go beyond the boundaries of the given
@scheme[s].}
@; -----------------------------------------------------------------------------
@section[#:tag "world-example"]{A First Sample World}
@ -395,22 +411,22 @@ Here is a diagram that translates our words into a graphical
@image["door-real.png"]
Like the picture of the general workings of a @tech{world} program, this
diagram displays a so-called "state machine". The three circled words are
diagram displays a so-called ``state machine.'' The three circled words are
the states that our informal description of the door identified: locked,
closed (and unlocked), and open. The arrows specify how the door can go
from one state into another. For example, when the door is open, the
automatic door closer shuts the door as time passes. This transition is
indicated by the arrow labeled "time passes." The other arrows represent
indicated by the arrow labeled ``time passes.'' The other arrows represent
transitions in a similar manner:
@itemize[
@item{"push" means a person pushes the door open (and let's go);}
@item{``push'' means a person pushes the door open (and let's go);}
@item{"lock" refers to the act of inserting a key into the lock and turning
@item{``lock'' refers to the act of inserting a key into the lock and turning
it to the locked position; and}
@item{"unlock" is the opposite of "lock".}
@item{``unlock'' is the opposite of ``lock.''}
]
@ -712,7 +728,7 @@ Each world-producing callback in a world program---those for handling clock
predicate.
@defproc[(package? [x any/c]) boolean?]{
determine whether @scheme[x] is a @deftech{Package}.}
determine whether @scheme[x] is a @tech{Package}.}
@defproc[(make-package [w any/c][m sexp?]) package?]{
create a @tech{Package} from a @tech{World} and an @tech{S-expression}.}
@ -720,23 +736,27 @@ Each world-producing callback in a world program---those for handling clock
As mentioned, all event handlers may return @tech{World}s or @tech{Package}s;
here are the revised specifications:
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{
@defform/none[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{
}
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))]
[rate-expr natural-number/c])]{
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))]
[rate-expr natural-number/c])]{
}
@defform[(on-key
[change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{
@defform/none[(on-key change-expr)
#:contracts
([change-expr (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{
}
@defform[(on-mouse
[clack
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{World}) package?))])]{
@defform/none[(on-mouse clack-expr)
#:contracts
([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent})
(or/c (unsyntax @tech{World}) package?))])]{
}
If one of these event handlers produces a @tech{Package}, the content of the world
@ -772,14 +792,16 @@ following shapes:
@itemize[
@item{
@defform[(register [ip-expr string?])]{
@defform[(register ip-expr) #:contracts ([ip-expr string?])]{
connect this world to a universe server at the specified @scheme[ip-expr]
address and set up capabilities for sending and receiving messages.}
}
@item{
@defform[(register [ip-expr string?]
[name-expr (or/c symbol? string?)])]{
@defform/none[(register ip-expr name-expr)
#:contracts
([ip-expr string?]
[name-expr (or/c symbol? string?)])]{
connect this world to a universe server @emph{under a specific} @scheme[name-expr].}
}
@ -799,8 +821,9 @@ Finally, the receipt of a message from the server is an event, just like
The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handler
for message receipts.
@defform[(on-receive
[receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{
@defform[(on-receive receive-expr)
#:contracts
([receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{
tell DrScheme to call @scheme[receive-expr] for every message receipt, on the current
@tech{World} and the received message. The result of the call becomes the current
@tech{World}.
@ -848,17 +871,17 @@ The teachpack provides a mechanism for designating event handlers for
@itemize[
@item{A server may be a "pass through" channel between two worlds, in which case
@item{A server may be a ``pass through'' channel between two worlds, in which case
it has no other function than to communicate whatever message it receives
from one world to the other, without any interference.}
@item{A server may enforce a "back and forth" protocol, i.e., it may force two
@item{A server may enforce a ``back and forth'' protocol, i.e., it may force two
(or more) worlds to engage in a civilized tit-for-tat exchange. Each
world is given a chance to send a message and must then wait
to get a reply before it sends anything again.}
@item{A server may play the role of a special-purpose arbiter, e.g., the referee
or administrator of a game. It may check that each world "plays" by the rules,
or administrator of a game. It may check that each world ``plays'' by the rules,
and it administrate the resources of the game.}
]
@ -985,15 +1008,17 @@ description. Two of them are mandatory:
@itemize[
@item{
@defform[(on-new
[new-expr (-> (unsyntax @tech{Universe}) world?
@defform[(on-new new-expr)
#:contracts
([new-expr (-> (unsyntax @tech{Universe}) world?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to call the function @scheme[new-expr] every time another world joins the
universe.}}
@item{
@defform[(on-msg
[msg-expr (-> (unsyntax @tech{Universe}) world? sexp?
@defform[(on-msg msg-expr)
#:contracts
([msg-expr (-> (unsyntax @tech{Universe}) world? sexp?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world
@ -1012,24 +1037,27 @@ optional handlers:
@itemize[
@item{
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{
@defform/none[(on-tick tick-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current state of the
universe. The handler is expected to produce a bundle of the new state of
the universe and a list of mails.
}
@defform[(on-tick
[tick-expr (-> (unsyntax @tech{Universe}) bundle?)]
[rate-expr natural-number/c])]{
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)]
[rate-expr natural-number/c])]{
tell DrScheme to apply @scheme[tick-expr] as above but use the specified
clock tick rate instead of the default.
}
}
@item{
@defform[(on-disconnect
[dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{
@defform[(on-disconnect dis-expr)
#:contracts
([dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{
tell DrScheme to invoke @scheme[dis-expr] every time a participating
@tech{world} drops its connection to the server. The first argument is the
current state of the universe; the second one is the world that got
@ -1038,8 +1066,9 @@ optional handlers:
}
@item{
@defform[(to-string
[render-expr (-> (unsyntax @tech{Universe}) string?)])]{
@defform[(to-string render-expr)
#:contracts
([render-expr (-> (unsyntax @tech{Universe}) string?)])]{
tell DrScheme to render the state of the universe after each event and to
display this string in the universe console.
}
@ -1058,7 +1087,7 @@ This section uses a simple example to explain the design of a universe,
@subsection{Two Ball Tossing Worlds}
Say we want to represent a universe that consists of a number of worlds and
that gives each world a "turn" in a round-robin fashion. If a world is
that gives each world a ``turn'' in a round-robin fashion. If a world is
given its turn, it displays a ball that ascends from the bottom of a
canvas to the top. It relinquishes its turn at that point and the server
gives the next world a turn.
@ -1097,7 +1126,7 @@ From the perspective of the @tech{universe}, the design of a protocol is
kinds of @tech{S-expression}s. The data definitions for messages must
therefore select a subset of suitable @tech{S-expression}s. As for the
state of the server and the worlds, they must reflect how they currently
relate to the universe. Later, when we design their "local" behavior, we
relate to the universe. Later, when we design their ``local'' behavior, we
may add more components to their state space.
In summary, the first step of a protocol design is to introduce:
@ -1204,7 +1233,7 @@ From the @tech{universe}'s perspective, each @tech{world} is in one of two state
@itemize[
@item{A passive @tech{world} is @emph{resting}. We use @scheme['resting] for this state.}
@item{An active @tech{world} is not resting. We delay choosing a representation
for this part of a @tech{world}'s state until we design its "local" behavior.}
for this part of a @tech{world}'s state until we design its ``local'' behavior.}
]
It is also clear that an active @tech{world} may receive additional messages,
which it may ignore. When it is done with its turn, it will send a

BIN
collects/teachpack/balls.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.5 KiB

3
collects/teachpack/teachpack.scrbl
View File

@ -23,7 +23,8 @@ This chapter covers the teachpacks for @italic{How to Design Programs}
@table-of-contents[]
@include-section["htdp/scribblings/htdp.scrbl"]
@include-section["htdc/scribblings/htdc.scrbl"]
@include-section["2htdp/scribblings/2htdp.scrbl"]

11
collects/tests/drscheme/teachpack.ss
View File

@ -213,13 +213,16 @@
(printf "FAILED built in teachpack test: ~a~n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected)))))))]
[test-teachpacks
(lambda (dir)
(for-each (test-teachpack dir)
(directory-list dir)))]
(lambda (paths)
(for-each (lambda (dir)
(for-each (test-teachpack dir)
(directory-list dir)))
paths))]
[teachpack-dir (normalize-path (collection-path "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student"))
(do-execute drs-frame)
(test-teachpacks (build-path teachpack-dir "htdp"))))
(test-teachpacks (list (build-path teachpack-dir "2htdp")
(build-path teachpack-dir "htdp")))))
(define (find-leftmost-choice frame)
(let loop ([p frame])

32
collects/tests/macro-debugger/gentests.ss
View File

@ -101,15 +101,15 @@
(define (check-steps expected actual)
(check-pred list? actual)
(check-pred reduction-sequence? actual)
(compare-step-sequences expected actual))
(compare-step-sequences actual expected))
(define (reduction-sequence? rs)
(andmap protostep? rs))
(define (compare-step-sequences expected actual)
(define (compare-step-sequences actual expected)
(cond [(and (pair? expected) (pair? actual))
(begin (compare-steps (car expected) (car actual))
(compare-step-sequences (cdr expected) (cdr actual)))]
(begin (compare-steps (car actual) (car expected))
(compare-step-sequences (cdr actual) (cdr expected)))]
[(pair? expected)
(fail (format "missing expected steps:\n~s" expected))]
[(pair? actual)
@ -121,7 +121,7 @@
(stx->datum (step-term2 step)))))))]
[else 'ok]))
(define (compare-steps expected actual)
(define (compare-steps actual expected)
(cond [(eq? expected 'error)
(check-pred misstep? actual)]
[else
@ -140,14 +140,16 @@
e-local
"Context frame")))]))
(define-binary-check (check-equal-syntax? a b)
(equal-syntax? a b))
(define-binary-check (check-equal-syntax? a e)
(equal-syntax? a e))
(define (equal-syntax? a b)
(cond [(and (pair? a) (pair? b))
(and (equal-syntax? (car a) (car b))
(equal-syntax? (cdr a) (cdr b)))]
[(and (symbol? a) (symbol? b))
(equal? (string->symbol (symbol->string a))
b)]
[else (equal? a b)]))
(define (equal-syntax? a e)
(cond [(and (pair? a) (pair? e))
(and (equal-syntax? (car a) (car e))
(equal-syntax? (cdr a) (cdr e)))]
[(and (symbol? a) (symbol? e))
(equal? (symbol->string a)
(symbol->string e))]
[(and (symbol? a) (regexp? e))
(regexp-match? e (symbol->string a))]
[else (equal? a e)]))

8
collects/tests/macro-debugger/tests/policy.ss
View File

@ -10,11 +10,13 @@
(eval '(require (prefix-in base: scheme/base)) ns)
(eval '(require (prefix-in scheme: scheme)) ns)
(define (make-test-id sym)
(parameterize ((current-namespace ns))
(namespace-symbol->identifier sym)))
(define-syntax-rule (test-policy policy name show?)
(test-case (format "~s" 'name)
(check-eq? (policy
(parameterize ((current-namespace ns))
(namespace-symbol->identifier 'name)))
(check-eq? (policy (make-test-id 'name))
show?)))
(define-syntax-rule (test-standard name show?)
(test-policy standard-policy name show?))

23
collects/tests/macro-debugger/tests/regression.ss
View File

@ -167,4 +167,25 @@
(add1 (g 2))))))])
(check-pred list? rs)
(check-true (ormap misstep? rs))))
))
;; Added 1/3/2008
;; Based on PR 10000
(test-case "eval within module expansion"
(let ([freshname (gensym)])
(eval `(module ,freshname scheme
(provide meval)
(define-syntax (meval stx)
(syntax-case stx ()
[(meval e)
(parameterize ((current-namespace (make-base-namespace)))
(eval `(define one '1))
(let ([v (eval `(+ 1 ,#'e))])
#`(quote #,v)))]))))
(eval `(require ',freshname))
(check-pred deriv?
(trace `(meval (+ 1 2))))
(check-pred deriv?
(trace `(module m mzscheme
(require ',freshname)
(meval (+ 1 2)))))))
))

105
collects/tests/macro-debugger/tests/syntax-macros.ss
View File

@ -44,76 +44,77 @@
(test "lift"
(lift 'a)
[#:steps (local-lift lifted (lift 'a))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:steps (local-lift #rx"^lifted" (lift 'a))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression
(#%top . #rx"^lifted"))))]
#:no-hidden-steps)
(test "lift with id"
(lift (id 'a))
[#:steps (local-lift lifted (lift (id 'a)))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) (id 'a))
(#%expression (#%top . lifted))))
(macro (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:steps (local-lift #rx"^lifted" (lift (id 'a)))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
#:no-hidden-steps)
(test "lift with Tid"
(lift (Tid 'a))
[#:steps (local-lift lifted (lift (Tid 'a)))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) (Tid 'a))
(#%expression (#%top . lifted))))
(macro (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:steps (local-lift #rx"^lifted" (lift (Tid 'a)))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
;; Don't show lifts, but do find (Tid 'a), show in orig ctx
[#:hidden-steps (macro (lift 'a))])
(test "Tlift"
(Tlift 'a)
[#:steps (local-lift lifted (Tlift 'a))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:hidden-steps (local-lift lifted (Tlift 'a))
(macro (#%expression lifted))
(capture-lifts (begin (define-values (lifted) 'a)
(#%expression lifted)))])
[#:steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression #rx"^lifted")))])
(test "Tlift with id"
(Tlift (id 'a))
[#:steps (local-lift lifted (Tlift (id 'a)))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) (id 'a))
(#%expression (#%top . lifted))))
(macro (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:hidden-steps (local-lift lifted (Tlift (id 'a)))
(macro (#%expression lifted))
(capture-lifts (begin (define-values (lifted) (id 'a))
(#%expression lifted)))])
[#:steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression #rx"^lifted")))])
(test "Tlift with Tid"
(Tlift (Tid 'a))
[#:steps (local-lift lifted (Tlift (Tid 'a)))
(macro (#%expression lifted))
(tag-top (#%expression (#%top . lifted)))
(capture-lifts (begin (define-values (lifted) (Tid 'a))
(#%expression (#%top . lifted))))
(macro (begin (define-values (lifted) 'a)
(#%expression (#%top . lifted))))]
[#:steps (local-lift lifted (Tlift (Tid 'a)))
(macro (#%expression lifted))
(capture-lifts (begin (define-values (lifted) (Tid 'a))
(#%expression lifted)))
(macro (begin (define-values (lifted) 'a)
(#%expression lifted)))])
[#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . #rx"^lifted"))))]
[#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression #rx"^lifted")))
(macro (begin (define-values (#rx"^lifted") 'a)
(#%expression #rx"^lifted")))])
[#:suite "set! macros"
(test "set! (macro)"

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

@ -5488,8 +5488,10 @@ so that propagation occurs.
(c)))
(ctest 2
'tail-arrow-d1
;; this one is not tail recursive, since the contract system
;; cannot tell that the range contract doesn't depend on 'arg'
(ctest 8
'tail-arrow-d1/changing-args
(let ([c (counter)])
(letrec ([f
(contract (->d ([arg any/c]) () (values [_ c] [_ c]))
@ -5499,8 +5501,22 @@ so that propagation occurs.
(f 3))
(c)))
(ctest 1
'tail-arrow-d2
(ctest 2
'tail-arrow-d1
(let ([c (counter)])
(letrec ([x 5]
[f
(contract (->d ([arg any/c]) () (values [_ c] [_ c]))
(λ (_ignored) (if (zero? x) (values x x) (begin (set! x (- x 1)) (f _ignored))))
'pos
'neg)])
(f 'ignored))
(c)))
;; this one is just like the one two above.
(ctest 4
'tail-arrow-d2/changing-args
(let ([c (counter)])
(letrec ([f
(contract (->d ([arg any/c]) () [rng c])
@ -5510,7 +5526,23 @@ so that propagation occurs.
(f 3))
(c)))
(ctest '(1 1)
(ctest 1
'tail-arrow-d2
(let ([c (counter)])
(letrec ([x 3]
[f
(contract (->d ([arg any/c]) () [rng c])
(λ (ignored) (if (zero? x) x (begin (set! x (- x 1)) (f ignored))))
'pos
'neg)])
(f 3))
(c)))
;; the tail-call optimization cannot handle two different
;; contracts on the stack one after the other one, so this
;; returns '(4 4) instead of '(1 1) (which would indicate
;; the optimization had happened).
(ctest '(4 4)
'tail->d-mut-rec
(letrec ([odd-count 0]
[pos-count 0]
@ -5563,6 +5595,40 @@ so that propagation occurs.
(f 4))
(c)))
(ctest '(1)
'mut-rec-with-any/c
(let ()
(define f
(contract (-> number? any/c)
(lambda (x)
(if (zero? x)
(continuation-mark-set->list (current-continuation-marks) 'tail-test)
(with-continuation-mark 'tail-test x
(g (- x 1)))))
'pos
'neg))
(define g
(contract (-> number? any/c)
(lambda (x)
(f x))
'pos
'neg))
(f 3)))
(test/pos-blame 'free-vars-change-so-cannot-drop-the-check
'(let ()
(define f
(contract (->d ([x number?]) () [_ (</c x)])
(lambda (x)
(cond
[(= x 0) 1]
[else (f 0)]))
'pos
'neg))
(f 10)))
;
;
;

2
collects/tests/mzscheme/foreign-test.c
View File

@ -21,7 +21,7 @@ X byte decimal_byte_int_byte (byte x, int y) { return 10*x + y; }
X byte decimal_int_byte_byte (int x, byte y) { return 10*x + y; }
X byte decimal_byte_byte_byte (byte x, byte y) { return 10*x + y; }
X int callback3_int_int_int (int(*f)(int)) { return f(3); }
X int callback3_int_int_int (int(*f)(int)) { if (f) return f(3); else return 79; }
X int callback3_byte_int_int (int(*f)(byte)) { return f(3); }
X int callback3_int_byte_int (byte(*f)(int)) { return f(3); }
X int callback3_byte_byte_int (byte(*f)(byte)) { return f(3); }

2
collects/tests/mzscheme/foreign-test.ss
View File

@ -77,6 +77,8 @@
(t 12 'decimal_byte_byte_byte (_fun _byte _byte -> _byte) 1 2)
;; ---
(t 9 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) sqr)
(t 79 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) #f) ; NULL allowed as function pointer
(t 9 'callback3_int_int_int (_fun _pointer -> _int ) (function-ptr sqr (_fun _int -> _int ))) ; callback allowed as pointer
(t 9 'callback3_byte_int_int (_fun (_fun _byte -> _int ) -> _int ) sqr)
(t 9 'callback3_int_byte_int (_fun (_fun _int -> _byte) -> _int ) sqr)
(t 9 'callback3_byte_byte_int (_fun (_fun _byte -> _byte) -> _int ) sqr)

52
collects/tests/mzscheme/htdp-image.ss
View File

@ -201,6 +201,32 @@
(image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2 0 0)
(p00 (rectangle 2 2 'solid 'blue))))
(test 10
'color-list8
(image-width (color-list->image '() 10 0 0 0)))
(test 0
'color-list9
(image-height (color-list->image '() 10 0 0 0)))
(test 0
'color-list10
(image-width (color-list->image '() 0 10 0 0)))
(test 10
'color-list11
(image-height (color-list->image '() 0 10 0 0)))
(test 3
'color-list12
(pinhole-x (color-list->image '() 10 0 3 0)))
(test 3
'color-list13
(pinhole-y (color-list->image '() 0 10 0 3)))
(test #t
'alpha-color-list1
(equal? (make-alpha-color 0 255 0 0)
@ -278,6 +304,32 @@
blue blue blue
red blue red)))
(test 10
'alpha-color-list11
(image-width (alpha-color-list->image '() 10 0 0 0)))
(test 0
'alpha-color-list12
(image-height (alpha-color-list->image '() 10 0 0 0)))
(test 0
'alpha-color-list13
(image-width (alpha-color-list->image '() 0 10 0 0)))
(test 10
'alpha-color-list14
(image-height (alpha-color-list->image '() 0 10 0 0)))
(test 3
'alpha-color-list15
(pinhole-x (alpha-color-list->image '() 10 0 3 0)))
(test 3
'alpha-color-list16
(pinhole-y (alpha-color-list->image '() 0 10 0 3)))
(test #t
'image=?1
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0)

2
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -60,6 +60,8 @@
(build-path example-servlets "add-v2.ss"))
(test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch"
(build-path example-servlets "add-ssd.ss"))
(test-add-two-numbers mkd "add-ssd.ss - send/formlet"
(build-path example-servlets "add-formlets.ss"))
(test-equal? "count.ss - state"
(let* ([d (mkd (build-path example-servlets "count.ss"))]
[ext (lambda (c)

15
collects/tests/web-server/dispatchers/servlet-test-util.ss
View File

@ -20,11 +20,16 @@
(test-equal?
t
(let* ([d (mkd p)]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
(list (make-binding:form #"number" xs)))))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
(list (make-binding:form #"number" ys)))))])
[r0 (call d url0 empty)]
[k0 (first ((sxpath "//form/@action/text()") r0))]
[i0 (first ((sxpath "//form/input/@name/text()") r0))]
[r1 (call d (format "~a?~a=~a" k0 i0 xs)
(list (make-binding:form (string->bytes/utf-8 i0) xs)))]
[k1 (first ((sxpath "//form/@action/text()") r1))]
[i1 (first ((sxpath "//form/input/@name/text()") r1))]
[r2 (call d (format "~a?~a=~a" k1 i1 ys)
(list (make-binding:form (string->bytes/utf-8 i1) ys)))]
[n (first ((sxpath "//p/text()") r2))])
n)
(format "The answer is ~a" (+ x y)))))

26
collects/web-server/default-web-root/htdocs/servlets/examples/add-formlets.ss Normal file
View File

@ -0,0 +1,26 @@
#lang scheme
(require web-server/servlet
web-server/formlets)
(provide (all-defined-out))
(define interface-version 'v1)
(define timeout +inf.0)
; request-number : str -> num
(define (request-number which-number)
(send/formlet
(formlet
(#%# "Enter the " ,which-number " number to add: "
,{input-int . => . the-number}
(input ([type "submit"] [name "enter"] [value "Enter"])))
the-number)
#:wrap
(lambda (f-expr)
`(html (head (title "Enter a Number to Add"))
(body ([bgcolor "white"])
,f-expr)))))
(define (start initial-request)
`(html (head (title "Sum"))
(body ([bgcolor "white"])
(p "The answer is "
,(number->string (+ (request-number "first") (request-number "second")))))))

16
collects/web-server/formlets/servlet.ss
View File

@ -4,15 +4,23 @@
"lib.ss")
(provide/contract
[send/formlet ((formlet/c any/c) . -> . any/c)])
[send/formlet (((formlet/c any/c))
(#:wrap (xexpr? . -> . response?))
. ->* . any/c)])
(define (send/formlet f)
(define (send/formlet f
#:wrap
[wrapper
(lambda (form-xexpr)
`(html (head (title "Form Entry"))
(body ,form-xexpr)))])
(formlet-process
f
(send/suspend
(lambda (k-url)
`(form ([action ,k-url])
,@(formlet-display f))))))
(wrapper
`(form ([action ,k-url])
,@(formlet-display f)))))))
(provide/contract
[embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr?)])

12
collects/web-server/scribblings/faq.scrbl
View File

@ -1,8 +1,20 @@
#lang scribble/doc
@(require "web-server.ss")
@(require (for-label web-server/dispatchers/dispatch-servlets))
@title{Troubleshooting and Tips}
@section{Why are my servlets not updating on the server when I change the code on disk?}
By default, the server uses @scheme[make-cached-url->servlet] to load servlets
from the disk. As it loads them, they are cached and the disk is not referred to for future
requests. This ensures that there is a single namespace for each servlet, so that different instances
can share resources, such as database connections, and communicate through the store. The default
configuration of the server (meaning the dispatcher sequence used when you load a configuration file)
provides a special URL to localhost that will reset the cache: @filepath{/conf/refresh-servlets}. If
you want the server to reload your changed servlet code, then GET this URL and the server will reload the
servlet on the next request.
@section{What special considerations are there for security with the Web Server?}
The biggest problem is that a naive usage of continuations will allow continuations to subvert

10
collects/web-server/scribblings/formlets.scrbl
View File

@ -226,10 +226,16 @@ There are a few basic @tech{formlet}s provided by this library.
A few utilities are provided for using @tech{formlet}s in Web applications.
@defproc[(send/formlet [f (formlet/c any/c)])
@defproc[(send/formlet [f (formlet/c any/c)]
[#:wrap wrapper
(xexpr? . -> . response?)
(lambda (form-xexpr)
`(html (head (title "Form Entry"))
(body ,form-xexpr)))])
any/c]{
Uses @scheme[send/suspend] to send @scheme[f]'s rendering (wrapped in a FORM tag whose action is
the continuation URL) to the client. When the form is submitted, the request is passed to the
the continuation URL (wrapped again by @scheme[wrapper])) to the client.
When the form is submitted, the request is passed to the
processing stage of @scheme[f].
}

28
collects/xml/test.ss
View File

@ -2,7 +2,8 @@
;; % mzscheme --require test.ss
(module test mzscheme
(require xml/xml)
(require xml/xml
scheme/port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -66,7 +67,7 @@
;; permissive?
(with-handlers ([exn?
(lambda (exn)
(regexp-match #rx"Expected content," (exn-message exn)))])
(regexp-match #rx"Expected content," (exn-message exn)))])
(report-err "Non-permissive" (xml->xexpr #f) "Exception"))
(with-handlers ([exn?
@ -77,6 +78,29 @@
(when tmp
(report-err "Permissive" tmp "#f")))))
;; doctype
(let ()
(define source-string #<<END
<!DOCTYPE html PUBLIC
"-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml"> </html>
END
)
(define source-document
(read-xml (open-input-string source-string)))
(define result-string
(with-output-to-string (lambda () (write-xml source-document))))
(define expected-string #<<END
<html xmlns="http://www.w3.org/1999/xhtml"> </html>
END
)
(unless (string=? expected-string result-string)
(report-err "DOCTYPE dropping"
result-string
expected-string)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; done

6
collects/xml/xml.scrbl
View File

@ -23,9 +23,9 @@ generating XML. XML can be represented as an instance of the
@scheme[document] structure type, or as a kind of S-expression that is
called an @deftech{X-expression}.
The @schememodname[xml] library does not provides Document Type
Declaration (DTD) processing, validation, expanding user-defined
entities, or reading user-defined entities in attributes.
The @schememodname[xml] library does not provide Document Type
Declaration (DTD) processing, including preservation of DTDs in read documents, or validation.
It also does not expand user-defined entities or read user-defined entities in attributes.
@; ----------------------------------------------------------------------

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

@ -1,3 +1,7 @@
Somewhere in there:
function contracts now preserve tail recursion in many cases; the
'any' contract is no longer special.
Version 4.1.3.8
Added procedure-rename
Added extra arguments to call-with-continuation-prompt

2
man/man1/tex2page.1
View File

@ -164,7 +164,7 @@ mpost(1).
.SH COPYRIGHT
Copyright 1997-2008 by Dorai Sitaram.
Copyright 1997-2009 by Dorai Sitaram.
Permission to distribute and use this work for any purpose is
hereby granted provided this copyright notice is included in

209
src/foreign/foreign.c
View File

@ -703,16 +703,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
#define FOREIGN_string_ucs_4 (18)
/* Type Name: string/ucs-4 (string_ucs_4)
* LibFfi type: ffi_type_pointer
* C type: mzchar*
* Predicate: SCHEME_CHAR_STRINGP(<Scheme>)
* Scheme->C: SCHEME_CHAR_STR_VAL(<Scheme>)
* S->C offset: 0
* C->Scheme: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_ucs_4_null (19)
/* Type Name: string/ucs-4/null (string_ucs_4_null)
* LibFfi type: ffi_type_pointer
* C type: mzchar*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
@ -721,18 +711,8 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: scheme_make_char_string_without_copying(<C>)
*/
#define FOREIGN_string_utf_16 (20)
#define FOREIGN_string_utf_16 (19)
/* Type Name: string/utf-16 (string_utf_16)
* LibFfi type: ffi_type_pointer
* C type: unsigned short*
* Predicate: SCHEME_CHAR_STRINGP(<Scheme>)
* Scheme->C: ucs4_string_to_utf16_pointer(<Scheme>)
* S->C offset: 0
* C->Scheme: utf16_pointer_to_ucs4_string(<C>)
*/
#define FOREIGN_string_utf_16_null (21)
/* Type Name: string/utf-16/null (string_utf_16_null)
* LibFfi type: ffi_type_pointer
* C type: unsigned short*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>)
@ -744,7 +724,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Byte strings -- not copying C strings, #f is NULL.
* (note: these are not like char* which is just a pointer) */
#define FOREIGN_bytes (22)
#define FOREIGN_bytes (20)
/* Type Name: bytes
* LibFfi type: ffi_type_pointer
* C type: char*
@ -754,7 +734,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
*/
#define FOREIGN_path (23)
#define FOREIGN_path (21)
/* Type Name: path
* LibFfi type: ffi_type_pointer
* C type: char*
@ -764,7 +744,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
* C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
*/
#define FOREIGN_symbol (24)
#define FOREIGN_symbol (22)
/* Type Name: symbol
* LibFfi type: ffi_type_pointer
* C type: char*
@ -777,7 +757,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is for any C pointer: #f is NULL, cpointer values as well as
* ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */
#define FOREIGN_pointer (25)
#define FOREIGN_pointer (23)
/* Type Name: pointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -789,7 +769,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */
#define FOREIGN_scheme (26)
#define FOREIGN_scheme (24)
/* Type Name: scheme
* LibFfi type: ffi_type_pointer
* C type: Scheme_Object*
@ -802,7 +782,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
/* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for
* creating function types. */
#define FOREIGN_fpointer (27)
#define FOREIGN_fpointer (25)
/* Type Name: fpointer
* LibFfi type: ffi_type_pointer
* C type: void*
@ -830,9 +810,7 @@ typedef union _ForeignAny {
double x_doubleS;
int x_bool;
mzchar* x_string_ucs_4;
mzchar* x_string_ucs_4_null;
unsigned short* x_string_utf_16;
unsigned short* x_string_utf_16_null;
char* x_bytes;
char* x_path;
char* x_symbol;
@ -842,7 +820,7 @@ typedef union _ForeignAny {
} ForeignAny;
/* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (28)
#define FOREIGN_struct (26)
/*****************************************************************************/
/* Type objects */
@ -963,9 +941,7 @@ static int ctype_sizeof(Scheme_Object *type)
case FOREIGN_doubleS: return sizeof(double);
case FOREIGN_bool: return sizeof(int);
case FOREIGN_string_ucs_4: return sizeof(mzchar*);
case FOREIGN_string_ucs_4_null: return sizeof(mzchar*);
case FOREIGN_string_utf_16: return sizeof(unsigned short*);
case FOREIGN_string_utf_16_null: return sizeof(unsigned short*);
case FOREIGN_bytes: return sizeof(char*);
case FOREIGN_path: return sizeof(char*);
case FOREIGN_symbol: return sizeof(char*);
@ -1097,19 +1073,62 @@ static Scheme_Object *foreign_make_cstruct_type(int argc, Scheme_Object *argv[])
return (Scheme_Object*)type;
}
/*****************************************************************************/
/* Callback type */
/* ffi-callback structure definition */
static Scheme_Type ffi_callback_tag;
typedef struct ffi_callback_struct {
Scheme_Object so;
void* callback;
Scheme_Object* proc;
Scheme_Object* itypes;
Scheme_Object* otype;
int call_in_scheduler;
} ffi_callback_struct;
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
#undef MYNAME
#define MYNAME "ffi-callback?"
static Scheme_Object *foreign_ffi_callback_p(int argc, Scheme_Object *argv[])
{ return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false; }
/* 3m stuff for ffi_callback */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;int ffi_callback_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_MARK(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcMARK(s->callback);
gcMARK(s->proc);
gcMARK(s->itypes);
gcMARK(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_FIXUP(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcFIXUP(s->callback);
gcFIXUP(s->proc);
gcFIXUP(s->itypes);
gcFIXUP(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
END_XFORM_SKIP;
#endif
/*****************************************************************************/
/* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */
#define SCHEME_FFIANYPTRP(x) \
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
SCHEME_BYTE_STRINGP(x))
SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
#define SCHEME_FFIANYPTR_VAL(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
(SCHEME_FALSEP(x) ? NULL : \
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
NULL)))
(SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
(SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
@ -1149,47 +1168,6 @@ static Scheme_Object *foreign_set_cpointer_tag_bang(int argc, Scheme_Object *arg
return scheme_void;
}
/*****************************************************************************/
/* Callback type */
/* ffi-callback structure definition */
static Scheme_Type ffi_callback_tag;
typedef struct ffi_callback_struct {
Scheme_Object so;
void* callback;
Scheme_Object* proc;
Scheme_Object* itypes;
Scheme_Object* otype;
} ffi_callback_struct;
#define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag)
#undef MYNAME
#define MYNAME "ffi-callback?"
static Scheme_Object *foreign_ffi_callback_p(int argc, Scheme_Object *argv[])
{ return SCHEME_FFICALLBACKP(argv[0]) ? scheme_true : scheme_false; }
/* 3m stuff for ffi_callback */
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;int ffi_callback_SIZE(void *p) {
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_MARK(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcMARK(s->callback);
gcMARK(s->proc);
gcMARK(s->itypes);
gcMARK(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
int ffi_callback_FIXUP(void *p) {
ffi_callback_struct *s = (ffi_callback_struct *)p;
gcFIXUP(s->callback);
gcFIXUP(s->proc);
gcFIXUP(s->itypes);
gcFIXUP(s->otype);
return gcBYTES_TO_WORDS(sizeof(ffi_callback_struct));
}
END_XFORM_SKIP;
#endif
/*****************************************************************************/
/* Scheme<-->C conversions */
@ -1240,9 +1218,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false);
case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
case FOREIGN_string_ucs_4_null: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*));
case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
case FOREIGN_string_utf_16_null: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*));
case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*));
case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*));
case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*));
@ -1287,6 +1263,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
else if (SCHEME_FALSEP(val))
((void**)W_OFFSET(dst,delta))[0] = NULL;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
@ -1492,9 +1470,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
delta += (sizeof(int)-sizeof(mzchar*));
}
#endif
if (SCHEME_CHAR_STRINGP(val)) {
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(SCHEME_CHAR_STR_VAL(val));
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL ||tmp == NULL) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
@ -1506,54 +1484,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_ucs_4_null:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(mzchar*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(mzchar*));
}
#endif
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp;
tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
if (basetype_p == NULL ||tmp == NULL) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_ucs_4_null;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/ucs-4/null",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*));
}
#endif
if (SCHEME_CHAR_STRINGP(val)) {
unsigned short* tmp;
tmp = (unsigned short*)(ucs4_string_to_utf16_pointer(val));
if (basetype_p == NULL ||tmp == NULL) {
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_utf_16;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_string_utf_16_null:
#ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*));
}
#endif
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp;
@ -1562,11 +1498,11 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
(((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL;
} else {
*basetype_p = FOREIGN_string_utf_16_null;
*basetype_p = FOREIGN_string_utf_16;
return tmp;
}
} else {
scheme_wrong_type("Scheme->C","string/utf-16/null",0,1,&(val));
scheme_wrong_type("Scheme->C","string/utf-16",0,1,&(val));
return NULL; /* hush the compiler */
}
case FOREIGN_bytes:
@ -2577,12 +2513,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv = argv_stack;
else
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
if (data->call_in_scheduler)
scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
}
/* see ffi-callback below */
@ -2685,6 +2625,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
data->proc = (argv[0]);
data->itypes = (argv[1]);
data->otype = (argv[2]);
data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
#ifdef MZ_PRECISE_GC
{
/* put data in immobile, weak box */
@ -2799,14 +2740,14 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 1), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
scheme_add_global("cpointer?",
scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv);
scheme_add_global("cpointer-tag",
scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv);
scheme_add_global("ffi-callback?",
scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv);
scheme_add_global("ctype-sizeof",
scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof",
@ -2850,7 +2791,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("ffi-call",
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback",
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 4), menv);
scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv);
s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
@ -2977,13 +2918,6 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/ucs-4/null");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4_null);
scheme_add_global("_string/ucs-4/null", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
@ -2991,13 +2925,6 @@ void scheme_init_foreign(Scheme_Env *env)
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("string/utf-16/null");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;
t->basetype = (s);
t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16_null);
scheme_add_global("_string/utf-16/null", (Scheme_Object*)t, menv);
s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag;

51
src/foreign/foreign.ssc
View File

@ -653,13 +653,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
)
(defctype 'string/ucs-4
'ftype "pointer"
'ctype "mzchar*"
'pred "SCHEME_CHAR_STRINGP"
's->c "SCHEME_CHAR_STR_VAL"
'c->s "scheme_make_char_string_without_copying")
(defctype 'string/ucs-4/null
'ftype "pointer"
'ctype "mzchar*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
@ -667,13 +660,6 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf)
'c->s "scheme_make_char_string_without_copying")
(defctype 'string/utf-16
'ftype "pointer"
'ctype "unsigned short*"
'pred "SCHEME_CHAR_STRINGP"
's->c "ucs4_string_to_utf16_pointer"
'c->s "utf16_pointer_to_ucs4_string")
(defctype 'string/utf-16/null
'ftype "pointer"
'ctype "unsigned short*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
@ -937,19 +923,30 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
return (Scheme_Object*)type;
}
/*****************************************************************************/
/* Callback type */
{:(cdefstruct ffi-callback
(callback "void*")
(proc "Scheme_Object*")
(itypes "Scheme_Object*")
(otype "Scheme_Object*")
(call_in_scheduler "int")):}
/*****************************************************************************/
/* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */
#define SCHEME_FFIANYPTRP(x) \
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(x) || \
SCHEME_BYTE_STRINGP(x))
SCHEME_BYTE_STRINGP(x) || SCHEME_FFICALLBACKP(x))
#define SCHEME_FFIANYPTR_VAL(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
(SCHEME_FALSEP(x) ? NULL : \
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
NULL)))
(SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
(SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \
@ -983,15 +980,6 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
return scheme_void;
}
/*****************************************************************************/
/* Callback type */
{:(cdefstruct ffi-callback
(callback "void*")
(proc "Scheme_Object*")
(itypes "Scheme_Object*")
(otype "Scheme_Object*")):}
/*****************************************************************************/
/* Scheme<-->C conversions */
@ -1068,6 +1056,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj;
else if (SCHEME_FALSEP(val))
((void**)W_OFFSET(dst,delta))[0] = NULL;
else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) {
@ -1966,12 +1956,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv = argv_stack;
else
argv = scheme_malloc(argc * sizeof(Scheme_Object*));
if (data->call_in_scheduler)
scheme_start_in_scheduler();
for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v;
}
p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
}
/* see ffi-callback below */
@ -2002,7 +1996,7 @@ void free_cl_cif_args(void *ignored, void *p)
/* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */
/* the treatment of in-types and out-types is similar to that in ffi-call */
/* the real work is done by ffi_do_callback above */
{:(cdefine ffi-callback 3 4):}
{:(cdefine ffi-callback 3 5):}
{
ffi_callback_struct *data;
Scheme_Object *itypes = argv[1];
@ -2067,7 +2061,8 @@ void free_cl_cif_args(void *ignored, void *p)
if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "data" ffi-callback
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"):}
"cl_cif_args" "argv[0]" "argv[1]" "argv[2]"
"((argc > 4) && SCHEME_TRUEP(argv[4]))"):}
#ifdef MZ_PRECISE_GC
{
/* put data in immobile, weak box */

2
src/mac/cw/MrEd.r
View File

@ -10,7 +10,7 @@ data 'DITL' (129) {
$"0081 0000 0000 0018 008F 0048 0170 8844" /* .<2E>.......<EFBFBD>.H.pˆD */
$"4372 6561 7465 6420 7769 7468 2050 4C54" /* Created with PLT */
$"2053 6368 656D 650D A920 3230 3034 2D32" /* Scheme.© 2004-2 */
$"3030 3720 504C 5420 5363 6865 6D65 2049" /* 007 PLT Scheme I */
$"3030 3920 504C 5420 5363 6865 6D65 2049" /* 009 PLT Scheme I */
$"6E63 2E20 0DA9 2031 3939 352D 3230 3033" /* nc. .© 1995-2003 */
$"2050 4C54 0000 0000 004D 008F 0089 018F" /* PLT.....M.<EFBFBD>.‰.<EFBFBD> */
$"884E 466F 7220 7570 2D74 6F2D 6461 7465" /* ˆNFor up-to-date */

2
src/mred/mred.cxx
View File

@ -3,7 +3,7 @@
* Purpose: MrEd main file, including a hodge-podge of global stuff
* Author: Matthew Flatt
* Created: 1995
* Copyright: (c) 2004-2008 PLT Scheme Inc.
* Copyright: (c) 2004-2009 PLT Scheme Inc.
* Copyright: (c) 1995-2000, Matthew Flatt
*/

2
src/mred/mred.h
View File

@ -189,7 +189,7 @@ MRED_EXTERN void mred_set_run_from_cmd_line(MrEd_Run_From_Cmd_Line_Proc);
# define mrVERSION_SUFFIX " [cgc]"
# endif
#endif
#define BANNER "MrEd v" MZSCHEME_VERSION mrVERSION_SUFFIX ", Copyright (c) 2004-2008 PLT Scheme Inc.\n"
#define BANNER "MrEd v" MZSCHEME_VERSION mrVERSION_SUFFIX ", Copyright (c) 2004-2009 PLT Scheme Inc.\n"
#ifndef WINDOW_STDIO
/* Removing "|| defined(wx_msw)" below uses the Windows console.

98
src/mred/mredmac.cxx
View File

@ -3,7 +3,7 @@
* Purpose: MrEd MacOS event loop
* Author: Matthew Flatt
* Created: 1996
* Copyright: (c) 2004-2008 PLT Scheme Inc.
* Copyright: (c) 2004-2009 PLT Scheme Inc.
* Copyright: (c) 1996, Matthew Flatt
*/
@ -1179,103 +1179,20 @@ int MrEdCheckForBreak(void)
/***************************************************************************/
#include <pthread.h>
static volatile int thread_running;
static volatile int need_post; /* 0=>1 transition has a benign race condition, an optimization */
static SLEEP_PROC_PTR mzsleep;
static pthread_t watcher;
static volatile float sleep_secs;
/* These file descriptors act as semaphores: */
static int watch_read_fd, watch_write_fd;
static int watch_done_read_fd, watch_done_write_fd;
/* These file descriptors are used for breaking the event loop.
See ARGH below. */
/* These file descriptors are used for breaking the event loop. */
static int cb_socket_ready;
static int ready_sock, write_ready_sock;
#ifdef MZ_PRECISE_GC
START_XFORM_SKIP;
#endif
static void *do_watch(void *fds)
{
while (1) {
char buf[1];
read(watch_read_fd, buf, 1);
mzsleep(sleep_secs, fds);
if (need_post) {
need_post = 0;
if (cb_socket_ready) {
/* Sometimes WakeUpProcess() doesn't work.
Try a notification socket as a backup.
See ARGH below. */
write(write_ready_sock, "y", 1);
}
}
write(watch_done_write_fd, "y", 1);
}
return NULL;
}
#ifdef MZ_PRECISE_GC
END_XFORM_SKIP;
#endif
static int StartFDWatcher(void (*mzs)(float secs, void *fds), float secs, void *fds)
{
if (!watch_write_fd) {
int fds[2];
if (!pipe(fds)) {
watch_read_fd = fds[0];
watch_write_fd = fds[1];
} else {
return 0;
}
}
if (!watch_done_write_fd) {
int fds[2];
if (!pipe(fds)) {
watch_done_read_fd = fds[0];
watch_done_write_fd = fds[1];
} else {
return 0;
}
}
if (!watcher) {
if (pthread_create(&watcher, NULL, do_watch, fds)) {
return 0;
}
}
mzsleep = mzs;
sleep_secs = secs;
thread_running = 1;
need_post = 1;
write(watch_write_fd, "x", 1);
scheme_start_sleeper_thread(mzs, secs, fds, write_ready_sock);
return 1;
}
static void EndFDWatcher(void)
{
char buf[1];
if (thread_running) {
if (need_post) {
need_post = 0;
scheme_signal_received();
}
read(watch_done_read_fd, buf, 1);
thread_running = 0;
}
scheme_end_sleeper_thread();
}
void socket_callback(CFSocketRef s, CFSocketCallBackType type, CFDataRef address, const void *data, void *info)
@ -1369,11 +1286,8 @@ void MrEdMacSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep)
going++;
if (need_post) /* useless check in principle, but an optimization
in the case that the select() succeeds before
we even start */
if (WNE(&e, secs ? secs : kEventDurationForever))
QueueTransferredEvent(&e);
if (WNE(&e, secs ? secs : kEventDurationForever))
QueueTransferredEvent(&e);
--going;

2
src/mred/mredmsw.cxx
View File

@ -3,7 +3,7 @@
* Purpose: MrEd Windows event loop
* Author: Matthew Flatt
* Created: 1996
* Copyright: (c) 2004-2008 PLT Scheme Inc.
* Copyright: (c) 2004-2009 PLT Scheme Inc.
* Copyright: (c) 1996, Matthew Flatt
*/

Some files were not shown because too many files have changed in this diff Show More