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

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 ;; Main compilation procedures
;; (c) 1997-2008 PLT ;; (c) 1997-2009 PLT
;; The various procedures provided by this library are implemented ;; The various procedures provided by this library are implemented
;; by dynamically linking to code supplied by the MzLib, dynext, and ;; 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))) (parse-options (current-command-line-arguments)))
(when (compiler:option:somewhat-verbose) (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) (version)
(system-type 'gc))) (system-type 'gc)))

35
collects/ffi/objc.scrbl
View File

@ -3,7 +3,7 @@
scribble/eval scribble/eval
(for-label scheme/base (for-label scheme/base
scheme/foreign scheme/foreign
ffi/objc)) "private/objc-doc-unsafe.ss"))
@(define objc-eval (make-base-eval)) @(define objc-eval (make-base-eval))
@(interaction-eval #:eval objc-eval (define-struct cpointer:id ())) @(interaction-eval #:eval objc-eval (define-struct cpointer:id ()))
@ -13,7 +13,9 @@
@title{@bold{Objective-C} FFI} @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 @schememodname[scheme/foreign] to support interaction with
@link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.} @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 argument and result types must be declared in terms of FFI C types
(@seeCtype). (@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[] @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} @section{FFI Types and Constants}
@defthing[_id ctype?]{ @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)) (eval:alts (import-class NSString) (void))
]} ]}
@defform/subs[#:literals (+ -) @defform/subs[#:literals (+ - +a -a)
(define-objc-class class-id superclass-expr (define-objc-class class-id superclass-expr
[field-id ...] [field-id ...]
method) method)
([method (mode result-ctype-expr (method-id) body ...+) ([method (mode result-ctype-expr (method-id) body ...+)
(mode result-ctype-expr (arg ...+) body ...+)] (mode result-ctype-expr (arg ...+) body ...+)]
[mode + -] [mode + - +a -a]
[arg (code:line method-id [ctype-expr arg-id])])]{ [arg (code:line method-id [ctype-expr arg-id])])]{
Defines @scheme[class-id] as a new, registered Objective-C class (of 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!]. be referenced and set with @scheme[get-ivar] and @scheme[set-ivar!].
Each @scheme[method] adds or overrides a method to the class (when 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 @scheme[mode] is @scheme[-] or @scheme[-a]) to be called on instances,
method to the meta-class (when @scheme[mode] is @scheme[+]) to be or it adds a method to the meta-class (when @scheme[mode] is
called on the class itself. All result and argument types must be @scheme[+] or @scheme[+a]) to be called on the class itself. All
declared using FFI C types (@seeCtype). 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 If a @scheme[method] is declared with a single @scheme[method-id] and
no arguments, then @scheme[method-id] must not end with 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) (define-syntax-rule (define-objc id type)
(begin (begin
(provide id) (provide* (unsafe id))
(define-objc/private id id type))) (define-objc/private id id type)))
;; ---------------------------------------- ;; ----------------------------------------
@ -86,16 +86,16 @@
(define msgSends (make-hash)) (define msgSends (make-hash))
(define (objc_msgSend/typed types) (define (objc_msgSend/typed types)
(lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id)) (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
(provide objc_msgSend/typed) (provide* (unsafe objc_msgSend/typed))
(define msgSendSupers (make-hash)) (define msgSendSupers (make-hash))
(define (objc_msgSendSuper/typed types) (define (objc_msgSendSuper/typed types)
(lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer)) (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) (define-syntax (import-class stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
@ -107,7 +107,7 @@
;; ---------------------------------------- ;; ----------------------------------------
;; iget-value and set-ivar! work only with fields that contain Scheme values ;; 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) (define-for-syntax (check-ivar ivar stx)
(unless (identifier? ivar) (unless (identifier? ivar)
@ -161,7 +161,7 @@
(hash-set! method-sels sym id) (hash-set! method-sels sym id)
id))) id)))
(provide selector) (provide* (unsafe selector))
(define-syntax (selector stx) (define-syntax (selector stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
@ -256,7 +256,7 @@
arg))) arg)))
(loop (cdr rest)))))))) (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) (define-for-syntax (build-send stx result-type send/typed send-args l-stx)
(let ([l (syntax->list l-stx)]) (let ([l (syntax->list l-stx)])
(with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)] (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) (define-syntax (define-objc-class stx)
(syntax-case stx () (syntax-case stx ()
@ -364,7 +364,7 @@
;; Given a dealloc extension: ;; Given a dealloc extension:
#'() #'()
;; Need to add one explicitly: ;; Need to add one explicitly:
#'((- _void (dealloc) (void)))))]) #'((-a _void (dealloc) (void)))))])
(syntax/loc stx (syntax/loc stx
(begin (begin
(define superclass-id superclass) (define superclass-id superclass)
@ -454,10 +454,13 @@
(syntax-case #'m () (syntax-case #'m ()
[(kind result-type (id arg ...) body0 body ...) [(kind result-type (id arg ...) body0 body ...)
(or (free-identifier=? #'kind #'+) (or (free-identifier=? #'kind #'+)
(free-identifier=? #'kind #'-)) (free-identifier=? #'kind #'-)
(free-identifier=? #'kind #'+a)
(free-identifier=? #'kind #'-a))
(let ([id #'id] (let ([id #'id]
[args (syntax->list #'(arg ...))] [args (syntax->list #'(arg ...))]
[in-class? (free-identifier=? #'kind #'+)]) [in-class? (or (free-identifier=? #'kind #'+)
(free-identifier=? #'kind #'+a))])
(when (null? args) (when (null? args)
(unless (identifier? id) (unless (identifier? id)
(raise-syntax-error #f (raise-syntax-error #f
@ -485,7 +488,9 @@
'())] '())]
[in-cls (if in-class? [in-cls (if in-class?
#'(object_getClass cls) #'(object_getClass cls)
#'cls)]) #'cls)]
[atomic? (or (free-identifier=? #'kind #'+a)
(free-identifier=? #'kind #'-a))])
(syntax/loc stx (syntax/loc stx
(let ([rt result-type] (let ([rt result-type]
[arg-id arg-type] ...) [arg-id arg-type] ...)
@ -498,7 +503,7 @@
[super-tell do-super-tell]) [super-tell do-super-tell])
body0 body ... body0 body ...
dealloc-body ...))) dealloc-body ...)))
(_fun _id _id arg-type ... -> rt) (_fun #:atomic? atomic? _id _id arg-type ... -> rt)
(generate-layout rt (list arg-id ...)))))))))] (generate-layout rt (list arg-id ...)))))))))]
[else (raise-syntax-error #f [else (raise-syntax-error #f
"bad method form" "bad method form"
@ -549,3 +554,8 @@
#'objc_msgSendSuper/typed #'objc_msgSendSuper/typed
#'((make-objc_super self super-class)) #'((make-objc_super self super-class))
#'(method/arg ...))])) #'(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: @item{Create a file @filepath{config.ss} with the following content:
@schemeblock[((active-dirs ("test")) @schemeblock[((active-dirs ("test"))
(https-port-number 9780))]} (https-port-number 7980))]}
@item{In your new directory, run @commandline{mred-text -l handin-server}} @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 active, design a checker to help ensure that the student has selected
the correct assignment in the handin dialog. the correct assignment in the handin dialog.
A student can download his/her own submissions through a web server A student can download his/her own submissions through the handin
that runs concurrently with the handin server. The starting URL is 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/} @commandline{https://SERVER:PORT/}
@ -478,5 +481,4 @@ to obtain a list of all assignments, or
@commandline{https://SERVER:PORT/?handin=ASSIGNMENT} @commandline{https://SERVER:PORT/?handin=ASSIGNMENT}
to start with a specific assignment (named ASSIGNMENT). The default to start with a specific assignment (named ASSIGNMENT).
PORT is 7980.

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

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

4
collects/help/search.ss
View File

@ -9,9 +9,11 @@
;; using javascript. ;; using javascript.
(define (send-main-page #:sub [sub "index.html"] (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)] (let* ([path (build-path (find-user-doc-dir) sub)]
[path (if (file-exists? path) path (build-path (find-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))) (send-url/file path #:fragment fragment #:query query)))
;; This is an example of changing this code to use the online manuals. ;; 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) (define (color-list->image cl in-w in-h px py)
(check 'color-list->image color-list? cl "list-of-colors" "first") (check 'color-list->image color-list? cl "list-of-colors" "first")
(check-posi-size 'color-list->image in-w "second") (check-size/0 'color-list->image in-w "second")
(check-posi-size 'color-list->image in-h "third") (check-size/0 'color-list->image in-h "third")
(check-coordinate 'color-list->image px "fourth") (check-coordinate 'color-list->image px "fourth")
(check-coordinate 'color-list->image py "fifth") (check-coordinate 'color-list->image py "fifth")
(let ([w (inexact->exact in-w)] (let ([w (inexact->exact in-w)]
[h (inexact->exact in-h)]) [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)) (unless (= (* w h) (length cl))
(error 'color-list->image (error 'color-list->image
"given width times given height is ~a, but the given color list has ~a items" "given width times given height is ~a, but the given color list has ~a items"
(* w h) (* w h)
(length cl))) (length cl)))
(let* ([bm (make-object bitmap% w h)]
[mask-bm (make-object bitmap% w h)] (cond
[dc (make-object bitmap-dc% bm)] [(or (equal? w 0) (equal? h 0))
[mask-dc (make-object bitmap-dc% mask-bm)]) (put-pinhole (rectangle w h 'solid 'black) px py)]
(unless (send bm ok?) [else
(error (format "cannot make ~a x ~a image" w h))) (unless (and (< 0 w 10000) (< 0 h 10000))
(let ([is (make-bytes (* 4 w h) 0)] (error 'color-list->image "cannot make ~a x ~a image" w h))
[mask-is (make-bytes (* 4 w h) 0)]
[cols (list->vector (map (λ (x) (let* ([bm (make-object bitmap% w h)]
(or (make-color% x) [mask-bm (make-object bitmap% w h)]
(error 'color-list->image "color ~e is unknown" x))) [dc (make-object bitmap-dc% bm)]
cl))]) [mask-dc (make-object bitmap-dc% mask-bm)])
(let yloop ([y 0][pos 0]) (unless (send bm ok?)
(unless (= y h) (error (format "cannot make ~a x ~a image" w h)))
(let xloop ([x 0][pos pos]) (let ([is (make-bytes (* 4 w h) 0)]
(if (= x w) [mask-is (make-bytes (* 4 w h) 0)]
(yloop (add1 y) pos) [cols (list->vector (map (λ (x)
(let* ([col (vector-ref cols (+ x (* y w)))] (or (make-color% x)
[r (pk (send col red))] (error 'color-list->image "color ~e is unknown" x)))
[g (pk (send col green))] cl))])
[b (pk (send col blue))]) (let yloop ([y 0][pos 0])
(bytes-set! is (+ 1 pos) r) (unless (= y h)
(bytes-set! is (+ 2 pos) g) (let xloop ([x 0][pos pos])
(bytes-set! is (+ 3 pos) b) (if (= x w)
(when (= 255 r g b) (yloop (add1 y) pos)
(bytes-set! mask-is (+ 1 pos) 255) (let* ([col (vector-ref cols (+ x (* y w)))]
(bytes-set! mask-is (+ 2 pos) 255) [r (pk (send col red))]
(bytes-set! mask-is (+ 3 pos) 255)) [g (pk (send col green))]
(xloop (add1 x) (+ pos 4))))))) [b (pk (send col blue))])
(send dc set-argb-pixels 0 0 w h is) (bytes-set! is (+ 1 pos) r)
(send mask-dc set-argb-pixels 0 0 w h mask-is)) (bytes-set! is (+ 2 pos) g)
(send dc set-bitmap #f) (bytes-set! is (+ 3 pos) b)
(send mask-dc set-bitmap #f) (when (= 255 r g b)
(bitmaps->cache-image-snip bm mask-bm px py)))) (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 (pk col) (min 255 (max 0 col)))
(define (alpha-color-list->image cl in-w in-h px py) (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 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first")
(check-posi-size 'alpha-color-list->image in-w "second") (check-size/0 '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-h "third")
(check-coordinate 'alpha-color-list->image px "fourth") (check-coordinate 'alpha-color-list->image px "fourth")
(check-coordinate 'alpha-color-list->image py "fifth") (check-coordinate 'alpha-color-list->image py "fifth")
(let ([w (inexact->exact in-w)] (let ([w (inexact->exact in-w)]
[h (inexact->exact in-h)]) [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)) (unless (= (* w h) (length cl))
(error 'alpha-color-list->image (error 'alpha-color-list->image
"given width times given height is ~a, but the given color list has ~a items" "given width times given height is ~a, but the given color list has ~a items"
(* w h) (length cl))) (* w h) (length cl)))
(let ([index-list (alpha-colors->ent-list cl)]) (cond
(argb->cache-image-snip (make-argb (list->vector index-list) w h) px py)))) [(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) ;; alpha-colors->ent-list : (listof alpha-color) -> (listof number)
(define (alpha-colors->ent-list cl) (define (alpha-colors->ent-list cl)

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

@ -2,13 +2,12 @@
(require mzlib/pretty (require mzlib/pretty
mzlib/date mzlib/date
mzlib/list mzlib/list
mzlib/etc) mzlib/etc
"html-spec.ss")
; date-string : -> String ; date-string : -> String
(define (date-string) (date->string (seconds->date (current-seconds)) 'seconds-please)) (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-name? x) (null? (cdr x)))
(define empty-names (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/list
mzlib/etc mzlib/etc
mzlib/include mzlib/include
"html-spec.ss"
"html-sig.ss" "html-sig.ss"
"sgml-reader-sig.ss" "sgml-reader-sig.ss"
xml/xml-sig) xml/xml-sig)
@ -118,7 +119,7 @@
;; may-contain : Kid-lister ;; may-contain : Kid-lister
(define may-contain (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 (define may-contain-anything
(sgml:gen-may-contain null)) (sgml:gen-may-contain null))

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

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

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

@ -88,9 +88,9 @@
;; A PatternParseResult is one of ;; A PatternParseResult is one of
;; - (listof value) ;; - (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 (ok? x) (or (pair? x) (null? x)))
(define-struct failed (stx patstx reason) (define-struct failed (stx patstx reason frontier)
#:transparent) #:transparent)

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

@ -14,11 +14,11 @@
(define-syntax-rule (define-pred-stxclass name pred) (define-syntax-rule (define-pred-stxclass name pred)
(define-basic-syntax-class name (define-basic-syntax-class name
([datum 0]) () ;; ([datum 0])
(lambda (x) (lambda (x)
(let ([d (if (syntax? x) (syntax-e x) x)]) (let ([d (if (syntax? x) (syntax-e x) x)])
(if (pred d) (if (pred d)
(list d) null ;; (list d)
(fail-sc x #:pattern 'name)))))) (fail-sc x #:pattern 'name))))))
(define-pred-stxclass identifier symbol?) (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 ;; - 'fail' stxparameterized to (non-escaping!) failure procedure
(define-struct pk (ps k) #:transparent) (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 ;; A FrontierIndex is one of
;; - nat ;; - nat
;; - `(+ ,nat expr ...) ;; - `(+ ,nat Syntax ...)
(define (empty-frontier x) (define (empty-frontier x)
(list 0 x)) (list 0 x))
@ -59,7 +61,7 @@
(with-syntax ([(arg ...) args]) (with-syntax ([(arg ...) args])
#`(lambda (x arg ...) #`(lambda (x arg ...)
(define (fail-rhs x expected reason frontier) (define (fail-rhs x expected reason frontier)
(make-failed x expected reason)) (make-failed x expected reason frontier))
#,(parse:pks (list #'x) #,(parse:pks (list #'x)
(list (empty-frontier #'x)) (list (empty-frontier #'x))
(rhs->pks rhs relsattrs #'x) (rhs->pks rhs relsattrs #'x)
@ -72,7 +74,7 @@
(with-syntax ([k k] [x x] [p p] [reason reason] (with-syntax ([k k] [x x] [p p] [reason reason]
[fc-expr (frontier->expr fc)]) [fc-expr (frontier->expr fc)])
#`(let ([failcontext fc-expr]) #`(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)))) (k x p 'reason failcontext))))
;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)
@ -309,7 +311,7 @@
[sub-parse-expr [sub-parse-expr
#`(#,(ssc-parser-name ssc) #,(car vars) #,@args)]) #`(#,(ssc-parser-name ssc) #,(car vars) #,@args)])
#'sub-parse-expr)))] #'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) rest-ps)
k)) k))
(let* ([xvar (car (generate-temporaries (list #'x)))] (let* ([xvar (car (generate-temporaries (list #'x)))]
@ -360,11 +362,6 @@
(if maxrep (if maxrep
#`(< #,repvar #,maxrep) #`(< #,repvar #,maxrep)
#`#t))] #`#t))]
[(minrepclause ...)
(for/list ([repvar reps] [minrep mins] #:when minrep)
#`[(< #,repvar #,minrep)
#,(fail #'enclosing-fail (car vars)
#:reason "minimum repetition constraint failed")])]
[(occurs-binding ...) [(occurs-binding ...)
(for/list ([head heads] [rep reps] #:when (head-occurs head)) (for/list ([head heads] [rep reps] #:when (head-occurs head))
#`[#,(head-occurs head) (positive? #,rep)])] #`[#,(head-occurs head) (positive? #,rep)])]
@ -376,10 +373,20 @@
(let ([rep (add1 rep)]) (let ([rep (add1 rep)])
(parse-loop x #,@hid-args #,@reps enclosing-fail)) (parse-loop x #,@hid-args #,@reps enclosing-fail))
#,(fail #'enclosing-fail #'var0 #,(fail #'enclosing-fail #'var0
#:fc (frontier:add-index (car fcs)
#'(calculate-index rep ...))
#:reason "maxiumum repetition constraint failed"))) #:reason "maxiumum repetition constraint failed")))
...]] ...]]
[tail-rhs [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 [else
(let ([hid (finalize hid-arg)] ... ... (let ([hid (finalize hid-arg)] ... ...
occurs-binding ... 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))] (make pat:datum stx null depth (syntax->datum #'datum))]
[(heads gdots . tail) [(heads gdots . tail)
(gdots? #'gdots) (gdots? #'gdots)
(let* ([heads (parse-heads #'heads decls (add1 depth))] (let* ([heads (parse-heads #'heads decls depth)]
[tail (parse-pattern #'tail decls depth)] [tail (parse-pattern #'tail decls depth)]
[hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)] [hattrs (append-attrs (for/list ([head heads]) (head-attrs head)) stx)]
[tattrs (pattern-attrs tail)]) [tattrs (pattern-attrs tail)])
@ -372,40 +372,6 @@
[(struct pattern (orig-stx iattrs depth)) [(struct pattern (orig-stx iattrs depth))
(make head orig-stx iattrs depth (list p) #f #f #t #f #f)])) (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 (define head-directive-table
(list (list '#:min check-nat/f) (list (list '#:min check-nat/f)
(list '#:max check-nat/f) (list '#:max check-nat/f)
@ -414,9 +380,24 @@
(list '#:opt) (list '#:opt)
(list '#:mand))) (list '#:mand)))
(define (parse-heads-k stx heads heads-attrs heads-depth k) (define (parse-heads stx decls enclosing-depth)
(define-values (chunks rest) (chunk-kw-seq/no-dups stx head-directive-table)) (syntax-case stx ()
(reject-duplicate-chunks chunks) [({} . 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)] (let* ([min-row (assq '#:min chunks)]
[max-row (assq '#:max chunks)] [max-row (assq '#:max chunks)]
[occurs-row (assq '#:occurs chunks)] [occurs-row (assq '#:occurs chunks)]
@ -443,20 +424,42 @@
(unless opt-row (unless opt-row
(raise-syntax-error #f (raise-syntax-error #f
"default only allowed for optional patterns" "default only allowed for optional patterns"
(cadr default-row))) (cadr default-row))))
(unless (and (pair? head-attrs) (parse-head/options pstx
(null? (cdr head-attrs)) decls
(= heads-depth (attr-depth (car head-attrs))) enclosing-depth
(null? (attr-inner (car head-attrs)))) (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 (raise-syntax-error #f
"default only allowed for patterns with single simple pattern variable" "default only allowed for patterns with single simple pattern variable"
(cadr default-row)))) (cadr default-row))))
(k rest (let ([occurs-attrs
(cond [opt-row 0] [mand-row 1] [else min]) (if occurs-pvar
(cond [opt-row 1] [mand-row 1] [else max]) (list (make-attr occurs-pvar depth null))
(not (or opt-row mand-row)) null)])
(and occurs-row (caddr occurs-row)) (make head pstx
(and default-row (caddr default-row))))) (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) ;; append-attrs : (listof (listof IAttr)) stx -> (listof IAttr)
(define (append-attrs attrss stx) (define (append-attrs attrss stx)

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

@ -214,7 +214,7 @@
(frontier->syntax rest)])) (frontier->syntax rest)]))
(define (fail-sc stx #:pattern [pattern #f] #:reason [reason #f]) (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]) (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)))] (raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
[(kw . more) [(kw . more)
(keyword? (syntax-e #'kw)) (keyword? (syntax-e #'kw))
(raise-syntax-error #f "unexpected keyword" #'kw ctx)] (raise-syntax-error #f "unexpected keyword" ctx #'kw)]
[_ [_
(values (reverse rchunks) stx)])) (values (reverse rchunks) stx)]))
(loop stx null)) (loop stx null))

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

@ -196,7 +196,7 @@
) )
display))) display)))
(define/private (calculate-columns) (define/public (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size))) (define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc))) (define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size)) (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) (define/override (on-size w h)
(send config set-width w) (send config set-width w)
(send config set-height h) (send config set-height h)
(send config set-columns (send (send widget get-view) calculate-columns))
(send widget update/preserve-view)) (send widget update/preserve-view))
(define warning-panel (define warning-panel

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

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

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

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

2
collects/mzlib/md5.ss
View File

@ -2,7 +2,7 @@
(provide md5) (provide md5)
;;; Copyright (c) 2005-2008, PLT Scheme Inc. ;;; Copyright (c) 2005-2009, PLT Scheme Inc.
;;; Copyright (c) 2002, Jens Axel Soegaard ;;; Copyright (c) 2002, Jens Axel Soegaard
;;; ;;;
;;; Permission to copy this software, in whole or in part, to use this ;;; 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 result is converted into a string using @scheme[pretty-print]. The
parameter's default value prints the given string followed by a newline to parameter's default value prints the given string followed by a newline to
@scheme[(current-output-port)].} @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.
}

54
collects/mzlib/trace.ss
View File

@ -4,18 +4,15 @@
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide trace untrace (provide trace untrace
current-trace-print-args trace-apply
current-trace-notify) current-trace-notify)
(define max-dash-space-depth 10) (define max-dash-space-depth 10)
(define number-nesting-depth 6) (define number-nesting-depth 6)
(define as-spaces (define (as-spaces s)
(lambda (s) (build-string (string-length s)
(let ((n (string-length s))) (lambda (i) #\space)))
(apply string-append
(let loop ((k n))
(if (zero? k) '("")
(cons " " (loop (sub1 k)))))))))
(define-struct prefix-entry (for-first for-rest)) (define-struct prefix-entry (for-first for-rest))
@ -101,27 +98,28 @@
(lambda (name args kws kw-vals level) (lambda (name args kws kw-vals level)
(as-trace-notify (as-trace-notify
(lambda () (lambda ()
(trace-print-args name args kws kw-vals level))))) ((current-trace-print-args) name args kws kw-vals level)))))
(define trace-print-args (define current-trace-print-args
(lambda (name args kws kw-vals level) (make-parameter
(let-values (((first rest) (lambda (name args kws kw-vals level)
(build-prefixes level))) (let-values (((first rest)
(parameterize ((pretty-print-print-line (build-prefixes level)))
(lambda (n port offset width) (parameterize ((pretty-print-print-line
(display (lambda (n port offset width)
(if n (display
(if (zero? n) first (if n
(format "~n~a" rest)) (if (zero? n) first
(format "~n")) (format "~n~a" rest))
port) (format "~n"))
(if n port)
(if (zero? n) (if n
(string-length first) (if (zero? n)
(string-length rest)) (string-length first)
0)))) (string-length rest))
(pretty-print (append (cons name args) 0))))
(apply append (map list kws kw-vals)))))))) (pretty-print (append (cons name args)
(apply append (map list kws kw-vals)))))))))
(define -:trace-print-results (define -:trace-print-results
(lambda (name results level) (lambda (name results level)
@ -197,6 +195,8 @@
;; the nesting depth: ;; the nesting depth:
(define -:trace-level-key (gensym)) (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 ;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation ;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls. ;; 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) (define-syntax (r5rs:quote stx)
(syntax-case stx () (syntax-case stx ()
[(_ form) [(_ form)
@ -162,15 +170,7 @@
(ormap loop (syntax->list #'(a ...)))] (ormap loop (syntax->list #'(a ...)))]
[_ #f])) [_ #f]))
;; quote has to create mpairs: ;; quote has to create mpairs:
(syntax-local-lift-expression (let loop ([form #'form]) (syntax-local-lift-expression #'(to-mutable '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)])))
;; no pairs to worry about: ;; no pairs to worry about:
#'(quote form))])) #'(quote form))]))

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

@ -6,7 +6,8 @@
(provide (provide
(rename-out [datum #%datum]) (rename-out [datum #%datum])
#%app #%top #%top-interaction) (rename-out [#%plain-app #%app])
#%top #%top-interaction)
;; ---------------------------------------- ;; ----------------------------------------
;; Datum ;; 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 v4.2
- added white-bracket-sizing to control how the brackets - added white-bracket-sizing to control how the brackets

3000
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" "term.ss"
"loc-wrapper.ss" "loc-wrapper.ss"
"error.ss" "error.ss"
mzlib/trace
(lib "list.ss") (lib "list.ss")
(lib "etc.ss")) (lib "etc.ss"))
@ -510,16 +511,13 @@
p)]))))) p)])))))
(define (do-leaf stx orig-name lang name-table from to extras lang-id) (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 ([(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)]) (let-values ([(names names/ellipses) (extract-names lang-nts orig-name #t from)])
(with-syntax ([side-conditions-rewritten (with-syntax ([side-conditions-rewritten (rw-sc from)]
(rewrite-side-conditions/check-errs [lhs-w/extras (rw-sc #`(side-condition #,from #,(bind-withs side-conditions/withs #'#t)))]
lang-nts [to to]
orig-name
#t
from)]
[to to #;#`,(begin (printf "~s\n" #,name) (term #,to))]
[name name] [name name]
[lang lang] [lang lang]
[(names ...) names] [(names ...) names]
@ -550,14 +548,15 @@
#`(do-leaf-match #`(do-leaf-match
name name
`side-conditions-rewritten `side-conditions-rewritten
`lhs-w/extras
(λ (main bindings) (λ (main bindings)
;; nested term-let's so that the bindings for the variables ;; 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 `fresh' side-conditions, the bindings for the variables
;; show up in the withs, and the withs show up in the 'fresh' side-conditions ;; 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 ([names/ellipses (lookup-binding bindings 'names)] ...)
(term-let (fresh-var-clauses ...) (term-let (fresh-var-clauses ...)
#,(bind-withs side-conditions/withs #,(bind-withs side-conditions/withs
#'(make-successful (term to)))))))))))) #'(make-successful (term to))))))))))))
;; the withs and side-conditions come in backwards order ;; the withs and side-conditions come in backwards order
(define (bind-withs stx body) (define (bind-withs stx body)
@ -756,22 +755,40 @@
(rewrite-proc-name child-make-proc) (rewrite-proc-name child-make-proc)
(subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from))) (subst lhs-frm-id (rewrite-proc-lhs child-make-proc) rhs-from)))
(define (do-leaf-match name pat proc) (define relation-coverage (make-parameter #f))
(make-rewrite-proc
(λ (lang) (define-struct covered-case (name apps) #:inspector (make-inspector))
(let ([cp (compile-pattern lang pat #t)])
(λ (main-exp exp f other-matches) (define (apply-case c)
(let ([mtchs (match-pattern cp exp)]) (struct-copy covered-case c [apps (add1 (covered-case-apps c))]))
(if mtchs
(map/mt (λ (mtch) (define (cover-case id name relation-coverage)
(let ([really-matched (proc main-exp (mtch-bindings mtch))]) (hash-update! relation-coverage id apply-case (make-covered-case name 0)))
(and really-matched
(list name (f (successful-result really-matched)))))) (define (covered-cases relation-coverage)
mtchs (hash-map relation-coverage (λ (k v) v)))
other-matches)
other-matches))))) (define fresh-coverage make-hasheq)
name
pat)) (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) (define-syntax (test-match stx)
(syntax-case stx () (syntax-case stx ()
@ -1047,25 +1064,35 @@
(define (check-clauses stx syn-error-name rest) (define (check-clauses stx syn-error-name rest)
(syntax-case rest () (syntax-case rest ()
[([(lhs ...) roc ...] ...) [([(lhs ...) roc1 roc2 ...] ...)
rest] 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 ...] ...) [([x roc ...] ...)
(for-each (begin
(λ (x) (for-each
(syntax-case x () (λ (x)
[(lhs ...) (void)] (syntax-case x ()
[x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)])) [(lhs ...) (void)]
(syntax->list #'(x ...))) [x (raise-syntax-error syn-error-name "expected a function prototype" stx #'x)]))
(raise-syntax-error syn-error-name "error checking failed.1" stx)] (syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.1" stx))]
[(x ...) [(x ...)
(for-each (begin
(λ (x) (for-each
(syntax-case x () (λ (x)
[(stuff ...) (void)] (syntax-case x ()
[x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)])) [(stuff ...) (void)]
(syntax->list #'(x ...))) [x (raise-syntax-error syn-error-name "expected a metafunction clause" stx #'x)]))
(raise-syntax-error syn-error-name "error checking failed.2" stx)])) (syntax->list #'(x ...)))
(raise-syntax-error syn-error-name "error checking failed.2" stx))]))
(define (extract-side-conditions name stx stuffs) (define (extract-side-conditions name stx stuffs)
(let loop ([stuffs (syntax->list stuffs)] (let loop ([stuffs (syntax->list stuffs)]
@ -1110,7 +1137,7 @@
(λ (exp) (λ (exp)
(let ([cache-ref (hash-ref cache exp not-in-cache)]) (let ([cache-ref (hash-ref cache exp not-in-cache)])
(cond (cond
[(eq? cache-ref not-in-cache) [(or (not (caching-enabled?)) (eq? cache-ref not-in-cache))
(when dom-compiled-pattern (when dom-compiled-pattern
(unless (match-pattern dom-compiled-pattern exp) (unless (match-pattern dom-compiled-pattern exp)
(redex-error name (redex-error name
@ -1138,14 +1165,23 @@
`(,name ,@exp) `(,name ,@exp)
(length mtchs))] (length mtchs))]
[else [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) (unless (match-pattern codom-compiled-pattern ans)
(redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp))) (redex-error name "codomain test failed for ~s, call was ~s" ans `(,name ,@exp)))
(hash-set! cache exp ans) (hash-set! cache exp ans)
ans)])))]))] ans)])))]))]
[else [else
cache-ref])))]) cache-ref])))]
metafunc) [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 compiled-patterns
rhss) rhss)
(if dom-compiled-pattern (if dom-compiled-pattern
@ -1153,6 +1189,8 @@
(λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns) (λ (exp) (and (ormap (λ (pat) (match-pattern pat exp)) compiled-patterns)
#t)))))) #t))))))
(define current-traced-metafunctions (make-parameter '()))
(define-syntax (metafunction-form stx) (define-syntax (metafunction-form stx)
(syntax-case stx () (syntax-case stx ()
[(_ id) [(_ id)
@ -1762,6 +1800,7 @@
(rename-out [metafunction-form metafunction]) (rename-out [metafunction-form metafunction])
metafunction? metafunction-proc metafunction? metafunction-proc
in-domain? in-domain?
current-traced-metafunctions
metafunc-proc-lang metafunc-proc-lang
metafunc-proc-pict-info metafunc-proc-pict-info
metafunc-proc-name metafunc-proc-name
@ -1793,3 +1832,8 @@
apply-reduction-relation* apply-reduction-relation*
variable-not-in variable-not-in
variables-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-any-decision (decision any))
(define next-sequence-decision (decision seq))))) (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 () (let ()
(define-language lc (define-language lc
(e (e e) x (λ (x) e)) (e (e e) x (λ (x) e))
@ -162,7 +168,7 @@
;; Generate (λ (x) x) ;; Generate (λ (x) x)
(test (test
(generate-term (generate-term/decisions
lc e 1 0 lc e 1 0
(decisions #:var (list (λ _ 'x) (λ _'x)) (decisions #:var (list (λ _ 'x) (λ _'x))
#:nt (patterns third first first first))) #:nt (patterns third first first first)))
@ -170,14 +176,14 @@
;; Generate pattern that's not a non-terminal ;; Generate pattern that's not a non-terminal
(test (test
(generate-term (generate-term/decisions
lc (x x x_1 x_1) 1 0 lc (x x x_1 x_1) 1 0
(decisions #:var (list (λ _ 'x) (λ _ 'y)))) (decisions #:var (list (λ _ 'x) (λ _ 'y))))
'(x x y y)) '(x x y y))
; After choosing (e e), size decremented forces each e to x. ; After choosing (e e), size decremented forces each e to x.
(test (test
(generate-term (generate-term/decisions
lc e 1 0 lc e 1 0
(decisions #:nt (patterns first) (decisions #:nt (patterns first)
#:var (list (λ _ 'x) (λ _ 'y)))) #:var (list (λ _ 'x) (λ _ 'y))))
@ -193,7 +199,9 @@
(let* ([x null] (let* ([x null]
[prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))]) [prepend! (λ (c l b a) (begin (set! x (cons (car b) x)) 'x))])
(test (begin (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 x)))) '(x x))))
@ -204,7 +212,7 @@
(x (variable-except λ))) (x (variable-except λ)))
(test (test
(exn:fail-message (exn:fail-message
(generate-term (generate-term/decisions
postfix e 2 0 postfix e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y)) (decisions #:var (list (λ _ 'x) (λ _ 'y))
#:nt (patterns third second first first)))) #:nt (patterns third second first first))))
@ -215,7 +223,7 @@
(define-language var (define-language var
(e (variable-except x y))) (e (variable-except x y)))
(test (test
(generate-term (generate-term/decisions
var e 2 0 var e 2 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z)))) (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x) (λ _ 'z))))
'z)) 'z))
@ -232,26 +240,28 @@
(n number) (n number)
(z 4)) (z 4))
(test (test
(generate-term (generate-term/decisions
lang a 2 0 lang a 2 0
(decisions #:num (build-list 3 (λ (n) (λ (_) n))) (decisions #:num (build-list 3 (λ (n) (λ (_) n)))
#:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1)))) #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 1))))
`(0 1 2 "foo" "foo" "foo" "bar" #t)) `(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) 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) 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))) '(4 4 4 4 (4 4) (4 4)))
(test (exn:fail-message (generate-term lang e 5)) (test (exn:fail-message (generate-term lang e 5))
#rx"generate: unable to generate pattern e") #rx"generate: unable to generate pattern e")
(test (generate-term lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) (test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null)
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (test (generate-term/decisions
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4) lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0
(λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3)))) (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 4)
(λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 1) (λ (_) 3))))
'((0 0 0) (0 0 0 0) (1 1 1))) '((0 0 0) (0 0 0 0) (1 1 1)))
(test (generate-term lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 (test (generate-term/decisions
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4) (λ (_) 2) (λ (_) 3) (λ (_) 5)))) 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)))) '((0 0 0) (0 0 0 0) (1 1 1) (1 1 1 1 1))))
(let () (let ()
@ -264,7 +274,7 @@
;; x and y bound in body ;; x and y bound in body
(test (test
(let/ec k (let/ec k
(generate-term (generate-term/decisions
lc e 10 0 lc e 10 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))) (decisions #:var (list (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))
#:nt (patterns first first first third first) #:nt (patterns first first first third first)
@ -274,7 +284,7 @@
(let () (let ()
(define-language lang (e (variable-prefix pf))) (define-language lang (e (variable-prefix pf)))
(test (test
(generate-term (generate-term/decisions
lang e 5 0 lang e 5 0
(decisions #:var (list (λ _ 'x)))) (decisions #:var (list (λ _ 'x))))
'pfx)) 'pfx))
@ -288,7 +298,7 @@
(define-language lang (define-language lang
(e number (e_1 e_2 e e_1 e_2))) (e number (e_1 e_2 e e_1 e_2)))
(test (test
(generate-term (generate-term/decisions
lang e 5 0 lang e 5 0
(decisions #:nt (patterns second first first first) (decisions #:nt (patterns second first first first)
#:num (list (λ _ 2) (λ _ 3) (λ _ 4)))) #:num (list (λ _ 2) (λ _ 3) (λ _ 4))))
@ -300,7 +310,7 @@
(x variable)) (x variable))
(test (test
(let/ec k (let/ec k
(generate-term (generate-term/decisions
lang e 5 0 lang e 5 0
(decisions #:var (list (λ _ 'x) (λ (c l b a) (k b)))))) (decisions #:var (list (λ _ 'x) (λ (c l b a) (k b))))))
'(x))) '(x)))
@ -311,12 +321,12 @@
(b (c_!_1 c_!_1 c_!_1)) (b (c_!_1 c_!_1 c_!_1))
(c 1 2)) (c 1 2))
(test (test
(generate-term (generate-term/decisions
lang a 5 0 lang a 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2)) '(1 1 2))
(test (test
(generate-term (generate-term/decisions
lang (number_!_1 number_!_2 number_!_1) 5 0 lang (number_!_1 number_!_2 number_!_1) 5 0
(decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2)))) (decisions #:num (list (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 1) (λ _ 2))))
'(1 1 2)) '(1 1 2))
@ -330,7 +340,7 @@
(f foo bar)) (f foo bar))
(test (test
(let/ec k (let/ec k
(generate-term (generate-term/decisions
lang e 5 0 lang e 5 0
(decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?)))))))) (decisions #:str (list (λ (c l a) (k (cons (sort c char<=?) (sort l string<=?))))))))
(cons '(#\a #\b #\f #\o #\r) (cons '(#\a #\b #\f #\o #\r)
@ -350,24 +360,26 @@
#rx"unable to generate") #rx"unable to generate")
(test ; binding works for with side-conditions failure/retry (test ; binding works for with side-conditions failure/retry
(let/ec k (let/ec k
(generate-term (generate-term/decisions
lang d 5 0 lang d 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b)))))) (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ (c l b a) (k b))))))
'(y)) '(y))
(test ; mismatch patterns work with side-condition failure/retry (test ; mismatch patterns work with side-condition failure/retry
(generate-term (generate-term/decisions
lang e 5 0 lang e 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y)))) (decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'y) (λ _ 'y) (λ _ 'x) (λ _ 'y))))
'(y x y)) '(y x y))
(test ; generate compiles side-conditions in pattern (test ; generate compiles side-conditions in pattern
(generate-term lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0 (generate-term/decisions
(decisions #:var (list (λ _ 'x) (λ _ 'y)))) lang (side-condition x_1 (not (eq? (term x_1) 'x))) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y))))
'y) 'y)
(test ; bindings within ellipses collected properly (test ; bindings within ellipses collected properly
(let/ec k (let/ec k
(generate-term lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0 (generate-term/decisions
(decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4)) lang (side-condition (((number_1 3) ...) ...) (k (term ((number_1 ...) ...)))) 5 0
#:num (build-list 7 (λ (n) (λ (_) n)))))) (decisions #:seq (list (λ (_) 2) (λ (_) 3) (λ (_) 4))
#:num (build-list 7 (λ (n) (λ (_) n))))))
'((0 1 2) (3 4 5 6)))) '((0 1 2) (3 4 5 6))))
(let () (let ()
@ -397,7 +409,7 @@
(y variable)) (y variable))
(test (test
(generate-term (generate-term/decisions
lang (in-hole A number ) 5 0 lang (in-hole A number ) 5 0
(decisions (decisions
#:nt (patterns second second first first third first second first first) #: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 (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 (hole 4) 5) (term (hole 4)))
(test (generate-term lang (variable_1 (in-hole C variable_1)) 5 0 (test (generate-term/decisions
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x)))) lang (variable_1 (in-hole C variable_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'y) (λ _ 'x))))
'(x x)) '(x x))
(test (generate-term lang (variable_!_1 (in-hole C variable_!_1)) 5 0 (test (generate-term/decisions
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y)))) lang (variable_!_1 (in-hole C variable_!_1)) 5 0
(decisions #:var (list (λ _ 'x) (λ _ 'x) (λ _ 'x) (λ _ 'y))))
'(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)) '(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)) '((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)) '(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))) '((2 ((3 (2 1)) 3)) 1)))
(let () (let ()
@ -426,7 +441,7 @@
(e (e e) (+ e e) x v) (e (e e) (+ e e) x v)
(v (λ (x) e) number) (v (λ (x) e) number)
(x variable-not-otherwise-mentioned)) (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)) 'x))
(let () (let ()
@ -436,19 +451,24 @@
(define-language empty) (define-language empty)
;; `any' pattern ;; `any' pattern
(test (call-with-values (λ () (pick-any four (make-random 0 1))) list) (let ([four (prepare-lang four)]
(list four 'f)) [sexp (prepare-lang sexp)])
(test (call-with-values (λ () (pick-any four (make-random 1))) list) (test (call-with-values (λ () (pick-any four sexp (make-random 0 1))) list)
(list sexp 'sexp)) (list four 'f))
(test (generate-term four any 5 0 (decisions #:any (list (λ _ (values four 'e))))) 4) (test (call-with-values (λ () (pick-any four sexp (make-random 1))) list)
(test (generate-term four any 5 0 (list sexp 'sexp)))
(decisions #:any (list (λ _ (values sexp 'sexp))) (test (generate-term/decisions
#:nt (patterns fifth second second second) four any 5 0 (decisions #:any (list (λ (lang sexp) (values lang 'e))))) 4)
#:seq (list (λ _ 3)) (test (generate-term/decisions
#:str (list (λ _ "foo") (λ _ "bar") (λ _ "baz")))) 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")) '("foo" "bar" "baz"))
(test (generate-term empty any 5 0 (decisions #:nt (patterns first) (test (generate-term/decisions
#:var (list (λ _ 'x)))) empty any 5 0 (decisions #:nt (patterns first)
#:var (list (λ _ 'x))))
'x)) 'x))
;; `hide-hole' pattern ;; `hide-hole' pattern
@ -469,15 +489,16 @@
(e x (e e) v) (e x (e e) v)
(v (λ (x) e)) (v (λ (x) e))
(x variable-not-otherwise-mentioned)) (x variable-not-otherwise-mentioned))
(test (generate-term lang (cross e) 3 0 (test (generate-term/decisions
(decisions #:nt (patterns fourth first first second first first first) lang (cross e) 3 0
#:var (list (λ _ 'x) (λ _ 'y)))) (decisions #:nt (patterns fourth first first second first first first)
#:var (list (λ _ 'x) (λ _ 'y))))
(term (λ (x) (hole y))))) (term (λ (x) (hole y)))))
;; current-error-port-output : (-> (-> any) string) ;; current-output : (-> (-> any) string)
(define (current-error-port-output thunk) (define (current-output thunk)
(let ([p (open-output-string)]) (let ([p (open-output-string)])
(parameterize ([current-error-port p]) (parameterize ([current-output-port p])
(thunk)) (thunk))
(begin0 (begin0
(get-output-string p) (get-output-string p)
@ -487,16 +508,78 @@
(let () (let ()
(define-language lang (define-language lang
(d 5) (d 5)
(e e 4)) (e e 4)
(test (current-error-port-output (λ () (check lang d 2 #f))) (n number))
"failed after 1 attempts:\n5\n") (test (current-output (λ () (check lang d #f)))
"counterexample found after 1 attempts:\n5\n")
(test (check lang d #t) #t) (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 e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
(test (check lang (d ...) 2 (zero? (modulo (foldl + 0 (term (d ...))) 5))) #t) (test (check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
(test (current-error-port-output (λ () (check lang (d e) 2 #f))) (test (current-output (λ () (check lang (d e) #f)))
"failed after 1 attempts:\n(5 4)\n") "counterexample found after 1 attempts:\n(5 4)\n")
(test (current-error-port-output (λ () (check lang d 2 (error 'pred-raised)))) (test (current-output (λ () (check lang d (error 'pred-raised))))
"failed after 1 attempts:\n5\n")) "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 ;; check-metafunction-contract
(let () (let ()
@ -518,38 +601,48 @@
[(i any ...) (any ...)]) [(i any ...) (any ...)])
;; Dom(f) < Ctc(f) ;; Dom(f) < Ctc(f)
(test (current-error-port-output (test (current-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 2) (λ _ 5)))))) (λ ()
"failed after 1 attempts:\n(5)\n") (parameterize ([generation-decisions
(decisions #:num (list (λ _ 2) (λ _ 5)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(5)\n")
;; Rng(f) > Codom(f) ;; Rng(f) > Codom(f)
(test (current-error-port-output (test (current-output
(λ () (check-metafunction-contract f (decisions #:num (list (λ _ 3)))))) (λ ()
"failed after 1 attempts:\n(3)\n") (parameterize ([generation-decisions
(decisions #:num (list (λ _ 3)))])
(check-metafunction-contract f))))
"counterexample found after 1 attempts:\n(3)\n")
;; LHS matches multiple ways ;; LHS matches multiple ways
(test (current-error-port-output (test (current-output
(λ () (check-metafunction-contract g (decisions #:num (list (λ _ 1) (λ _ 1)) (λ ()
#:seq (list (λ _ 2)))))) (parameterize ([generation-decisions
"failed after 1 attempts:\n(1 1)\n") (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) ;; OK -- generated from Dom(h)
(test (check-metafunction-contract h) #t) (test (check-metafunction-contract h) #t)
;; OK -- generated from pattern (any ...) ;; OK -- generated from pattern (any ...)
(test (check-metafunction-contract i) #t)) (test (check-metafunction-contract i #:attempts 5) #t))
;; check-reduction-relation ;; check-reduction-relation
(let () (let ()
(define-language L (define-language L
(e (+ e ...) number) (e (+ e ...) number)
(E (+ number ... E* e ...)) (E (+ number ... E* e ...))
(E* hole E*)) (E* hole E*)
(define R (n 4))
(reduction-relation
L (let ([generated null]
(==> (+ number ...) whatever) [R (reduction-relation
(--> (side-condition number (even? (term number))) whatever) L
with (==> (+ number ...) whatever)
[(--> (in-hole E a) whatever) (--> (side-condition number (even? (term number))) whatever)
(==> a b)])) with
(let ([generated null]) [(--> (in-hole E a) whatever)
(==> a b)])])
(test (begin (test (begin
(check-reduction-relation (check-reduction-relation
R (λ (term) (set! generated (cons term generated))) R (λ (term) (set! generated (cons term generated)))
@ -558,14 +651,31 @@
#:attempts 1) #:attempts 1)
generated) generated)
(reverse '((+ (+)) 0)))) (reverse '((+ (+)) 0))))
(let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
(test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t) (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
(test (current-error-port-output (test (current-output
(λ () (check-reduction-relation S (λ (x) #f)))) (λ () (check-reduction-relation S (λ (x) #f))))
"checking name failed after 1 attempts:\n1\n") "counterexample found after 1 attempts with name:\n1\n")
(test (current-error-port-output (test (current-output
(λ () (check-reduction-relation S (curry eq? 1)))) (λ () (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 ; check-metafunction
(let () (let ()
@ -575,11 +685,14 @@
[(m 2) whatever]) [(m 2) whatever])
(let ([generated null]) (let ([generated null])
(test (begin (test (begin
(check-metafunction m (λ (t) (set! generated (cons t generated))) 1) (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)
generated) generated)
(reverse '((1) (2))))) (reverse '((1) (2)))))
(test (current-error-port-output (λ () (check-metafunction m (curry eq? 1)))) (test (current-output (λ () (check-metafunction m (curry eq? 1))))
#rx"checking clause #1 failed after 1 attempt")) #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 ;; parse/unparse-pattern
(let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])])

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

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

@ -1,5 +1,8 @@
(module tl-test mzscheme (module tl-test mzscheme
(require "../reduction-semantics.ss" (require "../reduction-semantics.ss"
(only "reduction-semantics.ss"
relation-coverage fresh-coverage covered-cases
make-covered-case covered-case-name)
"test-util.ss" "test-util.ss"
(only "matcher.ss" make-bindings make-bind) (only "matcher.ss" make-bindings make-bind)
scheme/match scheme/match
@ -192,6 +195,45 @@
#t)) #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)
'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])) [else #f]))
; test shortcut in terms of shortcut ; test shortcut in terms of shortcut
(test (rewrite-proc-lhs (third (reduction-relation-make-procs r))) (test (match (rewrite-proc-lhs (third (reduction-relation-make-procs r)))
'((5 2) 1))) [`(((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)) (print-tests-passed 'tl-test.ss))

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

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

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 all non-GUI portions of Redex) and also exported by
@schememodname[redex] (which includes all of Redex). @schememodname[redex] (which includes all of Redex).
This section covers Redex's @deftech{pattern} language, used This section covers Redex's @deftech{pattern} language, used in many
in various ways: 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) @(schemegrammar* #:literals (any number string variable variable-except variable-prefix variable-not-otherwise-mentioned hole name in-hole side-condition cross)
[pattern any [pattern any
@ -324,16 +328,28 @@ clause is followed by an ellipsis. Nested ellipses produce
nested lists. 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 Changes the cache size; the default size is @scheme[350].
entirely. The default size is 350.
The cache is per-pattern (ie, each pattern has a cache of The cache is per-pattern (ie, each pattern has a cache of size at most
size at most 350 (by default)) and is a simple table that 350 (by default)) and is a simple table that maps expressions to how
maps expressions to how they matched the pattern. When the they matched the pattern (ie, the bindings for the pattern
cache gets full, it is thrown away and a new cache is variables). When the cache gets full, it is thrown away and a new
started. 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} @section{Terms}
@ -855,7 +871,8 @@ no clauses match, if one of the clauses matches multiple ways, or
if the contract is violated. if the contract is violated.
Note that metafunctions are assumed to always return the same results 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 metafunction is called with the same inputs twice, then its body is
only evaluated a single time. only evaluated a single time.
@ -927,6 +944,16 @@ legtimate inputs according to @scheme[metafunction-name]'s contract,
and @scheme[#f] otherwise. 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} @section{Testing}
All of the exports in this section are provided both by 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
define-metafunction/extension define-metafunction/extension
metafunction metafunction
in-domain?) in-domain?
caching-enabled?)
(provide (rename-out [test-match redex-match]) (provide (rename-out [test-match redex-match])
term-match term-match
@ -43,6 +44,7 @@
test-results) test-results)
(provide/contract (provide/contract
[current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))]
[reduction-relation->rule-names (-> reduction-relation? (listof symbol?))] [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))]
[language-nts (-> compiled-lang? (listof symbol?))] [language-nts (-> compiled-lang? (listof symbol?))]
[set-cache-size! (-> number? void?)] [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 (raise-syntax-error
#f #f
(string-append "expects a single identifer, a #:from clause, or a" (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)]))) stx)])))
(define (open-help-start) (define (open-help-start)
(find-help #'help)) (go-to-main-page))
;; Autoload utilities from help/help-utils; if it does not exists, ;; Autoload utilities from help/help-utils; if it does not exists,
;; suggest using docs.plt-scheme.org. ;; suggest using docs.plt-scheme.org.
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
(define get-binding (define get-binding
(let ([ns #f] [utils #f]) (let ([ns #f])
(lambda (sym) (lambda (sym)
(unless ns (unless ns
(set! ns (namespace-anchor->empty-namespace anchor)) (set! ns (namespace-anchor->empty-namespace anchor)))
(set! utils (resolved-module-path-name (with-handlers ([exn:fail?
(module-path-index-resolve (lambda (exn)
(module-path-index-join 'help/help-utils #f))))) ((error-display-handler)
(parameterize ([current-namespace ns]) (if (exn? exn)
(if (file-exists? utils) (exn-message exn)
(dynamic-require utils sym) (format "~s" exn))
(lambda _ exn)
(error 'help "documentation system unavailable; ~a\n~a" (raise-user-error
"try http://docs.plt-scheme.org/" 'help
(format " (missing file: ~a)" utils)))))))) (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-syntax-rule (define-help-autoload id)
(define id (define id
@ -67,3 +70,4 @@
(define-help-autoload find-help) (define-help-autoload find-help)
(define-help-autoload find-help/lib) (define-help-autoload find-help/lib)
(define-help-autoload search-for) (define-help-autoload search-for)
(define-help-autoload go-to-main-page)

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

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

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

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

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

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

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

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

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

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

@ -165,27 +165,25 @@ pointer.
@deftogether[( @deftogether[(
@defthing[_string/ucs-4 ctype?] @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. 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 These correspond to the C @cpp{mzchar*} type used by PLT Scheme. As usual, the types
@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and treat @scheme[#f] as @cpp{NULL} and vice-versa.}
vice-versa.}
@deftogether[( @deftogether[(
@defthing[_string/utf-16 ctype?] @defthing[_string/utf-16 ctype?]
@defthing[_string/utf-16/null ctype?]
)]{ )]{
Unicode strings in UTF-16 format. The @schemeidfont{/null} variant Unicode strings in UTF-16 format. As usual, the types treat
treats @scheme[#f] as @cpp{NULL} and vice-versa.} @scheme[#f] as @cpp{NULL} and vice-versa.}
@defthing[_path ctype?]{ @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?]{ @defthing[_symbol ctype?]{
@ -282,9 +280,9 @@ PLT Scheme's C API.}
Similar to @scheme[_pointer], except that when an @scheme[_fpointer] Similar to @scheme[_pointer], except that when an @scheme[_fpointer]
is extracted from a pointer produced by @scheme[ffi-obj-ref], then a is extracted from a pointer produced by @scheme[ffi-obj-ref], then a
level of indirection is skipped. A level of indirection is similarly level of indirection is skipped. A level of indirection is similarly
skipped when extracting a pointer via @scheme[get-ffi-obj]. Also skipped when extracting a pointer via @scheme[get-ffi-obj]. Like
unlike @scheme[_pointer], @scheme[_fpointer] does not convert @scheme[_pointer], @scheme[_fpointer] treats @scheme[#f] as @cpp{NULL}
@scheme[#f] to @cpp{NULL}. and vice-versa.
A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
and normally @scheme[_cprocedure] should be used instead of 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?)] @defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?] [output-type ctype?]
[#:abi abi (or/c symbol/c #f) #f] [#:abi abi (or/c symbol/c #f) #f]
[#:atomic? atomic? any/c #f]
[#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?))
#f] #f]
[#:keep keep (or/c boolean? box? (any/c . -> . any/c)) [#: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), @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 generating a matching foreign callout object. Such objects are new primitive
procedure objects that can be used like any other Scheme procedure. 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 A type created with @scheme[_cprocedure] can also be used for passing
Scheme procedures to foreign functions, which will generate a foreign 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 ``cdecl''). This is especially important on Windows, where most
system functions are @scheme['stdcall], which is not the default. 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 The optional @scheme[wrapper], if provided, is expected to be a
function that can change a callout procedure: when a callout is function that can change a callout procedure: when a callout is
generated, the wrapper is applied on the newly created primitive 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 (_fun fun-option ... maybe-args type-spec ... -> type-spec
maybe-wrapper) maybe-wrapper)
([fun-option (code:line #:abi abi-expr) ([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 [maybe-args code:blank
(code:line (id ...) ::) (code:line (id ...) ::)
(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] @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?]{ ffi-callback?]{
The symmetric counterpart of @scheme[ffi-call]. It receives a Scheme 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 can be converted to PLT Scheme programs by prefixing them with
@scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme @scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme
systems do not recognize @scheme[#, @hash-lang[] #, systems do not recognize @scheme[#, @hash-lang[] #,
@schememodname[r5rs]] (which is not part of the @|r5rs| standard). The @schememodname[r5rs]]. The @exec{plt-r5rs} executable (see
@exec{plt-r5rs} executable more directly conforms to the @|r5rs| @secref[#:doc '(lib "r5rs/r5rs.scrbl") "plt-r5rs"]) more directly
standard. conforms to the @|r5rs| standard.
Aside from the module system, the syntactic forms and functions of Aside from the module system, the syntactic forms and functions of
@|r5rs| and PLT Scheme differ. Only simple @|r5rs| become PLT Scheme @|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 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]. document starts with @scheme[#, @hash-lang[] scribble/doc].
PLT Scheme users can define their own languages. A language name maps 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{ @copyright{
PLT Scheme PLT Scheme
Copyright (c) 1995-2003 PLT 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: PLT software includes or extends the following copyrighted material:
@ -36,21 +36,21 @@ PLT software includes or extends the following copyrighted material:
@copyright{ @copyright{
DrScheme DrScheme
Copyright (c) 1995-2003 PLT Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc. Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved. All rights reserved.
} }
@copyright{ @copyright{
MrEd MrEd
Copyright (c) 1995-2003 PLT Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc. Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved. All rights reserved.
} }
@copyright{ @copyright{
MzScheme MzScheme
Copyright (c) 1995-2003 PLT Copyright (c) 1995-2003 PLT
Copyright (c) 2004-2008 PLT Scheme Inc. Copyright (c) 2004-2009 PLT Scheme Inc.
All rights reserved. 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 @item{Some modules live relative to other modules, without
necessarily belonging to any particular collection or package. 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 file @filepath{quick.ss} and add the line
@schemeblock[(provide rainbow square)] @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 @scheme[equal?] to ensure that data cycles are handled
properly and to work with @scheme[equal?/recur] (but beware properly and to work with @scheme[equal?/recur] (but beware
that an arbitrary function can be provided to 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 The @scheme[_equal-proc] is called for a pair of structures
only when they are not @scheme[eq?], and only when they both 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}.} @filepath{iconv.dll} is included with @filepath{libmzsch@italic{VERS}.dll}.}
The set of available encodings and combinations varies by platform, The set of available encodings and combinations varies by platform,
depending on the @exec{iconv} library that is installed. Under depending on the @exec{iconv} library that is installed; the
Windows, @filepath{iconv.dll} or @filepath{libiconv.dll} must be in the same @scheme[from-name] and @scheme[to-name] arguments are passed on to
directory as @filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is @tt{iconv_open}. Under Windows, @filepath{iconv.dll} or
a version number), in the user's path, in the system directory, or in @filepath{libiconv.dll} must be in the same directory as
the current executable's directory at run time, and the DLL must @filepath{libmzsch@italic{VERS}.dll} (where @italic{VERS} is a version
either supply @tt{_errno} or link to @filepath{msvcrt.dll} for number), in the user's path, in the system directory, or in the
@tt{_errno}; otherwise, only the guaranteed combinations are current executable's directory at run time, and the DLL must either
available.} 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]{ @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} @section[#:tag "createinterface"]{Creating Interfaces}
@guideintro["classes"]{classes, objects, and interfaces}
@defform[(interface (super-interface-expr ...) id ...)]{ @defform[(interface (super-interface-expr ...) id ...)]{
Produces an interface. The @scheme[id]s must be mutually distinct. 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} @section[#:tag "createclass"]{Creating Classes}
@guideintro["classes"]{classes and objects}
@defthing[object% class?]{ @defthing[object% class?]{
A built-in class that has no methods fields, implements only its own 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 a contract that accepts any value that any one of the contracts
accepts, individually. 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 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 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 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 calls @scheme[contract-first-order-passes?] with each of the
higher-order contracts. If only one returns true, @scheme[or/c] uses higher-order contracts. If only one returns true, @scheme[or/c] uses
that contract. If none of them return true, it signals a contract that contract. If none of them return true, it signals a contract
violation. If more than one returns true, it signals an error violation. If more than one returns true, it also signals a contract
indicating that the @scheme[or/c] contract is malformed. violation.
For example, this contract
The @scheme[or/c] result tests any value by applying the contracts in @schemeblock[
order, from left to right, with the exception that it always moves the (or/c (-> number? number?)
non-@tech{flat contracts} (if any) to the end, checking them last.} (-> 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))] ...) @defproc[(and/c [contract (or/c contract? (any/c . -> . any/c))] ...)
contract?]{ 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 ...+) @defform/subs[(for (for-clause ...) body ...+)
([for-clause [id seq-expr] ([for-clause [id seq-expr]
[(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 Iteratively evaluates @scheme[body]. The @scheme[for-clause]s
introduce bindings whose scope includes @scheme[body] and that 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 @defform[(define-sequence-syntax id
expr-transform-expr 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 Defines @scheme[id] as syntax. An @scheme[(id . _rest)] form is
treated specially when used to generate a sequence in a 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 @margin-note{See @schememodname[net/sendurl] for information on how
the user's browser is launched to display help information.} 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 A @scheme[(help id)] form looks for documentation specific to the
current binding of @scheme[id]. For example, 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].} applied to the initial @scheme[v].}
@defform[(parameterize ((parameter-expr value-expr) ...) @defform[(parameterize ((parameter-expr value-expr) ...)
body ...+)]{ body ...+)
#:contracts
([parameter-expr parameter?])]{
@guideintro["parameterize"]{@scheme[parameterize]} @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 a character-based operation, the port's bytes are decoded; see
@secref["encodings"]. @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, 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 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 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 Each syntactic form is described by a BNF-like notation that describes
a combination of (syntax-wrapped) pairs, symbols, and other data (not a combination of (syntax-wrapped) pairs, symbols, and other data (not
a sequence of characters). These grammatical specifications are shown 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, Within such specifications,
@ -42,26 +44,31 @@ Within such specifications,
@item{@scheme[...+] indicates one or @item{@scheme[...+] indicates one or
more repetitions of the preceding datum.} more repetitions of the preceding datum.}
@item{italic meta-identifiers play the role of non-terminals; in @item{Italic meta-identifiers play the role of non-terminals. Some
particular, meta-identifier names imply syntactic constraints:
@itemize{ @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.} identifier.}
@item{a meta-identifier that ends in @scheme[_keyword] stands @item{A meta-identifier that ends in @scheme[_keyword] stands
for a keyword.} for a keyword.}
@item{a meta-identifier that ends with @scheme[_expr] stands @item{A meta-identifier that ends with @scheme[_expr] (such as
for a sub-form that is expanded as an expression.} @scheme[_thing-expr]) stands for a sub-form that is
expanded as an expression.}
@item{A meta-identifier that ends with @scheme[_body] stands @item{A meta-identifier that ends with @scheme[_body] stands
for a sub-form that is expanded in an for a sub-form that is expanded in an
internal-definition context (see internal-definition context (see
@secref["intdef-body"]).} @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], ...} @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.} 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 ([maybe-id code:blank
(code:line #:id id)] (code:line #:id id)]
[maybe-literals code:blank [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 Produces a sequence of flow elements (encapsulated in a
@scheme[splice]) to document a syntatic form named by @scheme[id] @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 to specify @scheme[id], then @scheme[form-datum] must have the form
@scheme[(id . _datum)]. @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 instances of the @scheme[literal-id]s are typeset normally (i.e., as
determined by the enclosing context). determined by the enclosing context).
The typesetting of @scheme[form-datum] preserves the source layout, If a @scheme[#:contracts] clause is provided, each
like @scheme[schemeblock].} @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 Like @scheme[defform], but for multiple forms using the same
@scheme[_id].} @scheme[_id].}
@defform[(defform/subs maybe-id maybe-literals form-datum @defform[(defform/subs maybe-id maybe-literals form-datum
([nonterm-id clause-datum ...+] ...) ([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
Like @scheme[defform], but including an auxiliary grammar of 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 ...] @defform[(defform*/subs maybe-id maybe-literals [form-datum ...]
maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
Like @scheme[defform/subs], but for multiple forms for @scheme[_id].} 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.} 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.} 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 Like @scheme[defform], but without indexing or registering a
definition, and with indenting on the left for both the specification definition, and with indenting on the left for both the specification
and the @scheme[pre-flow]s.} 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 Similar to @scheme[defform], but without any specific identifier being
defined, and the table and flow are typeset indented. This form is 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 @defform[(specsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...) ([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
Like @scheme[specsubform], but with a grammar like Like @scheme[specsubform], but with a grammar like
@scheme[defform/subs].} @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 Like @scheme[specsubform], but indented an extra level. Since using
@scheme[specsubform] within the body of @scheme[specsubform] already @scheme[specsubform] within the body of @scheme[specsubform] already
@ -488,6 +506,7 @@ without nesting a description.}
@defform[(specspecsubform/subs maybe-literals datum @defform[(specspecsubform/subs maybe-literals datum
([nonterm-id clause-datum ...+] ...) ([nonterm-id clause-datum ...+] ...)
maybe-contracts
pre-flow ...)]{ pre-flow ...)]{
Like @scheme[specspecsubform], but with a grammar like 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 The path is relative to the current directory, which is set by
@exec{setup-plt} and @exec{scribble} to the directory of the main @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?] @defproc[(image/plain [filename-relative-to-source string?]
[pre-element any/c] ...) [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 Used as a style for an @scheme[element] to inline an image. The
@scheme[path] field can be a result of @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?]{ @defproc[(block? [v any/c]) boolean?]{

2
collects/sgl/sgl.ss
View File

@ -1,6 +1,6 @@
;; sgl -- An OpenGL extension of MzScheme ;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public License ;; 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 (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 ;; Implementation of SRFI 63 "Homogeneous and Heterogeneous Arrays" for PLT
;; Scheme. ;; Scheme.
;; Copyright (C) 2007-2008 Chongkai Zhu ;; Copyright (C) 2007-2009 Chongkai Zhu
;; Released under the same terms as the SRFI reference implementation. ;; 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 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 This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as 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 #lang scribble/doc
@(require scribble/manual "shared.ss" @(require scribble/manual "shared.ss"
(for-label scheme ; lang/htdp-beginner (for-label scheme
(only-in lang/htdp-beginner check-expect) (only-in lang/htdp-beginner check-expect)
"../universe.ss" teachpack/2htdp/universe
teachpack/htdp/image)) teachpack/htdp/image))
@(require scribble/struct) @(require scribble/struct)
@(define (table* . stuff) @(define (table* . stuff)
;; (list paragraph paragraph) *-> Table ;; (list paragraph paragraph) *-> Table
(define (flow* x) (make-flow (list x))) (define (flow* x) (make-flow (list x)))
(make-blockquote 'blockquote (make-blockquote #f
(list (list
(make-table (make-with-attributes 'boxed (make-table (make-with-attributes 'boxed
'((cellspacing . "6"))) '((cellspacing . "6")))
@ -25,11 +25,16 @@
@author{Matthias Felleisen} @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 This @tt{universe.ss} teachpack implements and provides the functionality
for creating interactive, graphical programs that consist of plain 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 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 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 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 have a series of projects available as a small booklet on
@link["http://world.cs.brown.edu/"]{How to Design Worlds}. @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 The teachpack assumes working knowledge of the basic image manipulation
primitives and supports several functions that require a special kind of primitives and supports several functions that require a special kind of
image, called a @deftech{scene}, , which are images whose pinholes are at image, called a @deftech{scene}, which is an image whose pinholes are at
position @scheme[(0,0)]. For example, the teachpack displays only position @math{(0, 0)}. For example, the teachpack displays only
@tech{scene}s in its canvas. @tech{scene}s in its canvas.
@defproc[(scene? [x any/c]) boolean?]{ @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?] @defproc[(place-image [img image?] [x number?] [y number?]
[s scene?]) [s scene?])
scene?]{ scene?]{
creates a scene by placing @scheme[img] at @scheme[(x,y)] into @scheme[s]; creates a scene by placing @scheme[img] at
@scheme[(x,y)] are computer graphics coordinates, i.e., they count right and @math{(@scheme[x], @scheme[y])} into @scheme[s];
down from the upper-left corner.} @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} @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)]) @defproc[(run-simulation [create-image (-> natural-number/c scene)])
true]{ true]{
opens a canvas and starts a clock that tick 28 times per second opens a canvas and starts a clock that tick 28 times per second.
seconds. Every time the clock ticks, drscheme applies Every time the clock ticks, DrScheme applies
@scheme[create-image] to the number of ticks passed since this function @scheme[create-image] to the number of ticks passed since this function
call. The results of these applications are displayed in the canvas. 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 The step from simulations to interactive programs is relatively
small. Roughly speaking, a simulation designates one function, 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 addition to clock ticks, @tech{world} programs can also deal with two
other kinds of events: keyboard events and mouse events. A keyboard event 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 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 @emph{handler} functions. Specifically, the teachpack provides for the
installation of three event handlers: @scheme[on-tick], @scheme[on-key], installation of three event handlers: @scheme[on-tick], @scheme[on-key],
and @scheme[on-mouse]. In addition, a @tech{world} program may specify a and @scheme[on-mouse]. In addition, a @tech{world} program may specify a
@emph{draw} function, which is called every time your program should @scheme[_dra]} function, which is called every time your program should
visualize the current world, and a @emph{stop?} predicate, which is used visualize the current world, and a @scheme[_stop?] predicate, which is used
to determine when the @tech{world} program should shut down. to determine when the @tech{world} program should shut down.
Each handler function consumes the current state of the @tech{world} and 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"] @image["nuworld.png"]
The @scheme[big-bang] form installs @emph{World_0} as the initial The @scheme[big-bang] form installs @scheme[World_0] as the initial
world. The handlers @emph{tock}, @emph{react}, and @emph{click} transform world. The handlers @scheme[tock], @scheme[react], and @scheme[click] transform
one world into another one; each time an event is handled, @emph{done} is 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 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. is then displayed on an external canvas.
@deftech{World} : @scheme[any/c] The design of a world program demands that @deftech{World} : @scheme[any/c]
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 The design of a world program demands that you come up with a data
distinguish it from the program. In principle, there are no constraints definition of all possible states. We use @tech{World} to refer to
on this data definition though it mustn't be an instance of the this collection of data, using a capital W to distinguish it from the
@tech{Package} structure (see below). You can even keep it implicit, even program. In principle, there are no constraints on this data
if this violates the Design Recipe. 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 @defform/subs[#:id big-bang
#:literals #:literals
@ -180,28 +188,30 @@ The following picture provides an intuitive overview of the workings of a
@itemize[ @itemize[
@item{ @item{
@defform[(on-tick @defform[(on-tick tick-expr)
[tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{ #:contracts
([tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))])]{
tell DrScheme to call the @scheme[tick-expr] function on the current 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 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.}} current world. The clock ticks at the rate of 28 times per second.}}
@item{ @item{
@defform[(on-tick @defform/none[(on-tick tick-expr rate-expr)
[tick-expr (-> (unsyntax @tech{World}) (unsyntax @tech{World}))] #:contracts
[rate-expr natural-number/c])]{ ([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 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 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].}} 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. released.
@deftech{KeyEvent} : @scheme[(or/c char? symbol?)] @deftech{KeyEvent} : @scheme[(or/c char? symbol?)]
A @tech{Char} is used to signal that the user has hit an alphanumeric A character is used to signal that the user has hit an alphanumeric
key. A @tech{Symbol} denotes arrow keys or special events: key. A symbol denotes arrow keys or special events:
@itemize[ @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?]{ @defproc[(key=? [x key-event?][y key-event?]) boolean?]{
compares two @tech{KeyEvent} for equality} compares two @tech{KeyEvent} for equality}
@defform[(on-key @defform[(on-key change-expr)
[change-expr (-> (unsyntax @tech{World}) key-event? (unsyntax @tech{World}))])]{ #: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 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 @tech{KeyEvent} for every keystroke the user of the computer makes. The result
of the call becomes the current world. 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?]{ @defproc[(mouse-event? [x any]) boolean?]{
determines whether @scheme[x] is a @tech{KeyEvent}} 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} compares two @tech{KeyEvent} for equality}
@defform[(on-mouse @defform[(on-mouse clack-expr)
[clack-expr #:contracts
([clack-expr
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) (unsyntax @tech{World}))])]{ (-> (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 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 @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{ @item{
@defform[(on-draw @defform[(on-draw render-expr)
[render-expr (-> (unsyntax @tech{World}) scene?)])]{ #:contracts
([render-expr (-> (unsyntax @tech{World}) scene?)])]{
tell DrScheme to call the function @scheme[render-expr] whenever the 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 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 dealt with an event. Its size is determined by the size of the first
generated @tech{scene}.} generated @tech{scene}.}
@defform[(on-draw @defform/none[(on-draw render-expr width-expr height-expr)
[render-expr (-> (unsyntax @tech{World}) scene?)] #:contracts
[width-expr natural-number/c] ([render-expr (-> (unsyntax @tech{World}) scene?)]
[height-expr natural-number/c])]{ [width-expr natural-number/c]
[height-expr natural-number/c])]{
tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr] tell DrScheme to use a @scheme[width-expr] by @scheme[height-expr]
canvas instead of one determine by the first generated @tech{scene}. canvas instead of one determine by the first generated @tech{scene}.
@ -309,8 +323,9 @@ All @tech{MouseEvent}s are represented via symbols:
@item{ @item{
@defform[(stop-when @defform[(stop-when last-world?)
[last-world? (-> (unsyntax @tech{World}) boolean?)])]{ #:contracts
([last-world? (-> (unsyntax @tech{World}) boolean?)])]{
tell DrScheme to call the @scheme[last-world?] function whenever the canvas is 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 drawn. If this call produces @scheme[true], the world program is shut
down. Specifically, the clock is stopped; no more down. Specifically, the clock is stopped; no more
@ -320,8 +335,9 @@ All @tech{MouseEvent}s are represented via symbols:
@item{ @item{
@defform[(record? @defform[(record? boolean-expr)
[boolean-expr boolean?])]{ #:contracts
([boolean-expr boolean?])]{
tell DrScheme to record all events and to enable a replay of the entire 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 interaction. The replay action also generates one png image per scene and
an animated gif for the entire sequence. an animated gif for the entire sequence.
@ -363,12 +379,12 @@ are highly useful for creating scenes.
corner.} corner.}
@defproc[(scene+line [s scene?][x0 number?][y0 number?][x1 number?][y1 number?][c Color]) scene?]{ @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 creates a scene by placing a line of color @scheme[c] from
@scheme[(x1,y1)] into @scheme[scene]; @math{(@scheme[x0], @scheme[y0])} to @math{(@scheme[x1],
@scheme[(x,y)] are computer graphics coordinates. @scheme[y1])} using computer graphics coordinates. In contrast to
In contrast to the @scheme[add-line] function, @scheme[scene+line] cuts the @scheme[add-line] function, @scheme[scene+line] cuts off those
off those portions of the line that go beyond the boundaries of portions of the line that go beyond the boundaries of the given
the given @scheme[s].} @scheme[s].}
@; ----------------------------------------------------------------------------- @; -----------------------------------------------------------------------------
@section[#:tag "world-example"]{A First Sample World} @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"] @image["door-real.png"]
Like the picture of the general workings of a @tech{world} program, this 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, the states that our informal description of the door identified: locked,
closed (and unlocked), and open. The arrows specify how the door can go 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 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 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: transitions in a similar manner:
@itemize[ @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} 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. predicate.
@defproc[(package? [x any/c]) boolean?]{ @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?]{ @defproc[(make-package [w any/c][m sexp?]) package?]{
create a @tech{Package} from a @tech{World} and an @tech{S-expression}.} 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; As mentioned, all event handlers may return @tech{World}s or @tech{Package}s;
here are the revised specifications: here are the revised specifications:
@defform[(on-tick @defform/none[(on-tick tick-expr)
[tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{ #:contracts
([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))])]{
} }
@defform[(on-tick @defform/none[(on-tick tick-expr rate-expr)
[tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))] #:contracts
[rate-expr natural-number/c])]{ ([tick-expr (-> (unsyntax @tech{World}) (or/c (unsyntax @tech{World}) package?))]
[rate-expr natural-number/c])]{
} }
@defform[(on-key @defform/none[(on-key change-expr)
[change (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{ #:contracts
([change-expr (-> (unsyntax @tech{World}) key-event? (or/c (unsyntax @tech{World}) package?))])]{
} }
@defform[(on-mouse @defform/none[(on-mouse clack-expr)
[clack #:contracts
(-> (unsyntax @tech{World}) natural-number/c natural-number/c (unsyntax @tech{MouseEvent}) ([clack-expr
(or/c (unsyntax @tech{World}) package?))])]{ (-> (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 If one of these event handlers produces a @tech{Package}, the content of the world
@ -772,14 +792,16 @@ following shapes:
@itemize[ @itemize[
@item{ @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] connect this world to a universe server at the specified @scheme[ip-expr]
address and set up capabilities for sending and receiving messages.} address and set up capabilities for sending and receiving messages.}
} }
@item{ @item{
@defform[(register [ip-expr string?] @defform/none[(register ip-expr name-expr)
[name-expr (or/c symbol? string?)])]{ #:contracts
([ip-expr string?]
[name-expr (or/c symbol? string?)])]{
connect this world to a universe server @emph{under a specific} @scheme[name-expr].} 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 The @scheme[on-receive] clause of a @scheme[big-bang] specifies the event handler
for message receipts. for message receipts.
@defform[(on-receive @defform[(on-receive receive-expr)
[receive-expr (-> (unsyntax @tech{World}) sexp? (or/c (unsyntax @tech{World}) package?))])]{ #: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 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} and the received message. The result of the call becomes the current
@tech{World}. @tech{World}.
@ -848,17 +871,17 @@ The teachpack provides a mechanism for designating event handlers for
@itemize[ @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 it has no other function than to communicate whatever message it receives
from one world to the other, without any interference.} 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 (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 world is given a chance to send a message and must then wait
to get a reply before it sends anything again.} 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 @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.} and it administrate the resources of the game.}
] ]
@ -985,15 +1008,17 @@ description. Two of them are mandatory:
@itemize[ @itemize[
@item{ @item{
@defform[(on-new @defform[(on-new new-expr)
[new-expr (-> (unsyntax @tech{Universe}) world? #:contracts
([new-expr (-> (unsyntax @tech{Universe}) world?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{ (cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to call the function @scheme[new-expr] every time another world joins the tell DrScheme to call the function @scheme[new-expr] every time another world joins the
universe.}} universe.}}
@item{ @item{
@defform[(on-msg @defform[(on-msg msg-expr)
[msg-expr (-> (unsyntax @tech{Universe}) world? sexp? #:contracts
([msg-expr (-> (unsyntax @tech{Universe}) world? sexp?
(cons (unsyntax @tech{Universe}) [listof mail?]))])]{ (cons (unsyntax @tech{Universe}) [listof mail?]))])]{
tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world tell DrScheme to apply @scheme[msg-expr] to the current state of the universe, the world
@ -1012,24 +1037,27 @@ optional handlers:
@itemize[ @itemize[
@item{ @item{
@defform[(on-tick @defform/none[(on-tick tick-expr)
[tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{ #:contracts
([tick-expr (-> (unsyntax @tech{Universe}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current state of the 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 universe. The handler is expected to produce a bundle of the new state of
the universe and a list of mails. the universe and a list of mails.
} }
@defform[(on-tick @defform/none[(on-tick tick-expr rate-expr)
[tick-expr (-> (unsyntax @tech{Universe}) bundle?)] #:contracts
[rate-expr natural-number/c])]{ ([tick-expr (-> (unsyntax @tech{Universe}) bundle?)]
[rate-expr natural-number/c])]{
tell DrScheme to apply @scheme[tick-expr] as above but use the specified tell DrScheme to apply @scheme[tick-expr] as above but use the specified
clock tick rate instead of the default. clock tick rate instead of the default.
} }
} }
@item{ @item{
@defform[(on-disconnect @defform[(on-disconnect dis-expr)
[dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{ #:contracts
([dis-expr (-> (unsyntax @tech{Universe}) world? bundle?)])]{
tell DrScheme to invoke @scheme[dis-expr] every time a participating tell DrScheme to invoke @scheme[dis-expr] every time a participating
@tech{world} drops its connection to the server. The first argument is the @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 current state of the universe; the second one is the world that got
@ -1038,8 +1066,9 @@ optional handlers:
} }
@item{ @item{
@defform[(to-string @defform[(to-string render-expr)
[render-expr (-> (unsyntax @tech{Universe}) string?)])]{ #:contracts
([render-expr (-> (unsyntax @tech{Universe}) string?)])]{
tell DrScheme to render the state of the universe after each event and to tell DrScheme to render the state of the universe after each event and to
display this string in the universe console. 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} @subsection{Two Ball Tossing Worlds}
Say we want to represent a universe that consists of a number of worlds and 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 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 canvas to the top. It relinquishes its turn at that point and the server
gives the next world a turn. 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 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 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 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. may add more components to their state space.
In summary, the first step of a protocol design is to introduce: 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[ @itemize[
@item{A passive @tech{world} is @emph{resting}. We use @scheme['resting] for this state.} @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 @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, 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 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[] @table-of-contents[]
@include-section["htdp/scribblings/htdp.scrbl"] @include-section["htdp/scribblings/htdp.scrbl"]
@include-section["htdc/scribblings/htdc.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 "FAILED built in teachpack test: ~a~n" (path->string teachpack))
(printf " got: ~s~n expected: ~s~n" got expected)))))))] (printf " got: ~s~n expected: ~s~n" got expected)))))))]
[test-teachpacks [test-teachpacks
(lambda (dir) (lambda (paths)
(for-each (test-teachpack dir) (for-each (lambda (dir)
(directory-list dir)))] (for-each (test-teachpack dir)
(directory-list dir)))
paths))]
[teachpack-dir (normalize-path (collection-path "teachpack"))]) [teachpack-dir (normalize-path (collection-path "teachpack"))])
(set-language-level! '("How to Design Programs" "Advanced Student")) (set-language-level! '("How to Design Programs" "Advanced Student"))
(do-execute drs-frame) (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) (define (find-leftmost-choice frame)
(let loop ([p frame]) (let loop ([p frame])

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

@ -101,15 +101,15 @@
(define (check-steps expected actual) (define (check-steps expected actual)
(check-pred list? actual) (check-pred list? actual)
(check-pred reduction-sequence? actual) (check-pred reduction-sequence? actual)
(compare-step-sequences expected actual)) (compare-step-sequences actual expected))
(define (reduction-sequence? rs) (define (reduction-sequence? rs)
(andmap protostep? rs)) (andmap protostep? rs))
(define (compare-step-sequences expected actual) (define (compare-step-sequences actual expected)
(cond [(and (pair? expected) (pair? actual)) (cond [(and (pair? expected) (pair? actual))
(begin (compare-steps (car expected) (car actual)) (begin (compare-steps (car actual) (car expected))
(compare-step-sequences (cdr expected) (cdr actual)))] (compare-step-sequences (cdr actual) (cdr expected)))]
[(pair? expected) [(pair? expected)
(fail (format "missing expected steps:\n~s" expected))] (fail (format "missing expected steps:\n~s" expected))]
[(pair? actual) [(pair? actual)
@ -121,7 +121,7 @@
(stx->datum (step-term2 step)))))))] (stx->datum (step-term2 step)))))))]
[else 'ok])) [else 'ok]))
(define (compare-steps expected actual) (define (compare-steps actual expected)
(cond [(eq? expected 'error) (cond [(eq? expected 'error)
(check-pred misstep? actual)] (check-pred misstep? actual)]
[else [else
@ -140,14 +140,16 @@
e-local e-local
"Context frame")))])) "Context frame")))]))
(define-binary-check (check-equal-syntax? a b) (define-binary-check (check-equal-syntax? a e)
(equal-syntax? a b)) (equal-syntax? a e))
(define (equal-syntax? a b) (define (equal-syntax? a e)
(cond [(and (pair? a) (pair? b)) (cond [(and (pair? a) (pair? e))
(and (equal-syntax? (car a) (car b)) (and (equal-syntax? (car a) (car e))
(equal-syntax? (cdr a) (cdr b)))] (equal-syntax? (cdr a) (cdr e)))]
[(and (symbol? a) (symbol? b)) [(and (symbol? a) (symbol? e))
(equal? (string->symbol (symbol->string a)) (equal? (symbol->string a)
b)] (symbol->string e))]
[else (equal? a b)])) [(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 base: scheme/base)) ns)
(eval '(require (prefix-in scheme: scheme)) 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?) (define-syntax-rule (test-policy policy name show?)
(test-case (format "~s" 'name) (test-case (format "~s" 'name)
(check-eq? (policy (check-eq? (policy (make-test-id 'name))
(parameterize ((current-namespace ns))
(namespace-symbol->identifier 'name)))
show?))) show?)))
(define-syntax-rule (test-standard name show?) (define-syntax-rule (test-standard name show?)
(test-policy standard-policy 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))))))]) (add1 (g 2))))))])
(check-pred list? rs) (check-pred list? rs)
(check-true (ormap misstep? 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" (test "lift"
(lift 'a) (lift 'a)
[#:steps (local-lift lifted (lift 'a)) [#:steps (local-lift #rx"^lifted" (lift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression
(#%top . #rx"^lifted"))))]
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with id" (test "lift with id"
(lift (id 'a)) (lift (id 'a))
[#:steps (local-lift lifted (lift (id 'a))) [#:steps (local-lift #rx"^lifted" (lift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
#:no-hidden-steps) #:no-hidden-steps)
(test "lift with Tid" (test "lift with Tid"
(lift (Tid 'a)) (lift (Tid 'a))
[#:steps (local-lift lifted (lift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (lift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
;; Don't show lifts, but do find (Tid 'a), show in orig ctx ;; Don't show lifts, but do find (Tid 'a), show in orig ctx
[#:hidden-steps (macro (lift 'a))]) [#:hidden-steps (macro (lift 'a))])
(test "Tlift" (test "Tlift"
(Tlift 'a) (Tlift 'a)
[#:steps (local-lift lifted (Tlift 'a)) [#:steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift lifted (Tlift 'a)) [#:hidden-steps (local-lift #rx"^lifted" (Tlift 'a))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) 'a) (capture-lifts (begin (define-values (#rx"^lifted") 'a)
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
(test "Tlift with id" (test "Tlift with id"
(Tlift (id 'a)) (Tlift (id 'a))
[#:steps (local-lift lifted (Tlift (id 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:hidden-steps (local-lift lifted (Tlift (id 'a))) [#:hidden-steps (local-lift #rx"^lifted" (Tlift (id 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) (id 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (id 'a))
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
(test "Tlift with Tid" (test "Tlift with Tid"
(Tlift (Tid 'a)) (Tlift (Tid 'a))
[#:steps (local-lift lifted (Tlift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(tag-top (#%expression (#%top . lifted))) (tag-top (#%expression (#%top . #rx"^lifted")))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression (#%top . lifted)))) (#%expression (#%top . #rx"^lifted"))))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression (#%top . lifted))))] (#%expression (#%top . #rx"^lifted"))))]
[#:steps (local-lift lifted (Tlift (Tid 'a))) [#:steps (local-lift #rx"^lifted" (Tlift (Tid 'a)))
(macro (#%expression lifted)) (macro (#%expression #rx"^lifted"))
(capture-lifts (begin (define-values (lifted) (Tid 'a)) (capture-lifts (begin (define-values (#rx"^lifted") (Tid 'a))
(#%expression lifted))) (#%expression #rx"^lifted")))
(macro (begin (define-values (lifted) 'a) (macro (begin (define-values (#rx"^lifted") 'a)
(#%expression lifted)))]) (#%expression #rx"^lifted")))])
[#:suite "set! macros" [#:suite "set! macros"
(test "set! (macro)" (test "set! (macro)"

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

@ -5488,8 +5488,10 @@ so that propagation occurs.
(c))) (c)))
(ctest 2 ;; this one is not tail recursive, since the contract system
'tail-arrow-d1 ;; cannot tell that the range contract doesn't depend on 'arg'
(ctest 8
'tail-arrow-d1/changing-args
(let ([c (counter)]) (let ([c (counter)])
(letrec ([f (letrec ([f
(contract (->d ([arg any/c]) () (values [_ c] [_ c])) (contract (->d ([arg any/c]) () (values [_ c] [_ c]))
@ -5499,8 +5501,22 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (c)))
(ctest 1 (ctest 2
'tail-arrow-d2 '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)]) (let ([c (counter)])
(letrec ([f (letrec ([f
(contract (->d ([arg any/c]) () [rng c]) (contract (->d ([arg any/c]) () [rng c])
@ -5510,7 +5526,23 @@ so that propagation occurs.
(f 3)) (f 3))
(c))) (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 'tail->d-mut-rec
(letrec ([odd-count 0] (letrec ([odd-count 0]
[pos-count 0] [pos-count 0]
@ -5563,6 +5595,40 @@ so that propagation occurs.
(f 4)) (f 4))
(c))) (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_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 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_byte_int_int (int(*f)(byte)) { return f(3); }
X int callback3_int_byte_int (byte(*f)(int)) { 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); } 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 12 'decimal_byte_byte_byte (_fun _byte _byte -> _byte) 1 2)
;; --- ;; ---
(t 9 'callback3_int_int_int (_fun (_fun _int -> _int ) -> _int ) sqr) (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_byte_int_int (_fun (_fun _byte -> _int ) -> _int ) sqr)
(t 9 'callback3_int_byte_int (_fun (_fun _int -> _byte) -> _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) (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) (image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2 0 0)
(p00 (rectangle 2 2 'solid 'blue)))) (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 (test #t
'alpha-color-list1 'alpha-color-list1
(equal? (make-alpha-color 0 255 0 0) (equal? (make-alpha-color 0 255 0 0)
@ -278,6 +304,32 @@
blue blue blue blue blue blue
red blue red))) 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 (test #t
'image=?1 'image=?1
(image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1 0 0) (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")) (build-path example-servlets "add-v2.ss"))
(test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch" (test-add-two-numbers mkd "add-ssd.ss - send/suspend/dispatch"
(build-path example-servlets "add-ssd.ss")) (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" (test-equal? "count.ss - state"
(let* ([d (mkd (build-path example-servlets "count.ss"))] (let* ([d (mkd (build-path example-servlets "count.ss"))]
[ext (lambda (c) [ext (lambda (c)

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

@ -20,11 +20,16 @@
(test-equal? (test-equal?
t t
(let* ([d (mkd p)] (let* ([d (mkd p)]
[k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))] [r0 (call d url0 empty)]
[k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs) [k0 (first ((sxpath "//form/@action/text()") r0))]
(list (make-binding:form #"number" xs)))))] [i0 (first ((sxpath "//form/input/@name/text()") r0))]
[n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys) [r1 (call d (format "~a?~a=~a" k0 i0 xs)
(list (make-binding:form #"number" ys)))))]) (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) n)
(format "The answer is ~a" (+ x y))))) (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") "lib.ss")
(provide/contract (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 (formlet-process
f f
(send/suspend (send/suspend
(lambda (k-url) (lambda (k-url)
`(form ([action ,k-url]) (wrapper
,@(formlet-display f)))))) `(form ([action ,k-url])
,@(formlet-display f)))))))
(provide/contract (provide/contract
[embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr?)]) [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 #lang scribble/doc
@(require "web-server.ss") @(require "web-server.ss")
@(require (for-label web-server/dispatchers/dispatch-servlets))
@title{Troubleshooting and Tips} @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?} @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 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. 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]{ any/c]{
Uses @scheme[send/suspend] to send @scheme[f]'s rendering (wrapped in a FORM tag whose action is 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]. processing stage of @scheme[f].
} }

26
collects/xml/test.ss
View File

@ -2,7 +2,8 @@
;; % mzscheme --require test.ss ;; % mzscheme --require test.ss
(module test mzscheme (module test mzscheme
(require xml/xml) (require xml/xml
scheme/port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -77,6 +78,29 @@
(when tmp (when tmp
(report-err "Permissive" tmp "#f"))))) (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 ;; 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 @scheme[document] structure type, or as a kind of S-expression that is
called an @deftech{X-expression}. called an @deftech{X-expression}.
The @schememodname[xml] library does not provides Document Type The @schememodname[xml] library does not provide Document Type
Declaration (DTD) processing, validation, expanding user-defined Declaration (DTD) processing, including preservation of DTDs in read documents, or validation.
entities, or reading user-defined entities in attributes. 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 Version 4.1.3.8
Added procedure-rename Added procedure-rename
Added extra arguments to call-with-continuation-prompt Added extra arguments to call-with-continuation-prompt

2
man/man1/tex2page.1
View File

@ -164,7 +164,7 @@ mpost(1).
.SH COPYRIGHT .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 Permission to distribute and use this work for any purpose is
hereby granted provided this copyright notice is included in 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) #define FOREIGN_string_ucs_4 (18)
/* Type Name: string/ucs-4 (string_ucs_4) /* 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 * LibFfi type: ffi_type_pointer
* C type: mzchar* * C type: mzchar*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>) * 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>) * 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) /* 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 * LibFfi type: ffi_type_pointer
* C type: unsigned short* * C type: unsigned short*
* Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP(<Scheme>) * 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. /* Byte strings -- not copying C strings, #f is NULL.
* (note: these are not like char* which is just a pointer) */ * (note: these are not like char* which is just a pointer) */
#define FOREIGN_bytes (22) #define FOREIGN_bytes (20)
/* Type Name: bytes /* Type Name: bytes
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: char* * 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>) * C->Scheme: (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
*/ */
#define FOREIGN_path (23) #define FOREIGN_path (21)
/* Type Name: path /* Type Name: path
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: char* * 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>) * C->Scheme: (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
*/ */
#define FOREIGN_symbol (24) #define FOREIGN_symbol (22)
/* Type Name: symbol /* Type Name: symbol
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: char* * 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 /* 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 * ffi-obj and string values pass their pointer. When used as a return
* value, either a cpointer object or #f is returned. */ * value, either a cpointer object or #f is returned. */
#define FOREIGN_pointer (25) #define FOREIGN_pointer (23)
/* Type Name: pointer /* Type Name: pointer
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: void* * 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 /* This is used for passing and Scheme_Object* value as is. Useful for
* functions that know about Scheme_Object*s, like MzScheme's. */ * functions that know about Scheme_Object*s, like MzScheme's. */
#define FOREIGN_scheme (26) #define FOREIGN_scheme (24)
/* Type Name: scheme /* Type Name: scheme
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: Scheme_Object* * 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 /* Special type, not actually used for anything except to mark values
* that are treated like pointers but not referenced. Used for * that are treated like pointers but not referenced. Used for
* creating function types. */ * creating function types. */
#define FOREIGN_fpointer (27) #define FOREIGN_fpointer (25)
/* Type Name: fpointer /* Type Name: fpointer
* LibFfi type: ffi_type_pointer * LibFfi type: ffi_type_pointer
* C type: void* * C type: void*
@ -830,9 +810,7 @@ typedef union _ForeignAny {
double x_doubleS; double x_doubleS;
int x_bool; int x_bool;
mzchar* x_string_ucs_4; mzchar* x_string_ucs_4;
mzchar* x_string_ucs_4_null;
unsigned short* x_string_utf_16; unsigned short* x_string_utf_16;
unsigned short* x_string_utf_16_null;
char* x_bytes; char* x_bytes;
char* x_path; char* x_path;
char* x_symbol; char* x_symbol;
@ -842,7 +820,7 @@ typedef union _ForeignAny {
} ForeignAny; } ForeignAny;
/* This is a tag that is used to identify user-made struct types. */ /* This is a tag that is used to identify user-made struct types. */
#define FOREIGN_struct (28) #define FOREIGN_struct (26)
/*****************************************************************************/ /*****************************************************************************/
/* Type objects */ /* Type objects */
@ -963,9 +941,7 @@ static int ctype_sizeof(Scheme_Object *type)
case FOREIGN_doubleS: return sizeof(double); case FOREIGN_doubleS: return sizeof(double);
case FOREIGN_bool: return sizeof(int); case FOREIGN_bool: return sizeof(int);
case FOREIGN_string_ucs_4: return sizeof(mzchar*); 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: return sizeof(unsigned short*);
case FOREIGN_string_utf_16_null: return sizeof(unsigned short*);
case FOREIGN_bytes: return sizeof(char*); case FOREIGN_bytes: return sizeof(char*);
case FOREIGN_path: return sizeof(char*); case FOREIGN_path: return sizeof(char*);
case FOREIGN_symbol: 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; 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 */ /* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */ /* use cpointer (with a NULL tag when creating), #f for NULL */
#define SCHEME_FFIANYPTRP(x) \ #define SCHEME_FFIANYPTRP(x) \
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(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) \ #define SCHEME_FFIANYPTR_VAL(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
(SCHEME_FALSEP(x) ? NULL : \ (SCHEME_FALSEP(x) ? NULL : \
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
NULL))) (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \ #define SCHEME_FFIANYPTR_OFFSET(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \ #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; 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 */ /* 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_doubleS: return scheme_make_double(REF_CTYPE(double));
case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false); 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: 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: 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_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_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*)); 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); ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val)) else if (SCHEME_FFIOBJP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj; ((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; */ else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) { } else switch (CTYPE_PRIMLABEL(type)) {
@ -1492,9 +1470,9 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
delta += (sizeof(int)-sizeof(mzchar*)); delta += (sizeof(int)-sizeof(mzchar*));
} }
#endif #endif
if (SCHEME_CHAR_STRINGP(val)) { if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
mzchar* tmp; 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) { if (basetype_p == NULL ||tmp == NULL) {
(((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; 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)); scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val));
return NULL; /* hush the compiler */ 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: case FOREIGN_string_utf_16:
#ifdef SCHEME_BIG_ENDIAN #ifdef SCHEME_BIG_ENDIAN
if (sizeof(unsigned short*)<sizeof(int) && ret_loc) { if (sizeof(unsigned short*)<sizeof(int) && ret_loc) {
((int*)W_OFFSET(dst,delta))[0] = 0; ((int*)W_OFFSET(dst,delta))[0] = 0;
delta += (sizeof(int)-sizeof(unsigned short*)); 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 #endif
if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
unsigned short* tmp; 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; (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
return NULL; return NULL;
} else { } else {
*basetype_p = FOREIGN_string_utf_16_null; *basetype_p = FOREIGN_string_utf_16;
return tmp; return tmp;
} }
} else { } 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 */ return NULL; /* hush the compiler */
} }
case FOREIGN_bytes: case FOREIGN_bytes:
@ -2577,12 +2513,16 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata)
argv = argv_stack; argv = argv_stack;
else else
argv = scheme_malloc(argc * sizeof(Scheme_Object*)); 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)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0); v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
} }
/* see ffi-callback below */ /* see ffi-callback below */
@ -2685,6 +2625,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
data->proc = (argv[0]); data->proc = (argv[0]);
data->itypes = (argv[1]); data->itypes = (argv[1]);
data->otype = (argv[2]); data->otype = (argv[2]);
data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4])));
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
{ {
/* put data in immobile, weak box */ /* 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_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv);
scheme_add_global("make-cstruct-type", scheme_add_global("make-cstruct-type",
scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 1), menv); 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_add_global("cpointer?",
scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv); scheme_make_prim_w_arity(foreign_cpointer_p, "cpointer?", 1, 1), menv);
scheme_add_global("cpointer-tag", scheme_add_global("cpointer-tag",
scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv); scheme_make_prim_w_arity(foreign_cpointer_tag, "cpointer-tag", 1, 1), menv);
scheme_add_global("set-cpointer-tag!", scheme_add_global("set-cpointer-tag!",
scheme_make_prim_w_arity(foreign_set_cpointer_tag_bang, "set-cpointer-tag!", 2, 2), menv); 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_add_global("ctype-sizeof",
scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv); scheme_make_prim_w_arity(foreign_ctype_sizeof, "ctype-sizeof", 1, 1), menv);
scheme_add_global("ctype-alignof", scheme_add_global("ctype-alignof",
@ -2850,7 +2791,7 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_add_global("ffi-call", scheme_add_global("ffi-call",
scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv);
scheme_add_global("ffi-callback", 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"); s = scheme_intern_symbol("void");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; 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->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4);
scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); 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"); s = scheme_intern_symbol("string/utf-16");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; 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->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer));
t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16);
scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); 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"); s = scheme_intern_symbol("bytes");
t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct));
t->so.type = ctype_tag; 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 (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" 'ftype "pointer"
'ctype "mzchar*" 'ctype "mzchar*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" '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") 'c->s "scheme_make_char_string_without_copying")
(defctype 'string/utf-16 (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" 'ftype "pointer"
'ctype "unsigned short*" 'ctype "unsigned short*"
'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP"
@ -937,19 +923,30 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
return (Scheme_Object*)type; 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 */ /* Pointer objects */
/* use cpointer (with a NULL tag when creating), #f for NULL */ /* use cpointer (with a NULL tag when creating), #f for NULL */
#define SCHEME_FFIANYPTRP(x) \ #define SCHEME_FFIANYPTRP(x) \
(SCHEME_FALSEP(x) || SCHEME_CPTRP(x) || SCHEME_FFIOBJP(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) \ #define SCHEME_FFIANYPTR_VAL(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \ (SCHEME_CPTRP(x) ? SCHEME_CPTR_VAL(x) : \
(SCHEME_FALSEP(x) ? NULL : \ (SCHEME_FALSEP(x) ? NULL : \
(SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \ (SCHEME_FFIOBJP(x) ? (((ffi_obj_struct*)x)->obj) : \
SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \ (SCHEME_BYTE_STRINGP(x) ? SCHEME_BYTE_STR_VAL(x) : \
NULL))) (SCHEME_FFICALLBACKP(x) ? ((ffi_callback_struct *)x)->callback : \
NULL)))))
#define SCHEME_FFIANYPTR_OFFSET(x) \ #define SCHEME_FFIANYPTR_OFFSET(x) \
(SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0) (SCHEME_CPTRP(x) ? SCHEME_CPTR_OFFSET(x) : 0)
#define SCHEME_FFIANYPTR_OFFSETVAL(x) \ #define SCHEME_FFIANYPTR_OFFSETVAL(x) \
@ -983,15 +980,6 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym)
return scheme_void; return scheme_void;
} }
/*****************************************************************************/
/* Callback type */
{:(cdefstruct ffi-callback
(callback "void*")
(proc "Scheme_Object*")
(itypes "Scheme_Object*")
(otype "Scheme_Object*")):}
/*****************************************************************************/ /*****************************************************************************/
/* Scheme<-->C conversions */ /* 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); ((void**)W_OFFSET(dst,delta))[0] = SCHEME_CPTR_VAL(val);
else if (SCHEME_FFIOBJP(val)) else if (SCHEME_FFIOBJP(val))
((void**)W_OFFSET(dst,delta))[0] = ((ffi_obj_struct*)val)->obj; ((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; */ else /* ((void**)W_OFFSET(dst,delta))[0] = val; */
scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
} else switch (CTYPE_PRIMLABEL(type)) { } 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; argv = argv_stack;
else else
argv = scheme_malloc(argc * sizeof(Scheme_Object*)); 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)) { for (i=0, p=data->itypes; i<argc; i++, p=SCHEME_CDR(p)) {
v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0); v = C2SCHEME(SCHEME_CAR(p), args[i], 0, 0);
argv[i] = v; argv[i] = v;
} }
p = _scheme_apply(data->proc, argc, argv); p = _scheme_apply(data->proc, argc, argv);
SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1);
if (data->call_in_scheduler)
scheme_end_in_scheduler();
} }
/* see ffi-callback below */ /* 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 */ /* (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 treatment of in-types and out-types is similar to that in ffi-call */
/* the real work is done by ffi_do_callback above */ /* the real work is done by ffi_do_callback above */
{:(cdefine ffi-callback 3 4):} {:(cdefine ffi-callback 3 5):}
{ {
ffi_callback_struct *data; ffi_callback_struct *data;
Scheme_Object *itypes = argv[1]; 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) if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK)
scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK");
{:(cmake-object "data" ffi-callback {:(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 #ifdef MZ_PRECISE_GC
{ {
/* put data in immobile, weak box */ /* 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 */ $"0081 0000 0000 0018 008F 0048 0170 8844" /* .<2E>.......<EFBFBD>.H.pˆD */
$"4372 6561 7465 6420 7769 7468 2050 4C54" /* Created with PLT */ $"4372 6561 7465 6420 7769 7468 2050 4C54" /* Created with PLT */
$"2053 6368 656D 650D A920 3230 3034 2D32" /* Scheme.© 2004-2 */ $"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 */ $"6E63 2E20 0DA9 2031 3939 352D 3230 3033" /* nc. .© 1995-2003 */
$"2050 4C54 0000 0000 004D 008F 0089 018F" /* PLT.....M.<EFBFBD>.‰.<EFBFBD> */ $"2050 4C54 0000 0000 004D 008F 0089 018F" /* PLT.....M.<EFBFBD>.‰.<EFBFBD> */
$"884E 466F 7220 7570 2D74 6F2D 6461 7465" /* ˆNFor up-to-date */ $"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 * Purpose: MrEd main file, including a hodge-podge of global stuff
* Author: Matthew Flatt * Author: Matthew Flatt
* Created: 1995 * Created: 1995
* Copyright: (c) 2004-2008 PLT Scheme Inc. * Copyright: (c) 2004-2009 PLT Scheme Inc.
* Copyright: (c) 1995-2000, Matthew Flatt * 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]" # define mrVERSION_SUFFIX " [cgc]"
# endif # endif
#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 #ifndef WINDOW_STDIO
/* Removing "|| defined(wx_msw)" below uses the Windows console. /* 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 * Purpose: MrEd MacOS event loop
* Author: Matthew Flatt * Author: Matthew Flatt
* Created: 1996 * Created: 1996
* Copyright: (c) 2004-2008 PLT Scheme Inc. * Copyright: (c) 2004-2009 PLT Scheme Inc.
* Copyright: (c) 1996, Matthew Flatt * Copyright: (c) 1996, Matthew Flatt
*/ */
@ -1179,103 +1179,20 @@ int MrEdCheckForBreak(void)
/***************************************************************************/ /***************************************************************************/
#include <pthread.h> #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: */ /* These file descriptors are used for breaking the event loop. */
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. */
static int cb_socket_ready; static int cb_socket_ready;
static int ready_sock, write_ready_sock; 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) static int StartFDWatcher(void (*mzs)(float secs, void *fds), float secs, void *fds)
{ {
if (!watch_write_fd) { scheme_start_sleeper_thread(mzs, secs, fds, write_ready_sock);
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);
return 1; return 1;
} }
static void EndFDWatcher(void) static void EndFDWatcher(void)
{ {
char buf[1]; scheme_end_sleeper_thread();
if (thread_running) {
if (need_post) {
need_post = 0;
scheme_signal_received();
}
read(watch_done_read_fd, buf, 1);
thread_running = 0;
}
} }
void socket_callback(CFSocketRef s, CFSocketCallBackType type, CFDataRef address, const void *data, void *info) 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++; going++;
if (need_post) /* useless check in principle, but an optimization if (WNE(&e, secs ? secs : kEventDurationForever))
in the case that the select() succeeds before QueueTransferredEvent(&e);
we even start */
if (WNE(&e, secs ? secs : kEventDurationForever))
QueueTransferredEvent(&e);
--going; --going;

2
src/mred/mredmsw.cxx
View File

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

2
src/mred/mredx.cxx
View File

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

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