diff --git a/collects/2htdp/private/universe.ss b/collects/2htdp/private/universe.ss index 7fc5426de7..f1dd4b08bd 100644 --- a/collects/2htdp/private/universe.ss +++ b/collects/2htdp/private/universe.ss @@ -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)))) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 4d2758168a..d26ef51db2 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -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 diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 430a3df3fe..2d3e051e73 100755 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -1,34 +1,58 @@ #reader "literate-reader.ss" + + +@title{Chat Noir} + +Chat Noir. What a game. + @chunk[
] -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[ -(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[ (define-struct cell (p blocked?) #:transparent)] +@section{Init Junk} @chunk[ @@ -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[ #;'() diff --git a/collects/games/chat-noir/literate-lang.ss b/collects/games/chat-noir/literate-lang.ss index 86eaf4441b..0c6aa80992 100755 --- a/collects/games/chat-noir/literate-lang.ss +++ b/collects/games/chat-noir/literate-lang.ss @@ -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 () diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 6db345a023..1d81a3ace1 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -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)") diff --git a/collects/mzlib/private/unit-compiletime.ss b/collects/mzlib/private/unit-compiletime.ss index 49ad4d8b49..b8eede078a 100644 --- a/collects/mzlib/private/unit-compiletime.ss +++ b/collects/mzlib/private/unit-compiletime.ss @@ -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 diff --git a/collects/mzlib/private/unit-contract-syntax.ss b/collects/mzlib/private/unit-contract-syntax.ss index 8f6fa734f5..97a6af6659 100644 --- a/collects/mzlib/private/unit-contract-syntax.ss +++ b/collects/mzlib/private/unit-contract-syntax.ss @@ -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 ...))) \ No newline at end of file + (pattern (export e:unit/contract-clause ...))) +(define-syntax-class dep-clause #:literals (init-depend) + #:transparent + (pattern (init-depend s:tagged-sig-id ...))) \ No newline at end of file diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 861ddfba68..a3813b91e2 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -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))]) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 3c1720252a..95f2bced3a 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index b64902d978..651b51c14c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14feb2009") +#lang scheme/base (provide stamp) (define stamp "15feb2009") diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index b62c4be140..15f476b2fb 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -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 ...))))])) diff --git a/collects/scribblings/guide/info.ss b/collects/scribblings/guide/info.ss index 75a56e7705..c4531297a3 100644 --- a/collects/scribblings/guide/info.ss +++ b/collects/scribblings/guide/info.ss @@ -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")) diff --git a/collects/scribblings/guide/unit.scrbl b/collects/scribblings/guide/unit.scrbl index 723b02fae1..e19dec8598 100644 --- a/collects/scribblings/guide/unit.scrbl +++ b/collects/scribblings/guide/unit.scrbl @@ -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) ] diff --git a/collects/scribblings/main/config.ss b/collects/scribblings/main/config.ss index fc404e023a..c9a169f2c6 100644 --- a/collects/scribblings/main/config.ss +++ b/collects/scribblings/main/config.ss @@ -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") diff --git a/collects/scribblings/main/getting-started.scrbl b/collects/scribblings/main/getting-started.scrbl new file mode 100644 index 0000000000..0e2c2a4ace --- /dev/null +++ b/collects/scribblings/main/getting-started.scrbl @@ -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. diff --git a/collects/scribblings/main/info.ss b/collects/scribblings/main/info.ss index bb178dfcb0..28faa2f7d1 100644 --- a/collects/scribblings/main/info.ss +++ b/collects/scribblings/main/info.ss @@ -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)))) diff --git a/collects/scribblings/main/private/manuals.ss b/collects/scribblings/main/private/manuals.ss index 9de7f40659..4c5b02600e 100644 --- a/collects/scribblings/main/private/manuals.ss +++ b/collects/scribblings/main/private/manuals.ss @@ -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) diff --git a/collects/scribblings/more/info.ss b/collects/scribblings/more/info.ss index d711129f4a..56d87e0160 100644 --- a/collects/scribblings/more/info.ss +++ b/collects/scribblings/more/info.ss @@ -1,3 +1,3 @@ #lang setup/infotab -(define scribblings '(("more.scrbl" () (getting-started 5)))) +(define scribblings '(("more.scrbl" () (getting-started 3)))) diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 0f589a42a0..40203b2090 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -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" diff --git a/collects/scribblings/reference/exns.scrbl b/collects/scribblings/reference/exns.scrbl index 37a1879cac..81e20b596b 100644 --- a/collects/scribblings/reference/exns.scrbl +++ b/collects/scribblings/reference/exns.scrbl @@ -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 diff --git a/collects/scribblings/reference/hashes.scrbl b/collects/scribblings/reference/hashes.scrbl index 42330cdeff..18c7c9daef 100644 --- a/collects/scribblings/reference/hashes.scrbl +++ b/collects/scribblings/reference/hashes.scrbl @@ -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].} diff --git a/collects/scribblings/reference/units.scrbl b/collects/scribblings/reference/units.scrbl index 2d3e585712..5ff110a198 100644 --- a/collects/scribblings/reference/units.scrbl +++ b/collects/scribblings/reference/units.scrbl @@ -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.} + @; ------------------------------------------------------------------------ diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 137629680e..a64bcff87f 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -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[ diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index 641bbd64f0..26432d2459 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -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. diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss index 360ed179bf..70c866aab3 100644 --- a/collects/tests/units/test-unit-contracts.ss +++ b/collects/tests/units/test-unit-contracts.ss @@ -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))) \ No newline at end of file + (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))) diff --git a/collects/tex2page/tex2page.tex b/collects/tex2page/tex2page.tex new file mode 100644 index 0000000000..0d49803775 --- /dev/null +++ b/collects/tex2page/tex2page.tex @@ -0,0 +1,1238 @@ +% tex2page.tex +% Dorai Sitaram + +% TeX files using these macros +% can be converted by the program +% tex2page into HTML + +\ifx\shipout\UnDeFiNeD\endinput\fi + +\message{version 2008-03-02} % last change + +\let\texonly\relax +\let\endtexonly\relax + +\let\htmlonly\iffalse +\let\endhtmlonly\fi + +\edef\atcatcodebeforetexzpage{% + \noexpand\catcode`\noexpand\@=\the\catcode`\@} +\catcode`\@11 + +% + +\def\verbwritefile{% + \ifx\verbwritefileQport\UnDeFiNeD + \expandafter\csname newwrite\endcsname\verbwritefileQport + \else\immediate\closeout\verbwritefileQport + \fi + \futurelet\verbwritefileQnext\verbwritefileQcheckchar} + +\def\verbwritefileQcheckchar{% + \ifx\verbwritefileQnext\bgroup + \let\verbwritefileQnext\verbwritefileQbracedfile + \else + \let\verbwritefileQnext\verbwritefileQspacedfile + \fi\verbwritefileQnext} + +\def\verbwritefileQspacedfile#1 {% + \immediate\openout\verbwritefileQport #1 +} + +\def\verbwritefileQbracedfile#1{% + \verbwritefileQspacedfile #1 +} + +\def\verbwrite{% + \ifx\verbwritefileQport\UnDeFiNeD + \verbwritefile \jobname.txt \fi + \begingroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \catcode`\^^M=12 \newlinechar=`\^^M% + \futurelet\verbwriteQopeningchar\verbwriteQii} + +\def\verbwriteQii{\ifx\verbwriteQopeningchar\bgroup + \let\verbwriteQiii\verbwriteQbrace\else + \let\verbwriteQiii\verbwriteQnonbrace\fi + \verbwriteQiii} + +\def\verbwriteQbrace#1{\immediate + \write\verbwritefileQport{#1}\endgroup} + +\def\verbwriteQnonbrace#1{% + \catcode`\{12 \catcode`\}12 + \def\verbwriteQnonbraceQii##1#1{% + \immediate\write\verbwritefileQport{##1}\endgroup}% + \verbwriteQnonbraceQii} + +\ifx\slatexignorecurrentfile\UnDeFiNeD\relax\fi + +% + +\def\defcsactive#1{\defnumactive{`#1}} + +\def\defnumactive#1{\catcode#1\active + \begingroup\lccode`\~#1% + \lowercase{\endgroup\def~}} + +% gobblegobblegobble + +\def\gobblegroup{\bgroup + \def\do##1{\catcode`##1=9 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \gobblegroupQii} + +\def\gobblegroupQii#1{\egroup} + +% \verb +% Usage: \verb{...lines...} or \verb|...lines...| +% In the former case, | can be used as escape char within +% the verbatim text + +\let\verbhook\relax + +\def\verbfont{\tt} +%\hyphenchar\tentt-1 + +\def\verbsetup{\frenchspacing + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\|=12 % needed? + \verbfont + \edef\verbQoldhyphenchar{\the\hyphenchar\font}% + \hyphenchar\font-1 + \def\verbQendgroup{\hyphenchar\font\verbQoldhyphenchar\endgroup}% +} + +\def\verbavoidligs{% avoid ligatures + \defcsactive\`{\relax\lq}% + \defcsactive\ {\leavevmode\ }% + \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% + \defcsactive\^^M{\leavevmode\endgraf}% + \ifx\noncmttQspecific\UnDeFiNeD\else\noncmttQspecific\fi} + +\def\verbinsertskip{% + \let\firstpar y% + \defcsactive\^^M{\ifx\firstpar y% + \let\firstpar n% + \verbdisplayskip + \parskip 0pt + \aftergroup\verbdisplayskip + \else\leavevmode\fi\endgraf}% + \verbhook} + +%\def\verb{\begingroup +% \verbsetup\verbQii} + +\ifx\verb\UnDeFiNeD\else % save away LaTeX's \verb + \let\LaTeXverb\verb +\fi + +\def\verb{\begingroup + \verbsetup\verbavoidligs\verbQcheckstar}% + +\def\verbQcheckstar{% + \futurelet\verbQcheckstarQnext\verbQcheckstarQii} + +\def\verbQcheckstarQii{% + \if\verbQcheckstarQnext*% + \let\verbQcheckstarQnext\verbQcheckstarQiii + \else + \let\verbQcheckstarQnext\verbQii + \fi + \verbQcheckstarQnext} + +\def\verbQcheckstarQiii#1{% + \defcsactive\ {\relax\char`\ }% + \verbQii} + +\newcount\verbbracebalancecount + +\def\verblbrace{\char`\{} +\def\verbrbrace{\char`\}} + +\ifx\verbatimescapechar\UnDeFiNeD +% don't clobber Eplain's \verbatimescapechar +\def\verbatimescapechar#1{% + \def\@makeverbatimescapechar{\catcode`#1=0 }}% +\fi +\let\verbescapechar\verbatimescapechar + +\verbatimescapechar\| + +{\catcode`\[1 \catcode`\]2 +\catcode`\{12 \catcode`\}12 +\gdef\verbQii#1[%\verbavoidligs + \verbinsertskip\verbhook + %\edef\verbQoldhyphenchar{\the\hyphenchar\tentt}% + %\hyphenchar\tentt=-1 + %\def\verbQendgroup{\hyphenchar\tentt\verbQoldhyphenchar\endgroup}% + %\let\verbQendgroup\endgroup% + \if#1{\@makeverbatimescapechar + \def\{[\char`\{]% + \def\}[\char`\}]% + \def\|[\char`\|]% + \verbbracebalancecount0 + \defcsactive\{[\advance\verbbracebalancecount by 1 + \verblbrace]% + \defcsactive\}[\ifnum\verbbracebalancecount=0 + \let\verbrbracenext\verbQendgroup\else + \advance\verbbracebalancecount by -1 + \let\verbrbracenext\verbrbrace\fi + \verbrbracenext]\else + \defcsactive#1[\verbQendgroup]\fi + \verbQiii +]] + +\def\verbQiii{\futurelet\verbQiiinext\verbQiv} + +{\catcode`\^^M\active% +\gdef\verbQiv{\ifx\verbQiiinext^^M\else% + \defcsactive\^^M{\leavevmode\ }\fi}} + +\let\verbdisplayskip\medbreak + +% \verbatiminput FILENAME +% displays contents of file FILENAME verbatim. + +%\def\verbatiminput#1 {{\verbsetup\verbavoidligs\verbhook +% \input #1 }} + +% ^ original \verbatiminput + +\ifx\verbatiminput\UnDeFiNeD +% LaTeX's (optional) verbatim package defines a \verbatiminput -- +% don't clobber it +\def\verbatiminput{% + \futurelet\verbatiminputQnext\verbatiminputQcheckchar}% +\fi + +\def\verbatiminputQcheckchar{% + \ifx\verbatiminputQnext\bgroup + \let\verbatiminputQnext\verbatiminputQbracedfile + \else + \let\verbatiminputQnext\verbatiminputQspacedfile + \fi\verbatiminputQnext} + +\def\verbatiminputQbracedfile#1{\verbatiminputQdoit{#1}} + +\def\verbatiminputQspacedfile#1 {\verbatiminputQdoit{#1}} + +\def\verbatiminputQdoit#1{{\verbsetup + \verbavoidligs\verbhook + \input #1 }} + +% \url{URL} becomes +% URL in HTML, and +% URL in DVI. + +% A-VERY-VERY-LONG-URL in a .bib file +% could be split by BibTeX +% across a linebreak, with % before the newline. +% To accommodate this, %-followed-by-newline will +% be ignored in the URL argument of \url and related +% macros. + +\ifx\url\UnDeFiNeD +\def\url{\bgroup\urlsetup\let\dummy=}% +\fi + +\def\urlsetup{\verbsetup\urlfont\verbavoidligs + \catcode`\{1 \catcode`\}2 + \defcsactive\%{\urlQpacifybibtex}% + \defcsactive\ {\relax}% + \defcsactive\^^M{\relax}% + \defcsactive\.{\discretionary{}{\char`\.}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \defcsactive\`{\relax\lq}} + +\let\urlfont\relax + +\def\urlQpacifybibtex{\futurelet\urlQpacifybibtexQnext\urlQpacifybibtexQii} + +\def\urlQpacifybibtexQii{\ifx\urlQpacifybibtexQnext^^M% + \else\%\fi} + + +% \urlh{URL}{TEXT} becomes +% TEXT in HTML, and +% TEXT in DVI. + +% If TEXT contains \\, the part after \\ appears in +% the DVI only. If, further, this part contains \1, +% the latter is replaced by a fixed-width representation +% of URL. + +\def\urlh{\bgroup\urlsetup + \afterassignment\urlhQii + \gdef\urlhQurlarg} + +\def\urlhQii{\egroup + \bgroup + \let\\\relax + \def\1{{\urlsetup\urlhQurlarg}}% + \let\dummy=} + +\def\urlp#1{{#1} \bgroup\urlsetup + \afterassignment\urlpQwrapparens + \gdef\urlpQurlarg} + +\def\urlpQwrapparens{\egroup + {\rm(}{\urlsetup\urlpQurlarg}{\rm)}} + +% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes +% HTML-TEXT in HTML, and +% DVI-TEXT in DVI + +\def\urlhd{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 + \urlhdQeaturlhtmlargs} + +\def\urlhdQeaturlhtmlargs#1#2{\egroup} + +\ifx\href\UnDeFiNeD +\let\href\urlh +\fi + +% Scheme + +\let\scm\verb +\let\scminput\verbatiminput +\let\scmdribble\scm + + +% Images + +\let\imgdef\def + +\let\makehtmlimage\relax + +\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} +\def\closemathg{$} + +\let\mathp\mathg + +\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} +\def\closemathdg{$$} + +% + +\ifx\label\UnDeFiNeD +\else +\def\xrtag#1#2{\@bsphack + \protected@write\@auxout{}% + {\string\newlabel{#1}{{#2}{\thepage}}}% +\@esphack}% +%\let\tagref\ref +\fi + +\ifx\definexref\UnDeFiNeD +\else +\def\xrtag#1#2{\definexref{#1}{#2}{}}% +\fi + +\ifx\IfFileExists\UnDeFiNeD +\def\IfFileExists#1#2#3{% + \openin0 #1 % + \ifeof0 % + #3% + \else + #2\fi + \closein0 }% +\fi + +\ifx\futurenonspacelet\UnDeFiNeD +\ifx\@futurenonspacelet\UnDeFiNeD +% +\def\futurenonspaceletQpickupspace/{% + \global\let\futurenonspaceletQspacetoken= }% +\futurenonspaceletQpickupspace/ % +% +\def\futurenonspacelet#1{\def\futurenonspaceletQargQi{#1}% + \afterassignment\futurenonspaceletQstepQone + \let\futurenonspaceletQargQii=}% +% +\def\futurenonspaceletQstepQone{% + \expandafter\futurelet\futurenonspaceletQargQi + \futurenonspaceletQstepQtwo}% +% +\def\futurenonspaceletQstepQtwo{% + \expandafter\ifx\futurenonspaceletQargQi\futurenonspaceletQspacetoken + \let\futurenonspaceletQnext=\futurenonspaceletQstepQthree + \else\let\futurenonspaceletQnext=\futurenonspaceletQargQii + \fi\futurenonspaceletQnext}% +% +\def\futurenonspaceletQstepQthree{% + \afterassignment\futurenonspaceletQstepQone + \let\futurenonspaceletQnext= }% +% +\else\let\futurenonspacelet\@futurenonspacelet +\fi +\fi + +\ifx\slatexversion\UnDeFiNeD +% SLaTeX compat +\let\scmkeyword\gobblegroup +\let\scmbuiltin\gobblegroup +\let\scmconstant\scmbuiltin +\let\scmvariable\scmbuiltin +\let\setbuiltin\scmbuiltin +\let\setconstant\scmbuiltin +\let\setkeyword\scmkeyword +\let\setvariable\scmvariable +\def\schemedisplay{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemedisplayI}% +\def\schemeresponse{\begingroup + \verbsetup\verbavoidligs + \verbinsertskip + \schemeresponseI}% +{\catcode`\|0 |catcode`|\12 + |long|gdef|schemedisplayI#1\endschemedisplay{% + #1|endgroup}% + |long|gdef|schemeresponseI#1\endschemeresponse{% + #1|endgroup}}% +\fi + + +% STOP LOADING HERE FOR LATEX + +\ifx\section\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +\newwrite\sectionQscratchfileport + +% Title + +\def\subject{% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \subjectI} + +\def\subjectI#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + $$\vbox{\bf \def\\{\cr}% + \halign{\hfil##\hfil\cr + \input Z-sec-temp + \cr}}$$% + \medskip} + +\let\title\subject + +% toc + +\let\tocactive0 + +\newcount\tocdepth + +%\tocdepth=10 +\tocdepth=3 + +\def\tocoutensure{\ifx\tocout\UnDeFiNeD + \csname newwrite\endcsname\tocout\fi} + +\def\tocactivate{\ifx\tocactive0% + \tocoutensure + \tocsave + \openout\tocout \jobname.toc + \global\let\tocactive1\fi} + +\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} + +\def\tocsave{\openin0=\jobname.toc + \ifeof0 \closein0 \else + \openout\tocout Z-T-\jobname.tex + \let\tocsaved 0% + \loop + \ifeof0 \closeout\tocout + \let\tocsaved1% + \else{\tocspecials + \read0 to \tocsaveline + \edef\temp{\write\tocout{\tocsaveline}}\temp}% + \fi + \ifx\tocsaved0% + \repeat + \fi + \closein0 } + +\def\tocentry#1#2{% + %#1=depth #2=secnum + \def\tocentryQsecnum{#2}% + \ifnum#1=1 + \ifnum\tocdepth>2 + \medbreak\begingroup\bf + \else\begingroup\fi + \else\begingroup\fi + \vtop\bgroup\raggedright + \noindent\hskip #1 em + \ifx\tocentryQsecnum\empty + \else\qquad\llap{\tocentryQsecnum}\enspace\fi + \bgroup + \aftergroup\tocentryQii + %read section title + \let\dummy=} + +\def\tocentryQii#1{% + %#1=page nr + , #1\strut\egroup + \endgroup\par +} + + +% allow {thebibliography} to be used directly +% in (plain-TeX) source document without +% generating it via BibTeX + +\ifx\thebibliography\UnDeFiNeD +\def\thebibliography#1{\vskip-\lastskip + \begingroup + \def\endthebibliography{\endgroup\endgroup}% + \def\input##1 ##2{\relax}% + \setbox0=\hbox{\biblabelcontents{#1}}% + \biblabelwidth=\wd0 + \@readbblfile}% +\fi + + +% + +\def\italiccorrection{\futurelet\italiccorrectionI + \italiccorrectionII} + +\def\italiccorrectionII{% + \if\noexpand\italiccorrectionI,\else + \if\noexpand\italiccorrectionI.\else + \/\fi\fi} + +\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} + +\def\emph{\bgroup\it + \ifmmode\else\aftergroup\italiccorrection\fi + \let\dummy=} + + +\def\begin#1{\begingroup + \def\end##1{\csname end#1\endcsname\endgroup}% + \csname #1\endcsname} + + +\def\textdegree{\ifmmode^\circ\else$^\circ$\fi} + + +% STOP LOADING HERE FOR EPLAIN + +\ifx\eplain\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing +% + +% Index generation +% +% Your TeX source contains \index{NAME} to +% signal that NAME should be included in the index. +% Check the makeindex documentation to see the various +% ways NAME can be specified, eg, for subitems, for +% explicitly specifying the alphabetization for a name +% involving TeX control sequences, etc. +% +% The first run of TeX will create \jobname.idx. +% makeindex on \jobname[.idx] will create the sorted +% index \jobname.ind. +% +% Use \inputindex (without arguments) to include this +% sorted index, typically somewhere to the end of your +% document. This will produce the items and subitems. +% It won't produce a section heading however -- you +% will have to typeset one yourself. + +%\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% +% \dospecials +% \catcode`\{=1 \catcode`\}=2 \catcode`\ =10 } + +\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% + \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% + \do\@\do\"\do\!\do\|\do\-\do\ \do\'} + +\def\index{%\unskip + \ifx\indexout\UnDeFiNeD + \csname newwrite\endcsname\indexout + \openout\indexout \jobname.idx\fi + \begingroup + \sanitizeidxletters + \indexQii} + +\def\indexQii#1{\endgroup + \write\indexout{\string\indexentry{#1}{\folio}}% + \ignorespaces} + +% The following index style indents subitems on a +% separate lines + +\def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\indexitem##1{\par\hangindent30pt \hangafter1 + \hskip ##1 }% + \def\item{\indexitem{0em}}% + \def\subitem{\indexitem{2em}}% + \def\subsubitem{\indexitem{4em}}% + \def\see{{\it see} \bgroup\aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip} + +\def\endtheindex{\endgroup} + +\def\inputindex{% + \openin0 \jobname.ind + \ifeof0 \closein0 + \message{\jobname.ind missing.}% + \else\closein0 + \begingroup + \def\begin##1{\csname##1\endcsname}% + \def\end##1{\csname end##1\endcsname}% + \input\jobname.ind + \endgroup\fi} + +% Cross-references + +% \openxrefout loads all the TAG-VALUE associations in +% \jobname.xrf and then opens \jobname.xrf as an +% output channel that \xrtag can use + +\def\openxrefout{% + \openin0=\jobname.xrf + \ifeof0 \closein0 + \else \closein0 {\catcode`\\0 \input \jobname.xrf }% + \fi + \expandafter\csname newwrite\endcsname\xrefout + \openout\xrefout=\jobname.xrf +} + +% I'd like to call \openxrefout lazily, but +% unfortunately it produces a bug in MiKTeX. +% So let's call it up front. + +\openxrefout + +% \xrtag{TAG}{VALUE} associates TAG with VALUE. +% Hereafter, \ref{TAG} will output VALUE. +% \xrtag stores its associations in \xrefout. +% \xrtag calls \openxrefout if \jobname.xrf hasn't +% already been opened + +\def\xrtag#1#2{\ifx\xrefout\UnDeFiNeD\openxrefout\fi + {\let\folio0% + \edef\temp{% + \write\xrefout{\string\expandafter\string\gdef + \string\csname\space XREF#1\string\endcsname + {#2}\string\relax}}% + \temp}\ignorespaces} + + +% \ref{TAG} outputs VALUE, assuming \xrtag put such +% an association into \xrefout. \ref calls +% \openxrefout if \jobname.xrf hasn't already +% been opened + +\def\ref#1{\ifx\xrefout\UnDeFiNeD\openxrefout\fi + \expandafter\ifx\csname XREF#1\endcsname\relax + %\message or \write16 ? + \message{\the\inputlineno: Unresolved label `#1'.}?\else + \csname XREF#1\endcsname\fi} + + +% + +\def\writenumberedtocline#1#2#3{% + %#1=depth + %#2=secnum + %#3=title + \tocactivate + \edef\@currentlabel{#2}% + {\let\folio0% + \edef\writetotocQtemp{\write\tocout + {\string\tocentry{#1}{#2}{#3}{\folio}}}% + \writetotocQtemp}} + +\def\tableofcontents{% + \ifx\tocactive0% + \openin0 \jobname.toc + \edef\QatcatcodebeforeToC{% + \noexpand\catcode`\noexpand\@=\the\catcode`\@}% + \catcode`\@=11 + \ifeof0 \closein0 \else + \closein0 \input \jobname.toc + \fi + \QatcatcodebeforeToC + \tocoutensure + \openout\tocout \jobname.toc + \global\let\tocactive1% + \else + \input Z-T-\jobname.tex + \fi} + +% + +\ifx\TZPplain\UnDeFiNeD +\let\maybeloadfollowing\relax +\else +\atcatcodebeforetexzpage +\let\maybeloadfollowing\endinput +\fi\maybeloadfollowing + +% Tally control sequences are cheap count +% registers: they doesn't use up TeX's limited number of +% real count registers. + +% A tally is a macro that expands to the +% number kept track of. Thus \edef\kount{0} defines a +% tally \kount that currently contains 0. + +% \advancetally\kount n increments \kount by n. +% \globaladvancetally increments the global \kount. +% If \kount is not defined, the \[global]advancetally +% macros define it to be 0 before proceeding with the +% incrementation. + +\def\newtally#1{\edef#1{0}} + +\def\advancetallyhelper#1#2#3{% + \ifx#2\UnDeFiNeD + #1\edef#2{0}\fi + \edef\setcountCCLV{\count255=#2 }% + \setcountCCLV + \advance\count255 by #3 + #1\edef#2{\the\count255 }} + +\def\advancetally{\advancetallyhelper\relax} +\def\globaladvancetally{\advancetallyhelper\global} + +% Sections + +\def\tracksectionchangeatlevel#1{% + \expandafter\let\expandafter\thiscount\csname + sectionnumber#1\endcsname + \ifx\thiscount\relax + \expandafter\edef\csname sectionnumber#1\endcsname{0}% + \fi + \expandafter\advancetally + \csname sectionnumber#1\endcsname 1% + \ifx\doingappendix0% + \edef\@currentlabel{\csname sectionnumber1\endcsname}% + \else + %\count255=\expandafter\csname sectionnumber1\endcsname + \edef\@currentlabel{\char\csname sectionnumber1\endcsname}% + \fi + \count255=0 + \loop + \advance\count255 by 1 + \ifnum\count255=1 + \else\edef\@currentlabel{\@currentlabel.\csname + sectionnumber\the\count255\endcsname}\fi + \ifnum\count255<#1% + \repeat + \loop + \advance\count255 by 1 + \expandafter\let\expandafter\nextcount\csname + sectionnumber\the\count255\endcsname + \ifx\nextcount\relax + \let\continue0% + \else + \expandafter\edef\csname + sectionnumber\the\count255\endcsname{0}% + \let\continue1\fi + \ifx\continue1% + \repeat} +\newcount\secnumdepth + +\secnumdepth=3 + +\def\sectiond#1{\count255=#1% + \ifx\usingchapters1\advance\count255 by 1 \fi + \edef\sectiondlvl{\the\count255 }% + \futurelet\sectionnextchar\sectiondispatch} + +\def\sectiondispatch{\ifx\sectionnextchar*% + \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else + \ifnum\sectiondlvl>\secnumdepth + \def\sectioncontinue{\sectionhelp{\sectiondlvl}{}}\else + \tracksectionchangeatlevel{\sectiondlvl}% + \def\sectioncontinue{\sectionhelp{\sectiondlvl}% + {\@currentlabel}}\fi\fi + \sectioncontinue} + +\def\sectionstar#1*{\sectionhelp{#1}{}} + +\def\sectionhelp#1#2{% + \edef\sectiondepth{#1}% + \def\sectionnr{#2}% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}= 2 + \sectionheader} + +% Vanilla section-header look -- change this macro for new look + +\def\sectionheader#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + \vskip -\lastskip + \ifnum\sectiondepth>\tocdepth\else + \writenumberedtocline{\sectiondepth}{\sectionnr}{#1}% + \fi + \vskip1.5\bigskipamount + \goodbreak %??? + \noindent + \hbox{\vtop{\pretolerance 10000 + \raggedright + \noindent\bf + \ifx\sectionnr\empty\else + \sectionnr\enspace\fi + \input Z-sec-temp }}% + \nobreak + \smallskip + %\noindent + } + +% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% +% \string\vtop{\string\hsize=.7\string\hsize +% \string\noindent\string\raggedright\space #3}\string\par}}\temp + + + +\def\section{\sectiond1} +\def\subsection{\sectiond2} +\def\subsubsection{\sectiond3} +\def\paragraph{\sectiond4} +\def\subparagraph{\sectiond5} + +\let\usingchapters0 + +\def\chapter{\global\let\usingchapters1% +\global\footnotenumber=0 +\futurelet\chapternextchar\chapterdispatch} + +\def\chapterdispatch{\ifx\chapternextchar*% + \let\chaptercontinue\chapterstar\else + \tracksectionchangeatlevel{1}% + \def\chaptercontinue{\chapterhelp{\@currentlabel}}\fi + \chaptercontinue} + +\def\chapterstar*{\chapterhelp{}} + +\def\chapterhelp#1{% + % #1=number #2=heading-text + \def\chapternr{#1}% + \immediate\openout\sectionQscratchfileport Z-sec-temp + \begingroup + \def\do##1{\catcode`##1=11 }\dospecials + \catcode`\{=1 \catcode`\}=2 + \chapterheader} + +\def\chapterheader#1{\endgroup + \immediate\write\sectionQscratchfileport {#1}% + \immediate\closeout\sectionQscratchfileport + \writenumberedtocline{1}{\chapternr}{#1}% + \vfill\eject + \null\vskip3em + \noindent + \ifx\chapternr\empty\hbox{~}\else + \ifx\doingappendix0% + \hbox{\bf Chapter \chapternr}\else + \hbox{\bf Appendix \chapternr}\fi\fi + \vskip 1em + \noindent + \hbox{\bf\vtop{%\hsize=.7\hsize + \pretolerance 10000 + \noindent\raggedright\input Z-sec-temp }}% + \nobreak\vskip3em + %\noindent + } + +\let\doingappendix=0 + +\def\appendix{\let\doingappendix=1% + \count255=`\A% + \advance\count255 by -1 + \expandafter\edef\csname + sectionnumber1\endcsname{\the\count255 }} + +% Numbered footnotes + +\ifx\plainfootnote\UnDeFiNeD + \let\plainfootnote\footnote +\fi + +\newcount\footnotenumber + +\def\numberedfootnote{\global\advance\footnotenumber 1 + \bgroup\csname footnotehook\endcsname + \plainfootnote{$^{\the\footnotenumber}$}\bgroup + \edef\@currentlabel{\the\footnotenumber}% + \aftergroup\egroup + \let\dummy=} + + +\let\@currentlabel\relax + +% \label, as in LaTeX + +% The sectioning commands +% define \@currentlabel so a subsequent call to \label will pick up the +% right label. + +\def\label#1{\xrtag{#1}{\@currentlabel}% + \xrtag{PAGE#1}{\folio}} + +% \pageref, as in LaTeX + +\def\pageref#1{\ref{PAGE#1}} + + +% + +\def\itemize{\par\begingroup + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \llap{$\bullet$\enspace}\ignorespaces}} + +\def\enditemize{\smallbreak\smallbreak\endgroup\par} + +\newtally\enumeratelevel + +\def\enumerate{\par\begingroup + \advancetally\enumeratelevel1% + \newtally\enumeratenumber + \advance\leftskip\parindent + \smallbreak + \def\item{\smallbreak\noindent + \advancetally\enumeratenumber1% + \ifnum\enumeratelevel=1 + \edef\enumeratemark{\enumeratenumber}\else + \ifnum\enumeratelevel=2 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `a + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \ifnum\enumeratelevel=3 + \edef\enumeratemark{\Romannumeral\enumeratenumber}\else + \ifnum\enumeratelevel=4 + \count255=\enumeratenumber + \advance\count255 by -1 \advance\count255 by `A + \edef\enumeratemark{\noexpand\char\the\count255 }\else + \edef\enumeratemark{\enumeratenumber}\fi\fi\fi\fi + \edef\@currentlabel{\enumeratemark}% needed? + \llap{\enumeratemark.\enspace}\ignorespaces}} + +\def\endenumerate{\smallbreak\smallbreak\endgroup\par} + +% \path is like \verb except that its argument +% can break across lines at `.' and `/'. + +\ifx\path\UnDeFiNeD +\def\path{\begingroup\verbsetup + \pathfont + \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% + \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% + \verbQii}% +\fi + +\let\pathfont\relax +% + +% plain's \{left,center,right}line can't handle catcode change +% within their argument + +\def\leftline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \let\dummy=} + +\def\leftlinefinish{\hss\egroup} + +\def\centerline{\line\bgroup\bgroup + \aftergroup\leftlinefinish + \hss\let\dummy=} + +\def\rightline{\line\bgroup\hss\let\dummy=} + +% +% definitions (useful in reference manuals) + +\def\defun#1{\def\defuntype{#1}% +\medbreak +\line\bgroup + \hbox\bgroup + \aftergroup\enddefun + \vrule width .5ex \thinspace + \vrule \enspace + \vbox\bgroup\setbox0=\hbox{\defuntype}% + \advance\hsize-\wd0 + \advance\hsize-1em + \obeylines + \parindent=0pt + \aftergroup\egroup + \strut + \let\dummy=} + +\def\enddefun{\hfil\defuntype\egroup\smallskip} + +% + +%\def\hr{\smallskip\line{\leaders\hbox{~.~}\hfill}\smallskip} + +% + +\def\sidemargin{\afterassignment\sidemarginQadjustoffset + \hoffset} + +\def\sidemarginQadjustoffset{% + \advance\hoffset -1true in + \advance\hsize -2\hoffset} + +% don't let caps disable end-of-sentence spacing -- assumes we won't use +% dots after caps for abbrevs + +\def\nocapdot{% +\count255=`\A +\loop +\sfcode\the\count255=1000 +\ifnum\count255<`\Z +\advance\count255 by 1 +\repeat +} + +% " --> `` or '' + +\def\smartdoublequotes{% + \defcsactive\"{\futurelet\smartdoublequotesI + \smartdoublequotesII}% + \def\smartdoublequotesII{% + \ifcat\noexpand\smartdoublequotesI a``\else + \if\noexpand\smartdoublequotesI 0``\else + \if\noexpand\smartdoublequotesI 1``\else + \if\noexpand\smartdoublequotesI 2``\else + \if\noexpand\smartdoublequotesI 3``\else + \if\noexpand\smartdoublequotesI 4``\else + \if\noexpand\smartdoublequotesI 5``\else + \if\noexpand\smartdoublequotesI 6``\else + \if\noexpand\smartdoublequotesI 7``\else + \if\noexpand\smartdoublequotesI 8``\else + \if\noexpand\smartdoublequotesI 9``\else + ''\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi}% +} + +% + +\def\emailliketext{\nocapdot\smartdoublequotes} + +% + +\def\gobbleencl{\bgroup + \def\do##1{\catcode`##1=12 }\dospecials + \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 + \futurelet\gobbleenclQnext\gobbleenclQii} + +\def\gobbleenclQii{\ifx\gobbleenclQnext\bgroup + \let\gobbleenclQnext\gobblegroupQii + \else\let\gobbleenclQnext\gobbleenclQiii\fi + \gobbleenclQnext} + +\def\gobbleenclQiii#1{% + \def\gobbleenclQiv##1#1{\egroup}% + \gobbleenclQiv} + +% + +\let\strike\fiverm % can be much better! +% + +\ifx\InputIfFileExists\UnDeFiNeD +\def\InputIfFileExists#1#2#3{% + \IfFileExists{#1}{#2\input #1 }{#3}}% +\fi + +% \packindex declares that subitems be bundled into one +% semicolon-separated paragraph + +\def\packindex{% + \def\theindex{\begingroup + \parskip0pt \parindent0pt + \def\item{\par\hangindent20pt \hangafter1 }% + \def\subitem{\unskip; }% + \def\subsubitem{\unskip; }% + \def\see{\bgroup\it see \aftergroup\gobblegroup\let\dummy=}% + \let\indexspace\medskip}} + +% Use \printindex instead of \inputindex if you want +% the section heading ``Index'' automatically generated. + +\def\printindex{\csname beginsection\endcsname Index\par + \inputindex} + +\def\inputepsf{% +\ifx\pdfoutput\UnDeFiNeD + \input epsf +\else + \input supp-pdf + \def\epsfbox##1{\convertMPtoPDF{##1}{1}{1}}% +\fi +} + +\def\r#1{{\accent23 #1}} + +\def\verbc{\begingroup + \verbsetup\afterassignment\verbcI + \let\verbcII=} + +\def\verbcI{{\verbfont\verbcII}\endgroup} + +\let\E\verbc + +% The current font is cmtt iff fontdimen3 = 0 _and_ +% fontdimen7 != 0 + +\def\noncmttQspecific{\let\noncmttQspecificQdoit y% + \ifdim\the\fontdimen3\the\font=0.0pt + \ifdim\the\fontdimen7\the\font=0.0pt + \let\noncmttQspecificQdoit n\fi\fi + \ifx\noncmttQspecificQdoit y% + \defcsactive\<{\relax\char`\<}% + \defcsactive\>{\relax\char`\>}% + \defcsactive\-{\variablelengthhyphen}% + \fi} + +% In a nonmonospaced font, - followed by a letter +% is a regular hyphen. Followed by anything else, it is a +% typewriter hyphen. + +\def\variablelengthhyphen{\futurelet\variablelengthhyphenI + \variablelengthhyphenII} + +\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI + a-\else{\tt\char`\-}\fi} + +% uppercase version of \romannumeral + +\def\Romannumeral{\afterassignment\RomannumeralI\count255=} + +\def\RomannumeralI{\uppercase\expandafter{\romannumeral\the\count255 }} + +% \xrdef, as in Eplain + +\def\xrdef#1{\xrtag{#1}{\folio}} + +% + +\def\quote{\bgroup\narrower\smallbreak} +\def\endquote{\smallbreak\egroup} + + +\ifx\frac\UnDeFiNeD +\def\frac#1/#2{{#1\over#2}}% +\fi + +\ifx\bull\UnDeFiNeD +\def\bull{$\bullet$}% +\fi + +% \mailto{ADDRESS} becomes +% ADDRESS in HTML, and +% ADDRESS in DVI. + +\let\mailto\url + +\def\raggedleft{% + \leftskip 0pt plus 1fil + \parfillskip 0pt +} + +%\def\rawhtml{\errmessage{Can't occur outside +% \string\htmlonly}} +%\def\endrawhtml{\errmessage{Can't occur outside +% \string\htmlonly}} + +\let\rawhtml\iffalse +\let\endrawhtml\fi + +\let\htmlheadonly\iffalse +\let\endhtmlheadonly\fi + +\let\cssblock\iffalse +\let\endcssblock\fi + +\def\inputcss#1 {\relax} +\let\htmladdimg\gobblegroup + +\def\htmlref{\bgroup\aftergroup\gobblegroup\let\dummy=} + +% + +\let\htmlcolophon\gobblegroup +\let\htmldoctype\gobblegroup +\let\htmlmathstyle\gobblegroup + +\let\slatexlikecomments\relax +\let\noslatexlikecomments\relax + +\let\imgpreamble\iffalse +\let\endimgpreamble\fi + +\def\inputexternallabels#1 {\relax} +\def\includeexternallabels#1 {\relax} + +\ifx\eval\UnDeFiNeD +\IfFileExists{eval4tex.tex}{\input eval4tex }{}\fi + +\let\evalh\gobblegroup +\let\evalq\gobblegroup + +\let\htmlpagebreak\relax + +\let\htmlpagelabel\gobblegroup + +\def\htmlpageref{\errmessage{Can't occur except inside + \string\htmlonly}} + +% Miscellaneous stuff + +%\def\hr{$$\hbox{---}$$} +\def\hr{\medbreak\centerline{---}\medbreak} +%\def\hr{\par\centerline{$*$}\par} + + +\let\htmlimageformat\gobblegroup +\let\htmlimageconversionprogram\gobblegroup + +\let\externaltitle\gobblegroup +\let\ignorenextinputtimestamp\relax + +% + +\let\htmladvancedentities\relax +\let\n\noindent +\let\p\verb +\let\q\scm +\let\f\numberedfootnote +\let\scmp\scm +\let\numfootnote\numberedfootnote +\let\writetotoc\writenumberedtocline +\let\tag\xrtag +\let\scmfilename\verbwritefile +\let\scmwrite\verbwrite + +% + +\atcatcodebeforetexzpage + +% end of file diff --git a/collects/web-server/info.ss b/collects/web-server/info.ss index 97d5076bce..3992ca5f84 100644 --- a/collects/web-server/info.ss +++ b/collects/web-server/info.ss @@ -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")) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index f60d0b79f3..24eedf89c4 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -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} diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index d033fc934a..f27c57b7b6 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -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] diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 71c477963a..5462977929 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -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; diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c index 19e7a1130f..02b69091ad 100644 --- a/src/mzscheme/gc2/sighand.c +++ b/src/mzscheme/gc2/sighand.c @@ -18,6 +18,11 @@ #include #include +#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(); } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 446d809fe4..0b0ed9010a 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -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);