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

Get subversion running

Browse Source 
merging in trunk today
looking for new features
and whatever comes my way

svn: r11951
This commit is contained in:
Stevie Strickland 2008-10-06 13:29:17 +00:00
commit 86bae10310
76 changed files with 2444 additions and 734 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/private/xform.ss
View File

@ -835,8 +835,8 @@
;; So we can ignore them: ;; So we can ignore them:
strlen cos sin exp pow log sqrt atan2 strlen cos sin exp pow log sqrt atan2
isnan isinf fpclass _fpclass _isnan __isfinited __isnanl isnan isinf fpclass _fpclass _isnan __isfinited __isnanl __isnan
__isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf
floor ceil round fmod fabs __maskrune _errno __errno floor ceil round fmod fabs __maskrune _errno __errno
isalpha isdigit isspace tolower toupper isalpha isdigit isspace tolower toupper
fread fwrite socket fcntl setsockopt connect send recv close fread fwrite socket fcntl setsockopt connect send recv close

29
collects/framework/private/frame.ss
View File

@ -1435,29 +1435,7 @@
(send evt get-x) (send evt get-x)
(send evt get-y))]) (send evt get-y))])
(send delegate-frame click-in-overview (send delegate-frame click-in-overview
(send text find-position editor-x editor-y)))] (send text find-position editor-x editor-y)))])))))
[(or (send evt entering?)
(send evt moving?))
(when (send evt entering?)
(send delegate-frame open-status-line 'plt:delegate))
(let-values ([(editor-x editor-y)
(send text dc-location-to-editor-location
(send evt get-x)
(send evt get-y))])
(let* ([b (box #f)]
[pos (send text find-position editor-x editor-y #f b)])
(cond
[(unbox b)
(let* ([para (send text position-paragraph pos)]
[start-pos (send text paragraph-start-position para)]
[end-pos (send text paragraph-end-position para)])
(send delegate-frame update-status-line 'plt:delegate
(at-most-200 (send text get-text start-pos end-pos))))]
[else
(send delegate-frame update-status-line 'plt:delegate #f)])))]
[(send evt leaving?)
(send delegate-frame update-status-line 'plt:delegate #f)
(send delegate-frame close-status-line 'plt:delegate)])))))
(super-new))) (super-new)))
(define (at-most-200 s) (define (at-most-200 s)
@ -1933,6 +1911,11 @@
(λ (text evt) (λ (text evt)
(send (send text get-top-level-window) search 'forward))) (send (send text get-top-level-window) search 'forward)))
(send search/replace-keymap map-function "s:return" "prev")
(send search/replace-keymap add-function "prev"
(λ (text evt)
(send (send text get-top-level-window) search 'backward)))
(send search/replace-keymap map-function "c:return" "insert-return") (send search/replace-keymap map-function "c:return" "insert-return")
(send search/replace-keymap map-function "a:return" "insert-return") (send search/replace-keymap map-function "a:return" "insert-return")
(send search/replace-keymap add-function "insert-return" (send search/replace-keymap add-function "insert-return"

5
collects/games/chat-noir/chat-noir-module.ss Normal file
View File

@ -0,0 +1,5 @@
(module chat-noir-module lang/htdp-intermediate-lambda
(require (lib "world.ss" "htdp"))
(require "hash.ss")
(require (lib "include.ss" "scheme"))
(include "chat-noir.ss"))

18
collects/games/chat-noir/chat-noir-unit.ss Normal file
View File

@ -0,0 +1,18 @@
#lang scheme/base
(require scheme/unit
scheme/runtime-path
(prefix-in x: lang/htdp-intermediate-lambda)
(prefix-in x: htdp/world))
(provide game@)
(define orig-namespace (current-namespace))
(define-runtime-path chat-noir "chat-noir-module.ss")
(define-unit game@
(import)
(export)
(define ns (make-base-namespace))
(parameterize ([current-namespace ns])
(namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
(namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
(dynamic-require chat-noir #f)))

BIN
collects/games/chat-noir/chat-noir.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.4 KiB

1011
collects/games/chat-noir/chat-noir.ss Normal file
View File

File diff suppressed because it is too large Load Diff

2
collects/games/chat-noir/hash.ss Normal file
View File

@ -0,0 +1,2 @@
#lang scheme/base
(provide make-hash hash-set! hash-ref hash-map)

6
collects/games/chat-noir/info.ss Normal file
View File

@ -0,0 +1,6 @@
#lang setup/infotab
(define game "chat-noir-unit.ss")
(define game-set "Puzzle Games")
(define compile-omit-files '("chat-noir.ss"))
(define name "Chat Noir")

59
collects/games/scribblings/chat-noir.scrbl Normal file
View File

@ -0,0 +1,59 @@
#lang scribble/doc
@(require "common.ss")
@(require scheme/runtime-path (for-syntax scheme/port scheme/base))
@(define-runtime-path cn "../chat-noir/chat-noir.ss")
@gametitle["Chat Noir" "chat-noir" "Puzzle Game"]
The goal of the game is to stop the cat from escaping the board. Each
turn you click on a circle, which prevents the cat from stepping on
that space, and the cat responds by taking a step. If the cat is
completely boxed in and thus unable reach the border, you win. If the
cat does reach the border, you lose.
The game was inspired by this one the one at
@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design}
and has essentailly the same rules.
This game is written in the
@link["http://www.htdp.org/"]{How to Design Programs}
Intermediate language. It is a model solution to the final project for
the introductory programming course at the University of Chicago in
the fall of 2008, as below.
@(define-syntax (m stx)
(syntax-case stx ()
[(_)
(call-with-input-file (build-path (current-load-relative-directory)
'up
"chat-noir"
"chat-noir.ss")
(lambda (port)
(port-count-lines! port)
#`(schemeblock
#,@
(let loop ()
(let* ([p (peeking-input-port port)]
[l (read-line p)])
(cond
[(eof-object? l) '()]
[(regexp-match #rx"^[ \t]*$" l)
(read-line port)
(loop)]
[(regexp-match #rx"^ *;+" l)
=>
(lambda (m)
(let-values ([(line col pos) (port-next-location port)])
(read-line port)
(let-values ([(line2 col2 pos2) (port-next-location port)])
(cons (datum->syntax
#f
`(code:comment ,(regexp-replace* #rx" " l "\u00a0"))
(list "chat-noir.ss" line col pos (- pos2 pos)))
(loop)))))]
[else
(cons (read-syntax "chat-noir.ss" port)
(loop))])))))
#:mode 'text)]))
@m[]

1
collects/games/scribblings/std-games.scrbl
View File

@ -22,4 +22,5 @@
@include-section["jewel.scrbl"] @include-section["jewel.scrbl"]
@include-section["parcheesi.scrbl"] @include-section["parcheesi.scrbl"]
@include-section["checkers.scrbl"] @include-section["checkers.scrbl"]
@include-section["chat-noir.scrbl"]
@include-section["gcalc.scrbl"] @include-section["gcalc.scrbl"]

8
collects/htdp/world.ss
View File

@ -918,9 +918,11 @@ Matthew
(define m (mouse-event->symbol e)) (define m (mouse-event->symbol e))
(when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT))
(with-handlers ([exn:break? break-handler][exn? exn-handler]) (with-handlers ([exn:break? break-handler][exn? exn-handler])
(set! the-world (f the-world x y m)) (let ([new-world (f the-world x y m)])
(add-event MOUSE x y m) (unless (eq? new-world the-world)
(redraw-callback))))))) (set! the-world new-world)
(add-event MOUSE x y m)
(redraw-callback)))))))))
;; MouseEvent -> MouseEventType ;; MouseEvent -> MouseEventType
(define (mouse-event->symbol e) (define (mouse-event->symbol e)

3
collects/lang/htdp-langs.ss
View File

@ -524,6 +524,9 @@
keywords] keywords]
[(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks]
[(drscheme:special:insert-lambda) #f] [(drscheme:special:insert-lambda) #f]
#;
;; FIXME: disable context for now, re-enable when it is possible
;; to have the context search the teachpack manual too.
[(drscheme:help-context-term) [(drscheme:help-context-term)
(let* ([m (get-module)] (let* ([m (get-module)]
[m (and m (pair? m) (pair? (cdr m)) (cadr m))] [m (and m (pair? m) (pair? (cdr m)) (cadr m))]

3
collects/mred/private/path-dialog.ss
View File

@ -40,7 +40,8 @@
(apply simplify-path (regexp-replace* (apply simplify-path (regexp-replace*
#rx"/" (if (path? p) (path->string p) p) "\\\\") #rx"/" (if (path? p) (path->string p) p) "\\\\")
more)) more))
(compose simplify-path expand-path*))) (lambda (p . more)
(apply simplify-path (expand-path* p) more))))
(define directory-exists*? (compose directory-exists? expand-path*)) (define directory-exists*? (compose directory-exists? expand-path*))
(define file-exists*? (compose file-exists? expand-path*)) (define file-exists*? (compose file-exists? expand-path*))

4
collects/mrlib/scribblings/hierlist/list.scrbl
View File

@ -19,8 +19,8 @@ Creates a hierarchical-list control.
Creates the control.} Creates the control.}
@defmethod[(selected) (or/c (is-a?/c hierarchical-list-item<%>) @defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>)
false/c)]{ false/c)]{
Returns the currently selected item, if any.} Returns the currently selected item, if any.}

60
collects/mzlib/foreign.ss
View File

@ -467,14 +467,26 @@
;; Creates a simple function type that can be used for callouts and callbacks, ;; Creates a simple function type that can be used for callouts and callbacks,
;; 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 [abi #f] [wrapper #f]) (define* (_cprocedure itypes otype
(if wrapper #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
(_cprocedure* itypes otype abi wrapper keep))
;; for internal use
(define held-callbacks (make-weak-hasheq))
(define (_cprocedure* itypes otype abi wrapper keep)
(define-syntax-rule (make-it wrap)
(make-ctype _fpointer (make-ctype _fpointer
(lambda (x) (ffi-callback (wrapper x) itypes otype abi)) (lambda (x)
(lambda (x) (wrapper (ffi-call x itypes otype abi)))) (let ([cb (ffi-callback (wrap x) itypes otype abi)])
(make-ctype _fpointer (cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
(lambda (x) (ffi-callback x itypes otype abi)) [(box? keep)
(lambda (x) (ffi-call x itypes otype abi))))) (let ([x (unbox keep)])
(set-box! keep
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)])
cb))
(lambda (x) (wrap (ffi-call x itypes otype abi)))))
(if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type: ;; Syntax for the special _fun type:
;; (_fun [{(name ... [. name]) | name} [-> expr] ::] ;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
@ -500,6 +512,7 @@
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
(define xs #f) (define xs #f)
(define abi #f) (define abi #f)
(define keep #f)
(define inputs #f) (define inputs #f)
(define output #f) (define output #f)
(define bind '()) (define bind '())
@ -557,15 +570,16 @@
;; parse keywords ;; parse keywords
(let loop () (let loop ()
(let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
(when (keyword? k) (define-syntax-rule (kwds [key var] ...)
(case k (case k
[(#:abi) (if abi [(key) (if var
(err "got a second #:abi keyword" (car xs)) (err (format "got a second ~s keyword") 'key (car xs))
(begin (set! abi (cadr xs)) (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
(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]))))
(unless abi (set! abi #'#f)) (unless abi (set! abi #'#f))
(unless keep (set! keep #'#t))
;; 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]))
@ -655,9 +669,10 @@
body 'inferred-name body 'inferred-name
(string->symbol (string-append "ffi-wrapper:" n))) (string->symbol (string-append "ffi-wrapper:" n)))
body))]) body))])
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
(lambda (ffi) #,body))) #,abi (lambda (ffi) #,body) #,keep))
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi))) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,keep)))
(syntax-case stx () (syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
@ -961,7 +976,7 @@
(define-struct cvector (ptr type length)) (define-struct cvector (ptr type length))
(provide* cvector? cvector-length cvector-type (provide* cvector? cvector-length cvector-type cvector-ptr
;; make-cvector* is a dangerous operation ;; make-cvector* is a dangerous operation
(unsafe (rename-out [make-cvector make-cvector*]))) (unsafe (rename-out [make-cvector make-cvector*])))
@ -1264,10 +1279,13 @@
;; Simple structs: call this with a list of types, and get a type that marshals ;; Simple structs: call this with a list of types, and get a type that marshals
;; C structs to/from Scheme lists. ;; C structs to/from Scheme lists.
(define* (_list-struct . types) (define* (_list-struct . types)
(let ([stype (make-cstruct-type types)] (let ([stype (make-cstruct-type types)]
[offsets (compute-offsets types)]) [offsets (compute-offsets types)]
[len (length types)])
(make-ctype stype (make-ctype stype
(lambda (vals) (lambda (vals)
(unless (and (list vals) (= len (length vals)))
(raise-type-error 'list-struct (format "list of ~a items" len) vals))
(let ([block (malloc stype)]) (let ([block (malloc stype)])
(for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
types offsets vals) types offsets vals)

5
collects/planet/resolver.ss
View File

@ -628,7 +628,7 @@ subdirectory.
(min-hi . ,(get pkg-spec-minor-hi)) (min-hi . ,(get pkg-spec-minor-hi))
(path . ,(get pkg-spec-path))))) (path . ,(get pkg-spec-path)))))
;; get-http-response-code : header[from net/head] -> string ;; get-http-response-code : header[from net/head] -> string or #f
;; gets the HTTP response code in the given header ;; gets the HTTP response code in the given header
(define (get-http-response-code header) (define (get-http-response-code header)
(let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)])
@ -656,7 +656,8 @@ subdirectory.
[ip (get-impure-port target)] [ip (get-impure-port target)]
[head (purify-port ip)] [head (purify-port ip)]
[response-code/str (get-http-response-code head)] [response-code/str (get-http-response-code head)]
[response-code (string->number response-code/str)]) [response-code (and response-code/str
(string->number response-code/str))])
(define (abort msg) (define (abort msg)
(close-input-port ip) (close-input-port ip)

5
collects/profj/tool.ss
View File

@ -872,8 +872,7 @@
eof eof
(begin (begin
(set! executed? #t) (set! executed? #t)
(errortrace-annotate (syntax-as-top
(syntax-as-top
(compile-interactions-ast (compile-interactions-ast
(parse-interactions port name level) (parse-interactions port name level)
name level types #t) name level types #t)
@ -881,7 +880,7 @@
#;(datum->syntax #;(datum->syntax
#f #f
`(parse-java-interactions ,(parse-interactions port name level) ,name) `(parse-java-interactions ,(parse-interactions port name level) ,name)
#f)))))))) #f)))))))
(define/public (front-end/finished-complete-program settings) (void)) (define/public (front-end/finished-complete-program settings) (void))
(define (get-defn-editor port-name) (define (get-defn-editor port-name)

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "28sep2008") #lang scheme/base (provide stamp) (define stamp "6oct2008")

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

@ -3,6 +3,7 @@
(require (for-syntax (rename-in r6rs/private/base-for-syntax (require (for-syntax (rename-in r6rs/private/base-for-syntax
[syntax-rules r6rs:syntax-rules]) [syntax-rules r6rs:syntax-rules])
scheme/base) scheme/base)
scheme/splicing
r6rs/private/qq-gen r6rs/private/qq-gen
r6rs/private/exns r6rs/private/exns
(prefix-in r5rs: r5rs) (prefix-in r5rs: r5rs)
@ -546,54 +547,20 @@
;; ---------------------------------------- ;; ----------------------------------------
;; let[rec]-syntax needs to be splicing, ad it needs the ;; let[rec]-syntax needs to be splicing, and it needs the
;; same transformer wrapper as in `define-syntax' ;; same transformer wrapper as in `define-syntax'
(define-for-syntax (do-let-syntax stx rec?) (define-syntax (r6rs:let-syntax stx)
(syntax-case stx () (syntax-case stx ()
[(_ ([id expr] ...) body ...) [(_ ([id expr] ...) body ...)
(if (eq? 'expression (syntax-local-context)) (syntax/loc stx
(with-syntax ([let-stx (if rec? (splicing-let-syntax ([id (wrap-as-needed expr)] ...) body ...))]))
#'letrec-syntax
#'let-syntax)])
(syntax/loc stx
(let-stx ([id (wrap-as-needed expr)] ...)
(#%expression body)
...)))
(let ([sli (if (list? (syntax-local-context))
syntax-local-introduce
values)])
(let ([ids (map sli (syntax->list #'(id ...)))]
[def-ctx (syntax-local-make-definition-context)]
[ctx (list (gensym 'intdef))])
(syntax-local-bind-syntaxes ids #f def-ctx)
(let* ([add-context
(lambda (expr)
(let ([q (local-expand #`(quote #,expr)
ctx
(list #'quote)
def-ctx)])
(syntax-case q ()
[(_ expr) #'expr])))])
(with-syntax ([(id ...)
(map sli (map add-context ids))]
[(expr ...)
(let ([exprs (syntax->list #'(expr ...))])
(if rec?
(map add-context exprs)
exprs))]
[(body ...)
(map add-context (syntax->list #'(body ...)))])
#'(begin
(define-syntax id (wrap-as-needed expr))
...
body ...))))))]))
(define-syntax (r6rs:let-syntax stx)
(do-let-syntax stx #f))
(define-syntax (r6rs:letrec-syntax stx) (define-syntax (r6rs:letrec-syntax stx)
(do-let-syntax stx #t)) (syntax-case stx ()
[(_ ([id expr] ...) body ...)
(syntax/loc stx
(splicing-letrec-syntax ([id (wrap-as-needed expr)] ...) body ...))]))
;; ---------------------------------------- ;; ----------------------------------------

8
collects/scheme/private/list.ss
View File

@ -247,13 +247,9 @@
(lambda args (f (apply g args)))) (lambda args (f (apply g args))))
(if (eqv? 1 (procedure-arity g)) ; optimize: single input (if (eqv? 1 (procedure-arity g)) ; optimize: single input
(lambda (a) (lambda (a)
(call-with-values (call-with-values (lambda () (g a)) f))
(lambda () (g a))
f))
(lambda args (lambda args
(call-with-values (call-with-values (lambda () (apply g args)) f)))))]
(lambda () (apply g args))
f)))))]
[(f . more) [(f . more)
(if (procedure? f) (if (procedure? f)
(let ([m (apply compose more)]) (let ([m (apply compose more)])

56
collects/scheme/splicing.ss
View File

@ -49,36 +49,32 @@
(let-stx ([ids expr] ...) (let-stx ([ids expr] ...)
(#%expression body) (#%expression body)
...))) ...)))
(let ([sli (if (list? (syntax-local-context)) (let ([def-ctx (syntax-local-make-definition-context)]
syntax-local-introduce [ctx (list (gensym 'intdef))])
values)]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx)
(let ([all-ids (map (lambda (ids) (map sli ids)) all-ids)] (let* ([add-context
[def-ctx (syntax-local-make-definition-context)] (lambda (expr)
[ctx (list (gensym 'intdef))]) (let ([q (local-expand #`(quote #,expr)
(syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) ctx
(let* ([add-context (list #'quote)
(lambda (expr) def-ctx)])
(let ([q (local-expand #`(quote #,expr) (syntax-case q ()
ctx [(_ expr) #'expr])))])
(list #'quote) (with-syntax ([((id ...) ...)
def-ctx)]) (map (lambda (ids)
(syntax-case q () (map add-context ids))
[(_ expr) #'expr])))]) all-ids)]
(with-syntax ([((id ...) ...) [(expr ...)
(map (lambda (ids) (let ([exprs (syntax->list #'(expr ...))])
(map sli (map add-context ids))) (if rec?
all-ids)] (map add-context exprs)
[(expr ...) exprs))]
(let ([exprs (syntax->list #'(expr ...))]) [(body ...)
(if rec? (map add-context (syntax->list #'(body ...)))])
(map add-context exprs) #'(begin
exprs))] (define-syntaxes (id ...) expr)
[(body ...) ...
(map add-context (syntax->list #'(body ...)))]) body ...))))))]))
#'(begin
(define-syntaxes (id ...) expr)
...
body ...)))))))]))
(define-syntax (splicing-let-syntax stx) (define-syntax (splicing-let-syntax stx)
(do-let-syntax stx #f #f)) (do-let-syntax stx #f #f))

68
collects/scribble/run.ss
View File

@ -2,6 +2,7 @@
(module run mzscheme (module run mzscheme
(require "struct.ss" (require "struct.ss"
"base-render.ss" "base-render.ss"
"xref.ss"
mzlib/cmdline mzlib/cmdline
mzlib/class mzlib/class
mzlib/file mzlib/file
@ -29,11 +30,21 @@
(make-parameter #f)) (make-parameter #f))
(define current-info-input-files (define current-info-input-files
(make-parameter null)) (make-parameter null))
(define current-xref-input-modules
(make-parameter null))
(define current-style-file (define current-style-file
(make-parameter #f)) (make-parameter #f))
(define current-redirect (define current-redirect
(make-parameter #f)) (make-parameter #f))
(define (read-one str)
(let ([i (open-input-string str)])
(with-handlers ([exn:fail:read? (lambda (x) #f)])
(let ([v (read i)])
(if (eof-object? (read i))
v
#f)))))
(define (get-command-line-files argv) (define (get-command-line-files argv)
(command-line (command-line
"scribble" "scribble"
@ -59,9 +70,23 @@
[("--info-out") file "write format-specific link information to <file>" [("--info-out") file "write format-specific link information to <file>"
(current-info-output-file file)]] (current-info-output-file file)]]
[multi [multi
[("++info-in") file "load format-specific link information form <file>" [("++info-in") file "load format-specific link information from <file>"
(current-info-input-files (current-info-input-files
(cons file (current-info-input-files)))]] (cons file (current-info-input-files)))]
[("++xref-in") module-path proc-id "load format-specific link information by"
"calling <proc-id> as exported by <module-path>"
(let ([mod (read-one module-path)]
[id (read-one proc-id)])
(unless (module-path? mod)
(raise-user-error 'scribble
"bad module path for ++ref-in: ~s"
module-path))
(unless (symbol? id)
(raise-user-error 'scribble
"bad procedure identifier for ++ref-in: ~s"
proc-id))
(current-xref-input-modules
(cons (cons mod id) (current-xref-input-modules))))]]
[args (file . another-file) (cons file another-file)])) [args (file . another-file) (cons file another-file)]))
(define (build-docs-files files) (define (build-docs-files files)
@ -90,19 +115,26 @@
fn)))) fn))))
files)] files)]
[info (send renderer collect docs fns)]) [info (send renderer collect docs fns)])
(let ([info (let loop ([info info] (for-each (lambda (file)
[files (reverse (current-info-input-files))]) (let ([s (with-input-from-file file read)])
(if (null? files) (send renderer deserialize-info s info)))
info (reverse (current-info-input-files)))
(loop (let ([s (with-input-from-file (car files) read)]) (for-each (lambda (mod+id)
(send renderer deserialize-info s info) (let ([get-xref (dynamic-require (car mod+id) (cdr mod+id))])
info) (let ([xr (get-xref)])
(cdr files))))]) (unless (xref? xr)
(let ([r-info (send renderer resolve docs fns info)]) (raise-user-error 'scribble
(send renderer render docs fns r-info) "result from `~s' of `~s' is not an xref: ~e"
(when (current-info-output-file) (cdr mod+id)
(let ([s (send renderer serialize-info r-info)]) (car mod+id)
(with-output-to-file (current-info-output-file) xr))
(lambda () (xref-transfer-info renderer info xr))))
(write s)) (reverse (current-xref-input-modules)))
'truncate/replace)))))))))) (let ([r-info (send renderer resolve docs fns info)])
(send renderer render docs fns r-info)
(when (current-info-output-file)
(let ([s (send renderer serialize-info r-info)])
(with-output-to-file (current-info-output-file)
(lambda ()
(write s))
'truncate/replace)))))))))

15
collects/scribblings/foreign/derived.scrbl
View File

@ -66,8 +66,8 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.}
@declare-exporting[scribblings/foreign/unsafe-foreign] @declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?] @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{ [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{
These two functions treat pointer tags as lists of tags. As described These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any in @secref["foreign:pointer-funcs"], a pointer tag does not have any
@ -125,7 +125,12 @@ Returns the length of a C vector.}
Returns the C type object of a C vector.} Returns the C type object of a C vector.}
@defproc[(cvector-ref [cvec cvector?][k exact-nonnegative-integer?]) any]{ @defproc[(cvector-ptr [cvec cvector?]) cpointer?]{
Returns the pointer that points at the beginning block of the given C vector.}
@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{
References the @scheme[k]th element of the @scheme[cvec] C vector. References the @scheme[k]th element of the @scheme[cvec] C vector.
The result has the type that the C vector uses.} The result has the type that the C vector uses.}
@ -154,7 +159,9 @@ Converts the list @scheme[lst] to a C vector of the given
@declare-exporting[scribblings/foreign/unsafe-foreign] @declare-exporting[scribblings/foreign/unsafe-foreign]
@defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{ @defproc[(make-cvector* [cptr any/c] [type ctype?]
[length exact-nonnegative-integer?])
cvector?]{
Constructs a C vector using an existing pointer object. This Constructs a C vector using an existing pointer object. This
operation is not safe, so it is intended to be used in specific operation is not safe, so it is intended to be used in specific

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

@ -267,8 +267,13 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on
@defproc[(_cprocedure [input-types (list ctype?)] @defproc[(_cprocedure [input-types (list ctype?)]
[output-type ctype?] [output-type ctype?]
[abi (or/c symbol/c false/c) #f] [#:abi abi (or/c symbol/c false/c) #f]
[wrapper (or false/c (procedure? . -> . procedure?)) #f]) any]{ [#:wrapper wrapper (or/c false/c
(procedure? . -> . procedure?))
#f]
[#:keep keep (or/c boolean? box? (any/c . -> . any/c))
#t])
any]{
A type constructor that creates a new function type, which is A type constructor that creates a new function type, which is
specified by the given @scheme[input-types] list and @scheme[output-type]. specified by the given @scheme[input-types] list and @scheme[output-type].
@ -286,27 +291,80 @@ function pointer that calls the given Scheme procedure when it is
used. There are no restrictions on the Scheme procedure; in used. There are no restrictions on the Scheme procedure; in
particular, its lexical context is properly preserved. particular, its lexical context is properly preserved.
The optional @scheme[abi] argument determines the foreign ABI that is The optional @scheme[abi] keyword argument determines the foreign ABI
used. @scheme[#f] or @scheme['default] will use a platform-dependent that is used. @scheme[#f] or @scheme['default] will use a
default; other possible values are @scheme['stdcall] and platform-dependent default; other possible values are
@scheme['sysv] (the latter corresponds to ``cdecl''). This is @scheme['stdcall] and @scheme['sysv] (the latter corresponds to
especially important on Windows, where most system functions are ``cdecl''). This is especially important on Windows, where most
@scheme['stdcall], which is not the default. system functions are @scheme['stdcall], which is not the default.
The optional @scheme[wrapper-proc], if provided, is expected to be a function that The optional @scheme[wrapper], if provided, is expected to be a
can change a callout procedure: when a callout is generated, the wrapper is function that can change a callout procedure: when a callout is
applied on the newly created primitive procedure, and its result is used as the generated, the wrapper is applied on the newly created primitive
new function. Thus, @scheme[wrapper-proc] is a hook that can perform various argument procedure, and its result is used as the new function. Thus,
manipulations before the foreign function is invoked, and return different @scheme[wrapper] is a hook that can perform various argument
results (for example, grabbing a value stored in an `output' pointer and manipulations before the foreign function is invoked, and return
returning multiple values). It can also be used for callbacks, as an different results (for example, grabbing a value stored in an
additional layer that tweaks arguments from the foreign code before they reach ``output'' pointer and returning multiple values). It can also be
the Scheme procedure, and possibly changes the result values too.} used for callbacks, as an additional layer that tweaks arguments from
the foreign code before they reach the Scheme procedure, and possibly
changes the result values too.
Sending Scheme functions as callbacks to foreign code is achieved by
translating them to a foreign ``closure'', which foreign code can call
as plain C functions. Additional care must be taken in case the
foreign code might hold on to the callback function. In these cases
you must arrange for the callback value to not be garbage-collected,
or the held callback will become invalid. The optional @scheme[keep]
keyword argument is used to achieve this. It can have the following
values: @itemize[
@item{@scheme[#t] makes the callback value stay in memory as long as
the converted function is. In order to use this, you need to hold
on to the original function, for example, have a binding for it.
Note that each function can hold onto one callback value (it is
stored in a weak hash table), so if you need to use a function in
multiple callbacks you will need to use one of the the last two
options below. (This is the default, as it is fine in most cases.)}
@item{@scheme[#f] means that the callback value is not held. This may
be useful for a callback that is only used for the duration of the
foreign call --- for example, the comparison function argument to
the standard C library @tt{qsort} function is only used while
@tt{qsort} is working, and no additional references to the
comparison function are kept. Use this option only in such cases,
when no holding is necessary and you want to avoid the extra cost.}
@item{A box holding @scheme[#f] (or a callback value) --- in this case
the callback value will be stored in the box, overriding any value
that was in the box (making it useful for holding a single callback
value). When you know that it is no longer needed, you can
`release' the callback value by changing the box contents, or by
allowing the box itself to be garbage-collected. This is can be
useful if the box is held for a dynamic extent that corresponds to
when the callback is needed; for example, you might encapsulate some
foreign functionality in a Scheme class or a unit, and keep the
callback box as a field in new instances or instantiations of the
unit.}
@item{A box holding @scheme[null] (or any list) -- this is similar to
the previous case, except that new callback values are consed onto
the contents of the box. It is therefore useful in (rare) cases
when a Scheme function is used in multiple callbacks (that is, sent
to foreign code to hold onto multiple times).}
@item{Finally, if a one-argument function is provided as
@scheme[keep], it will be invoked with the callback value when it
is generated. This allows you to grab the value directly and use it
in any way.}
]}
@defform/subs[#:literals (-> :: :) @defform/subs[#:literals (-> :: :)
(_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)]
[maybe-args code:blank [maybe-args code:blank
(code:line (id ...) ::) (code:line (id ...) ::)
(code:line id ::) (code:line id ::)

17
collects/scribblings/gui/dc-intf.scrbl
View File

@ -199,9 +199,10 @@ See also @method[dc<%> set-smoothing] for information on the
void?]{ void?]{
Draws the sub-paths of the given @scheme[dc-path%] object, adding Draws the sub-paths of the given @scheme[dc-path%] object, adding
@scheme[xoffset] and @scheme[yoffset] to each point. The current pen @scheme[xoffset] and @scheme[yoffset] to each point. (See
is used for drawing the path as a line, and the current brush is used @scheme[dc-path%] for general information on paths and sub-paths.)
for filling the area bounded by the path. The current pen is used for drawing the path as a line, and the
current brush is used for filling the area bounded by the path.
If both the pen and brush are non-transparent, the path is filled with If both the pen and brush are non-transparent, the path is filled with
the brush before the outline is drawn with the pen. The filling and the brush before the outline is drawn with the pen. The filling and
@ -350,11 +351,13 @@ See also @method[dc<%> set-smoothing] for information on the
[y3 real?]) [y3 real?])
void?]{ void?]{
Draws a spline from (@scheme[x1], @scheme[y1]) to (@scheme[x3], @scheme[y3]) @index['("drawing curves")]{Draws} a spline from (@scheme[x1],
using (@scheme[x2], @scheme[y2]) as the control point. @scheme[y1]) to (@scheme[x3], @scheme[y3]) using (@scheme[x2],
@scheme[y2]) as the control point.
See also @method[dc<%> set-smoothing] for information on the See also @method[dc<%> set-smoothing] for information on the
@scheme['aligned] smoothing mode. @scheme['aligned] smoothing mode. See also @scheme[dc-path%] and
@method[dc<%> draw-path] for drawing more complex curves.
@|DrawSizeNote| @|DrawSizeNote|
@ -918,7 +921,7 @@ Starts a page, relevant only when drawing to a printer or PostScript
device (including to a PostScript file). device (including to a PostScript file).
For printer or PostScript output, an exception is raised if For printer or PostScript output, an exception is raised if
@scheme[start-doc] is called when a page is already started, or when @scheme[start-page] is called when a page is already started, or when
@method[dc<%> start-doc] has not been called, or when @method[dc<%> @method[dc<%> start-doc] has not been called, or when @method[dc<%>
end-doc] has been called already. In addition, in the case of end-doc] has been called already. In addition, in the case of
PostScript output, Encapsulated PostScript (EPS) cannot contain PostScript output, Encapsulated PostScript (EPS) cannot contain

3
collects/scribblings/gui/dc-path-class.scrbl
View File

@ -14,7 +14,8 @@ A path consists of zero or more @deftech{closed sub-paths}, and
possibly one @deftech{open sub-path}. Some @scheme[dc-path%] methods possibly one @deftech{open sub-path}. Some @scheme[dc-path%] methods
extend the open sub-path, some @scheme[dc-path%] methods close the extend the open sub-path, some @scheme[dc-path%] methods close the
open sub-path, and some @scheme[dc-path%] methods add closed open sub-path, and some @scheme[dc-path%] methods add closed
sub-paths. sub-paths. This approach to drawing formulation is inherited from
PostScript @cite["Adobe99"].
When a path is drawn as a line, a closed sub-path is drawn as a closed When a path is drawn as a line, a closed sub-path is drawn as a closed
figure, analogous to a polygon. An open sub-path is drawn with figure, analogous to a polygon. An open sub-path is drawn with

14
collects/scribblings/gui/gui.scrbl
View File

@ -31,6 +31,20 @@ provides; this library cannot run in MzScheme.}
@include-section["config.scrbl"] @include-section["config.scrbl"]
@include-section["dynamic.scrbl"] @include-section["dynamic.scrbl"]
@;------------------------------------------------------------------------
@(bibliography
(bib-entry #:key "Adobe99"
#:author "Adobe Systems Incorporated"
#:title "PostScript Language Reference, third edition"
#:is-book? #t
#:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf"
#:date "1999")
)
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@index-section[] @index-section[]

10
collects/scribblings/reference/collects.scrbl
View File

@ -87,7 +87,15 @@ Produces a list of paths as follows:
defined, it is combined with the default list using defined, it is combined with the default list using
@scheme[path-list-string->path-list]. If it is not defined, the @scheme[path-list-string->path-list]. If it is not defined, the
default collection path list (as constructed by the first three default collection path list (as constructed by the first three
bullets above) is used directly.} bullets above) is used directly.
Note that under @|AllUnix|, paths are separated by @litchar{:}, and
under Windows by @litchar{;}. Also,
@scheme[path-list-string->path-list] splices the default paths at an
empty path, for example, with many Unix shells you can set
@envvar{PLTCOLLECTS} to @tt{":`pwd`"}, @tt{"`pwd`:"}, or
@tt{"`pwd`"} to specify search the current directory after, before,
or instead of the default paths respectively.}
}} }}

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

@ -959,20 +959,20 @@ combination of @scheme[envvar] and @scheme[as-index].}
Links to a bibliography entry, using @scheme[key] both to indicate the Links to a bibliography entry, using @scheme[key] both to indicate the
bibliography entry and, in square brackets, as the link text.} bibliography entry and, in square brackets, as the link text.}
@defproc[(bibliography [#:tag string? "doc-bibliography"] @defproc[(bibliography [#:tag tag string? "doc-bibliography"]
[entry bib-entry?] ...) [entry bib-entry?] ...)
part?]{ part?]{
Creates a bibliography part containing the given entries, each of Creates a bibliography part containing the given entries, each of
which is created with @scheme[bib-entry]. The entries are typeset in which is created with @scheme[bib-entry]. The entries are typeset in
order as given} order as given.}
@defproc[(bib-entry [#:key key string?] @defproc[(bib-entry [#:key key string?]
[#:title title any/c] [#:title title any/c]
[#:is-book? is-book? any/c #f] [#:is-book? is-book? any/c #f]
[#:author author any/c] [#:author author any/c #f]
[#:location location any/c] [#:location location any/c #f]
[#:date date any/c] [#:date date any/c #f]
[#:url url any/c #f]) [#:url url any/c #f])
bib-entry?]{ bib-entry?]{
@ -990,18 +990,21 @@ the entry:
order (as opposed to ``last, first''), and separate multiple order (as opposed to ``last, first''), and separate multiple
names with commas using ``and'' before the last name (where names with commas using ``and'' before the last name (where
there are multiple names). The @scheme[author] is typeset in there are multiple names). The @scheme[author] is typeset in
the bibliography as given.} the bibliography as given, or it is omitted if given as
@scheme[#f].}
@item{@scheme[location] names the publication venue, such as a @item{@scheme[location] names the publication venue, such as a
conference name or a journal with volume, number, and conference name or a journal with volume, number, and
pages. The @scheme[location] is typeset in the bibliography as pages. The @scheme[location] is typeset in the bibliography as
given.} given, or it is omitted if given as @scheme[#f].}
@item{@scheme[date] is a date, usually just a year (as a string). It @item{@scheme[date] is a date, usually just a year (as a string). It
is typeset in the bibliography as given.} is typeset in the bibliography as given, or it is omitted if
given as @scheme[#f].}
@item{@scheme[url] is an optional URL. It is typeset in the @item{@scheme[url] is an optional URL. It is typeset in the
bibliography using @scheme[tt] and hyperlinked.} bibliography using @scheme[tt] and hyperlinked, or it is
omitted if given as @scheme[#f].}
}} }}

4
collects/sirmail/sendr.ss
View File

@ -741,7 +741,7 @@
[body-lines (regexp-split [body-lines (regexp-split
#rx"\n" #rx"\n"
(substring message-str (cdar m) (string-length message-str)))]) (substring message-str (cdar m) (string-length message-str)))])
(validate-header header) (validate-header (regexp-replace #rx"[^\x0-\xFF]" header "_"))
(let* ([to* (sm-extract-addresses (extract-field "To" header))] (let* ([to* (sm-extract-addresses (extract-field "To" header))]
[to (map encode-for-header (map car to*))] [to (map encode-for-header (map car to*))]
[cc* (sm-extract-addresses (extract-field "CC" header))] [cc* (sm-extract-addresses (extract-field "CC" header))]
@ -762,6 +762,8 @@
[new-header (append-headers std-header prop-header)] [new-header (append-headers std-header prop-header)]
[tos (map cdr (append to* cc* bcc*))]) [tos (map cdr (append to* cc* bcc*))])
(validate-header new-header)
(as-background (as-background
enable enable
(lambda (break-bad break-ok) (lambda (break-bad break-ok)

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

@ -136,40 +136,43 @@
(vector? obj) (vector? obj)
(my-array? obj))) (my-array? obj)))
(define (s:equal? obj1 obj2) (define (s:equal? obj1 obj2)
(or (equal? obj1 obj2) (or (equal? obj1 obj2)
(and (box? obj1) (cond ((and (box? obj1)
(box? obj2) (box? obj2))
(s:equal? (unbox obj1) (s:equal? (unbox obj1)
(unbox obj2))) (unbox obj2)))
(and (pair? obj1) ((and (pair? obj1)
(pair? obj2) (pair? obj2))
(s:equal? (car obj1) (car obj2)) (and (s:equal? (car obj1) (car obj2))
(s:equal? (cdr obj1) (cdr obj2))) (s:equal? (cdr obj1) (cdr obj2))))
(if (vector? obj1) ((and (vector? obj1)
(and (vector? obj2) (vector? obj2))
(equal? (vector-length obj1) (vector-length obj2)) (and (equal? (vector-length obj1) (vector-length obj2))
(let lp ((idx (sub1 (vector-length obj1)))) (let lp ((idx (sub1 (vector-length obj1))))
(or (negative? idx) (or (negative? idx)
(and (s:equal? (vector-ref obj1 idx) (and (s:equal? (vector-ref obj1 idx)
(vector-ref obj2 idx)) (vector-ref obj2 idx))
(lp (sub1 idx)))))) (lp (sub1 idx)))))))
;; Not a vector ((and (string? obj1)
(or (and (array? obj1) (string? obj2))
(array? obj2) (string=? obj1 obj2))
(equal? (array-dimensions obj1) (array-dimensions obj2)) ((and (array? obj1)
(s:equal? (array->vector obj1) (array->vector obj2))) (array? obj2))
(and (struct? obj1) (and (equal? (array-dimensions obj1) (array-dimensions obj2))
(struct? obj2) (s:equal? (array->vector obj1) (array->vector obj2))))
(let-values (((obj1-type obj1-skipped?) ((and (struct? obj1)
(struct-info obj1)) (struct? obj2))
((obj2-type obj2-skipped?) (let-values (((obj1-type obj1-skipped?)
(struct-info obj2))) (struct-info obj1))
(and (eq? obj1-type obj2-type) ((obj2-type obj2-skipped?)
(not obj1-skipped?) (struct-info obj2)))
(not obj2-skipped?) (and (eq? obj1-type obj2-type)
(s:equal? (struct->vector obj1) (not obj1-skipped?)
(struct->vector obj2))))))))) (not obj2-skipped?)
(s:equal? (struct->vector obj1)
(struct->vector obj2)))))
(else #f))))
(define (array-rank obj) (define (array-rank obj)
(if (array? obj) (length (array-dimensions obj)) 0)) (if (array? obj) (length (array-dimensions obj)) 0))

BIN
collects/teachpack/door-real.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.7 KiB

BIN
collects/teachpack/door-sim.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 5.0 KiB

2
collects/teachpack/htdp/scribblings/image.scrbl
View File

@ -8,7 +8,7 @@
@teachpack["image"]{Manipulating Images} @teachpack["image"]{Manipulating Images}
@declare-exporting[teachpack/htdp/image] @declare-exporting[teachpack/htdp/image #:use-sources (htdp/image)]
The teachpack provides primitives for constructing and manipulating The teachpack provides primitives for constructing and manipulating
images. Basic, colored images are created as outlines or solid images. Basic, colored images are created as outlines or solid

342
collects/teachpack/htdp/scribblings/world.scrbl
View File

@ -1,6 +1,8 @@
#lang scribble/doc #lang scribble/doc
@(require scribble/manual "shared.ss" @(require scribble/manual
"shared.ss"
scribble/struct
(for-label scheme (for-label scheme
teachpack/htdp/image teachpack/htdp/image
teachpack/htdp/world teachpack/htdp/world
@ -10,9 +12,15 @@
@emph{Note}: For a quick and educational introduction to the teachpack, see @emph{Note}: For a quick and educational introduction to the teachpack, see
@link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How
to Design Programs, Second Edition: Prologue}. The purpose of this to Design Programs, Second Edition: Prologue}. As of August 2008, we also
documentation is to give experienced Schemers a concise overview for using have a series of projects available as a small booklet on
the library and for incorporating it elsewhere. @link["http://world.cs.brown.edu/"]{How to Design Worlds}.
The purpose of this documentation is to give experienced Schemers a concise
overview for using the library and for incorporating it elsewhere. The last
section presents @secref["example"] for an extremely simple domain and is
suited for a novice who knows how to design conditional functions for
symbols.
The teachpack provides two sets of tools. The first allows students to The teachpack provides two sets of tools. The first allows students to
create and display a series of animated scenes, i.e., a simulation. The create and display a series of animated scenes, i.e., a simulation. The
@ -20,6 +28,7 @@ second one generalizes the first by adding interactive GUI features.
@declare-exporting[teachpack/htdp/world #:use-sources (teachpack/htdp/image)] @declare-exporting[teachpack/htdp/world #:use-sources (teachpack/htdp/image)]
@; -----------------------------------------------------------------------------
@section[#:tag "basics"]{Basics} @section[#:tag "basics"]{Basics}
The teachpack assumes working knowledge of the basic image manipulation The teachpack assumes working knowledge of the basic image manipulation
@ -48,6 +57,7 @@ pinholes are at position @scheme[(0,0)].
@scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and @scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and
down from the upper-left corner.} down from the upper-left corner.}
@; -----------------------------------------------------------------------------
@section[#:tag "simulations"]{Simple Simulations} @section[#:tag "simulations"]{Simple Simulations}
@defproc[(run-simulation @defproc[(run-simulation
@ -86,13 +96,28 @@ Example:
@;----------------------------------------------------------------------------- @;-----------------------------------------------------------------------------
@section[#:tag "interactive"]{Interactions} @section[#:tag "interactive"]{Interactions}
An animation starts from a given ``world'' and generates new ones in response to events on the An animation starts from a given ``world'' and generates new ones in
computer. This teachpack keeps track of the ``current world'' and recognizes three kinds of events: response to events on the computer. This teachpack keeps track of the
clock ticks; keyboard presses and releases; and mouse movements, mouse clicks, etc. Your program may ``current world'' and recognizes three kinds of events: clock ticks;
deal with such events via the @emph{installation} of @emph{handlers}. The teachpack provides for the keyboard presses and releases; and mouse movements, mouse clicks,
installation of three event handlers: @scheme[on-tick-event], @scheme[on-key-event], and etc.
@scheme[on-mouse-event]. In addition, it provides for the installation of a @scheme[draw] handler,
which is called every time your program should visualize the current world. Your program may deal with such events via the @emph{installation} of
@emph{handlers}. The teachpack provides for the installation of three
event handlers: @scheme[on-tick-event], @scheme[on-key-event], and
@scheme[on-mouse-event]. In addition, it provides for the installation of
a @scheme[draw] handler, which is called every time your program should
visualize the current world.
The following picture provides an intuitive overview of the workings of
"world".
@image["world.png"]
The @scheme[big-bang] function installs @emph{World_0} as the initial
world; the callbacks @emph{tock}, @emph{react}, and @emph{click} transform
one world into another one; @emph{done} checks each time whether the world
is final; and @emph{draw} renders each world as a scene.
@deftech{World} @scheme[any/c] @deftech{World} @scheme[any/c]
@ -191,10 +216,12 @@ Example: The following examples shows that @scheme[(run-simulation 100 100
Exercise: Add a condition for stopping the flight of the UFO when it Exercise: Add a condition for stopping the flight of the UFO when it
reaches the bottom. reaches the bottom.
@; -----------------------------------------------------------------------------
@section{Scenes and Images} @section{Scenes and Images}
For the creation of scenes from the world, use the functions from @secref["image"]. The following two For the creation of scenes from the world, use the functions from
functions have turned out to be useful for the creation of scenes, too. @secref["image"]. The following two functions have turned out to be useful
for the creation of scenes, too.
@defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{ @defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{
@ -209,3 +236,292 @@ functions have turned out to be useful for the creation of scenes, too.
in contrast to the @scheme[add-line] function, this in contrast to the @scheme[add-line] function, this
one cuts off those portions of the line that go beyond the boundaries of one cuts off those portions of the line that go beyond the boundaries of
the given @scheme[s].} the given @scheme[s].}
@; -----------------------------------------------------------------------------
@(define (table* . stuff)
;; (list paragraph paragraph) *-> Table
(define (flow* x) (make-flow (list x)))
(make-blockquote #f
(list
(make-table (make-with-attributes 'boxed '((cellspacing . "6")))
;; list
(map (lambda (x) (map flow* x)) stuff)
#;(map flow* (map car stuff))
#;(map flow* (map cadr stuff))))))
@; -----------------------------------------------------------------------------
@section[#:tag "example"]{A First Example}
@subsection{Understanding a Door}
Say we want to represent a door with an automatic door closer. If this kind
of door is locked, you can unlock it. While this doesn't open the door per
se, it is now possible to do so. That is, an unlocked door is closed and
pushing at the door opens it. Once you have passed through the door and
you let go, the automatic door closer takes over and closes the door
again. Of course, at this point you could lock it again.
Here is a picture that translates our words into a graphical
representation:
@image["door-real.png"]
The picture displays a so-called "state machine". The three circled words
are the states that our informal description of the door identified:
locked, closed (and unlocked), and open. The arrows specify how the door
can go from one state into another. For example, when the door is open,
the automatic door closer shuts the door as time passes. This transition
is indicated by the arrow labeled "time passes." The other arrows
represent transitions in a similar manner:
@itemize[
@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
it to the locked position; and}
@item{"unlock" is the opposite of "lock".}
]
@; -----------------------------------------------------------------------------
@subsection{Simulations of the World}
Simulating any dynamic behavior via a program demands two different
activities. First, we must tease out those portions of our "world" that
change over time or in reaction to actions, and we must develop a data
representation @deftech{D} for this information. Keep in mind that a good data
definition makes it easy for readers to map data to information in the
real world and vice versa. For all others aspects of the world, we use
global constants, including graphical or visual constants that are used in
conjunction with the rendering operations.
Second, we must translate the "world" actions---the arrows in the above
diagram---into interactions with the computer that the world teachpack can
deal with. Once we have decided to use the passing of time for one aspect
and mouse movements for another, we must develop functions that map the
current state of the world---represented as data---into the next state of
the world. Since the data definition @tech{D} describes the class of data
that represents the world, these functions have the following general
contract and purpose statements:
@(begin
#reader scribble/comment-reader
(schemeblock
;; tick : @tech{D} -> @tech{D}
;; deal with the passing of time
(define (tick w) ...)
;; click : @tech{D} @scheme{Number} @scheme{Number} @tech{MouseEvent} -> @tech{D}
;; deal with a mouse click at (x,y) of kind @scheme{me}
;; in the current world @scheme{w}
(define (click w x y me) ...)
;; control : @tech{D} @tech{KeyEvent} -> @tech{D}
;; deal with a key event (symbol, char) @scheme{ke}
;; in the current world @scheme{w}
(define (control w ke) ...)
))
That is, the contracts of the various hooks dictate what the contracts of
these functions are once we have defined how to represent the world in
data.
A typical program does not use all three of these actions and functions but
often just one or two. Furthermore, the design of these functions provides
only the top-level, initial design goal. It often demands the design of
many auxiliary functions.
@; -----------------------------------------------------------------------------
@subsection{Simulating a Door: Data}
Our first and immediate goal is to represent the world as data. In this
specific example, the world consists of our door and what changes about
the door is whether it is locked, unlocked but closed, or open. We use
three symbols to represent the three states:
@deftech{SD}
@(begin
#reader scribble/comment-reader
(schemeblock
;; DATA DEF.
;; The state of the door (SD) is one of:
;; -- @scheme['locked]
;; -- @scheme['closed]
;; -- @scheme['open]
))
Symbols are particularly well-suited here because they directly express
the state of the door.
Now that we have a data definition, we must also decide which computer
actions and interactions should model the various actions on the door.
Our pictorial representation of the door's states and transitions,
specifically the arrow from "open" to "closed" suggests the use of a
function that simulates time. For the other three arrows, we could use
either keyboard events or mouse clicks or both. Our solution uses three
keystrokes:
@scheme{#\u} for unlocking the door,
@scheme{#\l} for locking it, and
@scheme{#\space} for pushing it open.
We can express these choices graphically by translating the above "state
machine" from the world of information into the world of data:
@image["door-sim.png"]
@; -----------------------------------------------------------------------------
@subsection{Simulating a Door: Functions}
Our analysis and data definition leaves us with three functions to design:
@itemize[
@item{@scheme{automatic-closer}, which closes the time during one tick;}
@item{@scheme{door-actions}, which manipulates the time in response to
pressing a key; and}
@item{@scheme{render}, which translates the current state of the door into
a visible scene.}
]
Let's start with @scheme{automatic-closer}. We know its contract and it is
easy to refine the purpose statement, too:
@(begin
#reader scribble/comment-reader
(schemeblock
;; automatic-closer : SD -> SD
;; closes an open door over the period of one tick
(define (automatic-closer state-of-door) ...)
))
Making up examples is trivial when the world can only be in one of three
states:
@table*[
@list[@t{ given state } @t{ desired state }]
@list[@t{ 'locked } @t{ 'locked }]
@list[@t{ 'closed } @t{ 'closed }]
@list[@t{ 'open } @t{ 'closed }]
]
@(begin
#reader scribble/comment-reader
(schemeblock
;; automatic-closer : SD -> SD
;; closes an open door over the period of one tick
(check-expect (automatic-closer 'locked) 'locked)
(check-expect (automatic-closer 'closed) 'closed)
(check-expect (automatic-closer 'open) 'closed)
(define (automatic-closer state-of-door) ...)
))
The template step demands a conditional with three clauses:
@(begin
#reader scribble/comment-reader
(schemeblock
(define (automatic-closer state-of-door)
(cond
[(symbol=? 'locked state-of-door) ...]
[(symbol=? 'closed state-of-door) ...]
[(symbol=? 'open state-of-door) ...]))
))
The examples basically dictate what the outcomes of the three cases must
be:
@(begin
#reader scribble/comment-reader
(schemeblock
(define (automatic-closer state-of-door)
(cond
[(symbol=? 'locked state-of-door) 'locked]
[(symbol=? 'closed state-of-door) 'closed]
[(symbol=? 'open state-of-door) 'closed]))
))
Don't forget to run the example-tests.
For the remaining three arrows of the diagram, we design a function that
reacts to the three chosen keyboard events. As mentioned, functions that
deal with keyboard events consume both a world and a keyevent:
@(begin
#reader scribble/comment-reader
(schemeblock
;; door-actions : SD Keyevent -> SD
;; key events simulate actions on the door
(define (door-actions s k) ...)
))
@table*[
@list[@t{ given state } @t{ given keyevent } @t{ desired state }]
@list[ @t{ 'locked } @t{ #\u } @t{ 'closed}]
@list[ @t{ 'closed } @t{ #\l } @t{ 'locked} ]
@list[ @t{ 'closed } @t{ #\space} @t{ 'open } ]
@list[ @t{ 'open } @t{ --- } @t{ 'open } ]]
The examples combine what the above picture shows and the choices we made
about mapping actions to keyboard events.
From here, it is straightforward to turn this into a complete design:
@schemeblock[
(define (door-actions s k)
(cond
[(and (symbol=? 'locked s) (key=? #\u k)) 'closed]
[(and (symbol=? 'closed s) (key=? #\l k)) 'locked]
[(and (symbol=? 'closed s) (key=? #\space k)) 'open]
[else s]))
(check-expect (door-actions 'locked #\u) 'closed)
(check-expect (door-actions 'closed #\l) 'locked)
(check-expect (door-actions 'closed #\space) 'open)
(check-expect (door-actions 'open 'any) 'open)
(check-expect (door-actions 'closed 'any) 'closed)
]
Last but not least we need a function that renders the current state of the
world as a scene. For simplicity, let's just use a large enough text for
this purpose:
@(begin
#reader scribble/comment-reader
(schemeblock
;; render : @tech{SD} -> @scheme{Scene}
;; translate the current state of the door into a large text
(define (render s)
(text (symbol->string s) 40 'red))
(check-expecy (render 'closed) (text "closed" 40 'red))
))
The function @scheme{symbol->string} translates a symbol into a string,
which is needed because @scheme{text} can deal only with the latter, not
the former. A look into the language documentation revealed that this
conversion function exists, and so we use it.
Once everything is properly designed, it is time to @emph{run} the
program. In the case of the world teachpack, this means we must specify
which function takes care of tick events, key events, and redraws:
@(begin
#reader scribble/comment-reader
(schemeblock
(big-bang 100 100 1 'locked)
(on-tick-event automatic-closer)
(on-key-event door-actions)
(on-redraw render)
))
Now it's time for you to collect the pieces and run them in DrScheme to see
whether it all works.

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

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 20 KiB

30
collects/tests/drscheme/repl-test.ss
View File

@ -133,12 +133,12 @@ This produces an ACK message
void) void)
(mktest "(" (mktest "("
("{stop-22x22.png} read: expected a `)'" ("{stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} read: expected a `)'" "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('"
"{stop-22x22.png} read: expected a `)'" "{stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} read: expected a `)'" "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'") "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('")
'definitions 'definitions
#f #f
void void
@ -467,12 +467,12 @@ This produces an ACK message
;; error in the middle ;; error in the middle
(mktest "1 2 ( 3 4" (mktest "1 2 ( 3 4"
("1\n2\n{stop-22x22.png} read: expected a `)'" ("1\n2\n{stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} read: expected a `)'" "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('"
"1\n2\n{stop-22x22.png} read: expected a `)'" "1\n2\n{stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} read: expected a `)'" "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'") "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('")
'definitions 'definitions
#f #f
void void
@ -1382,10 +1382,10 @@ This produces an ACK message
(let* ([end (- (get-int-pos) 1)] (let* ([end (- (get-int-pos) 1)]
[output (fetch-output drscheme-frame start end)] [output (fetch-output drscheme-frame start end)]
[expected "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"]) [expected #rx"reference to undefined identifier: x"])
(unless (equal? output expected) (unless (regexp-match expected output)
(failure) (failure)
(fprintf (current-error-port) "callcc-test: expected ~s, got ~s\n" expected output))))) (fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output)))))
(define (random-seed-test) (define (random-seed-test)
(define expression (define expression

2
collects/tests/framework/main.ss
View File

@ -53,7 +53,7 @@
(cond [all? all-files] (cond [all? all-files]
[batch? (remove* interactive-files all-files)] [batch? (remove* interactive-files all-files)]
[else files])))) [else files]))))
`("Names of the tests; defaults to all tests")) `("Names of the tests; defaults to all non-interactive tests"))
(when (file-exists? preferences-file) (when (file-exists? preferences-file)
(debug-printf admin " saving preferences file ~s to ~s\n" (debug-printf admin " saving preferences file ~s to ~s\n"

441
collects/tests/match/plt-match-tests.ss
View File

@ -1,233 +1,232 @@
(module plt-match-tests mzscheme #lang scheme/base
(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10)))
(require mzlib/plt-match) (require (for-syntax scheme/base))
(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10)))
(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10)))
(require (planet "views.ss" ("cobbe" "views.plt" 1 1))) (require mzlib/plt-match)
(define reg-tests (require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss")
(make-test-suite "Tests for regressions"
(make-test-case "quote in qp"
(assert eq? #t (match '(tile a b c)
[`(tile ,@'(a b c))
#t]
[else #f]))
(assert eq? #t (match '(tile a b c)
[`(tile ,@`(a b c))
#t]
[else #f])))))
(define cons-tests
(make-test-suite "Tests for cons pattern"
(make-test-case "simple"
(assert = 3 (match (cons 1 2) [(cons a b) (+ a b)])))))
(define match-expander-tests (require (planet "views.ss" ("cobbe" "views.plt" 1 1)))
(make-test-suite
"Tests for define-match-expander"
(make-test-case "Trivial expander"
(let ()
(define-match-expander bar (lambda (x) #'_) +)
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like +
(make-test-case "Trivial expander w/ keywords" (define reg-tests
(let () (make-test-suite "Tests for regressions"
(define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) (make-test-case "quote in qp"
(assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works (assert eq? #t (match '(tile a b c)
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything [`(tile ,@'(a b c))
(assert = 12 (bar 3 4 5)) #t]
(assert = 12 (apply bar '(3 4 5))))) ; bar works like + [else #f]))
(assert eq? #t (match '(tile a b c)
[`(tile ,@`(a b c))
#t]
[else #f])))))
(define cons-tests
(make-test-suite "Tests for cons pattern"
(make-test-case "simple"
(assert = 3 (match (cons 1 2) [(cons a b) (+ a b)])))))
;; gross hack to check for syntax errors (define match-expander-tests
(make-test-case "Only one xform gives syntax error" (make-test-suite
(assert-exn exn:fail:syntax? "Tests for define-match-expander"
(lambda () (make-test-case "Trivial expander"
(expand #'(let () (let ()
(define-match-expander bar (lambda (x) #'_)) (define-match-expander bar (lambda (x) #'_) +)
(bar 3 4)))))) (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works
(assert-true (match 3 [(bar) #t])) ; (bar) matches anything
(assert = 12 (bar 3 4 5))
(assert = 12 (apply bar '(3 4 5))))) ; bar works like +
;; more complex example from Dale (make-test-case "Trivial expander w/ keywords"
(make-test-case "Point structs" (let ()
(let () (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +)
(define-struct point (x y)) (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works
(define-match-expander Point (assert-true (match 3 [(bar) #t])) ; (bar) matches anything
(lambda (x) (assert = 12 (bar 3 4 5))
(syntax-case x () (assert = 12 (apply bar '(3 4 5))))) ; bar works like +
((Point a b) #'(struct point (a b)))))
make-point)
;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3)
[(Point x y) (+ x y)]))
;; check that sub-patterns still work
(assert = 7 (match (make-point 2 3)
[(Point (app add1 x) (app add1 y)) (+ x y)]))
;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3))
[(list (Point (app add1 x) (app add1 y))) (+ x y)]))
))
;; from richard's view documentation ;; gross hack to check for syntax errors
(make-test-case "Only one xform gives syntax error"
(assert-exn exn:fail:syntax?
(lambda ()
(expand #'(let ()
(define-match-expander bar (lambda (x) #'_))
(bar 3 4))))))
(make-test-case "Natural number views" ;; more complex example from Dale
(let () (make-test-case "Point structs"
(define natural-number? (let ()
(lambda (x) (define-struct point (x y))
(and (integer? x) (define-match-expander Point
(>= x 0)))) (lambda (x)
(define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) (syntax-case x ()
((Point a b) #'(struct point (a b)))))
(define-view peano-zero natural-zero? ()) make-point)
(define-view peano-succ natural-number? (sub1)) ;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3)
(define factorial [(Point x y) (+ x y)]))
(match-lambda ;; check that sub-patterns still work
[(peano-zero) 1] (assert = 7 (match (make-point 2 3)
[(and (peano-succ pred) n) (* n (factorial pred))])) [(Point (app add1 x) (app add1 y)) (+ x y)]))
(assert = 120 (factorial 5)))) ;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3))
;; more complex example from Dale [(list (Point (app add1 x) (app add1 y))) (+ x y)]))
(make-test-case "Point structs with keywords"
(let ()
(define-struct point (x y))
(define-match-expander Point
#:plt-match
(lambda (x)
(syntax-case x ()
((Point a b) #'(struct point (a b)))))
#:expression make-point)
;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3)
[(Point x y) (+ x y)]))
;; check that sub-patterns still work
(assert = 7 (match (make-point 2 3)
[(Point (app add1 x) (app add1 y)) (+ x y)]))
;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3))
[(list (Point (app add1 x) (app add1 y))) (+ x y)]))
))
))
(define simple-tests
(make-test-suite
"Some Simple Tests"
(make-test-case "Trivial"
(assert = 3 (match 3 [x x])))
(make-test-case "no order"
(assert equal? #t (match '(1 2 3 1)
[(list-no-order 3 2 1 1) #t]
[_ #f])))
(make-test-case "app pattern"
(assert = 4 (match 3 [(app add1 y) y])))
(make-test-case "struct patterns"
(let ()
(define-struct point (x y))
(define (origin? pt)
(match pt
((struct point (0 0)) #t)
(else #f)))
(assert-true (origin? (make-point 0 0)))
(assert-false (origin? (make-point 1 1)))))
))
(define nonlinear-tests
(make-test-suite
"Non-linear patterns"
(make-test-case "Very simple"
(assert = 3 (match '(3 3) [(list a a) a])))
(make-test-case "Fails"
(assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a]))))
(make-test-case "Use parameter"
(parameterize ([match-equality-test eq?])
(assert = 5 (match '((3) (3)) [(list a a) a] [_ 5]))))
(make-test-case "Nonlinear patterns use equal?"
(assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5])))))
(define doc-tests
(make-test-suite
"Tests from Help Desk Documentation"
(make-test-case "match-let"
(assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z))))
(make-test-case "lambda calculus"
(let ()
(define-struct Lam (args body))
(define-struct Var (s))
(define-struct Const (n))
(define-struct App (fun args))
(define parse
(match-lambda
[(and s (? symbol?) (not 'lambda))
(make-Var s)]
[(? number? n)
(make-Const n)]
[(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body)
(make-Lam args (parse body))]
[(list f args ...)
(make-App
(parse f)
(map parse args))]
[x (error 'syntax "invalid expression")]))
(define repeats?
(lambda (l)
(and (not (null? l))
(or (memq (car l) (cdr l)) (repeats? (cdr l))))))
(define unparse
(match-lambda
[(struct Var (s)) s]
[(struct Const (n)) n]
[(struct Lam (args body)) `(lambda ,args ,(unparse body))]
[(struct App (f args)) `(,(unparse f) ,@(map unparse args))]))
(assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x))))))
(make-test-case "counter : match-define"
(let ()
(match-define (list inc value reset)
(let ([val 0])
(list
(lambda () (set! val (add1 val)))
(lambda () val)
(lambda () (set! val 0)))))
(inc)
(inc)
(assert = 2 (value))
(inc)
(assert = 3 (value))
(reset)
(assert = 0 (value))))
))
(define plt-match-tests
(make-test-suite "Tests for plt-match.ss"
doc-tests
cons-tests
simple-tests
nonlinear-tests
match-expander-tests
reg-tests
)) ))
(define (run-tests) ;; from richard's view documentation
(test/text-ui (make-test-suite "Match Tests"
plt-match-tests (make-test-case "Natural number views"
match-tests (let ()
new-tests (define natural-number?
;; from bruce (lambda (x)
other-tests (and (integer? x)
other-plt-tests (>= x 0))))
))) (define natural-zero? (lambda (x) (and (integer? x) (zero? x))))
(if (getenv "PLT_TESTS")
(unless (parameterize ([current-output-port (open-output-string)]) (define-view peano-zero natural-zero? ())
(= 0 (run-tests))) (define-view peano-succ natural-number? (sub1))
(error "Match Tests did not pass."))
(run-tests)) (define factorial
) (match-lambda
[(peano-zero) 1]
[(and (peano-succ pred) n) (* n (factorial pred))]))
(assert = 120 (factorial 5))))
;; more complex example from Dale
(make-test-case "Point structs with keywords"
(let ()
(define-struct point (x y))
(define-match-expander Point
#:plt-match
(lambda (x)
(syntax-case x ()
((Point a b) #'(struct point (a b)))))
#:expression make-point)
;; check that it works as expression and as pattern
(assert = 5 (match (Point 2 3)
[(Point x y) (+ x y)]))
;; check that sub-patterns still work
(assert = 7 (match (make-point 2 3)
[(Point (app add1 x) (app add1 y)) (+ x y)]))
;; check that it works inside a list
(assert = 7 (match (list (make-point 2 3))
[(list (Point (app add1 x) (app add1 y))) (+ x y)]))
))
))
(define simple-tests
(make-test-suite
"Some Simple Tests"
(make-test-case "Trivial"
(assert = 3 (match 3 [x x])))
(make-test-case "no order"
(assert equal? #t (match '(1 2 3 1)
[(list-no-order 3 2 1 1) #t]
[_ #f])))
(make-test-case "app pattern"
(assert = 4 (match 3 [(app add1 y) y])))
(make-test-case "struct patterns"
(let ()
(define-struct point (x y))
(define (origin? pt)
(match pt
((struct point (0 0)) #t)
(else #f)))
(assert-true (origin? (make-point 0 0)))
(assert-false (origin? (make-point 1 1)))))
))
(define nonlinear-tests
(make-test-suite
"Non-linear patterns"
(make-test-case "Very simple"
(assert = 3 (match '(3 3) [(list a a) a])))
(make-test-case "Fails"
(assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a]))))
(make-test-case "Use parameter"
(parameterize ([match-equality-test eq?])
(assert = 5 (match '((3) (3)) [(list a a) a] [_ 5]))))
(make-test-case "Nonlinear patterns use equal?"
(assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5])))))
(define doc-tests
(make-test-suite
"Tests from Help Desk Documentation"
(make-test-case "match-let"
(assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z))))
(make-test-case "lambda calculus"
(let ()
(define-struct Lam (args body))
(define-struct Var (s))
(define-struct Const (n))
(define-struct App (fun args))
(define parse
(match-lambda
[(and s (? symbol?) (not 'lambda))
(make-Var s)]
[(? number? n)
(make-Const n)]
[(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body)
(make-Lam args (parse body))]
[(list f args ...)
(make-App
(parse f)
(map parse args))]
[x (error 'syntax "invalid expression")]))
(define repeats?
(lambda (l)
(and (not (null? l))
(or (memq (car l) (cdr l)) (repeats? (cdr l))))))
(define unparse
(match-lambda
[(struct Var (s)) s]
[(struct Const (n)) n]
[(struct Lam (args body)) `(lambda ,args ,(unparse body))]
[(struct App (f args)) `(,(unparse f) ,@(map unparse args))]))
(assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x))))))
(make-test-case "counter : match-define"
(let ()
(match-define (list inc value reset)
(let ([val 0])
(list
(lambda () (set! val (add1 val)))
(lambda () val)
(lambda () (set! val 0)))))
(inc)
(inc)
(assert = 2 (value))
(inc)
(assert = 3 (value))
(reset)
(assert = 0 (value))))
))
(define plt-match-tests
(make-test-suite "Tests for plt-match.ss"
doc-tests
cons-tests
simple-tests
nonlinear-tests
match-expander-tests
reg-tests
))
(define (run-tests)
(test/text-ui (make-test-suite "Match Tests"
plt-match-tests
match-tests
new-tests
;; from bruce
other-tests
other-plt-tests
)))
(unless (= 0 (run-tests))
(error "Match Tests did not pass."))

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

@ -57,3 +57,24 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); }
X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); } X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); }
X int grab7th(void *p) { return ((char *)p)[7]; } X int grab7th(void *p) { return ((char *)p)[7]; }
X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; }
typedef struct _char_int { unsigned char a; int b; } char_int;
X int charint_to_int(char_int x) { return ((int)x.a) + x.b; }
X char_int int_to_charint(int x) {
char_int result;
result.a = (unsigned char)x;
result.b = x;
return result;
}
X char_int charint_swap(char_int x) {
char_int result;
result.a = (unsigned char)x.b;
result.b = (int)x.a;
return result;
}
int(*grabbed_callback)(int) = NULL;
X void grab_callback(int(*f)(int)) { grabbed_callback = f; }
X int use_grabbed_callback(int n) { return grabbed_callback(n); }

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

@ -48,16 +48,19 @@
(compile-extension #t c o '()) (compile-extension #t c o '())
(link-extension #t (list o) so))) (link-extension #t (list o) so)))
(let* ([lib (ffi-lib "./foreign-test")] (define test-lib (ffi-lib "./foreign-test"))
[ffi (lambda (name type) (get-ffi-obj name lib type))]
[test* (lambda (expected name type proc) (for ([n (in-range 5)])
(test expected name (proc (ffi name type))))] (define (ffi name type) (get-ffi-obj name test-lib type))
[t (lambda (expected name type . args) (define (test* expected name type proc)
(test* expected name type (lambda (p) (apply p args))))] (test expected name (proc (ffi name type))))
[tc (lambda (expected name type arg1 . args) (define (t expected name type . args)
;; curry first argument (test* expected name type (lambda (p) (apply p args))))
(test* expected name type (lambda (p) (apply (p arg1) args))))] (define (tc expected name type arg1 . args)
[sqr (lambda (x) (* x x))]) ;; curry first argument
(test* expected name type (lambda (p) (apply (p arg1) args))))
(define (sqr x) (when (zero? (random 4)) (collect-garbage)) (* x x))
(define b (box #f))
;; --- ;; ---
(t 2 'add1_int_int (_fun _int -> _int ) 1) (t 2 'add1_int_int (_fun _int -> _int ) 1)
(t 2 'add1_byte_int (_fun _byte -> _int ) 1) (t 2 'add1_byte_int (_fun _byte -> _int ) 1)
@ -98,7 +101,7 @@
(test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int))
(lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10)))
;; --- ;; ---
(set-ffi-obj! "g3" lib (_fun _int -> _int) add1) (set-ffi-obj! "g3" test-lib (_fun _int -> _int) add1)
(t 4 'use_g3 (_fun _int -> _int) 3) (t 4 'use_g3 (_fun _int -> _int) 3)
(test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3))) (test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3)))
;; --- ;; ---
@ -120,11 +123,40 @@
(lambda (x y) (lambda (x y)
(let ([x (ptr-ref x _int)] [y (ptr-ref y _int)]) (let ([x (ptr-ref x _int)] [y (ptr-ref y _int)])
(cond [(< x y) -1] [(> x y) +1] [else 0]))))) (cond [(< x y) -1] [(> x y) +1] [else 0])))))
;; --- ;; ---
(t 55 'grab7th (_fun _pointer -> _int ) #"012345678") ;; test vectors
(t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1)) (t 55 'grab7th (_fun _pointer -> _int ) #"012345678")
(t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3)) (t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1))
(t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3))
(t 10 'vec4 (_fun (_list i _int) -> _int) '(1 2 3 4))
(t 10 'vec4 (_fun (_vector i _int) -> _int) '#(1 2 3 4))
(t 10 'vec4 (_fun _cvector -> _int) (list->cvector '(1 2 3 4) _int))
(t 10 'vec4 (_fun _pointer -> _int)
(cvector-ptr (list->cvector '(1 2 3 4) _int)))
;; ---
;; test passing and receiving structs
(let ([_charint (_list-struct _byte _int)])
(t 1212 'charint_to_int (_fun _charint -> _int) '(12 1200))
(t '(123 123) 'int_to_charint (_fun _int -> _charint) 123)
(t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255)))
;; ---
;; test sending a callback for C to hold, preventing the callback from GCing
(let ([with-keeper
(lambda (k)
(t (void) 'grab_callback
(_fun (_fun #:keep k _int -> _int) -> _void) sqr)
(t 9 'use_grabbed_callback (_fun _int -> _int) 3)
(collect-garbage) ; make sure it survives a GC
(t 25 'use_grabbed_callback (_fun _int -> _int) 5)
(collect-garbage)
(t 81 'use_grabbed_callback (_fun _int -> _int) 9))])
(with-keeper #t)
(with-keeper (box #f)))
;; ---
;; test exposing internal mzscheme functionality
(test '(1 2)
(get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme))
1 '(2))
) )
;; test setting vector elements ;; test setting vector elements
@ -184,7 +216,6 @@ The following is some random Scheme and C code, with some things that should be
added. added.
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
(define _foo (_list-struct (list _byte _int)))
(define foo-struct1 (define foo-struct1
(get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int))) (get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int)))
(define foo-struct2 (define foo-struct2
@ -284,12 +315,6 @@ added.
(string-set! x2 1 #\X) (string-set! x2 1 #\X)
(foo-test "foo_string" '(#f) '(string) 'string) (foo-test "foo_string" '(#f) '(string) 'string)
(newline)
(printf ">>> scheme_make_pair(1,2) -> ~s\n"
((ffi-call (ffi-obj libself "scheme_make_pair")
'(scheme scheme) 'scheme)
1 2))
(newline) (newline)
(printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int)) (printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int))
'(let loop ((l '())) '(let loop ((l '()))
@ -312,7 +337,6 @@ added.
(ffi-ptr-set! block1 'ulong 1 22) (ffi-ptr-set! block1 'ulong 1 22)
(ffi-ptr-set! block1 'ulong 2 33) (ffi-ptr-set! block1 'ulong 2 33)
(ffi-ptr-set! block1 'ulong 3 44) (ffi-ptr-set! block1 'ulong 3 44)
(foo-test "foo_vect" (list block1) '(pointer) 'int)
;(ffi-ptr-set! block1 'ulong 'abs 1 22) ;(ffi-ptr-set! block1 'ulong 'abs 1 22)
(printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0)) (printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0))
(printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1)) (printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1))
@ -393,26 +417,7 @@ char* foo_string (char* x) {
} }
} }
int foo_vect(int x[]) {
return x[0]+x[1]+x[2]+x[3];
}
int foo_foo(int x) { return x^1; } int foo_foo(int x) { return x^1; }
typedef struct _char_int {
unsigned char a;
int b;
} char_int;
int foo_struct1(char_int x) {
return ((int)x.a) + x.b;
}
char_int foo_struct2(char_int x) {
char_int result;
result.a = (unsigned char)x.b;
result.b = (int)x.a;
return result;
}
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
|# |#

51
collects/tests/mzscheme/syntax.ss
View File

@ -1128,6 +1128,57 @@
((car procs) 'x2 'z2) ((car procs) 'x2 'z2)
((cadr procs) 'x10 'z10)))) ((cadr procs) 'x10 'z10))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require scheme/splicing)
(define abcdefg 10)
(test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
[(_) 12])])
(abcdefg)))
(test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules ()
[(_) (abcdefg 10)]
[(_ x) (+ 3 x)])])
(abcdefg)))
(test 13 'splicing-letrec-syntax (let ([abcdefg 9])
(splicing-letrec-syntax ([abcdefg (syntax-rules ()
[(_) (abcdefg 10)]
[(_ x) (+ 3 x)])])
(abcdefg))))
(test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 12])])
(abcdefg)))
(test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)])
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 12])])
(abcdefg))))
(test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)])
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) (+ 2 (abcdefg 9))]
[(_ ?) 77])])
(abcdefg))))
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 8])])
(define hijklmn (abcdefg)))
(test 8 'hijklmn hijklmn)
(test 30 'local-hijklmn (let ()
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 8])])
(define hijklmn (abcdefg)))
(define other 22)
(+ other hijklmn)))
(test 8 'local-hijklmn (let ()
(splicing-let-syntax ([abcdefg (syntax-rules ()
[(_) 8])])
(begin
(define hijklmn (abcdefg))
hijklmn))))
(test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)])
(splicing-letrec-syntax ([abcdefg (syntax-rules ()
[(_) 0])])
(define x 10))
(abcdefg)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs) (report-errs)

6
collects/tests/typed-scheme/unit-tests/all-tests.ss
View File

@ -2,6 +2,7 @@
(require (require
"test-utils.ss" "test-utils.ss"
"planet-requires.ss"
"typecheck-tests.ss" "typecheck-tests.ss"
"subtype-tests.ss" ;; done "subtype-tests.ss" ;; done
"type-equal-tests.ss" ;; done "type-equal-tests.ss" ;; done
@ -12,9 +13,8 @@
"subst-tests.ss" "subst-tests.ss"
"infer-tests.ss") "infer-tests.ss")
(require (utils planet-requires) (r:infer infer infer-dummy)) (require (r:infer infer infer-dummy)
(schemeunit))
(require (schemeunit))
(provide unit-tests) (provide unit-tests)

9
collects/tests/typed-scheme/unit-tests/infer-tests.ss
View File

@ -1,11 +1,10 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (for-syntax scheme/base)) (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (utils planet-requires) (require (rep type-rep)
(rep type-rep)
(r:infer infer) (r:infer infer)
(private type-effect-convenience union type-utils) (private type-effect-convenience union type-utils)
(prefix-in table: (utils tables))) (prefix-in table: (utils tables))
(require (schemeunit)) (schemeunit))

3
collects/tests/typed-scheme/unit-tests/module-tests.ss
View File

@ -1,6 +1,5 @@
#lang scheme #lang scheme
(require "test-utils.ss") (require "test-utils.ss" "planet-requires.ss")
(require (utils planet-requires))
(require (schemeunit)) (require (schemeunit))
(provide module-tests) (provide module-tests)

4
collects/tests/typed-scheme/unit-tests/new-fv-tests.ss
View File

@ -1,6 +1,6 @@
(module new-fv-tests mzscheme (module new-fv-tests mzscheme
(require "test-utils.ss") (require "test-utils.ss" "planet-requires.ss")
(require/private type-rep rep-utils planet-requires type-effect-convenience meet-join subtype union) (require/private type-rep rep-utils type-effect-convenience meet-join subtype union)
(require-schemeunit) (require-schemeunit)
(define variance-gen (random-uniform Covariant Contravariant Invariant Constant)) (define variance-gen (random-uniform Covariant Contravariant Invariant Constant))

9
collects/tests/typed-scheme/unit-tests/parse-type-tests.ss
View File

@ -1,17 +1,16 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (for-syntax scheme/base)) (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (utils planet-requires tc-utils) (require (utils tc-utils)
(env type-alias-env type-environments type-name-env init-envs) (env type-alias-env type-environments type-name-env init-envs)
(rep type-rep) (rep type-rep)
(private type-comparison parse-type subtype (private type-comparison parse-type subtype
union type-utils)) union type-utils)
(schemeunit))
(require (rename-in (private type-effect-convenience) [-> t:->]) (require (rename-in (private type-effect-convenience) [-> t:->])
(except-in (private base-types) Un) (except-in (private base-types) Un)
(for-template (private base-types))) (for-template (private base-types)))
(require (schemeunit))
(provide parse-type-tests) (provide parse-type-tests)
;; HORRIBLE HACK! ;; HORRIBLE HACK!

9
collects/typed-scheme/utils/planet-requires.ss → collects/tests/typed-scheme/unit-tests/planet-requires.ss
View File

@ -47,17 +47,10 @@
(splice-requires (map mk (syntax->list #'(files ...)))))])))) (splice-requires (map mk (syntax->list #'(files ...)))))]))))
(provide galore schemeunit) (provide schemeunit)
;; why is this neccessary? ;; why is this neccessary?
(provide planet/multiple) (provide planet/multiple)
(define-module galore
(prefix-in table: "tables.ss"))
(require (galore))
(void (table:alist->eq '()))
(define-module schemeunit (define-module schemeunit
(planet/multiple ("schematics" "schemeunit.plt" 2 3) (planet/multiple ("schematics" "schemeunit.plt" 2 3)
"test.ss" "test.ss"

8
collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss
View File

@ -1,11 +1,9 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (for-syntax scheme/base)) (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (rep type-rep) (require (rep type-rep)
(utils planet-requires)
(r:infer infer) (r:infer infer)
(private type-effect-convenience remove-intersect subtype union)) (private type-effect-convenience remove-intersect subtype union)
(schemeunit))
(require (schemeunit))
(define-syntax (restr-tests stx) (define-syntax (restr-tests stx)
(syntax-case stx () (syntax-case stx ()

9
collects/tests/typed-scheme/unit-tests/subst-tests.ss
View File

@ -1,10 +1,9 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (for-syntax scheme/base)) (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (utils planet-requires) (require (rep type-rep)
(rep type-rep) (private type-utils type-effect-convenience)
(private type-utils type-effect-convenience)) (schemeunit))
(require (schemeunit))
(define-syntax-rule (s img var tgt result) (define-syntax-rule (s img var tgt result)
(test-eq? "test" (substitute img 'var tgt) result)) (test-eq? "test" (substitute img 'var tgt) result))

9
collects/tests/typed-scheme/unit-tests/subtype-tests.ss
View File

@ -1,15 +1,12 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss") (require "test-utils.ss" "planet-requires.ss")
(require (private subtype type-effect-convenience union) (require (private subtype type-effect-convenience union)
(rep type-rep) (rep type-rep)
(utils planet-requires)
(env init-envs type-environments) (env init-envs type-environments)
(r:infer infer infer-dummy)) (r:infer infer infer-dummy)
(schemeunit)
(require (schemeunit)
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide subtype-tests) (provide subtype-tests)

7
collects/tests/typed-scheme/unit-tests/test-utils.ss
View File

@ -1,15 +1,16 @@
#lang scheme/base #lang scheme/base
(provide (all-defined-out)) (provide (all-defined-out))
(require scheme/require-syntax (require "planet-requires.ss"
scheme/require-syntax
scheme/match scheme/match
typed-scheme/utils/utils typed-scheme/utils/utils
(for-syntax scheme/base)) (for-syntax scheme/base))
(require (utils planet-requires) (private type-comparison type-utils)) (require (private type-comparison type-utils)
(schemeunit))
(provide private typecheck (rename-out [infer r:infer]) utils env rep) (provide private typecheck (rename-out [infer r:infer]) utils env rep)
(require (schemeunit))
(define (mk-suite ts) (define (mk-suite ts)
(match (map (lambda (f) (f)) ts) (match (map (lambda (f) (f)) ts)

9
collects/tests/typed-scheme/unit-tests/type-annotation-test.ss
View File

@ -1,12 +1,11 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (require "test-utils.ss" "planet-requires.ss"
(for-syntax scheme/base)) (for-syntax scheme/base))
(require (private type-annotation type-effect-convenience parse-type) (require (private type-annotation type-effect-convenience parse-type)
(env type-environments type-name-env init-envs) (env type-environments type-name-env init-envs)
(utils planet-requires tc-utils) (utils tc-utils)
(rep type-rep)) (rep type-rep)
(schemeunit))
(require (schemeunit))
(provide type-annotation-tests) (provide type-annotation-tests)

8
collects/tests/typed-scheme/unit-tests/type-equal-tests.ss
View File

@ -1,9 +1,9 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (for-syntax scheme/base)) (require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base))
(require (utils planet-requires) (rep type-rep) (require (rep type-rep)
(private type-comparison type-effect-convenience union subtype)) (private type-comparison type-effect-convenience union subtype)
(require (schemeunit)) (schemeunit))
(provide type-equal-tests) (provide type-equal-tests)

9
collects/tests/typed-scheme/unit-tests/typecheck-tests.ss
View File

@ -1,21 +1,20 @@
#lang scheme/base #lang scheme/base
(require "test-utils.ss" (require "test-utils.ss" "planet-requires.ss"
(for-syntax scheme/base) (for-syntax scheme/base)
(for-template scheme/base)) (for-template scheme/base))
(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) (require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation)
(typecheck typechecker) (typecheck typechecker)
(rep type-rep effect-rep) (rep type-rep effect-rep)
(utils tc-utils planet-requires) (utils tc-utils)
(env type-name-env type-environments init-envs)) (env type-name-env type-environments init-envs)
(schemeunit))
(require (for-syntax (utils tc-utils) (require (for-syntax (utils tc-utils)
(typecheck typechecker) (typecheck typechecker)
(env type-env) (env type-env)
(private base-env)) (private base-env))
(for-template (private base-env base-types))) (for-template (private base-env base-types)))
(require (schemeunit))

2
collects/typed-scheme/private/type-effect-printer.ss
View File

@ -2,7 +2,7 @@
(require "../utils/utils.ss") (require "../utils/utils.ss")
(require (rep type-rep effect-rep rep-utils) (require (rep type-rep effect-rep rep-utils)
(utils planet-requires tc-utils) (utils tc-utils)
scheme/match) scheme/match)
;; do we attempt to find instantiations of polymorphic types to print? ;; do we attempt to find instantiations of polymorphic types to print?

1
collects/typed-scheme/rep/rep-utils.ss
View File

@ -4,7 +4,6 @@
(require mzlib/struct (require mzlib/struct
mzlib/plt-match mzlib/plt-match
syntax/boundmap syntax/boundmap
(utils planet-requires)
"free-variance.ss" "free-variance.ss"
"interning.ss" "interning.ss"
mzlib/etc mzlib/etc

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang scheme/base
(require "../utils/utils.ss") (require "../utils/utils.ss")
(require (utils planet-requires tc-utils) (require (utils tc-utils)
"rep-utils.ss" "effect-rep.ss" "free-variance.ss" "rep-utils.ss" "effect-rep.ss" "free-variance.ss"
mzlib/trace scheme/match mzlib/trace scheme/match
(for-syntax scheme/base)) (for-syntax scheme/base))

3
collects/typed-scheme/typecheck/tc-if-unit.ss
View File

@ -1,8 +1,7 @@
#lang scheme/unit #lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer])) (require (rename-in "../utils/utils.ss" [infer r:infer]))
(require (utils planet-requires) (require "signatures.ss"
"signatures.ss"
(rep type-rep effect-rep) (rep type-rep effect-rep)
(private type-effect-convenience subtype union type-utils type-comparison mutated-vars) (private type-effect-convenience subtype union type-utils type-comparison mutated-vars)
(env lexical-env) (env lexical-env)

6
doc/release-notes/mred/HISTORY.txt
View File

@ -1,3 +1,9 @@
Version 4.1.1, October 2008
Minor bug fixes
----------------------------------------------------------------------
Version 4.1, August 2008 Version 4.1, August 2008
Added auto-resize init argument and method to message% Added auto-resize init argument and method to message%

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

@ -1,4 +1,4 @@
Version 4.1.0.4 Version 4.1.1, October 2008
Added read-language Added read-language
Added module-compiled-language-info, module->language-info, Added module-compiled-language-info, module->language-info,
and 'module-language property support and 'module-language property support

1
doc/release-notes/stepper/DESIGN-NOTES
View File

@ -910,4 +910,5 @@ harder than I expected. Don't ask me about lazy scheme. Or Advanced. Grr!
2008-05-08 2008-05-08
**************

145
doc/release-notes/stepper/HISTORY.txt
View File

@ -1,61 +1,55 @@
Stepper Stepper
------- -------
Changes for v101: Changes for v4.1.1:
all steps scroll to bottom automatically. Check-expect now reduces to a boolean in the stepper. Also, this history file
constants like 'pi' are explicitly expanded in a step. now appears with the most recent entries at the top....
stepper uses fewer threads internally.
Changes for v102: Changes for v4.1:
Stepper handles intermediate level.
UI redesigned to use "side-by-side" reduction.
Changes for v103:
PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631
Changes for v200:
Total rewrite for new syntax. Addition of test suites.
Addition of somewhat more systematic macro unwinding.
Lots of bug fixes.
Changes for v201:
Minor bug fixes.
Changes for v203:
Much more systematic unwinding, intermediate almost ready, redesigned test suite
Changes for v204:
none. none.
Changes for v205: Changes for v4.0.1:
v. minor bug fixes. none.
Changes for v206: Changes for v4.0:
Stepper supports intermediate, minor bug fixes, major rewrite of interface overhauled support for check-expect, check-within, check-error.
between reconstruct and display.
Changes for v206p1: Changes for v372:
support for check-expect, check-within, and check-error
Changes for v371:
None. None.
Changes for v207: Changes for v370:
None. Added "End" button to stepper interface.
Changes for v208: Stepper supports "begin0". Again, you'll never know it unless you use
the PLTSTEPPERUNSAFE environment variable.
minor bug fixes. There's a known bug with expressions of the form (let <bindings> (begin
...)). (It's displayed as (let () X) rather than (begin X).)
Changes for v209: Changes for v361:
Bug fix for test cases
Changes for v360:
Stepper supports 'begin'. You'll never know it unless you use the
PLTSTEPPERUNSAFE environment variable, though.
Changes for v351:
Minor bug fixes
Changes for v350:
None. None.
@ -72,43 +66,60 @@ presence of mutation, it's no longer the case that the "finished" expressions
never change, which means that they can't always be shared between the left and never change, which means that they can't always be shared between the left and
right hand sides. right hand sides.
Changes for v350: Changes for v209:
None. None.
Changes for v351: Changes for v208:
Minor bug fixes minor bug fixes.
Changes for v360: Changes for v207:
Stepper supports 'begin'. You'll never know it unless you use the
PLTSTEPPERUNSAFE environment variable, though.
Changes for v361:
Bug fix for test cases
Changes for v370:
Added "End" button to stepper interface.
Stepper supports "begin0". Again, you'll never know it unless you use
the PLTSTEPPERUNSAFE environment variable.
There's a known bug with expressions of the form (let <bindings> (begin
...)). (It's displayed as (let () X) rather than (begin X).
Changes for v371:
None. None.
Changes for v372: support for check-expect, check-within, and check-error Changes for v206p1:
Changes for v4.0: overhauled support for check-expect, check-within, None.
check-error.
Changes for v4.0.1: none. Changes for v206:
Changes for v4.1: none. Stepper supports intermediate, minor bug fixes, major rewrite of interface
between reconstruct and display.
Changes for v205:
v. minor bug fixes.
Changes for v204:
none.
Changes for v203:
Much more systematic unwinding, intermediate almost ready, redesigned test suite
Changes for v201:
Minor bug fixes.
Changes for v200:
Total rewrite for new syntax. Addition of test suites.
Addition of somewhat more systematic macro unwinding.
Lots of bug fixes.
Changes for v103:
PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631
Changes for v102:
Stepper handles intermediate level.
UI redesigned to use "side-by-side" reduction.
Changes for v101:
all steps scroll to bottom automatically.
constants like 'pi' are explicitly expanded in a step.
stepper uses fewer threads internally.

5
doc/release-notes/teachpack/HISTORY.txt
View File

@ -1,3 +1,8 @@
------------------------------------------------------------------------
Version 4.1.1 [Tue Sep 30 10:17:26 EDT 2008]
* world.ss: big-bang can now be re-run after the world has stopped
------------------------------------------------------------------------ ------------------------------------------------------------------------
Version 4.1 [Sun Aug 10 12:56:58 EDT 2008] Version 4.1 [Sun Aug 10 12:56:58 EDT 2008]

50
src/foreign/foreign.c
View File

@ -4,6 +4,8 @@
** to make changes, edit that file and ** to make changes, edit that file and
** run it to generate an updated version ** run it to generate an updated version
** of this file. ** of this file.
** NOTE: This is no longer true, foreign.ssc needs to be updated to work with
** the scribble/text preprocessor instead.
********************************************/ ********************************************/
@ -2233,6 +2235,9 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar
len, 0); len, 0);
} }
/* *** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors. */
/* internal: apply Scheme finalizer */ /* internal: apply Scheme finalizer */
void do_scm_finalizer(void *p, void *finalizer) void do_scm_finalizer(void *p, void *finalizer)
{ {
@ -2263,9 +2268,6 @@ void do_ptr_finalizer(void *p, void *finalizer)
/* (Only needed in cases where pointer aliases might be created.) */ /* (Only needed in cases where pointer aliases might be created.) */
/* /*
*** Calling Scheme code while the GC is working leads to subtle bugs, so
*** this is implemented now in Scheme using will executors.
(defsymbols pointer) (defsymbols pointer)
(cdefine register-finalizer 2 3) (cdefine register-finalizer 2 3)
{ {
@ -2519,7 +2521,7 @@ typedef struct closure_and_cif_struct {
void free_cl_cif_args(void *ignored, void *p) void free_cl_cif_args(void *ignored, void *p)
{ {
/* /*
scheme_warning("Releaseing cl+cif+args %V %V (%d)", scheme_warning("Releasing cl+cif+args %V %V (%d)",
ignored, ignored,
(((closure_and_cif*)p)->data), (((closure_and_cif*)p)->data),
SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); SAME_OBJ(ignored,(((closure_and_cif*)p)->data)));
@ -2530,6 +2532,44 @@ void free_cl_cif_args(void *ignored, void *p)
free(p); free(p);
} }
/* This is a temporary hack to allocate a piece of executable memory, */
/* it should be removed when mzscheme's core will include a similar function */
#ifndef WINDOWS_DYNAMIC_LOAD
#include <sys/mman.h>
#endif
void *malloc_exec(size_t size) {
static long pagesize = -1;
void *p, *pp;
if (pagesize == -1) {
#ifndef WINDOWS_DYNAMIC_LOAD
pagesize = getpagesize();
#else
{
SYSTEM_INFO info;
GetSystemInfo(&info);
pagesize = info.dwPageSize;
}
#endif
}
p = malloc(size);
if (p == NULL)
scheme_signal_error("internal error: malloc failed (malloc_exec)");
/* set pp to the beginning of the page */
pp = (void*)(((long)p) & ~(pagesize-1));
/* set size to a pagesize multiple, in case the block is more than a page */
size = ((((long)p)+size+pagesize-1) & ~(pagesize-1)) - ((long)pp);
#ifndef WINDOWS_DYNAMIC_LOAD
if (mprotect(pp, size, PROT_READ|PROT_WRITE|PROT_EXEC))
perror("malloc_exec mprotect failure");
#else
{
DWORD old;
VirtualProtect(pp, size, PAGE_EXECUTE_READWRITE, &old);
}
#endif
return 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 */
@ -2586,7 +2626,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[])
rtype = CTYPE_PRIMTYPE(base); rtype = CTYPE_PRIMTYPE(base);
abi = GET_ABI(MYNAME,3); abi = GET_ABI(MYNAME,3);
/* malloc space for everything needed, so a single free gets rid of this */ /* malloc space for everything needed, so a single free gets rid of this */
cl_cif_args = malloc(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl_cif_args = malloc_exec(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*));
cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */
cif = &(cl_cif_args->cif); cif = &(cl_cif_args->cif);
atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif));

17
src/mzscheme/src/env.c
View File

@ -2513,10 +2513,19 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
/* Used out of context? */ /* Used out of context? */
if (SAME_OBJ(modidx, scheme_undefined)) { if (SAME_OBJ(modidx, scheme_undefined)) {
if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) if (!env->genv->module && SCHEME_STXP(find_id)) {
scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */
"identifier used out of context"); find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL);
return NULL; if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id)))
modidx = NULL; /* yes, it is bound */
}
if (modidx) {
if (!(flags & SCHEME_OUT_OF_CONTEXT_OK))
scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
"identifier used out of context");
return NULL;
}
} }
if (modidx) { if (modidx) {

4
src/mzscheme/src/eval.c
View File

@ -6399,6 +6399,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
result = scheme_make_pair(result, scheme_null); result = scheme_make_pair(result, scheme_null);
SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result);
return scheme_expand_list(result, env, rec, drec); return scheme_expand_list(result, env, rec, drec);
} else {
result = scheme_make_pair(result, scheme_null);
return scheme_datum_to_syntax(result, forms, forms, 0, 0);
} }
} }
} }
@ -6420,6 +6423,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env,
rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0); rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0);
first = scheme_compile_expr(first, env, recs, 0); first = scheme_compile_expr(first, env, recs, 0);
#if EMBEDDED_DEFINES_START_ANYWHERE #if EMBEDDED_DEFINES_START_ANYWHERE
forms = scheme_compile_expand_block(rest, env, recs, 1); forms = scheme_compile_expand_block(rest, env, recs, 1);
#else #else

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "4.1.0.4" #define MZSCHEME_VERSION "4.1.1.1"
#define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_X 4
#define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Y 1
#define MZSCHEME_VERSION_Z 0 #define MZSCHEME_VERSION_Z 1
#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_W 1
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)

110
src/mzscheme/src/stxobj.c
View File

@ -3247,6 +3247,35 @@ static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *
return NULL; return NULL;
} }
static int nonempty_rib(Scheme_Lexical_Rib *rib)
{
rib = rib->next;
while (rib) {
if (SCHEME_RENAME_LEN(rib->rename))
return 1;
rib = rib->next;
}
return 0;
}
static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
{
while (skip_ribs) {
if (SAME_OBJ(SCHEME_CAR(skip_ribs), timestamp))
return 1;
skip_ribs = SCHEME_CDR(skip_ribs);
}
return 0;
}
static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs)
{
return scheme_make_raw_pair(timestamp, skip_ribs);
}
#define QUICK_STACK_SIZE 10 #define QUICK_STACK_SIZE 10
#define EXPLAIN_RESOLVE 0 #define EXPLAIN_RESOLVE 0
@ -3275,7 +3304,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
If neither, result is #f and get_names[0] is either unchanged or NULL. */ If neither, result is #f and get_names[0] is either unchanged or NULL. */
{ {
WRAP_POS wraps; WRAP_POS wraps;
Scheme_Object *o_rename_stack = scheme_null; Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs;
Scheme_Object *mresult = scheme_false; Scheme_Object *mresult = scheme_false;
Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL;
Scheme_Object *rename_stack[QUICK_STACK_SIZE]; Scheme_Object *rename_stack[QUICK_STACK_SIZE];
@ -3286,7 +3315,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Object *bdg = NULL, *floating = NULL;
Scheme_Hash_Table *export_registry = NULL; Scheme_Hash_Table *export_registry = NULL;
EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))); EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL)));
if (_wraps) { if (_wraps) {
WRAP_POS_COPY(wraps, *_wraps); WRAP_POS_COPY(wraps, *_wraps);
@ -3553,17 +3583,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
} else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps))
&& !no_lexical)) { && !no_lexical)) {
/* Lexical rename: */ /* Lexical rename: */
Scheme_Object *rename, *renamed, *recur_skip_ribs; Scheme_Object *rename, *renamed;
int ri, c, istart, iend, is_rib; int ri, c, istart, iend, is_rib;
if (rib) { if (rib) {
rename = rib->rename; rename = rib->rename;
recur_skip_ribs = rib->timestamp;
rib = rib->next; rib = rib->next;
is_rib = 1; is_rib = 1;
} else { } else {
rename = WRAP_POS_FIRST(wraps); rename = WRAP_POS_FIRST(wraps);
recur_skip_ribs = skip_ribs;
is_rib = 0; is_rib = 0;
} }
@ -3658,19 +3686,23 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps);
EXPLAIN(printf("Rib: %p...\n", rib)); EXPLAIN(printf("Rib: %p...\n", rib));
if (skip_ribs) { if (skip_ribs) {
if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) { if (in_skip_set(rib->timestamp, skip_ribs)) {
EXPLAIN(printf("Skip rib\n")); EXPLAIN(printf("Skip rib\n"));
rib = NULL; rib = NULL;
} }
} }
if (rib) { if (rib) {
if (SAME_OBJ(did_rib, rib)) { if (nonempty_rib(rib)) {
EXPLAIN(printf("Did rib\n")); if (SAME_OBJ(did_rib, rib)) {
rib = NULL; EXPLAIN(printf("Did rib\n"));
} else { rib = NULL;
did_rib = rib; } else {
rib = rib->next; /* First rib record has no rename */ recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs);
} did_rib = rib;
rib = rib->next; /* First rib record has no rename */
}
} else
rib = NULL;
} }
} else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) {
did_rib = NULL; did_rib = NULL;
@ -4372,7 +4404,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
WRAP_POS w; WRAP_POS w;
WRAP_POS prev; WRAP_POS prev;
WRAP_POS w2; WRAP_POS w2;
Scheme_Object *stack = scheme_null, *key, *old_key; Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs;
Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl;
long size, vsize, psize, i, j, pos; long size, vsize, psize, i, j, pos;
@ -4381,8 +4413,14 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
(But don't mutate the wrap list, because that will stomp on (But don't mutate the wrap list, because that will stomp on
tables that might be needed by a propoagation.) tables that might be needed by a propoagation.)
In addition to depending on the rest of the wraps, a
simplifciation can depend on preceding wraps due to rib
skipping. So the lex_cache maps a wrap to another hash table that
maps a skip list to a simplified rename.
A lex_cache maps wrap starts w to simplified tables. A lex_cache A lex_cache maps wrap starts w to simplified tables. A lex_cache
is modified by this function, only. */ is modified by this function, only, but it's also read in
datum_to_wraps. */
WRAP_POS_INIT(w, wraps); WRAP_POS_INIT(w, wraps);
WRAP_POS_INIT_END(prev); WRAP_POS_INIT_END(prev);
@ -4396,9 +4434,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
key = WRAP_POS_KEY(w); key = WRAP_POS_KEY(w);
if (!SAME_OBJ(key, old_key)) { if (!SAME_OBJ(key, old_key)) {
v = scheme_hash_get(lex_cache, key); v = scheme_hash_get(lex_cache, key);
if (v)
v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs);
} else } else
v = NULL; v = NULL;
old_key = key; old_key = key;
orig_skip_ribs = skip_ribs;
if (v) { if (v) {
/* Tables here are already simplified. */ /* Tables here are already simplified. */
@ -4412,6 +4453,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
if (SCHEME_RIBP(v)) { if (SCHEME_RIBP(v)) {
/* A rib certainly isn't simplified yet. */ /* A rib certainly isn't simplified yet. */
add = 1; add = 1;
if (nonempty_rib((Scheme_Lexical_Rib *)v))
skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs);
} else { } else {
/* Need to simplify this vector? */ /* Need to simplify this vector? */
if (SCHEME_VEC_SIZE(v) == 1) if (SCHEME_VEC_SIZE(v) == 1)
@ -4425,7 +4468,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
if (add) { if (add) {
/* Need to simplify, but do deepest first: */ /* Need to simplify, but do deepest first: */
if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) { if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) {
stack = CONS(key, stack); stack = CONS(CONS(key, orig_skip_ribs), stack);
} }
} else { } else {
/* This is already simplified. Remember it and stop, because /* This is already simplified. Remember it and stop, because
@ -4442,8 +4485,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
while (!SCHEME_NULLP(stack)) { while (!SCHEME_NULLP(stack)) {
key = SCHEME_CAR(stack); key = SCHEME_CAR(stack);
orig_skip_ribs = SCHEME_CDR(key);
key = SCHEME_CAR(key);
v2l = scheme_null; v2l = scheme_null;
skip_ribs = orig_skip_ribs;
WRAP_POS_REVINIT(w, key); WRAP_POS_REVINIT(w, key);
while (!WRAP_POS_REVEND_P(w)) { while (!WRAP_POS_REVEND_P(w)) {
@ -4460,14 +4507,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
if (SCHEME_RIBP(v)) { if (SCHEME_RIBP(v)) {
init_rib = (Scheme_Lexical_Rib *)v; init_rib = (Scheme_Lexical_Rib *)v;
skip_ribs = init_rib->timestamp; if (nonempty_rib(init_rib))
rib = init_rib->next; skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs);
vsize = 0; rib = init_rib->next;
while (rib) { vsize = 0;
vsize += SCHEME_RENAME_LEN(rib->rename); while (rib) {
rib = rib->next; vsize += SCHEME_RENAME_LEN(rib->rename);
} rib = rib->next;
rib = init_rib->next; }
rib = init_rib->next;
} else } else
vsize = SCHEME_RENAME_LEN(v); vsize = SCHEME_RENAME_LEN(v);
@ -4611,7 +4659,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
WRAP_POS_DEC(w); WRAP_POS_DEC(w);
} }
scheme_hash_set(lex_cache, key, v2l); v = scheme_hash_get(lex_cache, key);
if (!v) {
v = (Scheme_Object *)scheme_make_hash_table_equal();
scheme_hash_set(lex_cache, key, v);
}
scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l);
stack = SCHEME_CDR(stack); stack = SCHEME_CDR(stack);
} }
@ -4622,7 +4675,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
Scheme_Hash_Table *rns, Scheme_Hash_Table *rns,
int just_simplify) int just_simplify)
{ {
Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null; Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null;
WRAP_POS w; WRAP_POS w;
Scheme_Hash_Table *lex_cache, *reverse_map; Scheme_Hash_Table *lex_cache, *reverse_map;
int stack_size = 0; int stack_size = 0;
@ -4690,8 +4743,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
of simplified tables for the current wrap segment. */ of simplified tables for the current wrap segment. */
if (SCHEME_NULLP(simplifies)) { if (SCHEME_NULLP(simplifies)) {
simplifies = scheme_hash_get(lex_cache, old_key); simplifies = scheme_hash_get(lex_cache, old_key);
simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs);
/* assert: a is not NULL; see the simplify_lex_rename() call above */ /* assert: a is not NULL; see the simplify_lex_rename() call above */
} }
if (SCHEME_RIBP(a)) {
if (nonempty_rib((Scheme_Lexical_Rib *)a))
skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs);
}
a = SCHEME_CAR(simplifies); a = SCHEME_CAR(simplifies);
/* used up one simplification: */ /* used up one simplification: */
simplifies = SCHEME_CDR(simplifies); simplifies = SCHEME_CDR(simplifies);

26
src/mzscheme/src/syntax.c
View File

@ -4464,6 +4464,9 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
Scheme_Comp_Env *env, Scheme_Comp_Env *env,
Scheme_Compile_Info *rec, int drec) Scheme_Compile_Info *rec, int drec)
{ {
#if 0
/* This attempt at a shortcut is wrong, because the sole expression might expand
to a `begin' that needs to be spliced into an internal-definition context. */
try_again: try_again:
if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) {
@ -4471,7 +4474,7 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
Scheme_Object *first, *val; Scheme_Object *first, *val;
first = SCHEME_STX_CAR(forms); first = SCHEME_STX_CAR(forms);
first = scheme_check_immediate_macro(first, env, rec, drec, 0, &val, NULL, NULL); first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL);
if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) {
/* Flatten begin: */ /* Flatten begin: */
@ -4485,17 +4488,18 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms,
} }
return scheme_compile_expr(first, env, rec, drec); return scheme_compile_expr(first, env, rec, drec);
}
#endif
if (scheme_stx_proper_list_length(forms) < 0) {
scheme_wrong_syntax(scheme_begin_stx_string, NULL,
scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0),
"bad syntax (" IMPROPER_LIST_FORM ")");
return NULL;
} else { } else {
if (scheme_stx_proper_list_length(forms) < 0) { Scheme_Object *body;
scheme_wrong_syntax(scheme_begin_stx_string, NULL, body = scheme_compile_block(forms, env, rec, drec);
scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), return scheme_make_sequence_compilation(body, 1);
"bad syntax (" IMPROPER_LIST_FORM ")");
return NULL;
} else {
Scheme_Object *body;
body = scheme_compile_block(forms, env, rec, drec);
return scheme_make_sequence_compilation(body, 1);
}
} }
} }

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

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

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

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

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

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

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

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

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

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

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

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