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

sync to trunk

Browse Source 
svn: r13609
This commit is contained in:
Sam Tobin-Hochstadt 2009-02-15 17:45:53 +00:00
parent 345abb820b
commit 738b8311af
32 changed files with 2072 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
collects/2htdp/private/universe.ss
View File

@ -57,21 +57,21 @@
(define (pname a ...)
(define (handler e) (stop! e))
(with-handlers ([exn? handler])
(define r (check-state-x-mail 'name (name worlds universe a ...)))
(define r (check-state-x-mail 'name (name iworlds universe a ...)))
(define u (bundle-state r))
(set! worlds (bundle-low r))
(set! iworlds (bundle-low r))
(set! universe u)
(unless (boolean? to-string) (send gui add (to-string worlds u)))
(unless (boolean? to-string) (send gui add (to-string iworlds u)))
(broadcast (bundle-mails r))))))
(def/cback private (pmsg world received) on-msg)
(def/cback private (pmsg iworld received) on-msg)
(def/cback private (pdisconnect world) on-disconnect)
(def/cback private (pdisconnect iworld) on-disconnect)
(def/cback private (pnew world) ppnew)
(def/cback private (pnew iworld) ppnew)
(define/private (ppnew low uni p)
(world-send p 'okay)
(iworld-send p 'okay)
(on-new low uni p))
(def/cback public (ptock) tick)
@ -90,7 +90,7 @@
;; -----------------------------------------------------------------------
;; start and stop server, start and stop the universe
(field [worlds '()] ;; [Listof World]
(field [iworlds '()] ;; [Listof World]
[gui (new gui%
[stop-server (lambda () (stop! universe))]
[stop-and-restart (lambda () (restart))])]
@ -103,50 +103,50 @@
(parameterize ([current-custodian the-custodian])
(define (loop)
(apply sync
(handle-evt (tcp-accept-evt tcp-listener) add-world)
(map world-wait-for-msg worlds)))
(define (add-world in-out)
(handle-evt (tcp-accept-evt tcp-listener) add-iworld)
(map iworld-wait-for-msg iworlds)))
(define (add-iworld in-out)
(with-handlers ((tcp-eof? (lambda _ (loop))))
(define in (first in-out))
(define next (tcp-receive in))
(match next
[(cons 'REGISTER info)
(let* ([w (create-world in (second in-out) info)])
; (set! worlds (cons w worlds))
(let* ([w (create-iworld in (second in-out) info)])
; (set! iworlds (cons w iworlds))
(pnew w)
(send gui add (format "~a signed up" info))
(loop))]
[else (loop)])))
(define (world-wait-for-msg p)
(handle-evt (world-in p)
(define (iworld-wait-for-msg p)
(handle-evt (iworld-in p)
(lambda (in)
(with-handlers
((tcp-eof?
(lambda (e)
(handler p e
(lambda ()
(if (null? worlds)
(if (null? iworlds)
(restart)
(loop)))))))
(define r (tcp-receive in))
(send gui add (format "~a ->: ~a" (world-name p) r))
(send gui add (format "~a ->: ~a" (iworld-name p) r))
(pmsg p r)
(loop)))))
(define tcp-listener
(with-handlers ((exn:fail:network? (lambda (x) (stop! x))))
(tcp-listen SQPORT 4 #t)))
;; --- go universe go ---
(set! worlds '())
(set! iworlds '())
(set! universe universe0)
(send gui add "a new universe is up and running")
(thread loop)))
;; World Exn (-> X) -> X
(define/private (handler p e cont)
(close-output-port (world-out p))
(close-input-port (world-in p))
(send gui add (format "~a !! closed port" (world-name p)))
(set! worlds (remq p worlds))
(close-output-port (iworld-out p))
(close-input-port (iworld-in p))
(send gui add (format "~a !! closed port" (iworld-name p)))
(set! iworlds (remq p iworlds))
(pdisconnect p)
(cont))
@ -163,12 +163,12 @@
;; (handler
(with-handlers ((exn? (lambda (e) (printf "\n\n*** to be done ***\n\n"))))
(define w (mail-to p+m))
(define n (world-name w))
(define n (iworld-name w))
(define p (mail-content p+m))
(unless (memq w worlds)
(unless (memq w iworlds)
(send gui add (format "~s not on list" n)))
(when (memq w worlds)
(world-send w p)
(when (memq w iworlds)
(iworld-send w p)
(send gui add (format "-> ~a: ~a" n p)))))
lm))
@ -184,9 +184,9 @@
(send gui add "stopping the universe")
(send gui add "----------------------------------")
(for-each (lambda (w)
(close-input-port (world-in w))
(close-output-port (world-out w)))
worlds)
(close-input-port (iworld-in w))
(close-output-port (iworld-out w)))
iworlds)
(custodian-shutdown-all the-custodian)
(semaphore-post go)))
@ -217,35 +217,35 @@
;
(provide
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world-name ;; World -> Symbol
world1 ;; sample worlds
world2
world3)
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
iworld-name ;; World -> Symbol
iworld1 ;; sample worlds
iworld2
iworld3)
;; --- the server representation of a world ---
(define-struct world (in out name info) #:transparent)
;; World = (make-world IPort OPort Symbol [Listof Sexp])
(define-struct iworld (in out name info) #:transparent)
;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
(define world1 (make-world (current-input-port) (current-output-port) 'sk '()))
(define world2 (make-world (current-input-port) (current-output-port) 'mf '()))
(define world3 (make-world (current-input-port) (current-output-port) 'rf '()))
(define iworld1 (make-iworld (current-input-port) (current-output-port) 'sk '()))
(define iworld2 (make-iworld (current-input-port) (current-output-port) 'mf '()))
(define iworld3 (make-iworld (current-input-port) (current-output-port) 'rf '()))
(define (world=? u v)
(check-arg 'world=? (world? u) 'world "first" u)
(check-arg 'world=? (world? v) 'world "second" v)
(define (iworld=? u v)
(check-arg 'iworld=? (iworld? u) 'iworld "first" u)
(check-arg 'iworld=? (iworld? v) 'iworld "second" v)
(eq? u v))
;; IPort OPort Sexp -> Player
(define (create-world i o info)
(define (create-iworld i o info)
(if (and (pair? info) (symbol? (car info)))
(make-world i o (car info) (cdr info))
(make-world i o (gensym 'world) info)))
(make-iworld i o (car info) (cdr info))
(make-iworld i o (gensym 'iworld) info)))
;; Player S-exp -> Void
(define (world-send p sexp)
(tcp-send (world-out p) sexp))
(define (iworld-send p sexp)
(tcp-send (iworld-out p) sexp))
;
;
@ -351,16 +351,16 @@
(set! make-bundle
(let ([make-bundle make-bundle])
(lambda (low state mails)
(check-arg-list 'make-bundle low world? "world" "first")
(check-arg-list 'make-bundle low iworld? "iworld" "first")
(check-arg-list 'make-bundle mails mail? "mail" "third")
(make-bundle low state mails))))
;; Symbol Any (Any -> Boolean) String String -> Void
;; raise a TP exception if low is not a list of world? elements
(define (check-arg-list tag low world? msg rank)
(define (check-arg-list tag low iworld? msg rank)
(check-arg tag (list? low) (format "list [of ~as]" msg) rank low)
(for-each (lambda (c)
(check-arg tag (world? c) msg (format "(elements of) ~a" rank) c))
(check-arg tag (iworld? c) msg (format "(elements of) ~a" rank) c))
low))
(define-struct mail (to content) #:transparent)
@ -368,6 +368,6 @@
(set! make-mail
(let ([make-mail make-mail])
(lambda (to content)
(check-arg 'make-mail (world? to) 'world "first" to)
(check-arg 'make-mail (iworld? to) 'iworld "first" to)
(check-arg 'make-mail (sexp? content) 'S-expression "second" content)
(make-mail to content))))

12
collects/2htdp/universe.ss
View File

@ -226,12 +226,12 @@
(provide
;; type World
world? ;; Any -> Boolean
world=? ;; World World -> Boolean
world-name ;; World -> Symbol
world1 ;; sample worlds
world2
world3
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
iworld-name ;; World -> Symbol
iworld1 ;; sample worlds
iworld2
iworld3
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle

53
collects/games/chat-noir/chat-noir-literate.ss
View File

@ -1,34 +1,58 @@
#reader "literate-reader.ss"
@title{Chat Noir}
Chat Noir. What a game.
@chunk[<main>
<init-junk>
<data-definitions>
<everything-else>]
The first main data definition for Chat Noir is the state of the world.
@schememodname[htdp/world]
@section{Data Definitions}
The main data structure for Chat Noir is @tt{world}.
@chunk[<data-definitions>
(define-struct world (board cat state size mouse-posn h-down?) #:transparent)
(define-struct world (board cat state size mouse-posn h-down?)
#:transparent)
]
;; a world is:
;; (make-world board posn state number mouse posn-or-false boolean)
;; a state is either:
;; - 'playing
;; - 'cat-won
;; - 'cat-lost
;; a board is
;; (listof cell)
It consists of a structure with six fields:
@itemize{
@item{
a @scheme[board],}
@item{
a @scheme[posn] for the cat,}
@item{the state of the game (@scheme[state] below), which can be one of
@itemize{
@item{@scheme['playing], indicating that the game is still going; this is the initial state.
}
@item{@scheme['cat-won], indicating that the game is over and the cat won, or}
@item{@scheme['cat-lost], indicating that the game is over and the cat lost.}}
}
@item{
a @scheme[posn] for the location of the mouse (or @scheme[#f] if the
mouse is not in the window),}
@item{and a boolean indicating if the @tt{h}
key has been pushed down.}
}
@verbatim[#<<---
;; a cell is
;; (make-cell (make-posn int[0-board-size]
;; int[0-board-size])
;; boolean)
---
]
@chunk[<data-definitions>
(define-struct cell (p blocked?) #:transparent)]
@section{Init Junk}
@chunk[<init-junk>
@ -68,6 +92,9 @@ The first main data definition for Chat Noir is the state of the world.
(map (λ (x) (cons (car x) (cadr x)))
init)))]
@section{Everything Else}
@chunk[<everything-else>
#;'()

50
collects/games/chat-noir/literate-lang.ss
View File

@ -15,16 +15,22 @@
(begin-for-syntax
(define main-id #f)
(define (mapping-get mapping id)
(free-identifier-mapping-get mapping id (lambda () '())))
;; maps a block identifier to its collected expressions
(define code-blocks (make-free-identifier-mapping))
(define (get-id-exprs id)
(free-identifier-mapping-get code-blocks id (lambda () '())))
;; maps a block identifier to all identifiers that are used to define it
(define block-groups (make-free-identifier-mapping))
(define (get-block id)
(map syntax-local-introduce (get-id-exprs id)))
(map syntax-local-introduce (mapping-get code-blocks id)))
(define (add-to-block! id exprs)
(unless main-id (set! main-id id))
(free-identifier-mapping-put!
block-groups id
(cons (syntax-local-introduce id) (mapping-get block-groups id)))
(free-identifier-mapping-put!
code-blocks id
`(,@(get-id-exprs id) ,@(map syntax-local-introduce exprs)))))
`(,@(mapping-get code-blocks id) ,@(map syntax-local-introduce exprs)))))
(define :make-splice make-splice)
@ -45,17 +51,31 @@
(schemeblock expr ...))))]))
(define-syntax (tangle stx)
#`(begin
#,@(let loop ([block (get-block main-id)])
(append-map (lambda (expr)
(if (identifier? expr)
(let ([subs (get-block expr)])
(if (pair? subs) (loop subs) (list expr)))
(let ([subs (syntax->list expr)])
(if subs
(list (loop subs))
(list expr)))))
block))))
(define block-mentions '())
(define body
(let loop ([block (get-block main-id)])
(append-map
(lambda (expr)
(if (identifier? expr)
(let ([subs (get-block expr)])
(if (pair? subs)
(begin (set! block-mentions (cons expr block-mentions))
(loop subs))
(list expr)))
(let ([subs (syntax->list expr)])
(if subs
(list (loop subs))
(list expr)))))
block)))
(with-syntax ([(body ...) body]
;; construct arrows manually
[((b-use b-id) ...)
(append-map (lambda (m)
(map (lambda (u)
(list m (syntax-local-introduce u)))
(mapping-get block-groups m)))
block-mentions)])
#`(begin body ... (let ([b-id (void)]) b-use) ...)))
(define-syntax (module-begin stx)
(syntax-case stx ()

112
collects/lang/private/beginner-funs.ss
View File

@ -14,7 +14,7 @@
("Numbers: Integers, Rationals, Reals, Complex, Exacts, Inexacts"
(number? (any -> boolean)
"to determine whether some value is a number")
(= (num num num ... -> boolean)
(= (number number number ... -> boolean)
"to compare numbers for equality")
(< (real real real ... -> boolean)
"to compare real numbers for less-than")
@ -25,30 +25,32 @@
(>= (real real ... -> boolean)
"to compare real numbers for greater-than or equality")
((beginner-+ +) (num num num ... -> num)
((beginner-+ +) (number number number ... -> number)
"to compute the sum of the input numbers")
(- (num num ... -> num)
(- (number number ... -> number)
"to subtract the second (and following) number(s) from the first; negate the number if there is only one argument")
((beginner-* *) (num num num ... -> num)
((beginner-* *) (number number number ... -> number)
"to compute the product of all of the input numbers")
((beginner-/ /) (num num num ... -> num)
((beginner-/ /) (number number number ... -> number)
"to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)"
" only the first number can be zero.")
(max (real real ... -> real)
"to determine the largest number")
(min (real real ... -> real)
"to determine the smallest number")
(quotient (int int -> int)
"to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)")
(remainder (int int -> int)
"to determine the remainder of dividing the first by the second integer")
(modulo (int int -> int)
(quotient (integer integer -> integer)
"to divide the first integer (exact or inexact) into the second; try (quotient 3 4) and (quotient 4 3)")
(remainder (integer integer -> integer)
"to determine the remainder of dividing the first by the second integer (exact or inexact)")
(modulo (integer integer -> integer)
"to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)")
(sqr (num -> num)
(sqr (number -> number)
"to compute the square of a number")
(sqrt (num -> num)
"to compute the square root of a number")
(expt (num num -> num)
(sqrt (number -> number)
"to compute the square root of a number")
(integer-sqrt (number -> integer)
"to compute the integer (exact or inexact) square root of a number")
(expt (number number -> number)
"to compute the power of the first to the second number")
(abs (real -> real)
"to compute the absolute value of a real number")
@ -56,31 +58,31 @@
"to compute the sign of a real number")
;; fancy numeric
(exp (num -> num)
(exp (number -> number)
"to compute e raised to a number")
(log (num -> num)
(log (number -> number)
"to compute the base-e logarithm of a number")
;; trigonometry
(sin (num -> num)
(sin (number -> number)
"to compute the sine of a number (radians)")
(cos (num -> num)
(cos (number -> number)
"to compute the cosine of a number (radians)")
(tan (num -> num)
(tan (number -> number)
"to compute the tangent of a number (radians)")
(asin (num -> num)
(asin (number -> number)
"to compute the arcsine (inverse of sin) of a number")
(acos (num -> num)
(acos (number -> number)
"to compute the arccosine (inverse of cos) of a number")
(atan (num -> num)
(atan (number -> number)
"to compute the arctan (inverse of tan) of a number")
(sinh (num -> num)
(sinh (number -> number)
"to compute the hyperbolic sine of a number")
(cosh (num -> num)
(cosh (number -> number)
"to compute the hyperbolic cosine of a number")
(exact? (num -> boolean)
(exact? (number -> boolean)
"to determine whether some number is exact")
(integer? (any -> boolean)
@ -93,84 +95,88 @@
(negative? (number -> boolean)
"to determine if some value is strictly smaller than zero")
(odd? (integer -> boolean)
"to determine if some value is odd or not")
"to determine if some integer (exact or inexact) is odd or not")
(even? (integer -> boolean)
"to determine if some value is even or not")
"to determine if some integer (exact or inexact) is even or not")
(add1 (number -> number)
"to compute a number one larger than a given number")
(sub1 (number -> number)
"to compute a number one smaller than a given number")
(lcm (int int ... -> int)
"to compute the least common multiple of two integers")
(lcm (integer integer ... -> integer)
"to compute the least common multiple of two integers (exact or inexact)")
(gcd (int int ... -> int)
"to compute the greatest common divisior")
(gcd (integer integer ... -> integer)
"to compute the greatest common divisior of two integers (exact or inexact)")
(rational? (any -> boolean)
"to determine whether some value is a rational number")
(numerator (rat -> int)
(numerator (rat -> integer)
"to compute the numerator of a rational")
(denominator (rat -> int)
(denominator (rat -> integer)
"to compute the denominator of a rational")
(inexact? (num -> boolean)
(inexact? (number -> boolean)
"to determine whether some number is inexact")
(real? (any -> boolean)
"to determine whether some value is a real number")
(floor (real -> int)
"to determine the closest integer below a real number")
(floor (real -> integer)
"to determine the closest integer (exact or inexact) below a real number")
(ceiling (real -> int)
"to determine the closest integer above a real number")
(ceiling (real -> integer)
"to determine the closest integer (exact or inexact) above a real number")
(round (real -> int)
(round (real -> integer)
"to round a real number to an integer (rounds to even to break ties)")
(complex? (any -> boolean)
"to determine whether some value is complex")
(make-polar (real real -> num)
(make-polar (real real -> number)
"to create a complex from a magnitude and angle")
(make-rectangular (real real -> number)
"to create a complex from a real and an imaginary part")
(real-part (num -> real)
(real-part (number -> real)
"to extract the real part from a complex number")
(imag-part (num -> real)
(imag-part (number -> real)
"to extract the imaginary part from a complex number")
(magnitude (num -> real)
(magnitude (number -> real)
"to determine the magnitude of a complex number")
(angle (num -> real)
(angle (number -> real)
"to extract the angle from a complex number")
(conjugate (num -> num)
(conjugate (number -> number)
"to compute the conjugate of a complex number")
(exact->inexact (num -> num)
(exact->inexact (number -> number)
"to convert an exact number to an inexact one")
(inexact->exact (num -> num)
(inexact->exact (number -> number)
"to approximate an inexact number by an exact one")
; "Odds and ends"
(number->string (num -> string)
(number->string (number -> string)
"to convert a number to a string")
(integer->char (int -> char)
"to lookup the character that corresponds to the given integer in the ASCII table (if any)")
(integer->char (integer -> char)
"to lookup the character that corresponds to the given integer (exact only!) in the ASCII table (if any)")
(random (int -> int)
"to generate a random natural number less than some given integer")
(random (integer -> integer)
"to generate a random natural number less than some given integer
(exact only!)")
(current-seconds (-> int)
(current-seconds (-> integer)
"to compute the current time in seconds elapsed"
" (since a platform-specific starting date)")

17
collects/mzlib/private/unit-compiletime.ss
View File

@ -111,16 +111,21 @@
(parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature form"))))
;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier)
(define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder)
;; (make-unit-info identifier (listof (cons symbol identifier)) (listof (cons symbol identifier)) identifier boolean)
(define-struct/proc unit-info (unit-id import-sig-ids export-sig-ids deps orig-binder contracted?)
(lambda (struct stx)
(with-syntax ((u (unit-info-unit-id struct)))
(syntax-case stx (set!)
((set! x y)
#`(begin
#,(syntax/loc #'y (check-unit y 'set!))
#,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
(set! u y)))
(if (unit-info-contracted? struct)
(raise-syntax-error 'set!
"cannot set! a contracted unit"
stx
(syntax x))
#`(begin
#,(syntax/loc #'y (check-unit y 'set!))
#,(syntax/loc #'y (check-sigs y (unit-import-sigs u) (unit-export-sigs u) 'set!))
(set! u y))))
((_ . y)
(syntax/loc stx (u . y)))
(x

57
collects/mzlib/private/unit-contract-syntax.ss
View File

@ -4,7 +4,8 @@
"unit-compiletime.ss"
(for-template "unit-keywords.ss"))
(provide import-clause export-clause)
(provide import-clause/contract export-clause/contract dep-clause
import-clause/c export-clause/c)
(define-syntax-class sig-id
#:attributes ()
@ -14,29 +15,55 @@
(signature? (set!-trans-extract x))))))
(define-syntax-class sig-spec #:literals (prefix rename only except)
#:attributes ((name 0))
#:transparent
(pattern name:sig-id)
(pattern (prefix i:identifier s:sig-spec)
#:with name #'s.name)
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...)
#:with name #'s.name)
(pattern (only s:sig-spec i:identifier ...)
#:with name #'s.name)
(pattern (except s:sig-spec i:identifier ...)
#:with name #'s.name))
(define-syntax-class tagged-sig-spec #:literals (tag)
#:transparent
(pattern s:sig-spec
#:with i #f)
(pattern (tag i:identifier s:sig-spec)))
(define-syntax-class tagged-sig-id #:literals (tag)
#:attributes ()
#:transparent
(pattern s:sig-id)
(pattern (prefix i:identifier s:sig-spec))
(pattern (rename s:sig-spec [int:identifier ext:identifier] ...))
(pattern (only s:sig-spec i:identifier ...))
(pattern (except s:sig-spec i:identifier ...)))
(define-syntax-class tagged-sig-spec #:literals (tag)
#:attributes ()
#:transparent
(pattern s:sig-spec)
(pattern (tag i:identifier s:sig-spec)))
(pattern (tag i:identifier s:sig-id)))
(define-syntax-class unit/c-clause
#:transparent
(pattern (s:tagged-sig-id [x:identifier c:expr] ...))
(pattern s:tagged-sig-id ;; allow a non-wrapped sig, which is the same as (sig)
#:with (x ...) null
#:with (c ...) null))
(define-syntax-class import-clause/c #:literals (import)
#:transparent
(pattern (import i:unit/c-clause ...)))
(define-syntax-class export-clause/c #:literals (export)
#:transparent
(pattern (export e:unit/c-clause ...)))
(define-syntax-class unit/contract-clause
#:transparent
(pattern (s:tagged-sig-spec [x:identifier c:expr] ...))
(pattern s:tagged-sig-spec ;; allow a non-wrapped sig, which is the same as (sig)
#:with (x ...) null
#:with (c ...) null))
(define-syntax-class import-clause #:literals (import)
(define-syntax-class import-clause/contract #:literals (import)
#:transparent
(pattern (import i:unit/c-clause ...)))
(define-syntax-class export-clause #:literals (export)
(pattern (import i:unit/contract-clause ...)))
(define-syntax-class export-clause/contract #:literals (export)
#:transparent
(pattern (export e:unit/c-clause ...)))
(pattern (export e:unit/contract-clause ...)))
(define-syntax-class dep-clause #:literals (init-depend)
#:transparent
(pattern (init-depend s:tagged-sig-id ...)))

127
collects/mzlib/private/unit-contract.ss
View File

@ -4,18 +4,57 @@
stxclass
syntax/boundmap
"unit-compiletime.ss"
"unit-contract-syntax.ss")
"unit-contract-syntax.ss"
"unit-syntax.ss")
scheme/contract
"unit-utils.ss"
"unit-runtime.ss")
(provide unit/c)
(provide (for-syntax unit/c/core) unit/c)
#|
We want to think of the contract as sitting between the outside world
and the unit in question. In the case where the signature in question
is contracted, we have:
pos unit/c neg
|
--- |
| | |
<---- | i | <-----|------ (v, o)
| | |
--- |
| | |
(v, u) ----> | e | ------|----->
| | |
--- |
|
So for an import, we start out with (v, o) coming in when the
import is being set. We need to first check the contract
(sig-ctc, o, neg), to make sure what's coming in appropriately
satisfies that contract (since it already has given us the
positive blame for the value incoming). Then we need to check
(ctc, neg, pos) (i.e. apply the projection with the blame
"switched"). That leaves pos as the appropriate thing to pack
with the value for the sig-ctc check inside the unit. When
the unit pulls it out (which isn't affected by the unit/c
contract combinator), it'll have the correct party to blame as
far as it knows.
For an export, we start on the other side, so we don't need to do
anything to the setting function as the unit will handle that. So for
the accessing function, we need to grab what's in the box,
check (sig-ctc, u, pos), then check (ctc, pos, neg) via projection
application, then last, but not least, return the resulting value
packed with the neg blame.
|#
(define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name)
(define def-table (make-bound-identifier-mapping))
(define (convert-reference vref ctc sig-ctc rename-bindings)
(define (convert-reference var vref ctc sig-ctc rename-bindings)
(let ([wrap-with-proj
(λ (ctc stx)
;; If contract coersion ends up being a large overhead, we can
@ -30,21 +69,33 @@
#,stx)))])
(if ctc
#`(cons
(λ ()
(let* ([old-v
#,(if sig-ctc
#`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj ctc #'(car old-v/c))
(cdr old-v/c)))
(wrap-with-proj ctc #`((car #,vref))))])
old-v))
(λ (v)
(let* ([new-v
#,(if sig-ctc
#`(cons #,(wrap-with-proj ctc #'(car v))
(cdr v))
(wrap-with-proj ctc #'v))])
((cdr #,vref) new-v))))
#,(if import?
#`(car #,vref)
#`(λ ()
(let* ([old-v
#,(if sig-ctc
#`(let ([old-v/c ((car #,vref))])
(cons #,(wrap-with-proj
ctc
#`(contract #,sig-ctc (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var)))
#,neg))
(wrap-with-proj ctc #`((car #,vref))))])
old-v)))
#,(if import?
#`(λ (v)
(let* ([new-v
#,(if sig-ctc
#`(cons #,(wrap-with-proj
ctc
#`(contract #,sig-ctc (car v)
(cdr v) #,neg
#,(id->contract-src-info var)))
#,pos)
(wrap-with-proj ctc #'v))])
((cdr #,vref) new-v)))
#`(cdr #,vref)))
vref)))
(for ([tagged-info (in-list import-tagged-infos)]
[sig (in-list import-sigs)])
@ -60,16 +111,13 @@
(get-member-bindings def-table target-sig pos)])
(for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))])
(let* ([vref
(bound-identifier-mapping-get
def-table
(car target-int/ext-name))]
(let* ([var (car target-int/ext-name)]
[vref
(bound-identifier-mapping-get def-table var)]
[ctc
(bound-identifier-mapping-get
ctc-table
(car target-int/ext-name)
(λ () #f))])
(convert-reference vref ctc sig-ctc rename-bindings))))))
ctc-table var (λ () #f))])
(convert-reference var vref ctc sig-ctc rename-bindings))))))
(((export-keys ...) ...)
(map tagged-info->keys import-tagged-infos)))
#'(unit-export ((export-keys ...)
@ -78,9 +126,9 @@
(define-for-syntax contract-imports (contract-imports/exports #t))
(define-for-syntax contract-exports (contract-imports/exports #f))
(define-syntax/err-param (unit/c stx)
(define-for-syntax (unit/c/core stx)
(syntax-parse stx
[(_ :import-clause :export-clause)
[(:import-clause/c :export-clause/c)
(begin
(define-values (isig tagged-import-sigs import-tagged-infos
import-tagged-sigids import-sigs)
@ -97,17 +145,15 @@
(define xs-list (syntax->list xs))
(let ([dup (check-duplicate-identifier xs-list)])
(when dup
(raise-syntax-error 'unit/c
(format "duplicate identifier found for signature ~a"
(syntax->datum name))
dup)))
(raise-stx-err (format "duplicate identifier found for signature ~a"
(syntax->datum name))
dup)))
(let ([ids (map car (car sig))])
(for-each (λ (id)
(unless (memf (λ (i) (bound-identifier=? id i)) ids)
(raise-syntax-error 'unit/c
(format "identifier not member of signature ~a"
(syntax-e name))
id)))
(raise-stx-err (format "identifier not member of signature ~a"
(syntax-e name))
id)))
xs-list))
(for ([x (in-list xs-list)]
[c (in-list (syntax->list cs))])
@ -130,7 +176,9 @@
(syntax->list #'((e.x ...) ...))
(syntax->list #'((e.c ...) ...)))
(with-syntax ([((import-key ...) ...)
(with-syntax ([(isig ...) isig]
[(esig ...) esig]
[((import-key ...) ...)
(map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...)
(map tagged-info->keys export-tagged-infos)]
@ -210,6 +258,11 @@
(list #f "not-used") 'not-used null))
#t)))))))]))
(define-syntax/err-param (unit/c stx)
(syntax-case stx ()
[(_ . sstx)
(unit/c/core #'sstx)]))
(define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
(define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))])

138
collects/mzlib/unit.ss
View File

@ -1,11 +1,13 @@
(module unit mzscheme
(require-for-syntax mzlib/list
stxclass
syntax/boundmap
syntax/context
syntax/kerncase
syntax/name
syntax/struct
syntax/stx
"private/unit-contract-syntax.ss"
"private/unit-compiletime.ss"
"private/unit-syntax.ss")
@ -20,14 +22,15 @@
(provide define-signature-form struct open
define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted
unit? (all-from "private/unit-contract.ss")
unit?
(rename :unit unit) define-unit
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
invoke-unit define-values/invoke-unit
invoke-unit/infer define-values/invoke-unit/infer
unit-from-context define-unit-from-context
define-unit-binding
unit/new-import-export define-unit/new-import-export)
unit/new-import-export define-unit/new-import-export
unit/c define-unit/contract)
(define-syntax/err-param (define-signature-form stx)
(syntax-case stx ()
@ -1148,10 +1151,19 @@
(dup (check-duplicate-identifier (apply append (map sig-int-names out-sigs))))
(out-vec (generate-temporaries out-sigs))
(tmarker (make-syntax-introducer))
(vmarker (make-syntax-introducer))
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs)))
(tmp-bindings (map (λ (s) (map tmarker (map car (car s)))) out-sigs))
(def-table (make-bound-identifier-mapping)))
(when dup
(raise-stx-err (format "duplicate binding for ~e" (syntax-e dup))))
(for-each
(λ (sig new-xs)
(for-each
(λ (old new)
(bound-identifier-mapping-put! def-table old new))
(map car (car sig))
new-xs))
out-sigs
tmp-bindings)
(with-syntax ((((key1 key ...) ...) (map tagged-info->keys out-tags))
((((int-binding . ext-binding) ...) ...) (map car out-sigs))
((out-vec ...) out-vec)
@ -1164,34 +1176,26 @@
(map (lambda (info) (car (siginfo-names (cdr info))))
out-tags))
(((tmp-binding ...) ...) tmp-bindings)
(((val-binding ...) ...) (map (λ (s) (map vmarker (map car (car s)))) out-sigs))
(((out-code ...) ...)
(map
(lambda (os ov)
(map
(lambda (i)
#`((car (vector-ref #,ov #,i))))
#`(vector-ref #,ov #,i))
(iota (length (car os)))))
out-sigs
out-vec))
(((val-code ...) ...)
(map (λ (tbs os)
(map (λ (tb c)
(if c
#`(car #,tb)
tb))
tbs
(cadddr os)))
tmp-bindings
out-sigs))
(((wrap-code ...) ...)
(map (λ (os ov tbs)
(define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference)))
(map (λ (tb i v c)
(if c
#`(contract #,(vmarker c) (car #,tb) (cdr #,tb)
(current-contract-region)
#,(id->contract-src-info v))
tb))
#`(let ([v/c ((car #,tb))])
#,(if c
#`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v))
#'v/c)))
tbs
(iota (length (car os)))
(map car (car os))
@ -1215,8 +1219,6 @@
(let ([out-vec (hash-table-get export-table key1)] ...)
(unit-fn #f)
(values out-code ... ...))))))
(define-values (val-binding ... ...)
(values val-code ... ...))
(define-values (int-binding ... ...)
(values wrap-code ... ...))
(define-syntaxes . renames) ...
@ -1264,32 +1266,38 @@
(define-for-syntax (build-define-unit-helper contracted?)
(lambda (stx build err-msg)
(syntax-case stx ()
((_ name . rest)
(begin
(check-id #'name)
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
(build #'rest ))))
(with-syntax ((((itag . isig) ...) i)
(((etag . esig) ...) e)
(((deptag . depsig) ...) d)
(contracted? contracted?))
(quasisyntax/loc (error-syntax)
(begin
(define u #,exp)
(define-syntax name
(make-set!-transformer
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
(list (cons 'itag (quote-syntax isig)) ...)
(list (cons 'etag (quote-syntax esig)) ...)
(list (cons 'deptag (quote-syntax deptag)) ...)
(quote-syntax name)
contracted?)))))))))
((_)
(raise-stx-err err-msg)))))
;; build-define-unit : syntax-object
;; (syntax-object -> (values syntax-object (listof identifier) (listof identifier))
;; string ->
;; syntax-object
(define-for-syntax (build-define-unit stx build err-msg)
(syntax-case stx ()
((_ name . rest)
(begin
(check-id #'name)
(let-values (((exp i e d) (parameterize ([error-syntax (syntax-property (error-syntax) 'inferred-name (syntax-e #'name))])
(build #'rest ))))
(with-syntax ((((itag . isig) ...) i)
(((etag . esig) ...) e)
(((deptag . depsig) ...) d))
(quasisyntax/loc (error-syntax)
(begin
(define u #,exp)
(define-syntax name
(make-set!-transformer
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
(list (cons 'itag (quote-syntax isig)) ...)
(list (cons 'etag (quote-syntax esig)) ...)
(list (cons 'deptag (quote-syntax deptag)) ...)
(quote-syntax name))))))))))
((_)
(raise-stx-err err-msg))))
(define-for-syntax build-define-unit (build-define-unit-helper #f))
(define-for-syntax build-define-unit/contracted (build-define-unit-helper #t))
(define-for-syntax (build-define-unit-binding stx)
@ -1360,6 +1368,46 @@
(check-ufc-syntax sig)
(build-unit-from-context sig))
"missing unit name and signature"))
(define-for-syntax (build-unit/contract stx)
(syntax-parse stx
[(:import-clause/contract :export-clause/contract dep:dep-clause . body)
(let-values ([(exp isigs esigs deps)
(build-unit
(check-unit-syntax
(syntax/loc stx
((import i.s ...) (export e.s ...) dep . body))))])
(with-syntax ([name (syntax-local-infer-name (error-syntax))]
[(import-tagged-sig-id ...)
(map (λ (i s)
(if (identifier? i) #`(tag #,i #,s) s))
(syntax->list #'(i.s.i ...))
(syntax->list #'(i.s.s.name ...)))]
[(export-tagged-sig-id ...)
(map (λ (i s)
(if (identifier? i) #`(tag #,i #,s) s))
(syntax->list #'(e.s.i ...))
(syntax->list #'(e.s.s.name ...)))])
(with-syntax ([new-unit exp]
[unit-contract
(unit/c/core
(syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]
[src-info (id->contract-src-info #'name)])
(values
(syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract
(syntax/loc stx
(ic ec (init-depend) . body)))]))
(define-syntax/err-param (define-unit/contract stx)
(build-define-unit/contracted stx (λ (stx)
(build-unit/contract stx))
"missing unit name"))
(define-for-syntax (unprocess-tagged-id ti)
(if (car ti)

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

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "14feb2009")
#lang scheme/base (provide stamp) (define stamp "15feb2009")

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

@ -442,6 +442,37 @@ improve method arity mismatch contract violation error messages?
[(_ p/c-ele ...)
(let ()
;; ids : table[id -o> (listof id)]
;; code-for-each-clause adds identifiers to this map.
;; when it binds things; they are then used to signal
;; a syntax error for duplicates
(define dups-table (make-hash))
(define (add-to-dups-table id)
(hash-update!
dups-table
(syntax-e id)
(λ (ids) (cons id ids))
'()))
(define (signal-dup-syntax-error)
(hash-for-each
dups-table
(λ (k ids)
(let loop ([ids ids])
(cond
[(null? ids) (void)]
[else
(cond
[(ormap (λ (x) (bound-identifier=? (car ids) x)) (cdr ids))
(let ([dups (filter (λ (x) (bound-identifier=? (car ids) x))
ids)])
(raise-syntax-error 'provide/contract
"duplicate identifiers"
provide-stx
(car dups)
(cdr dups)))]
[else
(loop (cdr ids))])])))))
;; code-for-each-clause : (listof syntax) -> (listof syntax)
;; constructs code for each clause of a provide/contract
(define (code-for-each-clause clauses)
@ -454,8 +485,10 @@ improve method arity mismatch contract violation error messages?
[(rename this-name new-name contract)
(and (identifier? (syntax this-name))
(identifier? (syntax new-name)))
(cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name))
(code-for-each-clause (cdr clauses)))]
(begin
(add-to-dups-table #'new-name)
(cons (code-for-one-id provide-stx (syntax this-name) (syntax contract) (syntax new-name))
(code-for-each-clause (cdr clauses))))]
[(rename this-name new-name contract)
(identifier? (syntax this-name))
(raise-syntax-error 'provide/contract
@ -477,6 +510,7 @@ improve method arity mismatch contract violation error messages?
(syntax struct-name)
(syntax->list (syntax (field-name ...)))
(syntax->list (syntax (contract ...))))])
(add-to-dups-table #'struct-name)
(cons sc (code-for-each-clause (cdr clauses))))]
[(struct name)
(identifier? (syntax name))
@ -516,8 +550,10 @@ improve method arity mismatch contract violation error messages?
clause)]
[(name contract)
(identifier? (syntax name))
(cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f)
(code-for-each-clause (cdr clauses)))]
(begin
(add-to-dups-table #'name)
(cons (code-for-one-id provide-stx (syntax name) (syntax contract) #f)
(code-for-each-clause (cdr clauses))))]
[(name contract)
(raise-syntax-error 'provide/contract
"expected identifier"
@ -935,6 +971,7 @@ improve method arity mismatch contract violation error messages?
(syntax (code id-rename)))))]))
(with-syntax ([(bodies ...) (code-for-each-clause (syntax->list (syntax (p/c-ele ...))))])
(signal-dup-syntax-error)
(syntax
(begin
bodies ...))))]))

2
collects/scribblings/guide/info.ss
View File

@ -1,5 +1,5 @@
#lang setup/infotab
(define scribblings '(("guide.scrbl" (multi-page) (getting-started))))
(define scribblings '(("guide.scrbl" (multi-page) (getting-started -10))))
(define compile-omit-paths '("contracts-examples"))

92
collects/scribblings/guide/unit.scrbl
View File

@ -530,85 +530,49 @@ causes the appropriate contract errors.
However, sometimes we may have a unit that must conform to an
already existing signature that is not contracted. In this case,
we can use the @scheme[unit/c] contract combinator, which creates
a new unit that protects parts of the wrapped unit as desired.
we can create a unit contract with @scheme[unit/c] or use
the @scheme[define-unit/contract] form, which defines a unit which
has been wrapped with a unit contract.
For example, here's a version of @scheme[toy-store@] which has a
slightly buggy implementation of the uncontracted @scheme[toy-store^]
signature. When we provide the new @scheme[wrapped-toy-store@] unit,
we protect its exports.
For example, here's a version of @scheme[toy-factory@] which still
implements the regular @scheme[toy-factory^], but whose exports
have been protected with an appropriate unit contract.
@schememod/eval[[#:file
"wrapped-toy-store-unit.ss"
"wrapped-simple-factory-unit.ss"
scheme
(require "toy-store-sig.ss"
"toy-factory-sig.ss")]
(require "toy-factory-sig.ss")]
(define-unit wrapped-toy-store@
(import toy-factory^)
(export toy-store^)
(define-unit/contract wrapped-simple-factory@
(import)
(export (toy-factory^
[build-toys (-> integer? (listof toy?))]
[repaint (-> toy? symbol? toy?)]
[toy? (-> any/c boolean?)]
[toy-color (-> toy? symbol?)]))
(define inventory null)
(printf "Factory started.\n")
(define (store-color) 3) (code:comment #, @t{Not a valid color!})
(define-struct toy (color) #:transparent)
(define (maybe-repaint t)
(if (eq? (toy-color t) (store-color))
t
(repaint t (store-color))))
(define (build-toys n)
(for/list ([i (in-range n)])
(make-toy 'blue)))
(define (stock! n)
(set! inventory
(append inventory
(map maybe-repaint
(build-toys n)))))
(define (repaint t col)
(make-toy col)))
(define (get-inventory) inventory))
(provide/contract
[wrapped-toy-store@
(unit/c (import toy-factory^)
(export (toy-store^
[store-color (-> symbol?)]
[stock! (-> integer? void?)]
[get-inventory (-> (listof toy?))])))])
(provide contracted-simple-factory@)
]
Since the result of the @scheme[unit/c] combinator is a new unit value
which has not been defined with @scheme[define-unit] or another similar
form, we run into problems with signature inference. The section
@secref{firstclassunits} lists options that we can use to handle the
resulting values.
@interaction[
#:eval toy-eval
(eval:alts (require "wrapped-toy-store-unit.ss")
(define wrapped-toy-store@
(contract (unit/c (import toy-factory^)
(export (toy-store^
[store-color (-> symbol?)]
[stock! (-> integer? void?)]
[get-inventory (-> (listof toy?))])))
wrapped-toy-store@
'wrapped-toy-store-unit
'top-level
(list (make-srcloc 'top-level #f #f #f #f) "wrapped-toy-store@"))))
(define-unit-binding protected-toy-store@
wrapped-toy-store@
(import toy-factory^)
(export toy-store^))
(define-compound-unit/infer checked-toy-store+factory@
(import)
(export toy-factory^ toy-store^)
(link store-specific-factory@ protected-toy-store@))
(define-values/invoke-unit/infer checked-toy-store+factory@)
(store-color)
(stock! 'a)
(code:comment #, @t{This fails because of the factory's (store-color) call})
(stock! 4)
(code:comment #, @t{Since it failed, there's no inventory})
(get-inventory)
(eval:alts (require "wrapped-simple-factory-unit.ss") (void))
(define-values/invoke-unit/infer wrapped-simple-factory@)
(build-toys 3)
(build-toys #f)
(repaint 3 'blue)
]

2
collects/scribblings/main/config.ss
View File

@ -26,7 +26,7 @@
;; Section definitions for manuals that appear on the start page.
(define manual-sections
'((getting-started "Getting Started")
'((getting-started (link "Getting Started" (lib "scribblings/main/getting-started.scrbl")))
(language "Languages")
(tool "Tools")
(gui-library "GUI and Graphics Libraries")

44
collects/scribblings/main/getting-started.scrbl Normal file
View File

@ -0,0 +1,44 @@
#lang scribble/doc
@(require scribble/manual)
@title{Getting Started with PLT Scheme}
If you are new to programming or if you have the patience to work
through a textbook:
@itemize[
@item{@italic{@link["http:///www.htdp.org/"]{How to
Design Programs}} is the best place to start.}
@item{@other-manual['(lib "web-server/scribblings/tutorial/continue.scrbl")]
introduces you to the Module language and building web applications.}
@item{@other-manual['(lib "scribblings/guide/guide.scrbl")] describes
the rest of the PLT Scheme language, which is much bigger than
the learning-oriented languages of the textbook. Since you
learned functional programming from the textbook, you'll be
able to skim chapters 1 and 2 of the Guide.}
]
If you're already a programmer and you're in more of a hurry:
@itemize[
@item{@other-manual['(lib "scribblings/quick/quick.scrbl")] gives you
a taste of PLT Scheme.}
@item{@other-manual['(lib "scribblings/more/more.scrbl")] dives much
deeper and much faster. If it's too much, just skip to the
Guide.}
@item{@other-manual['(lib "scribblings/guide/guide.scrbl")] starts
with a tutorial on Scheme based, and then it describes the rest
of the PLT Scheme language.}
]
Of course, you should feel free to mix and match the above two tracks,
since there is information in each that is not in the other.

1
collects/scribblings/main/info.ss
View File

@ -9,6 +9,7 @@
("master-index.scrbl" (depends-all-main no-depend-on) (omit))
("user/search.scrbl" (user-doc depends-all no-depend-on) (omit))
("user/master-index.scrbl" (user-doc depends-all no-depend-on) (omit))
("getting-started.scrbl" () (omit))
("license.scrbl" () (omit))
("acks.scrbl" () (omit))
("release.scrbl" () (omit))))

24
collects/scribblings/main/private/manuals.ss
View File

@ -80,12 +80,29 @@
s)))
infos
recs)]
[docs (cons
;; Add HtDP
(list
;; Category
'getting-started
;; Priority
7
;; Priority label (not used):
""
;; Path
'(url "http://www.htdp.org/")
;; Spec
(italic (link #:underline? #f "http://www.htdp.org/" "How to Design Programs")))
docs)]
[plain-line
(lambda content
(list (make-flow (list (make-paragraph content)))))]
[line
(lambda (spec)
(plain-line (hspace 2) (other-manual spec #:underline? #f)))])
(plain-line (hspace 2)
(if (element? spec)
spec
(other-manual spec #:underline? #f))))])
(define (contents renderer part resolve-info)
(make-table
#f
@ -96,7 +113,10 @@
docs)])
(list*
(plain-line (hspace 1))
(plain-line (sec-label sec))
(plain-line (let ([s (sec-label sec)])
(if (and (list? s) (eq? 'link (car s)))
(seclink "top" #:doc (caddr s) #:underline? #f (cadr s))
s)))
(add-sections
(sec-cat sec)
(lambda (str)

2
collects/scribblings/more/info.ss
View File

@ -1,3 +1,3 @@
#lang setup/infotab
(define scribblings '(("more.scrbl" () (getting-started 5))))
(define scribblings '(("more.scrbl" () (getting-started 3))))

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

@ -582,9 +582,16 @@ threads. That is, instead of a ``minimalist'' language---which is the
way that Scheme is often described---PLT Scheme offers a rich language
with an extensive set of libraries and tools.
To continue touring PLT Scheme, but from a systems-oriented
perspective instead of pictures, your next stop is @other-manual['(lib
"scribblings/more/more.scrbl")].
If you are new to programming or if you have the patience to work
through a textbook, we recommend reading
@italic{@link["http://www.htdp.org/"]{How to Design Programs}}. If you
have already read it, or if you want to see where the book will take
you, then see @other-manual['(lib
"web-server/scribblings/tutorial/continue.scrbl")].
For experienced programmers, to continue touring PLT Scheme from a
systems-oriented perspective instead of pictures, your next stop is
@other-manual['(lib "scribblings/more/more.scrbl")].
To instead start learning about the full PLT Scheme language and tools
in depth, move on to @other-manual['(lib "guide.scrbl"

29
collects/scribblings/reference/exns.scrbl
View File

@ -150,21 +150,24 @@ is provided; it is described in more detail below. The
@scheme[message] is used as the main body of the error message.
The optional @scheme[expr] argument is the erroneous source syntax
object or S-expression. The optional @scheme[sub-expr] argument is a
syntax object or S-expression within @scheme[expr] that more precisely
locates the error. Both may appear in the generated error-message
text if @scheme[error-print-source-location] is @scheme[#t]. Source
location information in the error-message text is similarly extracted
from @scheme[sub-expr] or @scheme[expr] when at least one is a syntax
object or S-expression (but the expression @scheme[#f] cannot be
represented by itself; it must be wrapped as a @tech{syntax
object}). The optional @scheme[sub-expr] argument is a syntax object
or S-expression (again, @scheme[#f] cannot represent itself) within
@scheme[expr] that more precisely locates the error. Both may appear
in the generated error-message text if
@scheme[error-print-source-location] is @scheme[#t]. Source location
information in the error-message text is similarly extracted from
@scheme[sub-expr] or @scheme[expr] when at least one is a syntax
object and @scheme[error-print-source-location] is @scheme[#t].
If @scheme[sub-expr] is provided, it is used (in syntax form) for the
@scheme[exprs] field of the generated exception record, else the
@scheme[expr] is used if provided. In either case, the syntax object
is @scheme[cons]ed onto @scheme[extra-sources] to produce the
@scheme[exprs] field, or @scheme[extra-sources] is used directly for
@scheme[exprs] if neither @scheme[expr] nor @scheme[sub-expr] is
provided.
If @scheme[sub-expr] is provided and not @scheme[#f], it is used (in
syntax form) for the @scheme[exprs] field of the generated exception
record, else the @scheme[expr] is used if provided and not
@scheme[#f]. In either case, the syntax object is @scheme[cons]ed onto
@scheme[extra-sources] to produce the @scheme[exprs] field, or
@scheme[extra-sources] is used directly for @scheme[exprs] if neither
@scheme[expr] nor @scheme[sub-expr] is provided and not @scheme[#f].
The form name used in the generated error message is determined
through a combination of the @scheme[name], @scheme[expr], and

92
collects/scribblings/reference/hashes.scrbl
View File

@ -3,6 +3,18 @@
@title[#:tag "hashtables"]{Hash Tables}
@(define (concurrency-caveat)
@elemref['(caveat "concurrency")]{caveats concerning concurrent modification})
@(define (mutable-key-caveat)
@elemref['(caveat "mutable-keys")]{caveat concerning mutable keys})
@(define (see-also-caveats)
@t{See also the @concurrency-caveat[] and the @mutable-key-caveat[] above.})
@(define (see-also-concurrency-caveat)
@t{See also the @concurrency-caveat[] above.})
@(define (see-also-mutable-key-caveat)
@t{See also the @mutable-key-caveat[] above.})
@guideintro["hash-tables"]{hash tables}
A @deftech{hash table} (or simply @deftech{hash}) maps each of its
@ -26,18 +38,18 @@ key-comparison procedure (@scheme[equal?], @scheme[eqv?], or
@scheme[eq?]), both hold keys strongly or weakly, and have the same
mutability.
@bold{Caveats concerning concurrent modification:} A mutable hash
table can be manipulated with @scheme[hash-ref], @scheme[hash-set!],
and @scheme[hash-remove!] concurrently by multiple threads, and the
operations are protected by a table-specific semaphore as needed. Three
caveats apply, however:
@elemtag['(caveat "concurrency")]{@bold{Caveats concerning concurrent
modification:}} A mutable hash table can be manipulated with
@scheme[hash-ref], @scheme[hash-set!], and @scheme[hash-remove!]
concurrently by multiple threads, and the operations are protected by
a table-specific semaphore as needed. Three caveats apply, however:
@itemize{
@item{If a thread is terminated while applying @scheme[hash-ref],
@scheme[hash-set!], or @scheme[hash-remove!] to a hash table that
uses @scheme[equal?] key comparisons, all current and future
operations on the hash table block indefinitely.}
uses @scheme[equal?] or @scheme[eqv?] key comparisons, all current
and future operations on the hash table block indefinitely.}
@item{The @scheme[hash-map] and @scheme[hash-for-each] procedures do
not use the table's semaphore. Consequently, if a hash table is
@ -58,10 +70,11 @@ caveats apply, however:
}
@bold{Caveat concerning mutable keys:} If a key into an
@scheme[equal?]-based hash table is mutated (e.g., a key string is
modified with @scheme[string-set!]), then the hash table's behavior
for insertion and lookup operations becomes unpredictable.
@elemtag['(caveat "mutable-keys")]{@bold{Caveat concerning mutable
keys:}} If a key in an @scheme[equal?]-based hash table is mutated
(e.g., a key string is modified with @scheme[string-set!]), then the
hash table's behavior for insertion and lookup operations becomes
unpredictable.
@defproc[(hash? [v any/c]) boolean?]{
@ -152,7 +165,9 @@ compares keys with @scheme[eq?].}
[v any/c]) void?]{
Maps @scheme[key] to @scheme[v] in @scheme[hash], overwriting
any existing mapping for @scheme[key].}
any existing mapping for @scheme[key].
@see-also-caveats[]}
@defproc[(hash-set [hash (and/c hash? immutable?)]
@ -162,7 +177,9 @@ any existing mapping for @scheme[key].}
Functionally extends @scheme[hash] by mapping @scheme[key] to
@scheme[v], overwriting any existing mapping for @scheme[key], and
returning the extended hash table.}
returning the extended hash table.
@see-also-mutable-key-caveat[]}
@defproc[(hash-ref [hash hash?]
@ -182,7 +199,9 @@ result:
@item{Otherwise, @scheme[failure-result] is returned as the result.}
}}
}
@see-also-caveats[]}
@defproc[(hash-update! [hash (and/c hash? (not/c immutable?))]
@ -196,7 +215,9 @@ Composes @scheme[hash-ref] and @scheme[hash-set!] to update an
existing mapping in @scheme[hash], where the optional
@scheme[failure-result] argument is used as in @scheme[hash-ref] when
no mapping exists for @scheme[key] already. See the caveat above about
concurrent updates.}
concurrent updates.
@see-also-caveats[]}
@defproc[(hash-update [hash (and/c hash? immutable?)]
@ -209,14 +230,18 @@ concurrent updates.}
Composes @scheme[hash-ref] and @scheme[hash-set] to functionally
update an existing mapping in @scheme[hash], where the optional
@scheme[failure-result] argument is used as in @scheme[hash-ref] when
no mapping exists for @scheme[key] already.}
no mapping exists for @scheme[key] already.
@see-also-mutable-key-caveat[]}
@defproc[(hash-remove! [hash (and/c hash? (not/c immutable?))]
[key any/c])
void?]{
Removes any existing mapping for @scheme[key] in @scheme[hash].}
Removes any existing mapping for @scheme[key] in @scheme[hash].
@see-also-caveats[]}
@defproc[(hash-remove [hash (and/c hash? immutable?)]
@ -224,7 +249,9 @@ Removes any existing mapping for @scheme[key] in @scheme[hash].}
(and/c hash? immutable?)]{
Functionally removes any existing mapping for @scheme[key] in
@scheme[hash], returning the fresh hash table.}
@scheme[hash], returning the fresh hash table.
@see-also-mutable-key-caveat[]}
@defproc[(hash-map [hash hash?]
@ -235,7 +262,9 @@ Applies the procedure @scheme[proc] to each element in
@scheme[hash] in an unspecified order, accumulating the results
into a list. The procedure @scheme[proc] is called each time with a
key and its value. See the caveat above about concurrent
modification.}
modification.
@see-also-concurrency-caveat[]}
@defproc[(hash-for-each [hash hash?]
@ -245,17 +274,18 @@ modification.}
Applies @scheme[proc] to each element in @scheme[hash] (for the
side-effects of @scheme[proc]) in an unspecified order. The procedure
@scheme[proc] is called each time with a key and its value. See the
caveat above about concurrent modification.}
caveat above about concurrent modification.
@see-also-concurrency-caveat[]}
@defproc[(hash-count [hash hash?])
exact-nonnegative-integer?]{
Returns the number of keys mapped by @scheme[hash]. If
@scheme[hash] is not created with @scheme['weak], then the
result is computed in constant time and atomically. If
@scheme[hash] is created with @scheme['weak], see the caveat
above about concurrent modification.}
Returns the number of keys mapped by @scheme[hash]. If @scheme[hash]
is not created with @scheme['weak], then the result is computed in
constant time and atomically. If @scheme[hash] is created with
@scheme['weak], see the @concurrency-caveat[] above.}
@defproc[(hash-iterate-first [hash hash?])
@ -311,24 +341,24 @@ key-comparison mode, and same key-holding strength as @scheme[hash].}
Returns an exact integer; for any two @scheme[eq?] values, the
returned integer is the same. Furthermore, for the result integer
@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)]
implies @scheme[(eq? k j)].}
@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)]
implies @scheme[(eq? _k _j)].}
@defproc[(eqv-hash-code [v any/c]) exact-integer?]{
Returns an exact integer; for any two @scheme[eqv?] values, the
returned integer is the same. Furthermore, for the result integer
@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)]
implies @scheme[(eq? k j)].}
@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)]
implies @scheme[(eq? _k _j)].}
@defproc[(equal-hash-code [v any/c]) exact-integer?]{
Returns an exact integer; for any two @scheme[equal?] values, the
returned integer is the same. Furthermore, for the result integer
@scheme[k] and any other exact integer @scheme[j], @scheme[(= k j)]
implies @scheme[(eq? k j)]. A has code is computed even when
@scheme[_k] and any other exact integer @scheme[_j], @scheme[(= _k _j)]
implies @scheme[(eq? _k _j)]. A has code is computed even when
@scheme[v] contains a cycle through pairs, vectors, boxes, and/or
inspectable structure fields. See also @scheme[prop:equal+hash].}

18
collects/scribblings/reference/units.scrbl
View File

@ -635,8 +635,8 @@ Expands to a @scheme[provide] of all identifiers implied by the
@defform/subs[#:literals (import export)
(unit/c (import sig-block ...) (export sig-block ...))
([sig-block (tagged-sig-spec [id contract] ...)
tagged-sig-spec])]{
([sig-block (tagged-sig-id [id contract] ...)
tagged-sig-id])]{
A @deftech{unit contract} wraps a unit and checks both its imported and
exported identifiers to ensure that they match the appropriate contracts.
@ -649,6 +649,20 @@ identifier which is not listed for a given signature is left alone.
Variables used in a given @scheme[contract] expression first refer to other
variables in the same signature, and then to the context of the
@scheme[unit/c] expression.}
@defform/subs[#:literals (import export)
(define-unit/contract unit-id
(import sig-spec-block ...)
(export sig-spec-block ...)
init-depends-decl
unit-body-expr-or-defn
...)
([sig-spec-block (tagged-sig-spec [id contract] ...)
tagged-sig-spec])]{
The @scheme[define-unit/contract] form defines an unit compatible with
link inference whose imports and exports are contracted with a unit
contract. The unit name is used for the positive blame of the contract.}
@; ------------------------------------------------------------------------

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

@ -906,41 +906,41 @@ Understanding the server's event handling functions demands several data
data representation of the @tech{world}s that participate in the
universe.
@defproc[(world? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{world}. Because the universe server
@defproc[(iworld? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{iworld}. Because the universe server
represents worlds via structures that collect essential information about
the connections, the teachpack does not export any constructor or selector
functions on worlds.}
@defproc[(world=? [u world?][v world?]) boolean?]{
compares two @emph{world}s for equality.}
@defproc[(iworld=? [u iworld?][v iworld?]) boolean?]{
compares two @emph{iworld}s for equality.}
@defproc[(world-name [w world?]) symbol?]{
extracts the name from a @emph{world} structure.}
@defproc[(iworld-name [w iworld?]) symbol?]{
extracts the name from a @emph{iworld} structure.}
@defthing[world1 world?]{a world for testing your programs}
@defthing[world2 world?]{another world for testing your programs}
@defthing[world3 world?]{and a third one}
@defthing[iworld1 iworld?]{an @emph{iworld} for testing your programs}
@defthing[iworld2 iworld?]{another iworld for testing your programs}
@defthing[iworld3 iworld?]{and a third one}
The three sample worlds are provided so that you can test your functions
The three sample iworlds are provided so that you can test your functions
for universe programs. For example:
@schemeblock[
(check-expect (world=? world1 world2) false)
(check-expect (world=? world2 world2) true)
(check-expect (iworld=? iworld1 iworld2) false)
(check-expect (iworld=? iworld2 iworld2) true)
]
}
@item{Each event handler produces a @emph{bundle}, which is a structure
that contains the list of @emph{world}s to keep track of; the
that contains the list of @emph{iworld}s to keep track of; the
@tech{server}'s remaining state; and a list of mails to other
worlds:
@defproc[(bundle? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{bundle}.}
@defproc[(make-bundle [low (listof world?)] [state any/c] [mails (listof mail?)]) bundle?]{
creates a @emph{bundle} from a list of worlds, a piece of data that represents a server
@defproc[(make-bundle [low (listof iworld?)] [state any/c] [mails (listof mail?)]) bundle?]{
creates a @emph{bundle} from a list of iworlds, a piece of data that represents a server
state, and a list of mails.}
A @emph{mail} represents a message from an event handler to a world. The
@ -949,8 +949,8 @@ teachpack provides only a predicate and a constructor for these structures:
@defproc[(mail? [x any/c]) boolean?]{
determines whether @scheme[x] is a @emph{mail}.}
@defproc[(make-mail [to world?] [content sexp?]) mail?]{
creates a @emph{mail} from a @emph{world} and an @tech{S-expression}.}
@defproc[(make-mail [to iworld?] [content sexp?]) mail?]{
creates a @emph{mail} from a @emph{iworld} and an @tech{S-expression}.}
}
]
@ -977,8 +977,7 @@ The @tech{server} itself is created with a description that includes the
@defform/subs[#:id universe
#:literals
(start stop max-worlds on-new on-msg on-tick
on-disconnect to-string)
(on-new on-msg on-tick on-disconnect to-string)
(universe state-expr clause ...)
([clause
(on-new new-expr)
@ -1012,10 +1011,10 @@ The mandatory clauses of a @scheme[universe] server description are
@item{
@defform[(on-new new-expr)
#:contracts
([new-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
([new-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? bundle?)])]{
tell DrScheme to call the function @scheme[new-expr] every time another world joins the
universe. The event handler is called on the current list of worlds and the
joining world, which isn't on the list yet. In particular, the handler may
universe. The event handler is called on the current list of iworlds and the
joining iworld, which isn't on the list yet. In particular, the handler may
reject a @tech{world} program from participating in a @tech{universe},
simply by not including it in the resulting @scheme[bundle] structure. The
handler may still send one message to the world that attempts to join. }
@ -1024,7 +1023,7 @@ The mandatory clauses of a @scheme[universe] server description are
@item{
@defform[(on-msg msg-expr)
#:contracts
([msg-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? sexp? bundle?)])]{
([msg-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? sexp? bundle?)])]{
tell DrScheme to apply @scheme[msg-expr] to the list of currently
participating worlds @scheme[low], the current state of the universe, the world
@ -1055,7 +1054,7 @@ optional handlers:
@item{
@defform/none[(on-tick tick-expr)
#:contracts
([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)])]{
([tick-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) bundle?)])]{
tell DrScheme to apply @scheme[tick-expr] to the current list of
participating worlds and the current state of the
universe.
@ -1063,7 +1062,7 @@ optional handlers:
@defform/none[(on-tick tick-expr rate-expr)
#:contracts
([tick-expr (-> [listof world?] (unsyntax @tech{UniverseState}) bundle?)]
([tick-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) bundle?)]
[rate-expr natural-number/c])]{
tell DrScheme to apply @scheme[tick-expr] as above but use the specified
clock tick rate instead of the default.
@ -1074,7 +1073,7 @@ optional handlers:
@item{
@defform[(on-disconnect dis-expr)
#:contracts
([dis-expr (-> [listof world?] (unsyntax @tech{UniverseState}) world? bundle?)])]{
([dis-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) iworld? bundle?)])]{
tell DrScheme to invoke @scheme[dis-expr] every time a participating
@tech{world} drops its connection to the server. The first two arguments
are the current list of participating worlds and the state of the
@ -1085,7 +1084,7 @@ optional handlers:
@item{
@defform[(to-string render-expr)
#:contracts
([render-expr (-> [listof world?] (unsyntax @tech{UniverseState}) string?)])]{
([render-expr (-> [listof iworld?] (unsyntax @tech{UniverseState}) string?)])]{
tell DrScheme to render the state of the universe after each event and to
display this string in the universe console.
}
@ -1212,14 +1211,14 @@ translates into the design of two functions with the following headers,
#reader scribble/comment-reader
(schemeblock
;; Bundle is
;; (make-bundle [Listof world?] UniverseState [Listof mail?])
;; (make-bundle [Listof iworld?] UniverseState [Listof mail?])
;; [Listof world?] UniverseState world? -> Bundle
;; [Listof iworld?] UniverseState iworld? -> Bundle
;; compute next list of worlds and new @tech{UniverseState}
;; when world w is joining the universe, which is in state s;
(define (add-world s w) ...)
;; [Listof world?] UniverseState world? W2U -> Bundle
;; [Listof iworld?] UniverseState iworld? W2U -> Bundle
;; compute next list of worlds and new @tech{UniverseState}
;; when world w is sending message m to universe in state s
(define (process s p m) ...)
@ -1245,27 +1244,27 @@ As for the server's state, it must obviously keep track of all @tech{world}s tha
no @tech{world}s and, at that point, the server has nothing to track.
While there are many different useful ways of representing such a
@tech{universe}, we just use the list of @emph{worlds} that is handed to
@tech{universe}, we just use the list of @emph{iworlds} that is handed to
each handler and that handlers return via their bundles. The
@tech{UniverseState} itself is useless for this trivial example. We
interpret non-empty lists as those where the first @tech{world} is active
and the remainder are the passive @tech{world}s. As for the two possible
interpret non-empty lists as those where the first @emph{iworld} is active
and the remainder are the passive @emph{iworld}s. As for the two possible
events,
@itemize[
@item{it is natural to add new @tech{world}s to the end of the list; and}
@item{it is natural to add new @emph{iworld}s to the end of the list; and}
@item{it is natural to move an active @tech{world} that relinquishes its turn to
@item{it is natural to move an active @emph{iworld} that relinquishes its turn to
the end of the list, too.}
]
The server should send messages to the first @tech{world} of its list as
long as it wishes this @tech{world} to remain active. In turn, it should
expect to receive messages only from this one active @tech{world} and no
other @tech{world}. The content of these two messages is nearly irrelevant
because a message from the server to a @tech{world} means that it is the
@tech{world}'s turn and a message from the @tech{world} to the server
The server should send messages to the first @emph{iworld} of its list as
long as it wishes this @emph{iworld} to remain active. In turn, it should
expect to receive messages only from this one active @emph{iworld} and no
other @emph{iworld}. The content of these two messages is nearly irrelevant
because a message from the server to a @emph{iworld} means that it is the
@emph{iworld}'s turn and a message from the @emph{iworld} to the server
means that the turn is over. Just so that we don't confuse ourselves, we
use two distinct symbols for these two messages:
@itemize[

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

@ -307,14 +307,14 @@ Second, we must translate the "world" actions---the arrows in the above
;; 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}
;; 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}
;; deal with a key event (symbol, char) @scheme[ke]
;; in the current world @scheme[w]
(define (control w ke) ...)
))
@ -357,9 +357,9 @@ Now that we have a data definition, we must also decide which computer
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.
@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:
@ -372,17 +372,17 @@ 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[automatic-closer], which closes the time during one tick;}
@item{@scheme{door-actions}, which manipulates the time in response to
@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
@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
Let's start with @scheme[automatic-closer]. We know its contract and it is
easy to refine the purpose statement, too:
@(begin
@ -490,15 +490,15 @@ this purpose:
@(begin
#reader scribble/comment-reader
(schemeblock
;; render : @tech{SD} -> @scheme{Scene}
;; 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 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.

79
collects/tests/units/test-unit-contracts.ss
View File

@ -1,5 +1,6 @@
(require "test-harness.ss"
scheme/unit)
scheme/unit
scheme/contract)
(define-signature sig1
((contracted [x number?])))
@ -717,4 +718,78 @@
(f 0)
(test-runtime-error exn:fail:contract? "V@ broke contract on f"
(f 3)))
(f 3)))
(let ()
(define-signature foo^ (x y))
(define-unit/contract U@
(import)
(export (foo^ [x (-> number? number?)]))
(define (x n) (zero? n))
(define y 4))
(define-unit V@
(import foo^)
(export)
(x 4))
(define-compound-unit/infer W@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
y
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(x #t))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(x 3))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(invoke-unit W@)))
(let ()
(define-signature foo^ (x? f))
(define-unit/contract U@
(import)
(export (foo^ [f (-> x? number?)]))
(define (x? n) (or (= n 3)
(zero? n)))
(define (f n) (if (= n 3) #t n)))
(define-unit V@
(import foo^)
(export)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(f 2))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(f 3)))
(define-compound-unit/infer W@
(import) (export) (link U@ V@))
(define-values/invoke-unit/infer U@)
(test-runtime-error exn:fail:contract? "top-level broke contract on x"
(f 4))
(test-runtime-error exn:fail:contract? "U@ broke contract on x"
(f 3))
(invoke-unit W@))
(let ()
(define-signature foo^
((contracted
[x? (-> number? boolean?)]
[f (-> x? number?)])))
(define-unit/contract foo@
(import)
(export (foo^ [x? (-> any/c boolean?)]))
(define (x? n) (zero? n))
(define (f x) 3))
(define-values/invoke-unit/infer foo@)
(f 0)
(test-runtime-error exn:fail:contract? "top-level broke the contract on x"
(f 4))
;; This is a weird one. The definition for foo@ has two conflicting
;; contracts. Who gets blamed? Still the top-level, since foo@ can't
;; get blamed for breaking its own contract. In theory you could say
;; that perhaps the top-level shouldn't be blamed, and that it should
;; just be an "overriding" contract, but a) that won't really work and
;; b) what about other units that might link with foo@, that expect
;; the stronger contract?
(test-runtime-error exn:fail:contract? "top-level broke the contract on x"
(f #t)))

1238
collects/tex2page/tex2page.tex Normal file
View File

File diff suppressed because it is too large Load Diff

2
collects/web-server/info.ss
View File

@ -2,7 +2,7 @@
(define scribblings
'(("scribblings/web-server.scrbl" (multi-page) (tool))
("scribblings/tutorial/continue.scrbl" () (getting-started))))
("scribblings/tutorial/continue.scrbl" () (getting-started 5))))
(define mzscheme-launcher-libraries '("main.ss"))
(define mzscheme-launcher-names '("PLT Web Server"))

6
collects/web-server/scribblings/tutorial/continue.scrbl
View File

@ -16,8 +16,10 @@ up a web server, how to generate dynamic web content, and how to
interact with the user.
The target audience for this tutorial are students who've gone through
the design and use of structures in @link["http://htdp.org/"]{How to Design Programs}, with some
higher-order functions, @scheme[local], and a minor bit of mutation.
the design and use of structures in
@italic{@link["http://www.htdp.org/"]{How to Design Programs}}, with
some higher-order functions, @scheme[local], and a minor bit of
mutation.
@section{Getting Started}

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

@ -1,3 +1,8 @@
------------------------------------------------------------------------
Version 4.1.****** [Sat Feb 14 20:12:23 EST 2009]
* the universe teachpack exports iworld, not world now
------------------------------------------------------------------------
Version 4.1.4 [Sun Jan 18 21:18:34 EST 2009]

14
src/mzscheme/gc2/newgc.c
View File

@ -52,6 +52,12 @@
#define PAGEMAP32_BITS(x) (NUM(x) >> LOG_APAGE_SIZE)
#endif
#if 0
# define GC_ASSERT(x) assert(x)
#else
# define GC_ASSERT(x) /* empty */
#endif
/* the page type constants */
enum {
PAGE_TAGGED = 0,
@ -1827,7 +1833,7 @@ static void propagate_marks(NewGC *gc)
if((unsigned long)mark_table[tag] < PAGE_TYPES) {
/* atomic */
} else {
assert(mark_table[tag]);
GC_ASSERT(mark_table[tag]);
mark_table[tag](start); break;
}
}
@ -1838,7 +1844,7 @@ static void propagate_marks(NewGC *gc)
unsigned short tag = *(unsigned short *)start;
end -= INSET_WORDS;
while(start < end) {
assert(mark_table[tag]);
GC_ASSERT(mark_table[tag]);
start += mark_table[tag](start);
}
break;
@ -1853,7 +1859,7 @@ static void propagate_marks(NewGC *gc)
case PAGE_TAGGED:
{
unsigned short tag = *(unsigned short*)p;
assert(mark_table[tag]);
GC_ASSERT(mark_table[tag]);
mark_table[tag](p);
break;
}
@ -1869,7 +1875,7 @@ static void propagate_marks(NewGC *gc)
void **end = PPTR(info) + (info->size - INSET_WORDS);
unsigned short tag = *(unsigned short *)start;
while(start < end) {
assert(mark_table[tag]);
GC_ASSERT(mark_table[tag]);
start += mark_table[tag](start);
}
break;

8
src/mzscheme/gc2/sighand.c
View File

@ -18,6 +18,11 @@
#include <sys/types.h>
#include <unistd.h>
#ifndef WAIT_FOR_GDB
# define WAIT_FOR_GDB 0
#endif
#if WAIT_FOR_GDB
static void launchgdb() {
pid_t pid = getpid();
char inbuffer[10];
@ -31,13 +36,16 @@ static void launchgdb() {
}
}
}
#endif
void fault_handler(int sn, struct siginfo *si, void *ctx)
{
void *p = si->si_addr;
if (si->si_code != SEGV_ACCERR) { /*SEGV_MAPERR*/
printf("SIGSEGV fault on %p\n", p);
#if WAIT_FOR_GDB
launchgdb();
#endif
abort();
}

5
src/mzscheme/src/error.c
View File

@ -2035,6 +2035,7 @@ static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[])
while (SCHEME_PAIRP(extra_sources)) {
if (!SCHEME_STXP(SCHEME_CAR(extra_sources)))
break;
extra_sources = SCHEME_CDR(extra_sources);
}
if (!SCHEME_NULLP(extra_sources)) {
scheme_wrong_type("raise-syntax-error", "list of syntax", 4, argc, argv);
@ -2044,8 +2045,8 @@ static Scheme_Object *raise_syntax_error(int argc, Scheme_Object *argv[])
}
scheme_wrong_syntax_with_more_sources(who,
(argc > 3) ? argv[3] : NULL,
(argc > 2) ? argv[2] : NULL,
((argc > 3) && !SCHEME_FALSEP(argv[3])) ? argv[3] : NULL,
((argc > 2) && !SCHEME_FALSEP(argv[2])) ? argv[2] : NULL,
extra_sources,
"%T", str);