diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index c024cb9d13..116b3df357 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -835,8 +835,8 @@ ;; So we can ignore them: strlen cos sin exp pow log sqrt atan2 - isnan isinf fpclass _fpclass _isnan __isfinited __isnanl - __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand + isnan isinf fpclass _fpclass _isnan __isfinited __isnanl __isnan + __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf floor ceil round fmod fabs __maskrune _errno __errno isalpha isdigit isspace tolower toupper fread fwrite socket fcntl setsockopt connect send recv close diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 99dc0a430e..a203326d93 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1435,29 +1435,7 @@ (send evt get-x) (send evt get-y))]) (send delegate-frame click-in-overview - (send text find-position editor-x editor-y)))] - [(or (send evt entering?) - (send evt moving?)) - (when (send evt entering?) - (send delegate-frame open-status-line 'plt:delegate)) - (let-values ([(editor-x editor-y) - (send text dc-location-to-editor-location - (send evt get-x) - (send evt get-y))]) - (let* ([b (box #f)] - [pos (send text find-position editor-x editor-y #f b)]) - (cond - [(unbox b) - (let* ([para (send text position-paragraph pos)] - [start-pos (send text paragraph-start-position para)] - [end-pos (send text paragraph-end-position para)]) - (send delegate-frame update-status-line 'plt:delegate - (at-most-200 (send text get-text start-pos end-pos))))] - [else - (send delegate-frame update-status-line 'plt:delegate #f)])))] - [(send evt leaving?) - (send delegate-frame update-status-line 'plt:delegate #f) - (send delegate-frame close-status-line 'plt:delegate)]))))) + (send text find-position editor-x editor-y)))]))))) (super-new))) (define (at-most-200 s) @@ -1933,6 +1911,11 @@ (λ (text evt) (send (send text get-top-level-window) search 'forward))) +(send search/replace-keymap map-function "s:return" "prev") +(send search/replace-keymap add-function "prev" + (λ (text evt) + (send (send text get-top-level-window) search 'backward))) + (send search/replace-keymap map-function "c:return" "insert-return") (send search/replace-keymap map-function "a:return" "insert-return") (send search/replace-keymap add-function "insert-return" diff --git a/collects/games/chat-noir/chat-noir-module.ss b/collects/games/chat-noir/chat-noir-module.ss new file mode 100644 index 0000000000..b9b57bdd27 --- /dev/null +++ b/collects/games/chat-noir/chat-noir-module.ss @@ -0,0 +1,5 @@ +(module chat-noir-module lang/htdp-intermediate-lambda + (require (lib "world.ss" "htdp")) + (require "hash.ss") + (require (lib "include.ss" "scheme")) + (include "chat-noir.ss")) diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss new file mode 100644 index 0000000000..5b16026954 --- /dev/null +++ b/collects/games/chat-noir/chat-noir-unit.ss @@ -0,0 +1,18 @@ +#lang scheme/base +(require scheme/unit + scheme/runtime-path + (prefix-in x: lang/htdp-intermediate-lambda) + (prefix-in x: htdp/world)) + +(provide game@) +(define orig-namespace (current-namespace)) +(define-runtime-path chat-noir "chat-noir-module.ss") + +(define-unit game@ + (import) + (export) + (define ns (make-base-namespace)) + (parameterize ([current-namespace ns]) + (namespace-attach-module orig-namespace '(lib "mred.ss" "mred")) + (namespace-attach-module orig-namespace '(lib "class.ss" "scheme")) + (dynamic-require chat-noir #f))) diff --git a/collects/games/chat-noir/chat-noir.png b/collects/games/chat-noir/chat-noir.png new file mode 100644 index 0000000000..cb5d82358c Binary files /dev/null and b/collects/games/chat-noir/chat-noir.png differ diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss new file mode 100644 index 0000000000..9f40276a1d --- /dev/null +++ b/collects/games/chat-noir/chat-noir.ss @@ -0,0 +1,1011 @@ +#| + +Hint: include the size of the board in your world structure +This enables you to make test cases with different size boards, +making some of the test cases much easier to manage. + +|# + +(define circle-radius 20) +(define circle-spacing 22) + +;; a world is: +;; (make-world board posn state number) +(define-struct world (board cat state size)) + +;; a state is either: +;; - 'playing +;; - 'cat-won +;; - 'cat-lost + +;; a board is +;; (listof cell) + +;; a cell is +;; (make-cell (make-posn int[0-board-size] +;; int[0-board-size]) +;; boolean) +(define-struct cell (p blocked?)) + + +; +; +; +; +; +; ;; ;;;; +; ;;;; ;;;;; +; ;;; ; +; ;;; ;;; ; ;;;; ;;;; ;;;;;; ;; ;;;; ;;;;;; ;; ;;;; ;;; +; ;;;;;;;;;;;;;; ;;;; ;;;;;;;;; ;; ;; ; ;;;;; ;;; ;;;; ;;;;;;; +; ;;;;;;;;; ;;; ;;;;;;;;;;;;;;; ;;; ;; ;; ;;; ;;; ;;;; ; ;;;; +; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;; ;;; ;; ;;; +; ;; ;;;; ;;; ;; ;;;; ;;; ;;;; ;;; ;;; ;;; ;;; ;;;;;;; +; ;;;;;;;; ;;; ;;;;;;;;;; ;;; ;; ;;;;; ;;;; ;;; ;;; ;;; +; ;;;;;;;;;;;;;;;; ;;;;;;;;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; ;;;; ;;; +; ;;;;; ;;;; ;;;; ;;;;; ;;; +; ;;;;;;; ;;; +; ;;;;;; +; + + +;; world->image : world -> image +(define (world->image w) + (chop-whiskers + (overlay (board->image (world-board w) (world-size w)) + (move-pinhole + (cond + [(equal? (world-state w) 'cat-won) happy-cat] + [(equal? (world-state w) 'cat-lost) sad-cat] + [else thinking-cat]) + (- (cell-center-x (world-cat w))) + (- (cell-center-y (world-cat w))))))) + +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'playing + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole thinking-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-won + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole happy-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-lost + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + +;; chop-whiskers : image -> image +;; crops the image so that anything above or to the left of the pinhole is gone +(define (chop-whiskers img) + (shrink img + 0 + 0 + (- (image-width img) (pinhole-x img) 1) + (- (image-height img) (pinhole-y img) 1))) +(check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) +(check-expect (chop-whiskers (rectangle 6 6 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + +(check-expect + (pinhole-x + (world->image + (make-world + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false)) + (make-posn 0 0) + 'playing + 2))) + 0) +(check-expect + (pinhole-x + (world->image + (make-world + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false)) + (make-posn 0 1) + 'playing + 2))) + 0) + + +;; board->image : board number -> image +(define (board->image cs world-size) + (foldl overlay + (nw:rectangle (world-width world-size) + (world-height world-size) + 'outline + 'black) + (map cell->image cs))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3) + (overlay + (cell->image + (make-cell (make-posn 0 0) false)) + (nw:rectangle (world-width 3) + (world-height 3) + 'outline + 'black))) + + +;; cell->image : cell -> image +(define (cell->image c) + (local [(define x (cell-center-x (cell-p c))) + (define y (cell-center-y (cell-p c)))] + (move-pinhole + (cond + [(cell-blocked? c) + (circle circle-radius 'solid 'black)] + [else + (circle circle-radius 'solid 'lightblue)]) + (- x) + (- y)))) + +(check-expect (cell->image (make-cell (make-posn 0 0) false)) + (move-pinhole (circle circle-radius 'solid 'lightblue) + (- circle-radius) + (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) true)) + (move-pinhole (circle circle-radius 'solid 'black) + (- circle-radius) + (- circle-radius))) + +;; world-width : number -> number +;; computes the width of the drawn world in terms of its size +(define (world-width board-size) + (local [(define rightmost-posn + (make-posn (- board-size 1) (- board-size 2)))] + (+ (cell-center-x rightmost-posn) circle-radius))) +(check-expect (world-width 3) 150) + +;; world-height : number -> number +;; computes the height of the drawn world in terms of its size +(define (world-height board-size) + (local [(define bottommost-posn + (make-posn (- board-size 1) (- board-size 1)))] + (+ (cell-center-y bottommost-posn) circle-radius))) +(check-expect (world-height 3) 116.208) + + +;; cell-center : cell -> number +(define (cell-center-x p) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (+ circle-radius + (* x circle-spacing 2) + (if (odd? y) + circle-spacing + 0)))) + +(check-expect (cell-center-x (make-posn 0 0)) + circle-radius) +(check-expect (cell-center-x (make-posn 0 1)) + (+ circle-spacing circle-radius)) +(check-expect (cell-center-x (make-posn 1 0)) + (+ (* 2 circle-spacing) circle-radius)) +(check-expect (cell-center-x (make-posn 1 1)) + (+ (* 3 circle-spacing) circle-radius)) + +;; cell-center-y : cell -> number +(define (cell-center-y p) + (local [(define y (posn-y p))] + (+ circle-radius + (* y circle-spacing 2 + .866 ;; .866 is an exact approximate to sin(pi/3) + )))) + +(check-expect (cell-center-y (make-posn 1 1)) + (+ circle-radius (* 2 circle-spacing .866))) +(check-expect (cell-center-y (make-posn 1 0)) + circle-radius) + + +; +; +; +; +; +; ;;;;; +; ;;;; +; ;;; +; ;;;; ;;; ; ;;;; ;;;; ;; ; ;;;; ;;; ; +; ;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;; ;;; +; ; ;;;; ;;; ;;;;;;;;;;;;;;; ;; ;; ;;; ;;;; +; ;; ;;; ;;; ;;;; ;;; ;;; ; ;; ;;;; ;;; +; ;;;;;;; ;;; ;; ;;;; ; ;;; ;;; ;;; +; ;;; ;;; ;;;;;;;;;; ;;;;;;; ;; ;;; +; ;;;; ;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ;; ;;; +; ;;;;; ;;; ;;;;; ;; ;;;; ;;; +; ;;;; ;;; ;; ;; +; ;;;;;; ; +; + +;; a distance-map is +;; (listof dist-cells) + +;; a dist-cell is +;; - (make-dist-cell posn number) +(define-struct dist-cell (p n)) + +;; build-table/fast : world -> distance-map +(define (build-table/fast world) + (local [(define board-size (world-size world)) + (define blocked (make-hash)) + (define ht (make-hash)) + (define (search p) + (cond + [(hash-ref blocked p) + '∞] + [(on-boundary? p board-size) + ((lambda (a b) b) + (hash-set! ht p 0) + 0)] + [(not (boolean? (hash-ref ht p #f))) + (hash-ref ht p)] + [else + ((lambda (a b c) c) + (hash-set! ht p '∞) + (hash-set! + ht + p + (add1/f (min-l (map search + (adjacent p board-size))))) + (hash-ref ht p))]))] + ((lambda (a b c) c) + (for-each (lambda (cell) + (hash-set! blocked + (cell-p cell) + (cell-blocked? cell))) + (world-board world)) + (search (world-cat world)) + (hash-map ht make-dist-cell)))) + +;; build-table : world -> distance-map +(define (build-table world) + (build-distance (world-board world) + (world-cat world) + '() + '() + (world-size world))) + +;; build-distance : board posn table (listof posn) number -> distance-map +(define (build-distance board p t visited board-size) + (cond + [(cell-blocked? (lookup-board board p)) + (add-to-table p '∞ t)] + [(on-boundary? p board-size) + (add-to-table p 0 t)] + [(in-table? t p) + t] + [(member p visited) + (add-to-table p '∞ t)] + [else + (local [(define neighbors (adjacent p board-size)) + (define neighbors-t (build-distances + board + neighbors + t + (cons p visited) + board-size))] + (add-to-table p + (add1/f + (min-l + (map (lambda (neighbor) + (lookup-in-table neighbors-t neighbor)) + neighbors))) + neighbors-t))])) + +;; build-distances : board (listof posn) distance-map (listof posn) number +;; -> distance-map +(define (build-distances board ps t visited board-size) + (cond + [(empty? ps) t] + [else + (build-distances board + (rest ps) + (build-distance board (first ps) t visited board-size) + visited + board-size)])) + +(check-expect (build-distance (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) + '() + '() + 1) + (list (make-dist-cell (make-posn 0 0) 0))) + +(check-expect (build-distance (list (make-cell (make-posn 0 0) true)) + (make-posn 0 0) + '() + '() + 1) + (list (make-dist-cell (make-posn 0 0) '∞))) + +(check-expect (build-distance (list (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + '() + '() + 3) + (list (make-dist-cell (make-posn 1 0) 0) + (make-dist-cell (make-posn 2 0) 0) + (make-dist-cell (make-posn 0 1) 0) + (make-dist-cell (make-posn 2 1) 0) + (make-dist-cell (make-posn 1 2) 0) + (make-dist-cell (make-posn 2 2) 0) + (make-dist-cell (make-posn 1 1) 1))) + +(check-expect (build-distance (list (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + '() + '() + 3) + (list (make-dist-cell (make-posn 1 0) '∞) + (make-dist-cell (make-posn 2 0) '∞) + (make-dist-cell (make-posn 0 1) '∞) + (make-dist-cell (make-posn 2 1) '∞) + (make-dist-cell (make-posn 1 2) '∞) + (make-dist-cell (make-posn 2 2) '∞) + (make-dist-cell (make-posn 1 1) '∞))) + +(check-expect (build-distance + (append-all + (build-list + 5 + (lambda (i) + (build-list + 5 + (lambda (j) + (make-cell (make-posn i j) false)))))) + (make-posn 2 2) + '() + '() + 5) + (list (make-dist-cell (make-posn 1 0) 0) + (make-dist-cell (make-posn 2 0) 0) + (make-dist-cell (make-posn 0 1) 0) + (make-dist-cell (make-posn 3 0) 0) + (make-dist-cell (make-posn 1 1) 1) + (make-dist-cell (make-posn 4 0) 0) + (make-dist-cell (make-posn 2 1) 1) + (make-dist-cell (make-posn 4 1) 0) + (make-dist-cell (make-posn 3 1) 1) + (make-dist-cell (make-posn 2 2) 2) + (make-dist-cell (make-posn 4 2) 0) + (make-dist-cell (make-posn 3 2) 1) + (make-dist-cell (make-posn 0 2) 0) + (make-dist-cell (make-posn 0 3) 0) + (make-dist-cell (make-posn 1 3) 1) + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 3) 1) + (make-dist-cell (make-posn 1 4) 0) + (make-dist-cell (make-posn 2 4) 0) + (make-dist-cell (make-posn 4 3) 0) + (make-dist-cell (make-posn 3 4) 0) + (make-dist-cell (make-posn 4 4) 0) + (make-dist-cell (make-posn 3 3) 1))) + + +;; lookup-board : board posn -> cell-or-false +(define (lookup-board board p) + (cond + [(empty? board) (error 'lookup-board "did not find posn")] + [else + (cond + [(equal? (cell-p (first board)) p) + (first board)] + [else + (lookup-board (rest board) p)])])) + +(check-expect (lookup-board (list (make-cell (make-posn 2 2) false)) + (make-posn 2 2)) + (make-cell (make-posn 2 2) false)) +(check-error (lookup-board '() (make-posn 0 0)) + "lookup-board: did not find posn") + +;; add-to-table : posn number table -> table +(define (add-to-table p n t) + (cond + [(empty? t) (list (make-dist-cell p n))] + [else + (cond + [(equal? p (dist-cell-p (first t))) + (cons (make-dist-cell p (min/f (dist-cell-n (first t)) n)) + (rest t))] + [else + (cons (first t) (add-to-table p n (rest t)))])])) + +(check-expect (add-to-table (make-posn 1 2) 3 '()) + (list (make-dist-cell (make-posn 1 2) 3))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 1 2) 4))) + (list (make-dist-cell (make-posn 1 2) 3))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 1 2) 2))) + (list (make-dist-cell (make-posn 1 2) 2))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 2 2) 2))) + (list (make-dist-cell (make-posn 2 2) 2) + (make-dist-cell (make-posn 1 2) 3))) + +;; in-table : table posn -> boolean +(define (in-table? t p) (number? (lookup-in-table t p))) + +(check-expect (in-table? empty (make-posn 1 2)) false) +(check-expect (in-table? (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + true) +(check-expect (in-table? (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + false) + +;; lookup-in-table : table posn -> number or '∞ +;; looks for the distance as recorded in the table t, +;; if not found returns a distance of '∞ +(define (lookup-in-table t p) + (cond + [(empty? t) '∞] + [else (cond + [(equal? p (dist-cell-p (first t))) + (dist-cell-n (first t))] + [else + (lookup-in-table (rest t) p)])])) + +(check-expect (lookup-in-table empty (make-posn 1 2)) '∞) +(check-expect (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + 3) +(check-expect (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + '∞) + +;; on-boundary? : posn number -> boolean +(define (on-boundary? p board-size) + (or (= (posn-x p) 0) + (= (posn-y p) 0) + (= (posn-x p) (- board-size 1)) + (= (posn-y p) (- board-size 1)))) + +(check-expect (on-boundary? (make-posn 0 1) 13) true) +(check-expect (on-boundary? (make-posn 1 0) 13) true) +(check-expect (on-boundary? (make-posn 12 1) 13) true) +(check-expect (on-boundary? (make-posn 1 12) 13) true) +(check-expect (on-boundary? (make-posn 1 1) 13) false) +(check-expect (on-boundary? (make-posn 10 10) 13) false) + +;; adjacent : posn number -> (listof posn) +(define (adjacent p board-size) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (filter (lambda (x) (in-bounds? x board-size)) + (cond + [(even? y) + (list (make-posn (- x 1) (- y 1)) + (make-posn x (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn (- x 1) (+ y 1)) + (make-posn x (+ y 1)))] + [else + (list (make-posn x (- y 1)) + (make-posn (+ x 1) (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn x (+ y 1)) + (make-posn (+ x 1) (+ y 1)))])))) + +(check-expect (adjacent (make-posn 1 1) 11) + (list (make-posn 1 0) + (make-posn 2 0) + (make-posn 0 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 2 2))) +(check-expect (adjacent (make-posn 2 2) 11) + (list (make-posn 1 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 3 2) + (make-posn 1 3) + (make-posn 2 3))) + +;; in-bounds? : posn number -> boolean +(define (in-bounds? p board-size) + (and (<= 0 (posn-x p) (- board-size 1)) + (<= 0 (posn-y p) (- board-size 1)) + (not (equal? p (make-posn 0 0))) + (not (equal? p (make-posn 0 (- board-size 1)))))) +(check-expect (in-bounds? (make-posn 0 0) 11) false) +(check-expect (in-bounds? (make-posn 0 1) 11) true) +(check-expect (in-bounds? (make-posn 1 0) 11) true) +(check-expect (in-bounds? (make-posn 10 10) 11) true) +(check-expect (in-bounds? (make-posn 0 -1) 11) false) +(check-expect (in-bounds? (make-posn -1 0) 11) false) +(check-expect (in-bounds? (make-posn 0 11) 11) false) +(check-expect (in-bounds? (make-posn 11 0) 11) false) +(check-expect (in-bounds? (make-posn 10 0) 11) true) +(check-expect (in-bounds? (make-posn 0 10) 11) false) + +;; min-l : (listof number-or-symbol) -> number-or-symbol +(define (min-l ls) (foldr (lambda (x y) (min/f x y)) '∞ ls)) +(check-expect (min-l (list)) '∞) +(check-expect (min-l (list 10 1 12)) 1) + +;; <=/f : (number or '∞) (number or '∞) -> (number or '∞) +(define (<=/f a b) (equal? a (min/f a b))) +(check-expect (<=/f 1 2) true) +(check-expect (<=/f 2 1) false) +(check-expect (<=/f '∞ 1) false) +(check-expect (<=/f 1 '∞) true) +(check-expect (<=/f '∞ '∞) true) + +;; min/f : (number or '∞) (number or '∞) -> (number or '∞) +(define (min/f x y) + (cond + [(equal? x '∞) y] + [(equal? y '∞) x] + [else (min x y)])) +(check-expect (min/f '∞ 1) 1) +(check-expect (min/f 1 '∞) 1) +(check-expect (min/f '∞ '∞) '∞) +(check-expect (min/f 1 2) 1) + +;; add1/f : number or '∞ -> number or '∞ +(define (add1/f n) + (cond + [(equal? n '∞) '∞] + [else (add1 n)])) +(check-expect (add1/f 1) 2) +(check-expect (add1/f '∞) '∞) + +; +; +; +; +; +; ;;;;; ;;;; ;;;;;; +; ;;; ;;;;; ;;;; +; ;;; ;;; +; ;;;;;; ;;; ; ;;;;;; ;;; ;;;; +; ;;; ;;;; ;;; ;;;;; ;;; ;;;; ;;; ;;;;;; +; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;;;; +; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;; +; ;;; ;; ;;; ;;; ;;;;;; +; ;;; ; ;;; ;;;; ;;; ; ;; ;; +; ;;; ; ;;;; ;;;;;;;;;; ; ;;;;; ;;;; +; ;;;; ;;;; +; +; +; + + +(define (clack world x y evt) + (cond + [(equal? evt 'button-up) + (cond + [(equal? 'playing (world-state world)) + (move-cat + (make-world (add-obstacle (world-board world) x y) + (world-cat world) + (world-state world) + (world-size world)))] + [else + world])] + [else + world])) + +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1) + 10 + 10 + 'button-down) + (make-world '() (make-posn 0 0) 'playing 1)) +(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1) + 10 + 10 + 'button-up) + (make-world '() (make-posn 0 0) 'cat-lost 1)) +(check-expect (clack + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'playing + 3) + 10 10 'button-up) + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3)) + +;; move-cat : board -> board +(define (move-cat world) + (local [(define cat-position (world-cat world)) + (define table (build-table/fast world)) + (define neighbors (adjacent cat-position (world-size world))) + (define next-cat-position + (find-best-position (first neighbors) + (lookup-in-table table (first neighbors)) + (rest neighbors) + (map (lambda (p) (lookup-in-table table p)) + (rest neighbors))))] + (make-world (world-board world) + (cond + [(boolean? next-cat-position) + cat-position] + [else next-cat-position]) + (cond + [(boolean? next-cat-position) + 'cat-lost] + [(on-boundary? next-cat-position (world-size world)) + 'cat-won] + [else 'playing]) + (world-size world)))) + +(check-expect + (move-cat + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 2) + 'playing + 5)) + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 3) + 'playing + 5)) + +;; find-best-position : (nelistof posn) (nelistof number or '∞) +;; -> posn or #f +;; returns #f if there is no non-infinite move, otherwise returns +;; the next step for the cat. +(define (find-best-position best-posn score rest-posns scores) + (cond + [(empty? rest-posns) + (cond + [(equal? score '∞) + false] + [else + best-posn])] + [else (cond + [(<=/f score (first scores)) + (find-best-position best-posn + score + (rest rest-posns) + (rest scores))] + [else + (find-best-position (first rest-posns) + (first scores) + (rest rest-posns) + (rest scores))])])) + +(check-expect (find-best-position (make-posn 1 1) + 1 + (list (make-posn 2 2)) + (list 2)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list) + (list)) + (make-posn 2 2)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list (make-posn 1 1)) + (list 1)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + '∞ + (list (make-posn 1 1)) + (list 1)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list (make-posn 1 1)) + (list '∞)) + (make-posn 2 2)) + +;; add-obstacle : board number number -> board +(define (add-obstacle board x y) + (cond + [(empty? board) board] + [else + (local [(define cell (first board)) + (define cx (cell-center-x (cell-p cell))) + (define cy (cell-center-y (cell-p cell)))] + (cond + [(and (<= (- cx circle-radius) x (+ cx circle-radius)) + (<= (- cy circle-radius) y (+ cy circle-radius))) + (cons (make-cell (cell-p cell) true) + (rest board))] + [else + (cons cell (add-obstacle (rest board) x y))]))])) + +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true))) +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) + (list (make-cell (make-posn 0 0) false))) +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true) + (make-cell (make-posn 0 1) false))) + + +; +; +; +; +; +; ;;;; +; ;;; +; ;;; ; +; ;;;;;; ;;;; ;;;;;;;;;;; +; ;;; ;;;; ;;;;;;;;; ;;; ;; +; ;;; ;;;;;;;;;;;;;;; ;;; +; ;;; ;;;;;;; ;;; ;;; ;;;; +; ;;; ;; ;;;; ;;; ;;;;; +; ;;; ; ;;;;;;;;;; ;;; ;;;; +; ;;; ; ;;;;;;;;;;; ;;; ;; +; ;;;; ;;;;; ;;;;; +; +; +; + + +;; cat : symbol -> image +(define (cat mode) + (local [(define face-color + (cond + [(symbol=? mode 'sad) 'pink] + [else 'lightgray])) + + (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) + (define right-ear (regular-polygon 3 8 'solid 'black 0)) + (define ear-x-offset 14) + (define ear-y-offset 9) + + (define eye (overlay (ellipse 12 8 'solid 'black) + (ellipse 6 4 'solid 'limegreen))) + (define eye-x-offset 8) + (define eye-y-offset 3) + + (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) + + (define mouth-happy + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline 'black) + (move-pinhole + (rectangle 10 5 'solid face-color) + 0 + 4))) + (define mouth-no-expression + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline face-color) + (rectangle 10 5 'solid face-color))) + + (define mouth + (cond + [(symbol=? mode 'happy) mouth-happy] + [else mouth-no-expression])) + (define mouth-x-offset 4) + (define mouth-y-offset -5)] + + (add-line + (add-line + (add-line + (add-line + (add-line + (add-line + (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) + (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) + (ellipse 40 26 'solid 'black) + (ellipse 36 22 'solid face-color) + (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) + (move-pinhole mouth mouth-x-offset mouth-y-offset) + (move-pinhole eye (- eye-x-offset) eye-y-offset) + (move-pinhole eye eye-x-offset eye-y-offset) + (move-pinhole nose -1 -4)) + 6 4 30 12 'black) + 6 4 30 4 'black) + 6 4 30 -4 'black) + -6 4 -30 12 'black) + -6 4 -30 4 'black) + -6 4 -30 -4 'black))) + +(define happy-cat (cat 'happy)) +(define sad-cat (cat 'sad)) +(define thinking-cat (cat 'thinking)) + + +; +; +; +; +; +; ;;;; ;;;; ;;;; ;;;; ;;;;; +; ;;;;; ;;;;; ;;; ;;;;; ;;; +; ;;; ; ;;; +; ;;;;;; ;; ; ;;;;;;;;; ; ;;;; ;; ;;; +; ;;;;; ;;; ;;;; ;;;;; ;;; ;;;;;;; ;;;;;;;;; ;;; +; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; +; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;; +; ;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;;;; ;;; +; ;;;;;;;;;; ;;; ;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;; +; ;;;; ;;;;; ;;;;; +; ;;; +; +; +; +; +; +; +; +; ;;;;; ;; +; ;;;; ;;;; +; ;;; ;;; +; ;;; ;;; ;;;;; ;;;; ;; ; ;;;; ;;; ;;; +; ;;;;;;;; ;;;;;;; ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;;;;;;;; +; ;;; ;; ;; ; ;;; ;;; ;;; ;;;; ;;; ;;; +; ;;; ;; ; ;; ;; ;;;; ;;; ;; ;;;; +; ;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;; +; ;;;;;;; ;;;;;; ;;;;;;;;;;;;;;;;;; ;;;;;;;;; +; ;;;; ;;;;; +; +; +; + +;; append-all : (listof (list X)) -> (listof X) +(define (append-all ls) + (foldr append empty ls)) + +(check-expect (append-all empty) empty) +(check-expect (append-all (list (list 1 2 3))) (list 1 2 3)) +(check-expect (append-all (list (list 1) (list 2) (list 3))) + (list 1 2 3)) + +(define dummy + (local + [(define board-size 11) + (define initial-board + (filter + (lambda (c) + (not (and (= 0 (posn-x (cell-p c))) + (or (= 0 (posn-y (cell-p c))) + (= (- board-size 1) + (posn-y (cell-p c))))))) + (append-all + (build-list + board-size + (lambda (i) + (build-list + board-size + (lambda (j) + (let ([cat-cell? (and (= i (quotient board-size 2)) + (= j (quotient board-size 2)))]) + (make-cell (make-posn i j) + (and (not cat-cell?) + (zero? (random 30)))))))))))) + (define initial-world + (make-world initial-board + (make-posn (quotient board-size 2) + (quotient board-size 2)) + 'playing + board-size))] + + (and + + ;; illustrates the speedup for state-based dfs + ;((lambda (x) true) (time (build-table initial-world))) + ;((lambda (x) true) (time (build-table/fast initial-world))) + + (big-bang (world-width board-size) + (world-height board-size) + 1 + initial-world) + (on-redraw world->image) + (on-mouse-event clack)))) diff --git a/collects/games/chat-noir/hash.ss b/collects/games/chat-noir/hash.ss new file mode 100644 index 0000000000..8903bb9415 --- /dev/null +++ b/collects/games/chat-noir/hash.ss @@ -0,0 +1,2 @@ +#lang scheme/base +(provide make-hash hash-set! hash-ref hash-map) diff --git a/collects/games/chat-noir/info.ss b/collects/games/chat-noir/info.ss new file mode 100644 index 0000000000..3e6104bd42 --- /dev/null +++ b/collects/games/chat-noir/info.ss @@ -0,0 +1,6 @@ +#lang setup/infotab + +(define game "chat-noir-unit.ss") +(define game-set "Puzzle Games") +(define compile-omit-files '("chat-noir.ss")) +(define name "Chat Noir") \ No newline at end of file diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl new file mode 100644 index 0000000000..15c4ce7e44 --- /dev/null +++ b/collects/games/scribblings/chat-noir.scrbl @@ -0,0 +1,59 @@ +#lang scribble/doc +@(require "common.ss") +@(require scheme/runtime-path (for-syntax scheme/port scheme/base)) +@(define-runtime-path cn "../chat-noir/chat-noir.ss") + +@gametitle["Chat Noir" "chat-noir" "Puzzle Game"] + +The goal of the game is to stop the cat from escaping the board. Each +turn you click on a circle, which prevents the cat from stepping on +that space, and the cat responds by taking a step. If the cat is +completely boxed in and thus unable reach the border, you win. If the +cat does reach the border, you lose. + +The game was inspired by this one the one at +@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design} +and has essentailly the same rules. + +This game is written in the +@link["http://www.htdp.org/"]{How to Design Programs} +Intermediate language. It is a model solution to the final project for +the introductory programming course at the University of Chicago in +the fall of 2008, as below. + +@(define-syntax (m stx) + (syntax-case stx () + [(_) + (call-with-input-file (build-path (current-load-relative-directory) + 'up + "chat-noir" + "chat-noir.ss") + (lambda (port) + (port-count-lines! port) + #`(schemeblock + #,@ + (let loop () + (let* ([p (peeking-input-port port)] + [l (read-line p)]) + (cond + [(eof-object? l) '()] + [(regexp-match #rx"^[ \t]*$" l) + (read-line port) + (loop)] + [(regexp-match #rx"^ *;+" l) + => + (lambda (m) + (let-values ([(line col pos) (port-next-location port)]) + (read-line port) + (let-values ([(line2 col2 pos2) (port-next-location port)]) + (cons (datum->syntax + #f + `(code:comment ,(regexp-replace* #rx" " l "\u00a0")) + (list "chat-noir.ss" line col pos (- pos2 pos))) + (loop)))))] + [else + (cons (read-syntax "chat-noir.ss" port) + (loop))]))))) + #:mode 'text)])) + +@m[] diff --git a/collects/games/scribblings/std-games.scrbl b/collects/games/scribblings/std-games.scrbl index 9750d425c1..e0a881e935 100644 --- a/collects/games/scribblings/std-games.scrbl +++ b/collects/games/scribblings/std-games.scrbl @@ -22,4 +22,5 @@ @include-section["jewel.scrbl"] @include-section["parcheesi.scrbl"] @include-section["checkers.scrbl"] +@include-section["chat-noir.scrbl"] @include-section["gcalc.scrbl"] diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index daa3bea1c5..e79d2d6d38 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -918,9 +918,11 @@ Matthew (define m (mouse-event->symbol e)) (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) (with-handlers ([exn:break? break-handler][exn? exn-handler]) - (set! the-world (f the-world x y m)) - (add-event MOUSE x y m) - (redraw-callback))))))) + (let ([new-world (f the-world x y m)]) + (unless (eq? new-world the-world) + (set! the-world new-world) + (add-event MOUSE x y m) + (redraw-callback))))))))) ;; MouseEvent -> MouseEventType (define (mouse-event->symbol e) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 78ecc63e33..82004b4038 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -524,6 +524,9 @@ keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] + #; + ;; FIXME: disable context for now, re-enable when it is possible + ;; to have the context search the teachpack manual too. [(drscheme:help-context-term) (let* ([m (get-module)] [m (and m (pair? m) (pair? (cdr m)) (cadr m))] diff --git a/collects/mred/private/path-dialog.ss b/collects/mred/private/path-dialog.ss index 336c201c72..464eedc840 100644 --- a/collects/mred/private/path-dialog.ss +++ b/collects/mred/private/path-dialog.ss @@ -40,7 +40,8 @@ (apply simplify-path (regexp-replace* #rx"/" (if (path? p) (path->string p) p) "\\\\") more)) - (compose simplify-path expand-path*))) + (lambda (p . more) + (apply simplify-path (expand-path* p) more)))) (define directory-exists*? (compose directory-exists? expand-path*)) (define file-exists*? (compose file-exists? expand-path*)) diff --git a/collects/mrlib/scribblings/hierlist/list.scrbl b/collects/mrlib/scribblings/hierlist/list.scrbl index 0988b3a7f9..de9b6b0a3e 100644 --- a/collects/mrlib/scribblings/hierlist/list.scrbl +++ b/collects/mrlib/scribblings/hierlist/list.scrbl @@ -19,8 +19,8 @@ Creates a hierarchical-list control. Creates the control.} -@defmethod[(selected) (or/c (is-a?/c hierarchical-list-item<%>) - false/c)]{ +@defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>) + false/c)]{ Returns the currently selected item, if any.} diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index ba49128b32..be4163e98b 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -467,14 +467,26 @@ ;; Creates a simple function type that can be used for callouts and callbacks, ;; optionally applying a wrapper function to modify the result primitive ;; (callouts) or the input procedure (callbacks). -(define* (_cprocedure itypes otype [abi #f] [wrapper #f]) - (if wrapper +(define* (_cprocedure itypes otype + #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f]) + (_cprocedure* itypes otype abi wrapper keep)) + +;; for internal use +(define held-callbacks (make-weak-hasheq)) +(define (_cprocedure* itypes otype abi wrapper keep) + (define-syntax-rule (make-it wrap) (make-ctype _fpointer - (lambda (x) (ffi-callback (wrapper x) itypes otype abi)) - (lambda (x) (wrapper (ffi-call x itypes otype abi)))) - (make-ctype _fpointer - (lambda (x) (ffi-callback x itypes otype abi)) - (lambda (x) (ffi-call x itypes otype abi))))) + (lambda (x) + (let ([cb (ffi-callback (wrap x) itypes otype abi)]) + (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] + [(box? keep) + (let ([x (unbox keep)]) + (set-box! keep + (if (or (null? x) (pair? x)) (cons cb x) cb)))] + [(procedure? keep) (keep cb)]) + cb)) + (lambda (x) (wrap (ffi-call x itypes otype abi))))) + (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: ;; (_fun [{(name ... [. name]) | name} [-> expr] ::] @@ -500,6 +512,7 @@ (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define xs #f) (define abi #f) + (define keep #f) (define inputs #f) (define output #f) (define bind '()) @@ -557,15 +570,16 @@ ;; parse keywords (let loop () (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) - (when (keyword? k) + (define-syntax-rule (kwds [key var] ...) (case k - [(#:abi) (if abi - (err "got a second #:abi keyword" (car xs)) - (begin (set! abi (cadr xs)) - (set! xs (cddr xs)) - (loop)))] - [else (err "unknown keyword" (car xs))])))) - (unless abi (set! abi #'#f)) + [(key) (if var + (err (format "got a second ~s keyword") 'key (car xs)) + (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] + ... + [else (err "unknown keyword" (car xs))])) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep])))) + (unless abi (set! abi #'#f)) + (unless keep (set! keep #'#t)) ;; parse known punctuation (set! xs (map (lambda (x) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) @@ -655,9 +669,10 @@ body 'inferred-name (string->symbol (string-append "ffi-wrapper:" n))) body))]) - #`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi - (lambda (ffi) #,body))) - #`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi))) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi (lambda (ffi) #,body) #,keep)) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi #f #,keep))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) @@ -961,7 +976,7 @@ (define-struct cvector (ptr type length)) -(provide* cvector? cvector-length cvector-type +(provide* cvector? cvector-length cvector-type cvector-ptr ;; make-cvector* is a dangerous operation (unsafe (rename-out [make-cvector make-cvector*]))) @@ -1264,10 +1279,13 @@ ;; Simple structs: call this with a list of types, and get a type that marshals ;; C structs to/from Scheme lists. (define* (_list-struct . types) - (let ([stype (make-cstruct-type types)] - [offsets (compute-offsets types)]) + (let ([stype (make-cstruct-type types)] + [offsets (compute-offsets types)] + [len (length types)]) (make-ctype stype (lambda (vals) + (unless (and (list vals) (= len (length vals))) + (raise-type-error 'list-struct (format "list of ~a items" len) vals)) (let ([block (malloc stype)]) (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) types offsets vals) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 2725b9b052..5cdb3a166c 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -628,7 +628,7 @@ subdirectory. (min-hi . ,(get pkg-spec-minor-hi)) (path . ,(get pkg-spec-path))))) -;; get-http-response-code : header[from net/head] -> string +;; get-http-response-code : header[from net/head] -> string or #f ;; gets the HTTP response code in the given header (define (get-http-response-code header) (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) @@ -656,7 +656,8 @@ subdirectory. [ip (get-impure-port target)] [head (purify-port ip)] [response-code/str (get-http-response-code head)] - [response-code (string->number response-code/str)]) + [response-code (and response-code/str + (string->number response-code/str))]) (define (abort msg) (close-input-port ip) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 411bd10be3..2ae863f5aa 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -872,8 +872,7 @@ eof (begin (set! executed? #t) - (errortrace-annotate - (syntax-as-top + (syntax-as-top (compile-interactions-ast (parse-interactions port name level) name level types #t) @@ -881,7 +880,7 @@ #;(datum->syntax #f `(parse-java-interactions ,(parse-interactions port name level) ,name) - #f)))))))) + #f))))))) (define/public (front-end/finished-complete-program settings) (void)) (define (get-defn-editor port-name) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 56bb61c48b..de61f90848 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "28sep2008") +#lang scheme/base (provide stamp) (define stamp "6oct2008") diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index f44e68ecc5..d8d5ebdbae 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -3,6 +3,7 @@ (require (for-syntax (rename-in r6rs/private/base-for-syntax [syntax-rules r6rs:syntax-rules]) scheme/base) + scheme/splicing r6rs/private/qq-gen r6rs/private/exns (prefix-in r5rs: r5rs) @@ -546,54 +547,20 @@ ;; ---------------------------------------- -;; let[rec]-syntax needs to be splicing, ad it needs the +;; let[rec]-syntax needs to be splicing, and it needs the ;; same transformer wrapper as in `define-syntax' -(define-for-syntax (do-let-syntax stx rec?) +(define-syntax (r6rs:let-syntax stx) (syntax-case stx () [(_ ([id expr] ...) body ...) - (if (eq? 'expression (syntax-local-context)) - (with-syntax ([let-stx (if rec? - #'letrec-syntax - #'let-syntax)]) - (syntax/loc stx - (let-stx ([id (wrap-as-needed expr)] ...) - (#%expression body) - ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([ids (map sli (syntax->list #'(id ...)))] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([(id ...) - (map sli (map add-context ids))] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntax id (wrap-as-needed expr)) - ... - body ...))))))])) - -(define-syntax (r6rs:let-syntax stx) - (do-let-syntax stx #f)) + (syntax/loc stx + (splicing-let-syntax ([id (wrap-as-needed expr)] ...) body ...))])) (define-syntax (r6rs:letrec-syntax stx) - (do-let-syntax stx #t)) + (syntax-case stx () + [(_ ([id expr] ...) body ...) + (syntax/loc stx + (splicing-letrec-syntax ([id (wrap-as-needed expr)] ...) body ...))])) ;; ---------------------------------------- diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index b6b8b0aa8e..a5202a47f8 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -247,13 +247,9 @@ (lambda args (f (apply g args)))) (if (eqv? 1 (procedure-arity g)) ; optimize: single input (lambda (a) - (call-with-values - (lambda () (g a)) - f)) + (call-with-values (lambda () (g a)) f)) (lambda args - (call-with-values - (lambda () (apply g args)) - f)))))] + (call-with-values (lambda () (apply g args)) f)))))] [(f . more) (if (procedure? f) (let ([m (apply compose more)]) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 906587efd1..7124f054be 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -49,36 +49,32 @@ (let-stx ([ids expr] ...) (#%expression body) ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([all-ids (map (lambda (ids) (map sli ids)) all-ids)] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([((id ...) ...) - (map (lambda (ids) - (map sli (map add-context ids))) - all-ids)] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntaxes (id ...) expr) - ... - body ...)))))))])) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))]) + (with-syntax ([((id ...) ...) + (map (lambda (ids) + (map add-context ids)) + all-ids)] + [(expr ...) + (let ([exprs (syntax->list #'(expr ...))]) + (if rec? + (map add-context exprs) + exprs))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + #'(begin + (define-syntaxes (id ...) expr) + ... + body ...))))))])) (define-syntax (splicing-let-syntax stx) (do-let-syntax stx #f #f)) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index 28e08c4df8..e2bd9ccf61 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -2,6 +2,7 @@ (module run mzscheme (require "struct.ss" "base-render.ss" + "xref.ss" mzlib/cmdline mzlib/class mzlib/file @@ -29,11 +30,21 @@ (make-parameter #f)) (define current-info-input-files (make-parameter null)) + (define current-xref-input-modules + (make-parameter null)) (define current-style-file (make-parameter #f)) (define current-redirect (make-parameter #f)) + (define (read-one str) + (let ([i (open-input-string str)]) + (with-handlers ([exn:fail:read? (lambda (x) #f)]) + (let ([v (read i)]) + (if (eof-object? (read i)) + v + #f))))) + (define (get-command-line-files argv) (command-line "scribble" @@ -59,9 +70,23 @@ [("--info-out") file "write format-specific link information to " (current-info-output-file file)]] [multi - [("++info-in") file "load format-specific link information form " + [("++info-in") file "load format-specific link information from " (current-info-input-files - (cons file (current-info-input-files)))]] + (cons file (current-info-input-files)))] + [("++xref-in") module-path proc-id "load format-specific link information by" + "calling as exported by " + (let ([mod (read-one module-path)] + [id (read-one proc-id)]) + (unless (module-path? mod) + (raise-user-error 'scribble + "bad module path for ++ref-in: ~s" + module-path)) + (unless (symbol? id) + (raise-user-error 'scribble + "bad procedure identifier for ++ref-in: ~s" + proc-id)) + (current-xref-input-modules + (cons (cons mod id) (current-xref-input-modules))))]] [args (file . another-file) (cons file another-file)])) (define (build-docs-files files) @@ -90,19 +115,26 @@ fn)))) files)] [info (send renderer collect docs fns)]) - (let ([info (let loop ([info info] - [files (reverse (current-info-input-files))]) - (if (null? files) - info - (loop (let ([s (with-input-from-file (car files) read)]) - (send renderer deserialize-info s info) - info) - (cdr files))))]) - (let ([r-info (send renderer resolve docs fns info)]) - (send renderer render docs fns r-info) - (when (current-info-output-file) - (let ([s (send renderer serialize-info r-info)]) - (with-output-to-file (current-info-output-file) - (lambda () - (write s)) - 'truncate/replace)))))))))) + (for-each (lambda (file) + (let ([s (with-input-from-file file read)]) + (send renderer deserialize-info s info))) + (reverse (current-info-input-files))) + (for-each (lambda (mod+id) + (let ([get-xref (dynamic-require (car mod+id) (cdr mod+id))]) + (let ([xr (get-xref)]) + (unless (xref? xr) + (raise-user-error 'scribble + "result from `~s' of `~s' is not an xref: ~e" + (cdr mod+id) + (car mod+id) + xr)) + (xref-transfer-info renderer info xr)))) + (reverse (current-xref-input-modules))) + (let ([r-info (send renderer resolve docs fns info)]) + (send renderer render docs fns r-info) + (when (current-info-output-file) + (let ([s (send renderer serialize-info r-info)]) + (with-output-to-file (current-info-output-file) + (lambda () + (write s)) + 'truncate/replace))))))))) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index d01425c895..2b64510041 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -66,8 +66,8 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.} @declare-exporting[scribblings/foreign/unsafe-foreign] -@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?] - [(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{ +@defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] + [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ These two functions treat pointer tags as lists of tags. As described in @secref["foreign:pointer-funcs"], a pointer tag does not have any @@ -125,7 +125,12 @@ Returns the length of a C vector.} Returns the C type object of a C vector.} -@defproc[(cvector-ref [cvec cvector?][k exact-nonnegative-integer?]) any]{ +@defproc[(cvector-ptr [cvec cvector?]) cpointer?]{ + +Returns the pointer that points at the beginning block of the given C vector.} + + +@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{ References the @scheme[k]th element of the @scheme[cvec] C vector. The result has the type that the C vector uses.} @@ -154,7 +159,9 @@ Converts the list @scheme[lst] to a C vector of the given @declare-exporting[scribblings/foreign/unsafe-foreign] -@defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{ +@defproc[(make-cvector* [cptr any/c] [type ctype?] + [length exact-nonnegative-integer?]) + cvector?]{ Constructs a C vector using an existing pointer object. This operation is not safe, so it is intended to be used in specific diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index f25a32b24c..d8003bbcbd 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -267,8 +267,13 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on @defproc[(_cprocedure [input-types (list ctype?)] [output-type ctype?] - [abi (or/c symbol/c false/c) #f] - [wrapper (or false/c (procedure? . -> . procedure?)) #f]) any]{ + [#:abi abi (or/c symbol/c false/c) #f] + [#:wrapper wrapper (or/c false/c + (procedure? . -> . procedure?)) + #f] + [#:keep keep (or/c boolean? box? (any/c . -> . any/c)) + #t]) + any]{ A type constructor that creates a new function type, which is specified by the given @scheme[input-types] list and @scheme[output-type]. @@ -286,27 +291,80 @@ function pointer that calls the given Scheme procedure when it is used. There are no restrictions on the Scheme procedure; in particular, its lexical context is properly preserved. -The optional @scheme[abi] argument determines the foreign ABI that is -used. @scheme[#f] or @scheme['default] will use a platform-dependent -default; other possible values are @scheme['stdcall] and -@scheme['sysv] (the latter corresponds to ``cdecl''). This is -especially important on Windows, where most system functions are -@scheme['stdcall], which is not the default. +The optional @scheme[abi] keyword argument determines the foreign ABI +that is used. @scheme[#f] or @scheme['default] will use a +platform-dependent default; other possible values are +@scheme['stdcall] and @scheme['sysv] (the latter corresponds to +``cdecl''). This is especially important on Windows, where most +system functions are @scheme['stdcall], which is not the default. -The optional @scheme[wrapper-proc], if provided, is expected to be a function that -can change a callout procedure: when a callout is generated, the wrapper is -applied on the newly created primitive procedure, and its result is used as the -new function. Thus, @scheme[wrapper-proc] is a hook that can perform various argument -manipulations before the foreign function is invoked, and return different -results (for example, grabbing a value stored in an `output' pointer and -returning multiple values). It can also be used for callbacks, as an -additional layer that tweaks arguments from the foreign code before they reach -the Scheme procedure, and possibly changes the result values too.} +The optional @scheme[wrapper], if provided, is expected to be a +function that can change a callout procedure: when a callout is +generated, the wrapper is applied on the newly created primitive +procedure, and its result is used as the new function. Thus, +@scheme[wrapper] is a hook that can perform various argument +manipulations before the foreign function is invoked, and return +different results (for example, grabbing a value stored in an +``output'' pointer and returning multiple values). It can also be +used for callbacks, as an additional layer that tweaks arguments from +the foreign code before they reach the Scheme procedure, and possibly +changes the result values too. + +Sending Scheme functions as callbacks to foreign code is achieved by +translating them to a foreign ``closure'', which foreign code can call +as plain C functions. Additional care must be taken in case the +foreign code might hold on to the callback function. In these cases +you must arrange for the callback value to not be garbage-collected, +or the held callback will become invalid. The optional @scheme[keep] +keyword argument is used to achieve this. It can have the following +values: @itemize[ + +@item{@scheme[#t] makes the callback value stay in memory as long as + the converted function is. In order to use this, you need to hold + on to the original function, for example, have a binding for it. + Note that each function can hold onto one callback value (it is + stored in a weak hash table), so if you need to use a function in + multiple callbacks you will need to use one of the the last two + options below. (This is the default, as it is fine in most cases.)} + +@item{@scheme[#f] means that the callback value is not held. This may + be useful for a callback that is only used for the duration of the + foreign call --- for example, the comparison function argument to + the standard C library @tt{qsort} function is only used while + @tt{qsort} is working, and no additional references to the + comparison function are kept. Use this option only in such cases, + when no holding is necessary and you want to avoid the extra cost.} + +@item{A box holding @scheme[#f] (or a callback value) --- in this case + the callback value will be stored in the box, overriding any value + that was in the box (making it useful for holding a single callback + value). When you know that it is no longer needed, you can + `release' the callback value by changing the box contents, or by + allowing the box itself to be garbage-collected. This is can be + useful if the box is held for a dynamic extent that corresponds to + when the callback is needed; for example, you might encapsulate some + foreign functionality in a Scheme class or a unit, and keep the + callback box as a field in new instances or instantiations of the + unit.} + +@item{A box holding @scheme[null] (or any list) -- this is similar to + the previous case, except that new callback values are consed onto + the contents of the box. It is therefore useful in (rare) cases + when a Scheme function is used in multiple callbacks (that is, sent + to foreign code to hold onto multiple times).} + +@item{Finally, if a one-argument function is provided as + @scheme[keep], it will be invoked with the callback value when it + is generated. This allows you to grab the value directly and use it + in any way.} + +]} @defform/subs[#:literals (-> :: :) (_fun fun-option ... maybe-args type-spec ... -> type-spec maybe-wrapper) - ([fun-option (code:line #:abi abi-expr)] + ([fun-option (code:line #:abi abi-expr) + (code:line #:keep keep-expr)] [maybe-args code:blank (code:line (id ...) ::) (code:line id ::) diff --git a/collects/scribblings/gui/dc-intf.scrbl b/collects/scribblings/gui/dc-intf.scrbl index 14a73d9b27..92b6c4c97b 100644 --- a/collects/scribblings/gui/dc-intf.scrbl +++ b/collects/scribblings/gui/dc-intf.scrbl @@ -199,9 +199,10 @@ See also @method[dc<%> set-smoothing] for information on the void?]{ Draws the sub-paths of the given @scheme[dc-path%] object, adding - @scheme[xoffset] and @scheme[yoffset] to each point. The current pen - is used for drawing the path as a line, and the current brush is used - for filling the area bounded by the path. + @scheme[xoffset] and @scheme[yoffset] to each point. (See + @scheme[dc-path%] for general information on paths and sub-paths.) + The current pen is used for drawing the path as a line, and the + current brush is used for filling the area bounded by the path. If both the pen and brush are non-transparent, the path is filled with the brush before the outline is drawn with the pen. The filling and @@ -350,11 +351,13 @@ See also @method[dc<%> set-smoothing] for information on the [y3 real?]) void?]{ -Draws a spline from (@scheme[x1], @scheme[y1]) to (@scheme[x3], @scheme[y3]) - using (@scheme[x2], @scheme[y2]) as the control point. +@index['("drawing curves")]{Draws} a spline from (@scheme[x1], + @scheme[y1]) to (@scheme[x3], @scheme[y3]) using (@scheme[x2], + @scheme[y2]) as the control point. See also @method[dc<%> set-smoothing] for information on the -@scheme['aligned] smoothing mode. + @scheme['aligned] smoothing mode. See also @scheme[dc-path%] and + @method[dc<%> draw-path] for drawing more complex curves. @|DrawSizeNote| @@ -918,7 +921,7 @@ Starts a page, relevant only when drawing to a printer or PostScript device (including to a PostScript file). For printer or PostScript output, an exception is raised if - @scheme[start-doc] is called when a page is already started, or when + @scheme[start-page] is called when a page is already started, or when @method[dc<%> start-doc] has not been called, or when @method[dc<%> end-doc] has been called already. In addition, in the case of PostScript output, Encapsulated PostScript (EPS) cannot contain diff --git a/collects/scribblings/gui/dc-path-class.scrbl b/collects/scribblings/gui/dc-path-class.scrbl index 131bf593f8..e37bf31158 100644 --- a/collects/scribblings/gui/dc-path-class.scrbl +++ b/collects/scribblings/gui/dc-path-class.scrbl @@ -14,7 +14,8 @@ A path consists of zero or more @deftech{closed sub-paths}, and possibly one @deftech{open sub-path}. Some @scheme[dc-path%] methods extend the open sub-path, some @scheme[dc-path%] methods close the open sub-path, and some @scheme[dc-path%] methods add closed - sub-paths. + sub-paths. This approach to drawing formulation is inherited from + PostScript @cite["Adobe99"]. When a path is drawn as a line, a closed sub-path is drawn as a closed figure, analogous to a polygon. An open sub-path is drawn with diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 0b319e650e..06abcca664 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -31,6 +31,20 @@ provides; this library cannot run in MzScheme.} @include-section["config.scrbl"] @include-section["dynamic.scrbl"] + +@;------------------------------------------------------------------------ + +@(bibliography + + (bib-entry #:key "Adobe99" + #:author "Adobe Systems Incorporated" + #:title "PostScript Language Reference, third edition" + #:is-book? #t + #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" + #:date "1999") + + ) + @;------------------------------------------------------------------------ @index-section[] diff --git a/collects/scribblings/reference/collects.scrbl b/collects/scribblings/reference/collects.scrbl index db56dd2d7c..12425b23b1 100644 --- a/collects/scribblings/reference/collects.scrbl +++ b/collects/scribblings/reference/collects.scrbl @@ -87,7 +87,15 @@ Produces a list of paths as follows: defined, it is combined with the default list using @scheme[path-list-string->path-list]. If it is not defined, the default collection path list (as constructed by the first three - bullets above) is used directly.} + bullets above) is used directly. + + Note that under @|AllUnix|, paths are separated by @litchar{:}, and + under Windows by @litchar{;}. Also, + @scheme[path-list-string->path-list] splices the default paths at an + empty path, for example, with many Unix shells you can set + @envvar{PLTCOLLECTS} to @tt{":`pwd`"}, @tt{"`pwd`:"}, or + @tt{"`pwd`"} to specify search the current directory after, before, + or instead of the default paths respectively.} }} diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index d0bb66dcdb..3676d8549e 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -959,20 +959,20 @@ combination of @scheme[envvar] and @scheme[as-index].} Links to a bibliography entry, using @scheme[key] both to indicate the bibliography entry and, in square brackets, as the link text.} -@defproc[(bibliography [#:tag string? "doc-bibliography"] +@defproc[(bibliography [#:tag tag string? "doc-bibliography"] [entry bib-entry?] ...) part?]{ Creates a bibliography part containing the given entries, each of which is created with @scheme[bib-entry]. The entries are typeset in -order as given} +order as given.} @defproc[(bib-entry [#:key key string?] [#:title title any/c] [#:is-book? is-book? any/c #f] - [#:author author any/c] - [#:location location any/c] - [#:date date any/c] + [#:author author any/c #f] + [#:location location any/c #f] + [#:date date any/c #f] [#:url url any/c #f]) bib-entry?]{ @@ -990,18 +990,21 @@ the entry: order (as opposed to ``last, first''), and separate multiple names with commas using ``and'' before the last name (where there are multiple names). The @scheme[author] is typeset in - the bibliography as given.} + the bibliography as given, or it is omitted if given as + @scheme[#f].} @item{@scheme[location] names the publication venue, such as a conference name or a journal with volume, number, and pages. The @scheme[location] is typeset in the bibliography as - given.} + given, or it is omitted if given as @scheme[#f].} @item{@scheme[date] is a date, usually just a year (as a string). It - is typeset in the bibliography as given.} + is typeset in the bibliography as given, or it is omitted if + given as @scheme[#f].} @item{@scheme[url] is an optional URL. It is typeset in the - bibliography using @scheme[tt] and hyperlinked.} + bibliography using @scheme[tt] and hyperlinked, or it is + omitted if given as @scheme[#f].} }} diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index bb2b1c250b..3f648394e6 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -741,7 +741,7 @@ [body-lines (regexp-split #rx"\n" (substring message-str (cdar m) (string-length message-str)))]) - (validate-header header) + (validate-header (regexp-replace #rx"[^\x0-\xFF]" header "_")) (let* ([to* (sm-extract-addresses (extract-field "To" header))] [to (map encode-for-header (map car to*))] [cc* (sm-extract-addresses (extract-field "CC" header))] @@ -762,6 +762,8 @@ [new-header (append-headers std-header prop-header)] [tos (map cdr (append to* cc* bcc*))]) + (validate-header new-header) + (as-background enable (lambda (break-bad break-ok) diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index 373a126416..79a6e1706d 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -136,40 +136,43 @@ (vector? obj) (my-array? obj))) - (define (s:equal? obj1 obj2) - (or (equal? obj1 obj2) - (and (box? obj1) - (box? obj2) - (s:equal? (unbox obj1) - (unbox obj2))) - (and (pair? obj1) - (pair? obj2) - (s:equal? (car obj1) (car obj2)) - (s:equal? (cdr obj1) (cdr obj2))) - (if (vector? obj1) - (and (vector? obj2) - (equal? (vector-length obj1) (vector-length obj2)) - (let lp ((idx (sub1 (vector-length obj1)))) - (or (negative? idx) - (and (s:equal? (vector-ref obj1 idx) - (vector-ref obj2 idx)) - (lp (sub1 idx)))))) - ;; Not a vector - (or (and (array? obj1) - (array? obj2) - (equal? (array-dimensions obj1) (array-dimensions obj2)) - (s:equal? (array->vector obj1) (array->vector obj2))) - (and (struct? obj1) - (struct? obj2) - (let-values (((obj1-type obj1-skipped?) - (struct-info obj1)) - ((obj2-type obj2-skipped?) - (struct-info obj2))) - (and (eq? obj1-type obj2-type) - (not obj1-skipped?) - (not obj2-skipped?) - (s:equal? (struct->vector obj1) - (struct->vector obj2))))))))) + (define (s:equal? obj1 obj2) + (or (equal? obj1 obj2) + (cond ((and (box? obj1) + (box? obj2)) + (s:equal? (unbox obj1) + (unbox obj2))) + ((and (pair? obj1) + (pair? obj2)) + (and (s:equal? (car obj1) (car obj2)) + (s:equal? (cdr obj1) (cdr obj2)))) + ((and (vector? obj1) + (vector? obj2)) + (and (equal? (vector-length obj1) (vector-length obj2)) + (let lp ((idx (sub1 (vector-length obj1)))) + (or (negative? idx) + (and (s:equal? (vector-ref obj1 idx) + (vector-ref obj2 idx)) + (lp (sub1 idx))))))) + ((and (string? obj1) + (string? obj2)) + (string=? obj1 obj2)) + ((and (array? obj1) + (array? obj2)) + (and (equal? (array-dimensions obj1) (array-dimensions obj2)) + (s:equal? (array->vector obj1) (array->vector obj2)))) + ((and (struct? obj1) + (struct? obj2)) + (let-values (((obj1-type obj1-skipped?) + (struct-info obj1)) + ((obj2-type obj2-skipped?) + (struct-info obj2))) + (and (eq? obj1-type obj2-type) + (not obj1-skipped?) + (not obj2-skipped?) + (s:equal? (struct->vector obj1) + (struct->vector obj2))))) + (else #f)))) (define (array-rank obj) (if (array? obj) (length (array-dimensions obj)) 0)) diff --git a/collects/teachpack/door-real.png b/collects/teachpack/door-real.png new file mode 100644 index 0000000000..1514131ad0 Binary files /dev/null and b/collects/teachpack/door-real.png differ diff --git a/collects/teachpack/door-sim.png b/collects/teachpack/door-sim.png new file mode 100644 index 0000000000..014d4a7a9a Binary files /dev/null and b/collects/teachpack/door-sim.png differ diff --git a/collects/teachpack/htdp/scribblings/image.scrbl b/collects/teachpack/htdp/scribblings/image.scrbl index 31a73a6395..08b0f8450d 100644 --- a/collects/teachpack/htdp/scribblings/image.scrbl +++ b/collects/teachpack/htdp/scribblings/image.scrbl @@ -8,7 +8,7 @@ @teachpack["image"]{Manipulating Images} -@declare-exporting[teachpack/htdp/image] +@declare-exporting[teachpack/htdp/image #:use-sources (htdp/image)] The teachpack provides primitives for constructing and manipulating images. Basic, colored images are created as outlines or solid diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index 3c2842257a..a0f6584c97 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -1,6 +1,8 @@ #lang scribble/doc -@(require scribble/manual "shared.ss" +@(require scribble/manual + "shared.ss" + scribble/struct (for-label scheme teachpack/htdp/image teachpack/htdp/world @@ -10,9 +12,15 @@ @emph{Note}: For a quick and educational introduction to the teachpack, see @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How -to Design Programs, Second Edition: Prologue}. The purpose of this -documentation is to give experienced Schemers a concise overview for using -the library and for incorporating it elsewhere. +to Design Programs, Second Edition: Prologue}. As of August 2008, we also +have a series of projects available as a small booklet on +@link["http://world.cs.brown.edu/"]{How to Design Worlds}. + +The purpose of this documentation is to give experienced Schemers a concise +overview for using the library and for incorporating it elsewhere. The last +section presents @secref["example"] for an extremely simple domain and is +suited for a novice who knows how to design conditional functions for +symbols. The teachpack provides two sets of tools. The first allows students to create and display a series of animated scenes, i.e., a simulation. The @@ -20,6 +28,7 @@ second one generalizes the first by adding interactive GUI features. @declare-exporting[teachpack/htdp/world #:use-sources (teachpack/htdp/image)] +@; ----------------------------------------------------------------------------- @section[#:tag "basics"]{Basics} The teachpack assumes working knowledge of the basic image manipulation @@ -48,6 +57,7 @@ pinholes are at position @scheme[(0,0)]. @scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and down from the upper-left corner.} +@; ----------------------------------------------------------------------------- @section[#:tag "simulations"]{Simple Simulations} @defproc[(run-simulation @@ -86,13 +96,28 @@ Example: @;----------------------------------------------------------------------------- @section[#:tag "interactive"]{Interactions} -An animation starts from a given ``world'' and generates new ones in response to events on the -computer. This teachpack keeps track of the ``current world'' and recognizes three kinds of events: -clock ticks; keyboard presses and releases; and mouse movements, mouse clicks, etc. Your program may -deal with such events via the @emph{installation} of @emph{handlers}. The teachpack provides for the -installation of three event handlers: @scheme[on-tick-event], @scheme[on-key-event], and -@scheme[on-mouse-event]. In addition, it provides for the installation of a @scheme[draw] handler, -which is called every time your program should visualize the current world. +An animation starts from a given ``world'' and generates new ones in + response to events on the computer. This teachpack keeps track of the + ``current world'' and recognizes three kinds of events: clock ticks; + keyboard presses and releases; and mouse movements, mouse clicks, + etc. + +Your program may deal with such events via the @emph{installation} of + @emph{handlers}. The teachpack provides for the installation of three + event handlers: @scheme[on-tick-event], @scheme[on-key-event], and + @scheme[on-mouse-event]. In addition, it provides for the installation of + a @scheme[draw] handler, which is called every time your program should + visualize the current world. + +The following picture provides an intuitive overview of the workings of + "world". + +@image["world.png"] + + The @scheme[big-bang] function installs @emph{World_0} as the initial + world; the callbacks @emph{tock}, @emph{react}, and @emph{click} transform + one world into another one; @emph{done} checks each time whether the world + is final; and @emph{draw} renders each world as a scene. @deftech{World} @scheme[any/c] @@ -191,10 +216,12 @@ Example: The following examples shows that @scheme[(run-simulation 100 100 Exercise: Add a condition for stopping the flight of the UFO when it reaches the bottom. +@; ----------------------------------------------------------------------------- @section{Scenes and Images} -For the creation of scenes from the world, use the functions from @secref["image"]. The following two -functions have turned out to be useful for the creation of scenes, too. +For the creation of scenes from the world, use the functions from +@secref["image"]. The following two functions have turned out to be useful +for the creation of scenes, too. @defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{ @@ -209,3 +236,292 @@ functions have turned out to be useful for the creation of scenes, too. in contrast to the @scheme[add-line] function, this one cuts off those portions of the line that go beyond the boundaries of the given @scheme[s].} + +@; ----------------------------------------------------------------------------- + +@(define (table* . stuff) + ;; (list paragraph paragraph) *-> Table + (define (flow* x) (make-flow (list x))) + (make-blockquote #f + (list + (make-table (make-with-attributes 'boxed '((cellspacing . "6"))) + ;; list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) + +@; ----------------------------------------------------------------------------- +@section[#:tag "example"]{A First Example} + + +@subsection{Understanding a Door} + +Say we want to represent a door with an automatic door closer. If this kind + of door is locked, you can unlock it. While this doesn't open the door per + se, it is now possible to do so. That is, an unlocked door is closed and + pushing at the door opens it. Once you have passed through the door and + you let go, the automatic door closer takes over and closes the door + again. Of course, at this point you could lock it again. + +Here is a picture that translates our words into a graphical + representation: + +@image["door-real.png"] + +The picture displays a so-called "state machine". The three circled words + are the states that our informal description of the door identified: + locked, closed (and unlocked), and open. The arrows specify how the door + can go from one state into another. For example, when the door is open, + the automatic door closer shuts the door as time passes. This transition + is indicated by the arrow labeled "time passes." The other arrows + represent transitions in a similar manner: + +@itemize[ + +@item{"push" means a person pushes the door open (and let's go);} + +@item{"lock" refers to the act of inserting a key into the lock and turning +it to the locked position; and} + +@item{"unlock" is the opposite of "lock".} + +] + +@; ----------------------------------------------------------------------------- +@subsection{Simulations of the World} + +Simulating any dynamic behavior via a program demands two different + activities. First, we must tease out those portions of our "world" that + change over time or in reaction to actions, and we must develop a data + representation @deftech{D} for this information. Keep in mind that a good data + definition makes it easy for readers to map data to information in the + real world and vice versa. For all others aspects of the world, we use + global constants, including graphical or visual constants that are used in + conjunction with the rendering operations. + +Second, we must translate the "world" actions---the arrows in the above + diagram---into interactions with the computer that the world teachpack can + deal with. Once we have decided to use the passing of time for one aspect + and mouse movements for another, we must develop functions that map the + current state of the world---represented as data---into the next state of + the world. Since the data definition @tech{D} describes the class of data + that represents the world, these functions have the following general + contract and purpose statements: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; tick : @tech{D} -> @tech{D} +;; deal with the passing of time +(define (tick w) ...) + +;; click : @tech{D} @scheme{Number} @scheme{Number} @tech{MouseEvent} -> @tech{D} +;; deal with a mouse click at (x,y) of kind @scheme{me} +;; in the current world @scheme{w} +(define (click w x y me) ...) + +;; control : @tech{D} @tech{KeyEvent} -> @tech{D} +;; deal with a key event (symbol, char) @scheme{ke} +;; in the current world @scheme{w} +(define (control w ke) ...) +)) + +That is, the contracts of the various hooks dictate what the contracts of +these functions are once we have defined how to represent the world in +data. + +A typical program does not use all three of these actions and functions but + often just one or two. Furthermore, the design of these functions provides + only the top-level, initial design goal. It often demands the design of + many auxiliary functions. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Data} + +Our first and immediate goal is to represent the world as data. In this + specific example, the world consists of our door and what changes about + the door is whether it is locked, unlocked but closed, or open. We use + three symbols to represent the three states: + +@deftech{SD} + +@(begin +#reader scribble/comment-reader +(schemeblock +;; DATA DEF. +;; The state of the door (SD) is one of: +;; -- @scheme['locked] +;; -- @scheme['closed] +;; -- @scheme['open] +)) + +Symbols are particularly well-suited here because they directly express + the state of the door. + +Now that we have a data definition, we must also decide which computer + actions and interactions should model the various actions on the door. + Our pictorial representation of the door's states and transitions, + specifically the arrow from "open" to "closed" suggests the use of a + function that simulates time. For the other three arrows, we could use + either keyboard events or mouse clicks or both. Our solution uses three + keystrokes: +@scheme{#\u} for unlocking the door, +@scheme{#\l} for locking it, and +@scheme{#\space} for pushing it open. + We can express these choices graphically by translating the above "state + machine" from the world of information into the world of data: + +@image["door-sim.png"] + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Functions} + +Our analysis and data definition leaves us with three functions to design: + +@itemize[ + +@item{@scheme{automatic-closer}, which closes the time during one tick;} + +@item{@scheme{door-actions}, which manipulates the time in response to +pressing a key; and} + +@item{@scheme{render}, which translates the current state of the door into +a visible scene.} + +] + +Let's start with @scheme{automatic-closer}. We know its contract and it is +easy to refine the purpose statement, too: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : SD -> SD +;; closes an open door over the period of one tick +(define (automatic-closer state-of-door) ...) +)) + + Making up examples is trivial when the world can only be in one of three + states: + +@table*[ + @list[@t{ given state } @t{ desired state }] + @list[@t{ 'locked } @t{ 'locked }] + @list[@t{ 'closed } @t{ 'closed }] + @list[@t{ 'open } @t{ 'closed }] +] + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : SD -> SD +;; closes an open door over the period of one tick + +(check-expect (automatic-closer 'locked) 'locked) +(check-expect (automatic-closer 'closed) 'closed) +(check-expect (automatic-closer 'open) 'closed) + +(define (automatic-closer state-of-door) ...) +)) + + The template step demands a conditional with three clauses: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) ...] + [(symbol=? 'closed state-of-door) ...] + [(symbol=? 'open state-of-door) ...])) +)) + + The examples basically dictate what the outcomes of the three cases must + be: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) 'locked] + [(symbol=? 'closed state-of-door) 'closed] + [(symbol=? 'open state-of-door) 'closed])) +)) + + Don't forget to run the example-tests. + +For the remaining three arrows of the diagram, we design a function that + reacts to the three chosen keyboard events. As mentioned, functions that + deal with keyboard events consume both a world and a keyevent: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; door-actions : SD Keyevent -> SD +;; key events simulate actions on the door +(define (door-actions s k) ...) +)) + +@table*[ + @list[@t{ given state } @t{ given keyevent } @t{ desired state }] + +@list[ @t{ 'locked } @t{ #\u } @t{ 'closed}] +@list[ @t{ 'closed } @t{ #\l } @t{ 'locked} ] +@list[ @t{ 'closed } @t{ #\space} @t{ 'open } ] +@list[ @t{ 'open } @t{ --- } @t{ 'open } ]] + + The examples combine what the above picture shows and the choices we made + about mapping actions to keyboard events. + +From here, it is straightforward to turn this into a complete design: + +@schemeblock[ +(define (door-actions s k) + (cond + [(and (symbol=? 'locked s) (key=? #\u k)) 'closed] + [(and (symbol=? 'closed s) (key=? #\l k)) 'locked] + [(and (symbol=? 'closed s) (key=? #\space k)) 'open] + [else s])) + +(check-expect (door-actions 'locked #\u) 'closed) +(check-expect (door-actions 'closed #\l) 'locked) +(check-expect (door-actions 'closed #\space) 'open) +(check-expect (door-actions 'open 'any) 'open) +(check-expect (door-actions 'closed 'any) 'closed) +] + +Last but not least we need a function that renders the current state of the +world as a scene. For simplicity, let's just use a large enough text for +this purpose: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; render : @tech{SD} -> @scheme{Scene} +;; translate the current state of the door into a large text +(define (render s) + (text (symbol->string s) 40 'red)) + +(check-expecy (render 'closed) (text "closed" 40 'red)) +)) + The function @scheme{symbol->string} translates a symbol into a string, + which is needed because @scheme{text} can deal only with the latter, not + the former. A look into the language documentation revealed that this + conversion function exists, and so we use it. + +Once everything is properly designed, it is time to @emph{run} the +program. In the case of the world teachpack, this means we must specify +which function takes care of tick events, key events, and redraws: + +@(begin +#reader scribble/comment-reader +(schemeblock +(big-bang 100 100 1 'locked) +(on-tick-event automatic-closer) +(on-key-event door-actions) +(on-redraw render) +)) + +Now it's time for you to collect the pieces and run them in DrScheme to see +whether it all works. diff --git a/collects/teachpack/world.png b/collects/teachpack/world.png new file mode 100644 index 0000000000..82dd678265 Binary files /dev/null and b/collects/teachpack/world.png differ diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 795b3d7087..4a6f5e0b54 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -133,12 +133,12 @@ This produces an ACK message void) (mktest "(" - ("{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'" - "{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'") + ("{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('" + "{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('") 'definitions #f void @@ -467,12 +467,12 @@ This produces an ACK message ;; error in the middle (mktest "1 2 ( 3 4" - ("1\n2\n{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'" - "1\n2\n{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'") + ("1\n2\n{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('" + "1\n2\n{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('") 'definitions #f void @@ -1382,10 +1382,10 @@ This produces an ACK message (let* ([end (- (get-int-pos) 1)] [output (fetch-output drscheme-frame start end)] - [expected "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"]) - (unless (equal? output expected) + [expected #rx"reference to undefined identifier: x"]) + (unless (regexp-match expected output) (failure) - (fprintf (current-error-port) "callcc-test: expected ~s, got ~s\n" expected output))))) + (fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output))))) (define (random-seed-test) (define expression diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index a290b77360..5b10ada2c7 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -53,7 +53,7 @@ (cond [all? all-files] [batch? (remove* interactive-files all-files)] [else files])))) - `("Names of the tests; defaults to all tests")) + `("Names of the tests; defaults to all non-interactive tests")) (when (file-exists? preferences-file) (debug-printf admin " saving preferences file ~s to ~s\n" diff --git a/collects/tests/match/plt-match-tests.ss b/collects/tests/match/plt-match-tests.ss index d50f65f05c..06276f5684 100644 --- a/collects/tests/match/plt-match-tests.ss +++ b/collects/tests/match/plt-match-tests.ss @@ -1,233 +1,232 @@ -(module plt-match-tests mzscheme - (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10))) +#lang scheme/base - (require mzlib/plt-match) - - (require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") - - (require (planet "views.ss" ("cobbe" "views.plt" 1 1))) - - (define reg-tests - (make-test-suite "Tests for regressions" - (make-test-case "quote in qp" - (assert eq? #t (match '(tile a b c) - [`(tile ,@'(a b c)) - #t] - [else #f])) - (assert eq? #t (match '(tile a b c) - [`(tile ,@`(a b c)) - #t] - [else #f]))))) - (define cons-tests - (make-test-suite "Tests for cons pattern" - (make-test-case "simple" - (assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) - - (define match-expander-tests - (make-test-suite - "Tests for define-match-expander" - (make-test-case "Trivial expander" - (let () - (define-match-expander bar (lambda (x) #'_) +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + - - (make-test-case "Trivial expander w/ keywords" - (let () - (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + - - ;; gross hack to check for syntax errors - (make-test-case "Only one xform gives syntax error" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-match-expander bar (lambda (x) #'_)) - (bar 3 4)))))) +(require (for-syntax scheme/base)) - ;; more complex example from Dale - (make-test-case "Point structs" - (let () - (define-struct point (x y)) - (define-match-expander Point - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) - - ;; from richard's view documentation - - (make-test-case "Natural number views" - (let () - (define natural-number? - (lambda (x) - (and (integer? x) - (>= x 0)))) - (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) - - (define-view peano-zero natural-zero? ()) - (define-view peano-succ natural-number? (sub1)) - - (define factorial - (match-lambda - [(peano-zero) 1] - [(and (peano-succ pred) n) (* n (factorial pred))])) - (assert = 120 (factorial 5)))) - - ;; more complex example from Dale - (make-test-case "Point structs with keywords" - (let () - (define-struct point (x y)) - (define-match-expander Point - #:plt-match - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - #:expression make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) - )) - - (define simple-tests - (make-test-suite - "Some Simple Tests" - (make-test-case "Trivial" - (assert = 3 (match 3 [x x]))) - (make-test-case "no order" - (assert equal? #t (match '(1 2 3 1) - [(list-no-order 3 2 1 1) #t] - [_ #f]))) - (make-test-case "app pattern" - (assert = 4 (match 3 [(app add1 y) y]))) - (make-test-case "struct patterns" - (let () - (define-struct point (x y)) - (define (origin? pt) - (match pt - ((struct point (0 0)) #t) - (else #f))) - (assert-true (origin? (make-point 0 0))) - (assert-false (origin? (make-point 1 1))))) - )) - - (define nonlinear-tests - (make-test-suite - "Non-linear patterns" - (make-test-case "Very simple" - (assert = 3 (match '(3 3) [(list a a) a]))) - (make-test-case "Fails" - (assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) - (make-test-case "Use parameter" - (parameterize ([match-equality-test eq?]) - (assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) - (make-test-case "Nonlinear patterns use equal?" - (assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) - - - (define doc-tests - (make-test-suite - "Tests from Help Desk Documentation" - (make-test-case "match-let" - (assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) - (make-test-case "lambda calculus" - (let () - (define-struct Lam (args body)) - (define-struct Var (s)) - (define-struct Const (n)) - (define-struct App (fun args)) - - (define parse - (match-lambda - [(and s (? symbol?) (not 'lambda)) - (make-Var s)] - [(? number? n) - (make-Const n)] - [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) - (make-Lam args (parse body))] - [(list f args ...) - (make-App - (parse f) - (map parse args))] - [x (error 'syntax "invalid expression")])) - - (define repeats? - (lambda (l) - (and (not (null? l)) - (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) - - (define unparse - (match-lambda - [(struct Var (s)) s] - [(struct Const (n)) n] - [(struct Lam (args body)) `(lambda ,args ,(unparse body))] - [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) - - (assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) - - (make-test-case "counter : match-define" - (let () - (match-define (list inc value reset) - (let ([val 0]) - (list - (lambda () (set! val (add1 val))) - (lambda () val) - (lambda () (set! val 0))))) - (inc) - (inc) - (assert = 2 (value)) - (inc) - (assert = 3 (value)) - (reset) - (assert = 0 (value)))) - - )) - - (define plt-match-tests - (make-test-suite "Tests for plt-match.ss" - doc-tests - cons-tests - simple-tests - nonlinear-tests - match-expander-tests - reg-tests +(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) +(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10))) + +(require mzlib/plt-match) + +(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") + +(require (planet "views.ss" ("cobbe" "views.plt" 1 1))) + +(define reg-tests + (make-test-suite "Tests for regressions" + (make-test-case "quote in qp" + (assert eq? #t (match '(tile a b c) + [`(tile ,@'(a b c)) + #t] + [else #f])) + (assert eq? #t (match '(tile a b c) + [`(tile ,@`(a b c)) + #t] + [else #f]))))) +(define cons-tests + (make-test-suite "Tests for cons pattern" + (make-test-case "simple" + (assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) + +(define match-expander-tests + (make-test-suite + "Tests for define-match-expander" + (make-test-case "Trivial expander" + (let () + (define-match-expander bar (lambda (x) #'_) +) + (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (assert-true (match 3 [(bar) #t])) ; (bar) matches anything + (assert = 12 (bar 3 4 5)) + (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + + (make-test-case "Trivial expander w/ keywords" + (let () + (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) + (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (assert-true (match 3 [(bar) #t])) ; (bar) matches anything + (assert = 12 (bar 3 4 5)) + (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + + ;; gross hack to check for syntax errors + (make-test-case "Only one xform gives syntax error" + (assert-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-match-expander bar (lambda (x) #'_)) + (bar 3 4)))))) + + ;; more complex example from Dale + (make-test-case "Point structs" + (let () + (define-struct point (x y)) + (define-match-expander Point + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + make-point) + ;; check that it works as expression and as pattern + (assert = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (assert = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (assert = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) )) - - (define (run-tests) - (test/text-ui (make-test-suite "Match Tests" - plt-match-tests - match-tests - new-tests - ;; from bruce - other-tests - other-plt-tests - ))) - (if (getenv "PLT_TESTS") - (unless (parameterize ([current-output-port (open-output-string)]) - (= 0 (run-tests))) - (error "Match Tests did not pass.")) - (run-tests)) - ) + + ;; from richard's view documentation + + (make-test-case "Natural number views" + (let () + (define natural-number? + (lambda (x) + (and (integer? x) + (>= x 0)))) + (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) + + (define-view peano-zero natural-zero? ()) + (define-view peano-succ natural-number? (sub1)) + + (define factorial + (match-lambda + [(peano-zero) 1] + [(and (peano-succ pred) n) (* n (factorial pred))])) + (assert = 120 (factorial 5)))) + + ;; more complex example from Dale + (make-test-case "Point structs with keywords" + (let () + (define-struct point (x y)) + (define-match-expander Point + #:plt-match + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + #:expression make-point) + ;; check that it works as expression and as pattern + (assert = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (assert = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (assert = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) + )) + )) + +(define simple-tests + (make-test-suite + "Some Simple Tests" + (make-test-case "Trivial" + (assert = 3 (match 3 [x x]))) + (make-test-case "no order" + (assert equal? #t (match '(1 2 3 1) + [(list-no-order 3 2 1 1) #t] + [_ #f]))) + (make-test-case "app pattern" + (assert = 4 (match 3 [(app add1 y) y]))) + (make-test-case "struct patterns" + (let () + (define-struct point (x y)) + (define (origin? pt) + (match pt + ((struct point (0 0)) #t) + (else #f))) + (assert-true (origin? (make-point 0 0))) + (assert-false (origin? (make-point 1 1))))) + )) + +(define nonlinear-tests + (make-test-suite + "Non-linear patterns" + (make-test-case "Very simple" + (assert = 3 (match '(3 3) [(list a a) a]))) + (make-test-case "Fails" + (assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) + (make-test-case "Use parameter" + (parameterize ([match-equality-test eq?]) + (assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) + (make-test-case "Nonlinear patterns use equal?" + (assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) + + +(define doc-tests + (make-test-suite + "Tests from Help Desk Documentation" + (make-test-case "match-let" + (assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) + (make-test-case "lambda calculus" + (let () + (define-struct Lam (args body)) + (define-struct Var (s)) + (define-struct Const (n)) + (define-struct App (fun args)) + + (define parse + (match-lambda + [(and s (? symbol?) (not 'lambda)) + (make-Var s)] + [(? number? n) + (make-Const n)] + [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) + (make-Lam args (parse body))] + [(list f args ...) + (make-App + (parse f) + (map parse args))] + [x (error 'syntax "invalid expression")])) + + (define repeats? + (lambda (l) + (and (not (null? l)) + (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) + + (define unparse + (match-lambda + [(struct Var (s)) s] + [(struct Const (n)) n] + [(struct Lam (args body)) `(lambda ,args ,(unparse body))] + [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) + + (assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) + + (make-test-case "counter : match-define" + (let () + (match-define (list inc value reset) + (let ([val 0]) + (list + (lambda () (set! val (add1 val))) + (lambda () val) + (lambda () (set! val 0))))) + (inc) + (inc) + (assert = 2 (value)) + (inc) + (assert = 3 (value)) + (reset) + (assert = 0 (value)))) + + )) + +(define plt-match-tests + (make-test-suite "Tests for plt-match.ss" + doc-tests + cons-tests + simple-tests + nonlinear-tests + match-expander-tests + reg-tests + )) + +(define (run-tests) + (test/text-ui (make-test-suite "Match Tests" + plt-match-tests + match-tests + new-tests + ;; from bruce + other-tests + other-plt-tests + ))) +(unless (= 0 (run-tests)) + (error "Match Tests did not pass.")) diff --git a/collects/tests/mzscheme/foreign-test.c b/collects/tests/mzscheme/foreign-test.c index cb1dc07906..d0da456d43 100644 --- a/collects/tests/mzscheme/foreign-test.c +++ b/collects/tests/mzscheme/foreign-test.c @@ -57,3 +57,24 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); } X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); } X int grab7th(void *p) { return ((char *)p)[7]; } + +X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; } + +typedef struct _char_int { unsigned char a; int b; } char_int; +X int charint_to_int(char_int x) { return ((int)x.a) + x.b; } +X char_int int_to_charint(int x) { + char_int result; + result.a = (unsigned char)x; + result.b = x; + return result; +} +X char_int charint_swap(char_int x) { + char_int result; + result.a = (unsigned char)x.b; + result.b = (int)x.a; + return result; +} + +int(*grabbed_callback)(int) = NULL; +X void grab_callback(int(*f)(int)) { grabbed_callback = f; } +X int use_grabbed_callback(int n) { return grabbed_callback(n); } diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index e141bbd5b9..bb624d4ddb 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -48,16 +48,19 @@ (compile-extension #t c o '()) (link-extension #t (list o) so))) -(let* ([lib (ffi-lib "./foreign-test")] - [ffi (lambda (name type) (get-ffi-obj name lib type))] - [test* (lambda (expected name type proc) - (test expected name (proc (ffi name type))))] - [t (lambda (expected name type . args) - (test* expected name type (lambda (p) (apply p args))))] - [tc (lambda (expected name type arg1 . args) - ;; curry first argument - (test* expected name type (lambda (p) (apply (p arg1) args))))] - [sqr (lambda (x) (* x x))]) +(define test-lib (ffi-lib "./foreign-test")) + +(for ([n (in-range 5)]) + (define (ffi name type) (get-ffi-obj name test-lib type)) + (define (test* expected name type proc) + (test expected name (proc (ffi name type)))) + (define (t expected name type . args) + (test* expected name type (lambda (p) (apply p args)))) + (define (tc expected name type arg1 . args) + ;; curry first argument + (test* expected name type (lambda (p) (apply (p arg1) args)))) + (define (sqr x) (when (zero? (random 4)) (collect-garbage)) (* x x)) + (define b (box #f)) ;; --- (t 2 'add1_int_int (_fun _int -> _int ) 1) (t 2 'add1_byte_int (_fun _byte -> _int ) 1) @@ -98,7 +101,7 @@ (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) ;; --- - (set-ffi-obj! "g3" lib (_fun _int -> _int) add1) + (set-ffi-obj! "g3" test-lib (_fun _int -> _int) add1) (t 4 'use_g3 (_fun _int -> _int) 3) (test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3))) ;; --- @@ -120,11 +123,40 @@ (lambda (x y) (let ([x (ptr-ref x _int)] [y (ptr-ref y _int)]) (cond [(< x y) -1] [(> x y) +1] [else 0]))))) - ;; --- - (t 55 'grab7th (_fun _pointer -> _int ) #"012345678") - (t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1)) - (t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3)) + ;; test vectors + (t 55 'grab7th (_fun _pointer -> _int ) #"012345678") + (t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1)) + (t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3)) + (t 10 'vec4 (_fun (_list i _int) -> _int) '(1 2 3 4)) + (t 10 'vec4 (_fun (_vector i _int) -> _int) '#(1 2 3 4)) + (t 10 'vec4 (_fun _cvector -> _int) (list->cvector '(1 2 3 4) _int)) + (t 10 'vec4 (_fun _pointer -> _int) + (cvector-ptr (list->cvector '(1 2 3 4) _int))) + ;; --- + ;; test passing and receiving structs + (let ([_charint (_list-struct _byte _int)]) + (t 1212 'charint_to_int (_fun _charint -> _int) '(12 1200)) + (t '(123 123) 'int_to_charint (_fun _int -> _charint) 123) + (t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255))) + ;; --- + ;; test sending a callback for C to hold, preventing the callback from GCing + (let ([with-keeper + (lambda (k) + (t (void) 'grab_callback + (_fun (_fun #:keep k _int -> _int) -> _void) sqr) + (t 9 'use_grabbed_callback (_fun _int -> _int) 3) + (collect-garbage) ; make sure it survives a GC + (t 25 'use_grabbed_callback (_fun _int -> _int) 5) + (collect-garbage) + (t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) + (with-keeper #t) + (with-keeper (box #f))) + ;; --- + ;; test exposing internal mzscheme functionality + (test '(1 2) + (get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme)) + 1 '(2)) ) ;; test setting vector elements @@ -184,7 +216,6 @@ The following is some random Scheme and C code, with some things that should be added. ------------------------------------------------------------------------------- -(define _foo (_list-struct (list _byte _int))) (define foo-struct1 (get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int))) (define foo-struct2 @@ -284,12 +315,6 @@ added. (string-set! x2 1 #\X) (foo-test "foo_string" '(#f) '(string) 'string) -(newline) -(printf ">>> scheme_make_pair(1,2) -> ~s\n" - ((ffi-call (ffi-obj libself "scheme_make_pair") - '(scheme scheme) 'scheme) - 1 2)) - (newline) (printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int)) '(let loop ((l '())) @@ -312,7 +337,6 @@ added. (ffi-ptr-set! block1 'ulong 1 22) (ffi-ptr-set! block1 'ulong 2 33) (ffi-ptr-set! block1 'ulong 3 44) -(foo-test "foo_vect" (list block1) '(pointer) 'int) ;(ffi-ptr-set! block1 'ulong 'abs 1 22) (printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0)) (printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1)) @@ -393,26 +417,7 @@ char* foo_string (char* x) { } } -int foo_vect(int x[]) { - return x[0]+x[1]+x[2]+x[3]; -} - int foo_foo(int x) { return x^1; } -typedef struct _char_int { - unsigned char a; - int b; -} char_int; - -int foo_struct1(char_int x) { - return ((int)x.a) + x.b; -} - -char_int foo_struct2(char_int x) { - char_int result; - result.a = (unsigned char)x.b; - result.b = (int)x.a; - return result; -} ------------------------------------------------------------------------------- |# diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index f13f177a17..b3cf53c677 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1128,6 +1128,57 @@ ((car procs) 'x2 'z2) ((cadr procs) 'x10 'z10)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require scheme/splicing) + +(define abcdefg 10) +(test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (let ([abcdefg 9]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg)))) +(test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg)))) +(test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) (+ 2 (abcdefg 9))] + [(_ ?) 77])]) + (abcdefg)))) +(splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) +(test 8 'hijklmn hijklmn) +(test 30 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) + (define other 22) + (+ other hijklmn))) +(test 8 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (begin + (define hijklmn (abcdefg)) + hijklmn)))) + +(test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 0])]) + (define x 10)) + (abcdefg))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 1fe728d05b..ec859fed7f 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -2,6 +2,7 @@ (require "test-utils.ss" + "planet-requires.ss" "typecheck-tests.ss" "subtype-tests.ss" ;; done "type-equal-tests.ss" ;; done @@ -12,9 +13,8 @@ "subst-tests.ss" "infer-tests.ss") -(require (utils planet-requires) (r:infer infer infer-dummy)) - -(require (schemeunit)) +(require (r:infer infer infer-dummy) + (schemeunit)) (provide unit-tests) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index aef624b748..bf3b7b95ec 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,11 +1,10 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) (r:infer infer) (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables))) -(require (schemeunit)) + (prefix-in table: (utils tables)) + (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 490c1c2a89..decc67820c 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,5 @@ #lang scheme -(require "test-utils.ss") -(require (utils planet-requires)) +(require "test-utils.ss" "planet-requires.ss") (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss index 7e24d23ca2..d9ca47239b 100644 --- a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss @@ -1,8 +1,8 @@ (module new-fv-tests mzscheme - (require "test-utils.ss") - (require/private type-rep rep-utils planet-requires type-effect-convenience meet-join subtype union) - (require-schemeunit) - + (require "test-utils.ss" "planet-requires.ss") + (require/private type-rep rep-utils type-effect-convenience meet-join subtype union) + (require-schemeunit) + (define variance-gen (random-uniform Covariant Contravariant Invariant Constant)) (define alpha-string (random-string (random-char (random-int-between 65 90)) (random-size 1))) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index fedf84fb81..b40e131b1f 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,17 +1,16 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires tc-utils) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (utils tc-utils) (env type-alias-env type-environments type-name-env init-envs) (rep type-rep) (private type-comparison parse-type subtype - union type-utils)) + union type-utils) + (schemeunit)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) (for-template (private base-types))) -(require (schemeunit)) - (provide parse-type-tests) ;; HORRIBLE HACK! diff --git a/collects/typed-scheme/utils/planet-requires.ss b/collects/tests/typed-scheme/unit-tests/planet-requires.ss similarity index 92% rename from collects/typed-scheme/utils/planet-requires.ss rename to collects/tests/typed-scheme/unit-tests/planet-requires.ss index eb6f7b26e7..038b3fb17e 100644 --- a/collects/typed-scheme/utils/planet-requires.ss +++ b/collects/tests/typed-scheme/unit-tests/planet-requires.ss @@ -47,18 +47,11 @@ (splice-requires (map mk (syntax->list #'(files ...)))))])))) -(provide galore schemeunit) +(provide schemeunit) ;; why is this neccessary? (provide planet/multiple) -(define-module galore - (prefix-in table: "tables.ss")) - -(require (galore)) - -(void (table:alist->eq '())) - -(define-module schemeunit +(define-module schemeunit (planet/multiple ("schematics" "schemeunit.plt" 2 3) "test.ss" ;"graphical-ui.ss" diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 20da5c73c3..e18cd04b91 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,11 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (utils planet-requires) (r:infer infer) - (private type-effect-convenience remove-intersect subtype union)) - -(require (schemeunit)) + (private type-effect-convenience remove-intersect subtype union) + (schemeunit)) (define-syntax (restr-tests stx) (syntax-case stx () diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 10a35fc98a..91d42cd426 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (private type-utils type-effect-convenience)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-utils type-effect-convenience) + (schemeunit)) (define-syntax-rule (s img var tgt result) (test-eq? "test" (substitute img 'var tgt) result)) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 83bb3e9a51..6aac041abb 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "test-utils.ss") +(require "test-utils.ss" "planet-requires.ss") (require (private subtype type-effect-convenience union) (rep type-rep) - (utils planet-requires) (env init-envs type-environments) - (r:infer infer infer-dummy)) - - -(require (schemeunit) + (r:infer infer infer-dummy) + (schemeunit) (for-syntax scheme/base)) (provide subtype-tests) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index b160cacdf9..9c40943939 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -1,15 +1,16 @@ #lang scheme/base (provide (all-defined-out)) -(require scheme/require-syntax +(require "planet-requires.ss" + scheme/require-syntax scheme/match typed-scheme/utils/utils (for-syntax scheme/base)) -(require (utils planet-requires) (private type-comparison type-utils)) +(require (private type-comparison type-utils) + (schemeunit)) (provide private typecheck (rename-out [infer r:infer]) utils env rep) -(require (schemeunit)) (define (mk-suite ts) (match (map (lambda (f) (f)) ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 167db51eb7..9f5398e72a 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,12 +1,11 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (private type-annotation type-effect-convenience parse-type) (env type-environments type-name-env init-envs) - (utils planet-requires tc-utils) - (rep type-rep)) - -(require (schemeunit)) + (utils tc-utils) + (rep type-rep) + (schemeunit)) (provide type-annotation-tests) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 899b8e1e97..1e4c5c2202 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,9 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) (rep type-rep) - (private type-comparison type-effect-convenience union subtype)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-comparison type-effect-convenience union subtype) + (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 5506b1ff4f..0be4c518f5 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -1,21 +1,20 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base) (for-template scheme/base)) (require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) (typecheck typechecker) (rep type-rep effect-rep) - (utils tc-utils planet-requires) - (env type-name-env type-environments init-envs)) + (utils tc-utils) + (env type-name-env type-environments init-envs) + (schemeunit)) (require (for-syntax (utils tc-utils) (typecheck typechecker) (env type-env) (private base-env)) (for-template (private base-env base-types))) -(require (schemeunit)) - diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 812f58a684..6b29c7c6da 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (rep type-rep effect-rep rep-utils) - (utils planet-requires tc-utils) + (utils tc-utils) scheme/match) ;; do we attempt to find instantiations of polymorphic types to print? diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2f49dba9f6..8e4124b37e 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -4,7 +4,6 @@ (require mzlib/struct mzlib/plt-match syntax/boundmap - (utils planet-requires) "free-variance.ss" "interning.ss" mzlib/etc diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 6e744cfa52..5536a84417 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (utils planet-requires tc-utils) +(require (utils tc-utils) "rep-utils.ss" "effect-rep.ss" "free-variance.ss" mzlib/trace scheme/match (for-syntax scheme/base)) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index e1d75c236c..bbae72978d 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -1,8 +1,7 @@ #lang scheme/unit (require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (utils planet-requires) - "signatures.ss" +(require "signatures.ss" (rep type-rep effect-rep) (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) (env lexical-env) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index cb3f7764c1..5dcbd5342f 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.1.1, October 2008 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.1, August 2008 Added auto-resize init argument and method to message% diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 14e1caab2b..e568c4828e 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,4 +1,4 @@ -Version 4.1.0.4 +Version 4.1.1, October 2008 Added read-language Added module-compiled-language-info, module->language-info, and 'module-language property support diff --git a/doc/release-notes/stepper/DESIGN-NOTES b/doc/release-notes/stepper/DESIGN-NOTES index 5b5b8e0d2d..5ee1b1bedc 100644 --- a/doc/release-notes/stepper/DESIGN-NOTES +++ b/doc/release-notes/stepper/DESIGN-NOTES @@ -910,4 +910,5 @@ harder than I expected. Don't ask me about lazy scheme. Or Advanced. Grr! 2008-05-08 +************** diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index add9b03cd8..6fd01607ee 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,61 +1,55 @@ Stepper ------- -Changes for v101: +Changes for v4.1.1: -all steps scroll to bottom automatically. -constants like 'pi' are explicitly expanded in a step. -stepper uses fewer threads internally. +Check-expect now reduces to a boolean in the stepper. Also, this history file +now appears with the most recent entries at the top.... -Changes for v102: - -Stepper handles intermediate level. -UI redesigned to use "side-by-side" reduction. - -Changes for v103: - -PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631 - -Changes for v200: - -Total rewrite for new syntax. Addition of test suites. -Addition of somewhat more systematic macro unwinding. -Lots of bug fixes. - -Changes for v201: - -Minor bug fixes. - -Changes for v203: - -Much more systematic unwinding, intermediate almost ready, redesigned test suite - -Changes for v204: +Changes for v4.1: none. -Changes for v205: +Changes for v4.0.1: -v. minor bug fixes. +none. -Changes for v206: +Changes for v4.0: -Stepper supports intermediate, minor bug fixes, major rewrite of interface - between reconstruct and display. +overhauled support for check-expect, check-within, check-error. -Changes for v206p1: +Changes for v372: + +support for check-expect, check-within, and check-error + +Changes for v371: None. -Changes for v207: +Changes for v370: -None. +Added "End" button to stepper interface. -Changes for v208: +Stepper supports "begin0". Again, you'll never know it unless you use +the PLTSTEPPERUNSAFE environment variable. -minor bug fixes. +There's a known bug with expressions of the form (let (begin +...)). (It's displayed as (let () X) rather than (begin X).) -Changes for v209: +Changes for v361: + +Bug fix for test cases + +Changes for v360: + +Stepper supports 'begin'. You'll never know it unless you use the +PLTSTEPPERUNSAFE environment variable, though. + +Changes for v351: + +Minor bug fixes + +Changes for v350: None. @@ -72,43 +66,60 @@ presence of mutation, it's no longer the case that the "finished" expressions never change, which means that they can't always be shared between the left and right hand sides. -Changes for v350: +Changes for v209: None. -Changes for v351: +Changes for v208: -Minor bug fixes +minor bug fixes. -Changes for v360: - -Stepper supports 'begin'. You'll never know it unless you use the -PLTSTEPPERUNSAFE environment variable, though. - -Changes for v361: - -Bug fix for test cases - -Changes for v370: - -Added "End" button to stepper interface. - -Stepper supports "begin0". Again, you'll never know it unless you use -the PLTSTEPPERUNSAFE environment variable. - -There's a known bug with expressions of the form (let (begin -...)). (It's displayed as (let () X) rather than (begin X). - -Changes for v371: +Changes for v207: None. -Changes for v372: support for check-expect, check-within, and check-error +Changes for v206p1: -Changes for v4.0: overhauled support for check-expect, check-within, -check-error. +None. -Changes for v4.0.1: none. +Changes for v206: -Changes for v4.1: none. +Stepper supports intermediate, minor bug fixes, major rewrite of interface + between reconstruct and display. +Changes for v205: + +v. minor bug fixes. + +Changes for v204: + +none. + +Changes for v203: + +Much more systematic unwinding, intermediate almost ready, redesigned test suite + +Changes for v201: + +Minor bug fixes. + +Changes for v200: + +Total rewrite for new syntax. Addition of test suites. +Addition of somewhat more systematic macro unwinding. +Lots of bug fixes. + +Changes for v103: + +PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631 + +Changes for v102: + +Stepper handles intermediate level. +UI redesigned to use "side-by-side" reduction. + +Changes for v101: + +all steps scroll to bottom automatically. +constants like 'pi' are explicitly expanded in a step. +stepper uses fewer threads internally. diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index f1f612fe15..e50f737849 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,8 @@ +------------------------------------------------------------------------ +Version 4.1.1 [Tue Sep 30 10:17:26 EDT 2008] + +* world.ss: big-bang can now be re-run after the world has stopped + ------------------------------------------------------------------------ Version 4.1 [Sun Aug 10 12:56:58 EDT 2008] diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 8f4a910d73..ff643ae59f 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -4,6 +4,8 @@ ** to make changes, edit that file and ** run it to generate an updated version ** of this file. + ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with + ** the scribble/text preprocessor instead. ********************************************/ @@ -2233,6 +2235,9 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar len, 0); } +/* *** Calling Scheme code while the GC is working leads to subtle bugs, so + *** this is implemented now in Scheme using will executors. */ + /* internal: apply Scheme finalizer */ void do_scm_finalizer(void *p, void *finalizer) { @@ -2263,9 +2268,6 @@ void do_ptr_finalizer(void *p, void *finalizer) /* (Only needed in cases where pointer aliases might be created.) */ /* - *** Calling Scheme code while the GC is working leads to subtle bugs, so - *** this is implemented now in Scheme using will executors. - (defsymbols pointer) (cdefine register-finalizer 2 3) { @@ -2519,7 +2521,7 @@ typedef struct closure_and_cif_struct { void free_cl_cif_args(void *ignored, void *p) { /* - scheme_warning("Releaseing cl+cif+args %V %V (%d)", + scheme_warning("Releasing cl+cif+args %V %V (%d)", ignored, (((closure_and_cif*)p)->data), SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); @@ -2530,6 +2532,44 @@ void free_cl_cif_args(void *ignored, void *p) free(p); } +/* This is a temporary hack to allocate a piece of executable memory, */ +/* it should be removed when mzscheme's core will include a similar function */ +#ifndef WINDOWS_DYNAMIC_LOAD +#include +#endif +void *malloc_exec(size_t size) { + static long pagesize = -1; + void *p, *pp; + if (pagesize == -1) { +#ifndef WINDOWS_DYNAMIC_LOAD + pagesize = getpagesize(); +#else + { + SYSTEM_INFO info; + GetSystemInfo(&info); + pagesize = info.dwPageSize; + } +#endif + } + p = malloc(size); + if (p == NULL) + scheme_signal_error("internal error: malloc failed (malloc_exec)"); + /* set pp to the beginning of the page */ + pp = (void*)(((long)p) & ~(pagesize-1)); + /* set size to a pagesize multiple, in case the block is more than a page */ + size = ((((long)p)+size+pagesize-1) & ~(pagesize-1)) - ((long)pp); +#ifndef WINDOWS_DYNAMIC_LOAD + if (mprotect(pp, size, PROT_READ|PROT_WRITE|PROT_EXEC)) + perror("malloc_exec mprotect failure"); +#else + { + DWORD old; + VirtualProtect(pp, size, PAGE_EXECUTE_READWRITE, &old); + } +#endif + return p; +} + /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2586,7 +2626,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); /* malloc space for everything needed, so a single free gets rid of this */ - cl_cif_args = malloc(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); + cl_cif_args = malloc_exec(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ cif = &(cl_cif_args->cif); atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index e3c2fe7757..e49d9bb5f4 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2513,10 +2513,19 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; + if (!env->genv->module && SCHEME_STXP(find_id)) { + /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); + if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) + modidx = NULL; /* yes, it is bound */ + } + + if (modidx) { + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context"); + return NULL; + } } if (modidx) { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 9b2fe75ef1..e9270db361 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6399,6 +6399,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, result = scheme_make_pair(result, scheme_null); SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); return scheme_expand_list(result, env, rec, drec); + } else { + result = scheme_make_pair(result, scheme_null); + return scheme_datum_to_syntax(result, forms, forms, 0, 0); } } } @@ -6420,6 +6423,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0); first = scheme_compile_expr(first, env, recs, 0); + #if EMBEDDED_DEFINES_START_ANYWHERE forms = scheme_compile_expand_block(rest, env, recs, 1); #else diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index d443cd80a4..e071a13ecb 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.0.4" +#define MZSCHEME_VERSION "4.1.1.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_Z 1 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 41a2e8ee5c..c483f01bc6 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3247,6 +3247,35 @@ static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object * return NULL; } +static int nonempty_rib(Scheme_Lexical_Rib *rib) +{ + rib = rib->next; + + while (rib) { + if (SCHEME_RENAME_LEN(rib->rename)) + return 1; + rib = rib->next; + } + + return 0; +} + +static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + while (skip_ribs) { + if (SAME_OBJ(SCHEME_CAR(skip_ribs), timestamp)) + return 1; + skip_ribs = SCHEME_CDR(skip_ribs); + } + + return 0; +} + +static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + return scheme_make_raw_pair(timestamp, skip_ribs); +} + #define QUICK_STACK_SIZE 10 #define EXPLAIN_RESOLVE 0 @@ -3275,7 +3304,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, If neither, result is #f and get_names[0] is either unchanged or NULL. */ { WRAP_POS wraps; - Scheme_Object *o_rename_stack = scheme_null; + Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; Scheme_Object *mresult = scheme_false; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *rename_stack[QUICK_STACK_SIZE]; @@ -3286,7 +3315,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; - EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))); + EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); if (_wraps) { WRAP_POS_COPY(wraps, *_wraps); @@ -3553,17 +3583,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) && !no_lexical)) { /* Lexical rename: */ - Scheme_Object *rename, *renamed, *recur_skip_ribs; + Scheme_Object *rename, *renamed; int ri, c, istart, iend, is_rib; if (rib) { rename = rib->rename; - recur_skip_ribs = rib->timestamp; rib = rib->next; is_rib = 1; } else { rename = WRAP_POS_FIRST(wraps); - recur_skip_ribs = skip_ribs; is_rib = 0; } @@ -3658,19 +3686,23 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); EXPLAIN(printf("Rib: %p...\n", rib)); if (skip_ribs) { - if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) { + if (in_skip_set(rib->timestamp, skip_ribs)) { EXPLAIN(printf("Skip rib\n")); rib = NULL; } } if (rib) { - if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(printf("Did rib\n")); - rib = NULL; - } else { - did_rib = rib; - rib = rib->next; /* First rib record has no rename */ - } + if (nonempty_rib(rib)) { + if (SAME_OBJ(did_rib, rib)) { + EXPLAIN(printf("Did rib\n")); + rib = NULL; + } else { + recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); + did_rib = rib; + rib = rib->next; /* First rib record has no rename */ + } + } else + rib = NULL; } } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { did_rib = NULL; @@ -4372,7 +4404,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS w; WRAP_POS prev; WRAP_POS w2; - Scheme_Object *stack = scheme_null, *key, *old_key; + Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; long size, vsize, psize, i, j, pos; @@ -4380,9 +4412,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca we can simplify it in the context of a particular wrap suffix. (But don't mutate the wrap list, because that will stomp on tables that might be needed by a propoagation.) + + In addition to depending on the rest of the wraps, a + simplifciation can depend on preceding wraps due to rib + skipping. So the lex_cache maps a wrap to another hash table that + maps a skip list to a simplified rename. A lex_cache maps wrap starts w to simplified tables. A lex_cache - is modified by this function, only. */ + is modified by this function, only, but it's also read in + datum_to_wraps. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); @@ -4396,9 +4434,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca key = WRAP_POS_KEY(w); if (!SAME_OBJ(key, old_key)) { v = scheme_hash_get(lex_cache, key); + if (v) + v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs); } else v = NULL; old_key = key; + orig_skip_ribs = skip_ribs; if (v) { /* Tables here are already simplified. */ @@ -4412,6 +4453,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ add = 1; + if (nonempty_rib((Scheme_Lexical_Rib *)v)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs); } else { /* Need to simplify this vector? */ if (SCHEME_VEC_SIZE(v) == 1) @@ -4425,7 +4468,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (add) { /* Need to simplify, but do deepest first: */ if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) { - stack = CONS(key, stack); + stack = CONS(CONS(key, orig_skip_ribs), stack); } } else { /* This is already simplified. Remember it and stop, because @@ -4442,8 +4485,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); + orig_skip_ribs = SCHEME_CDR(key); + key = SCHEME_CAR(key); v2l = scheme_null; + skip_ribs = orig_skip_ribs; + WRAP_POS_REVINIT(w, key); while (!WRAP_POS_REVEND_P(w)) { @@ -4460,14 +4507,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { init_rib = (Scheme_Lexical_Rib *)v; - skip_ribs = init_rib->timestamp; - rib = init_rib->next; - vsize = 0; - while (rib) { - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; - } - rib = init_rib->next; + if (nonempty_rib(init_rib)) + skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs); + rib = init_rib->next; + vsize = 0; + while (rib) { + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + rib = init_rib->next; } else vsize = SCHEME_RENAME_LEN(v); @@ -4611,7 +4659,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS_DEC(w); } - scheme_hash_set(lex_cache, key, v2l); + v = scheme_hash_get(lex_cache, key); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, key, v); + } + scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l); stack = SCHEME_CDR(stack); } @@ -4622,7 +4675,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Hash_Table *rns, int just_simplify) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null; + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; int stack_size = 0; @@ -4690,8 +4743,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, of simplified tables for the current wrap segment. */ if (SCHEME_NULLP(simplifies)) { simplifies = scheme_hash_get(lex_cache, old_key); + simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs); /* assert: a is not NULL; see the simplify_lex_rename() call above */ } + if (SCHEME_RIBP(a)) { + if (nonempty_rib((Scheme_Lexical_Rib *)a)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs); + } a = SCHEME_CAR(simplifies); /* used up one simplification: */ simplifies = SCHEME_CDR(simplifies); diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 4cd2a3bbbd..e095659f65 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -4464,6 +4464,9 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { +#if 0 + /* This attempt at a shortcut is wrong, because the sole expression might expand + to a `begin' that needs to be spliced into an internal-definition context. */ try_again: if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { @@ -4471,7 +4474,7 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Object *first, *val; first = SCHEME_STX_CAR(forms); - first = scheme_check_immediate_macro(first, env, rec, drec, 0, &val, NULL, NULL); + first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL); if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { /* Flatten begin: */ @@ -4485,17 +4488,18 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, } return scheme_compile_expr(first, env, rec, drec); + } +#endif + + if (scheme_stx_proper_list_length(forms) < 0) { + scheme_wrong_syntax(scheme_begin_stx_string, NULL, + scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), + "bad syntax (" IMPROPER_LIST_FORM ")"); + return NULL; } else { - if (scheme_stx_proper_list_length(forms) < 0) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, - scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), - "bad syntax (" IMPROPER_LIST_FORM ")"); - return NULL; - } else { - Scheme_Object *body; - body = scheme_compile_block(forms, env, rec, drec); - return scheme_make_sequence_compilation(body, 1); - } + Scheme_Object *body; + body = scheme_compile_block(forms, env, rec, drec); + return scheme_make_sequence_compilation(body, 1); } } diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 856377cb90..95ce4208bc 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@