From 15240d45ba56c7eaba473cf85e611e9715ac0c8b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 19 Dec 2008 06:22:21 +0000 Subject: [PATCH 01/25] removed the code, since it is no longer truly code that students in HtDP would likely produce, also waiting for the literate programming support to do a better job here svn: r12900 --- collects/games/scribblings/chat-noir.scrbl | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index 94f46d8a45..8f48886ccb 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -12,8 +12,14 @@ 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. +@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game +Design} and has essentially the same rules. It also inspired the final +project for the introductory programming course at the University of +Chicago in the fall of 2008. + +@;{ + +This is commented out, waiting for the literate programming stuff. This game is written in the @link["http://www.htdp.org/"]{How to Design Programs} @@ -54,3 +60,4 @@ the fall of 2008, as below. #:mode 'text)) @m[] +} \ No newline at end of file From 6b4b9fa1a18e24b979dcbcd38b1d24f134d19179 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 19 Dec 2008 06:29:26 +0000 Subject: [PATCH 02/25] improved the cat algorithm (fixed it really) and prepared things for more feedback about where the cat would like to go svn: r12902 --- collects/games/chat-noir/chat-noir-module.ss | 2 +- collects/games/chat-noir/chat-noir.ss | 819 ++++++++++++------- collects/games/chat-noir/hash.ss | 8 +- 3 files changed, 513 insertions(+), 316 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-module.ss b/collects/games/chat-noir/chat-noir-module.ss index b9b57bdd27..b00cff6de0 100644 --- a/collects/games/chat-noir/chat-noir-module.ss +++ b/collects/games/chat-noir/chat-noir-module.ss @@ -1,5 +1,5 @@ (module chat-noir-module lang/htdp-intermediate-lambda (require (lib "world.ss" "htdp")) - (require "hash.ss") +; (require "hash.ss") (require (lib "include.ss" "scheme")) (include "chat-noir.ss")) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index af8c67309a..2ecff2f226 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -1,7 +1,14 @@ +(require "hash.ss") + ;; constants (define circle-radius 20) (define circle-spacing 22) +(define normal-color 'lightskyblue) +(define on-shortest-path-color normal-color) +;(define on-shortest-path-color 'cornflowerblue) +(define blocked-color 'black) + ;; data definitions ;; a world is: @@ -47,7 +54,9 @@ ;; world->image : world -> image (define (world->image w) (chop-whiskers - (overlay (board->image (world-board w) (world-size w)) + (overlay (board->image (world-board w) + (world-size w) + (on-cats-path? w)) (move-pinhole (cond [(equal? (world-state w) 'cat-won) happy-cat] @@ -55,7 +64,7 @@ [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)) @@ -64,10 +73,12 @@ 2)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2) + 2 + (lambda (x) true)) (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)) @@ -76,10 +87,12 @@ 2)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2) + 2 + (lambda (x) true)) (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)) @@ -88,7 +101,8 @@ 2)) (overlay (board->image (list (make-cell (make-posn 0 1) false)) - 2) + 2 + (lambda (x) true)) (move-pinhole sad-cat (- (cell-center-x (make-posn 0 1))) (- (cell-center-y (make-posn 0 1)))))) @@ -111,65 +125,108 @@ (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)) + (empty-board 3) (make-posn 0 0) 'playing - 2))) + 3))) 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)) + (empty-board 3) (make-posn 0 1) 'playing - 2))) + 3))) 0) -;; board->image : board number -> image -(define (board->image cs world-size) +;; board->image : board number (posn -> boolean) -> image +(define (board->image cs world-size on-cat-path?) (foldl (lambda (x y) (overlay y x)) (nw:rectangle (world-width world-size) (world-height world-size) 'solid 'white) - (map cell->image cs))) + (map (lambda (c) (cell->image c (on-cat-path? (cell-p c)))) + cs))) -(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3) +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false)) (overlay (nw:rectangle (world-width 3) (world-height 3) 'solid 'white) - (cell->image (make-cell (make-posn 0 0) false)))) + (cell->image (make-cell (make-posn 0 0) false) + false))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) true)) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + true))) -;; cell->image : cell -> image -(define (cell->image c) +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) + 3 + (lambda (x) false)) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + 3 + (lambda (x) (equal? x (make-posn 0 1)))) + (overlay + (nw:rectangle (world-width 3) + (world-height 3) + 'solid + 'white) + (cell->image (make-cell (make-posn 0 0) false) + false) + (cell->image (make-cell (make-posn 0 1) false) + true))) + + +;; cell->image : cell boolean -> image +(define (cell->image c on-short-path?) (local [(define x (cell-center-x (cell-p c))) (define y (cell-center-y (cell-p c)))] (move-pinhole (cond + [on-short-path? + (circle circle-radius 'solid on-shortest-path-color)] [(cell-blocked? c) - (circle circle-radius 'solid 'black)] + (circle circle-radius 'solid blocked-color)] [else - (circle circle-radius 'solid 'lightblue)]) + (circle circle-radius 'solid normal-color)]) (- x) (- y)))) -(check-expect (cell->image (make-cell (make-posn 0 0) false)) - (move-pinhole (circle circle-radius 'solid 'lightblue) +(check-expect (cell->image (make-cell (make-posn 0 0) false) false) + (move-pinhole (circle circle-radius 'solid normal-color) (- circle-radius) (- circle-radius))) -(check-expect (cell->image (make-cell (make-posn 0 0) true)) +(check-expect (cell->image (make-cell (make-posn 0 0) true) false) (move-pinhole (circle circle-radius 'solid 'black) (- circle-radius) (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) false) true) + (move-pinhole (circle circle-radius 'solid on-shortest-path-color) + (- circle-radius) + (- circle-radius))) ;; world-width : number -> number ;; computes the width of the drawn world in terms of its size @@ -249,231 +306,227 @@ ;; - (make-dist-cell posn (number or '∞)) (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) + +;; build-bfs-table : world (or/c 'boundary posn) -> distance-table +(define (build-bfs-table world init-point) + (local [;; posn : posn + ;; dist : number + (define-struct queue-ent (posn dist)) + + (define neighbors/w (neighbors world)) + + (define (bfs queue dist-table) (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)] + [(empty? queue) dist-table] [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)))) + (local [(define hd (first queue))] + (cond + [(boolean? (hash-ref dist-table (queue-ent-posn hd) #f)) + (local [(define dist (queue-ent-dist hd)) + (define p (queue-ent-posn hd))] + (bfs + (append (rest queue) + (map (lambda (p) (make-queue-ent p (+ dist 1))) + (neighbors/w p))) + (hash-set dist-table p dist)))] + [else + (bfs (rest queue) dist-table)]))]))] + + (hash-map + (bfs (list (make-queue-ent init-point 0)) + (make-immutable-hash/list-init)) + make-dist-cell))) -;; build-table : world -> distance-map -(define (build-table world) - (build-distance (world-board world) - (world-cat world) - '() - '() - (world-size world))) +;; same-sets? : (listof X) (listof X) -> boolean +(define (same-sets? l1 l2) + (and (andmap (lambda (e1) (member e1 l2)) l1) + (andmap (lambda (e2) (member e2 l1)) l2))) -;; build-distance : board posn distance-map (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))])) +(check-expect (same-sets? (list) (list)) true) +(check-expect (same-sets? (list) (list 1)) false) +(check-expect (same-sets? (list 1) (list)) false) +(check-expect (same-sets? (list 1 2) (list 2 1)) true) -;; 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 or '∞) distance-map -> distance-map -(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 : distance-map 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)) +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3) + 'boundary) + (list + (make-dist-cell 'boundary 0) + + (make-dist-cell (make-posn 1 0) 1) + (make-dist-cell (make-posn 2 0) 1) + + (make-dist-cell (make-posn 0 1) 1) + (make-dist-cell (make-posn 1 1) 2) + (make-dist-cell (make-posn 2 1) 1) + + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 2) 1))) true) -(check-expect (in-table? (list (make-dist-cell (make-posn 2 1) 3)) - (make-posn 1 2)) - false) + +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3) + (make-posn 1 1)) + (list + (make-dist-cell 'boundary 2) + + (make-dist-cell (make-posn 1 0) 1) + (make-dist-cell (make-posn 2 0) 1) + + (make-dist-cell (make-posn 0 1) 1) + (make-dist-cell (make-posn 1 1) 0) + (make-dist-cell (make-posn 2 1) 1) + + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 2) 1))) + true) + +(check-expect (same-sets? + (build-bfs-table (make-world (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) + 'playing + 3) + 'boundary) + (list + (make-dist-cell 'boundary 0))) + true) + +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 5) + (make-posn 2 2) + 'playing + 5) + 'boundary) + (list + (make-dist-cell 'boundary 0) + + (make-dist-cell (make-posn 1 0) 1) + (make-dist-cell (make-posn 2 0) 1) + (make-dist-cell (make-posn 3 0) 1) + (make-dist-cell (make-posn 4 0) 1) + + (make-dist-cell (make-posn 0 1) 1) + (make-dist-cell (make-posn 1 1) 2) + (make-dist-cell (make-posn 2 1) 2) + (make-dist-cell (make-posn 3 1) 2) + (make-dist-cell (make-posn 4 1) 1) + + (make-dist-cell (make-posn 0 2) 1) + (make-dist-cell (make-posn 1 2) 2) + (make-dist-cell (make-posn 2 2) 3) + (make-dist-cell (make-posn 3 2) 2) + (make-dist-cell (make-posn 4 2) 1) + + (make-dist-cell (make-posn 0 3) 1) + (make-dist-cell (make-posn 1 3) 2) + (make-dist-cell (make-posn 2 3) 2) + (make-dist-cell (make-posn 3 3) 2) + (make-dist-cell (make-posn 4 3) 1) + + + (make-dist-cell (make-posn 1 4) 1) + (make-dist-cell (make-posn 2 4) 1) + (make-dist-cell (make-posn 3 4) 1) + (make-dist-cell (make-posn 4 4) 1))) + true) + +(check-expect (same-sets? + (build-bfs-table (make-world (block-cell + (make-posn 4 2) + (empty-board 5)) + (make-posn 2 2) + 'playing + 5) + 'boundary) + (list + (make-dist-cell 'boundary 0) + + (make-dist-cell (make-posn 1 0) 1) + (make-dist-cell (make-posn 2 0) 1) + (make-dist-cell (make-posn 3 0) 1) + (make-dist-cell (make-posn 4 0) 1) + + (make-dist-cell (make-posn 0 1) 1) + (make-dist-cell (make-posn 1 1) 2) + (make-dist-cell (make-posn 2 1) 2) + (make-dist-cell (make-posn 3 1) 2) + (make-dist-cell (make-posn 4 1) 1) + + (make-dist-cell (make-posn 0 2) 1) + (make-dist-cell (make-posn 1 2) 2) + (make-dist-cell (make-posn 2 2) 3) + (make-dist-cell (make-posn 3 2) 3) + + (make-dist-cell (make-posn 0 3) 1) + (make-dist-cell (make-posn 1 3) 2) + (make-dist-cell (make-posn 2 3) 2) + (make-dist-cell (make-posn 3 3) 2) + (make-dist-cell (make-posn 4 3) 1) + + + (make-dist-cell (make-posn 1 4) 1) + (make-dist-cell (make-posn 2 4) 1) + (make-dist-cell (make-posn 3 4) 1) + (make-dist-cell (make-posn 4 4) 1))) + true) + +(check-expect (same-sets? + (build-bfs-table (make-world (empty-board 5) + (make-posn 2 2) + 'playing + 5) + (make-posn 2 2)) + (list + (make-dist-cell 'boundary 3) + + (make-dist-cell (make-posn 1 0) 2) + (make-dist-cell (make-posn 2 0) 2) + (make-dist-cell (make-posn 3 0) 2) + (make-dist-cell (make-posn 4 0) 3) + + (make-dist-cell (make-posn 0 1) 2) + (make-dist-cell (make-posn 1 1) 1) + (make-dist-cell (make-posn 2 1) 1) + (make-dist-cell (make-posn 3 1) 2) + (make-dist-cell (make-posn 4 1) 3) + + (make-dist-cell (make-posn 0 2) 2) + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 2) 0) + (make-dist-cell (make-posn 3 2) 1) + (make-dist-cell (make-posn 4 2) 2) + + (make-dist-cell (make-posn 0 3) 2) + (make-dist-cell (make-posn 1 3) 1) + (make-dist-cell (make-posn 2 3) 1) + (make-dist-cell (make-posn 3 3) 2) + (make-dist-cell (make-posn 4 3) 3) + + + (make-dist-cell (make-posn 1 4) 2) + (make-dist-cell (make-posn 2 4) 2) + (make-dist-cell (make-posn 3 4) 2) + (make-dist-cell (make-posn 4 4) 3))) + true) + +(check-expect (lookup-in-table + (build-bfs-table (make-world (empty-board 5) + (make-posn 2 2) + 'playing + 5) + (make-posn 2 2)) + (make-posn 1 4)) + 2) + ;; lookup-in-table : distance-map posn -> number or '∞ ;; looks for the distance as recorded in the table t, @@ -495,40 +548,123 @@ (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) +;; on-cats-path? : world -> posn -> boolean +;; returns true when the posn is on the shortest path +;; from the cat to the edge of the board, in the given world +(define (on-cats-path? w) + (local [(define edge-distance-map (build-bfs-table w 'boundary)) + (define cat-distance-map (build-bfs-table w (world-cat w))) + (define cat-distance (lookup-in-table edge-distance-map + (world-cat w)))] + (lambda (p) + (equal? (+/f (lookup-in-table cat-distance-map p) + (lookup-in-table edge-distance-map p)) + cat-distance)))) + +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5)) + (make-posn 1 0)) + true) +(check-expect ((on-cats-path? (make-world (empty-board 5) (make-posn 1 1) 'playing 5)) + (make-posn 2 1)) + false) + +;; neighbors : world (or/c 'boundary posn) -> (listof (or/c 'boundary posn)) +;; computes the neighbors of a posn, for a given board size +(define (neighbors w) + (local [(define blocked (map cell-p + (filter cell-blocked? + (world-board w)))) + (define boundary-cells (filter (lambda (p) + (and (not (member p blocked)) + (on-boundary? p (world-size w)))) + (map cell-p (world-board w))))] + (lambda (p) + (cond + [(member p blocked) + '()] + [(equal? p 'boundary) + boundary-cells] + [else + (local [(define x (posn-x p)) + (define y (posn-y p)) + (define adjacent-posns (adjacent p (world-size w))) + (define in-bounds + (filter (lambda (x) (in-bounds? x (world-size w))) + adjacent-posns))] + (filter + (lambda (x) (not (member x blocked))) + (cond + [(equal? in-bounds adjacent-posns) + in-bounds] + [else + (cons 'boundary in-bounds)])))])))) + +(check-expect ((neighbors (empty-world 11)) (make-posn 1 1)) + (adjacent (make-posn 1 1) 11)) +(check-expect ((neighbors (empty-world 11)) (make-posn 2 2)) + (adjacent (make-posn 2 2) 11)) +(check-expect ((neighbors (empty-world 3)) 'boundary) + (list (make-posn 0 1) + (make-posn 1 0) + (make-posn 1 2) + (make-posn 2 0) + (make-posn 2 1) + (make-posn 2 2))) +(check-expect ((neighbors (empty-world 11)) (make-posn 1 0)) + (list 'boundary + (make-posn 2 0) + (make-posn 0 1) + (make-posn 1 1))) +(check-expect ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (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) + 'playing + 3)) + (make-posn 1 1)) + '()) +(check-expect ((neighbors (make-world (list + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) true) + (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) + 'playing + 3)) + (make-posn 1 0)) + (list 'boundary (make-posn 2 0) (make-posn 0 1))) + ;; adjacent : posn number -> (listof posn) +;; returns a list of the posns that are adjacent to +;; `p' on an infinite hex grid (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)))])))) + (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) @@ -545,6 +681,23 @@ (make-posn 1 3) (make-posn 2 3))) + + +;; 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) + + ;; in-bounds? : posn number -> boolean (define (in-bounds? p board-size) (and (<= 0 (posn-x p) (- board-size 1)) @@ -562,37 +715,29 @@ (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 '∞) -> boolean -(define (<=/f a b) (equal? a (min/f a b))) +(define (<=/f a b) + (cond + [(equal? b '∞) true] + [(equal? a '∞) false] + [else (<= 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) +(define (+/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) + [(or (equal? x '∞) (equal? y '∞)) + '∞] + [else + (+ x y)])) -;; 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 '∞) '∞) +(check-expect (+/f '∞ '∞) '∞) +(check-expect (+/f '∞ 1) '∞) +(check-expect (+/f 1 '∞) '∞) +(check-expect (+/f 1 2) 3) ; ; @@ -675,7 +820,7 @@ ;; move-cat : world -> world (define (move-cat world) (local [(define cat-position (world-cat world)) - (define table (build-table/fast world)) + (define table (build-bfs-table world 'boundary)) (define neighbors (adjacent cat-position (world-size world))) (define next-cat-positions (find-best-positions neighbors @@ -1003,38 +1148,84 @@ (random (length unblocked-cells))))] (add-n-random-blocked-cells (sub1 n) - (map (lambda (c) (if (equal? to-block c) - (make-cell (cell-p c) true) - c)) - all-cells) + (block-cell (cell-p to-block) all-cells) board-size))])) +;; block-cell : posn board -> board +(define (block-cell to-block board) + (map (lambda (c) (if (equal? to-block (cell-p c)) + (make-cell to-block true) + c)) + board)) +(check-expect (block-cell (make-posn 1 1) + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 2) false))) + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 2) false))) + (check-expect (add-n-random-blocked-cells 0 (list (make-cell (make-posn 0 0) true)) 10) (list (make-cell (make-posn 0 0) true))) (check-expect (add-n-random-blocked-cells 1 (list (make-cell (make-posn 0 0) false)) 10) (list (make-cell (make-posn 0 0) true))) +;; empty-board : number -> (listof cell) +(define (empty-board board-size) + (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) + (make-cell (make-posn i j) + false)))))))) + +(check-expect (empty-board 3) + (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))) + +;; empty-world : number -> world +(define (empty-world board-size) + (make-world (empty-board board-size) + (make-posn (quotient board-size 2) + (quotient board-size 2)) + 'playing + board-size)) + +(check-expect (empty-world 3) + (make-world (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) + 'playing + 3)) + (define dummy (local [(define board-size 11) (define initial-board (add-n-random-blocked-cells 6 - (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) - (make-cell (make-posn i j) - false))))))) + (empty-board board-size) board-size)) (define initial-world (make-world initial-board @@ -1043,7 +1234,7 @@ 'playing board-size))] - (and ;((lambda (x) true) (time (build-table initial-world))) ;((lambda (x) true) (time (build-table/fast initial-world))) + (and (big-bang (world-width board-size) (world-height board-size) 1 diff --git a/collects/games/chat-noir/hash.ss b/collects/games/chat-noir/hash.ss index 8903bb9415..c072a052aa 100644 --- a/collects/games/chat-noir/hash.ss +++ b/collects/games/chat-noir/hash.ss @@ -1,2 +1,8 @@ #lang scheme/base -(provide make-hash hash-set! hash-ref hash-map) +(provide make-immutable-hash/list-init + hash-set hash-ref hash-map) + +(define (make-immutable-hash/list-init [init '()]) + (make-immutable-hash + (map (λ (x) (cons (car x) (cadr x))) + init))) From 441265278470e6d9530fcfa68d43a5019ddecaa5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 19 Dec 2008 08:50:17 +0000 Subject: [PATCH 03/25] Welcome to a new PLT day. svn: r12903 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 12fc3fd4b8..8480331818 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18dec2008") +#lang scheme/base (provide stamp) (define stamp "19dec2008") From 064776348a4529b30f497376b98bd0ae95e45807 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 17:16:39 +0000 Subject: [PATCH 04/25] fix ready-toplevel optimization svn: r12905 --- collects/compiler/decompile.ss | 4 ++-- collects/compiler/zo-parse.ss | 6 +++--- src/mzscheme/src/env.c | 7 +++++-- src/mzscheme/src/eval.c | 13 ++++++++++++- src/mzscheme/src/module.c | 23 ++++++++++++++--------- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/syntax.c | 2 +- 7 files changed, 38 insertions(+), 19 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index 99336c5e37..c78d310a40 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -172,9 +172,9 @@ (define (decompile-expr expr globs stack closed) (match expr - [(struct toplevel (depth pos const? mutated?)) + [(struct toplevel (depth pos const? ready?)) (let ([id (list-ref/protect globs pos 'toplevel)]) - (if const? + (if (or const? ready?) id `(#%checked ,id)))] [(struct topsyntax (depth pos midpt)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 41366dafdb..00c1a5dbb2 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -37,7 +37,7 @@ (define-form-struct localref (unbox? offset clear?)) ; access local via stack -(define-form-struct toplevel (depth pos const? mutated?)) ; access binding via prefix array (which is on stack) +(define-form-struct toplevel (depth pos const? ready?)) ; access binding via prefix array (which is on stack) (define-form-struct topsyntax (depth pos midpt)) ; access syntax object via prefix array (which is on stack) (define-form-struct application (rator rands)) ; function call @@ -68,12 +68,12 @@ (define (read-toplevel v) (define SCHEME_TOPLEVEL_CONST #x01) - (define SCHEME_TOPLEVEL_MUTATED #x02) + (define SCHEME_TOPLEVEL_READY #x02) (match v [(cons depth (cons pos flags)) (make-toplevel depth pos (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST)) - (positive? (bitwise-and flags SCHEME_TOPLEVEL_MUTATED)))] + (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))] [(cons depth pos) (make-toplevel depth pos #f #f)])) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 3b467e7e66..d39eaef82c 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -3690,7 +3690,7 @@ int scheme_resolve_quote_syntax_pos(Resolve_Info *info) return info->prefix->num_toplevels; } -Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr) +Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready) { int skip; @@ -3699,7 +3699,10 @@ Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr) return make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */ SCHEME_TOPLEVEL_POS(expr), 1, - SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_CONST); + SCHEME_TOPLEVEL_FLAGS(expr) & (SCHEME_TOPLEVEL_CONST + | (keep_ready + ? SCHEME_TOPLEVEL_READY + : 0))); } Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 5fb9529f3c..70013d0363 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -778,6 +778,17 @@ int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, } } + if (vtype == scheme_compiled_toplevel_type) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (SCHEME_TOPLEVEL_FLAGS(o) + & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)) + return 1; + else + return 0; + } + } + if ((vtype == scheme_syntax_type) && (SCHEME_PINT_VAL(o) == CASE_LAMBDA_EXPD)) { note_match(1, vals, warn_info); @@ -1906,7 +1917,7 @@ Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) case scheme_compiled_let_void_type: return scheme_resolve_lets(expr, info); case scheme_compiled_toplevel_type: - return scheme_resolve_toplevel(info, expr); + return scheme_resolve_toplevel(info, expr, 1); case scheme_compiled_quote_syntax_type: { Scheme_Quote_Syntax *qs; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index a1c2b39b40..28156d0998 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4803,7 +4803,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info) int start_simltaneous = 0, i_m, cnt; Scheme_Object *cl_first = NULL, *cl_last = NULL; Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL; - int cont; + int cont, next_pos_ready = -1; old_context = info->context; info->context = (Scheme_Object *)m; @@ -4887,14 +4887,8 @@ module_optimize(Scheme_Object *data, Optimize_Info *info) /* Test for ISCONST to indicate no set!: */ if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { pos = SCHEME_TOPLEVEL_POS(a); - - if (!ready_table) { - ready_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); - } - scheme_hash_set(ready_table, scheme_make_integer(pos), scheme_true); + + next_pos_ready = pos; } } } @@ -4966,6 +4960,17 @@ module_optimize(Scheme_Object *data, Optimize_Info *info) re_consts = NULL; start_simltaneous = i_m + 1; } + + if (next_pos_ready > -1) { + if (!ready_table) { + ready_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); + } + scheme_hash_set(ready_table, scheme_make_integer(next_pos_ready), scheme_true); + next_pos_ready = -1; + } } /* Check one more time for expressions that we can omit: */ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 798d84c3ec..0ff2debbc0 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2225,7 +2225,7 @@ int scheme_resolve_toplevel_pos(Resolve_Info *info); int scheme_resolve_is_toplevel_available(Resolve_Info *info); int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info); int scheme_resolve_quote_syntax_pos(Resolve_Info *info); -Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr); +Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready); Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info); Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl); Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta); diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 85a738ce65..00c61b81ee 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1010,7 +1010,7 @@ define_values_resolve(Scheme_Object *data, Resolve_Info *rslv) && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) { a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST); } - a = scheme_resolve_toplevel(rslv, a); + a = scheme_resolve_toplevel(rslv, a, 0); SCHEME_CAR(l) = a; cnt++; } From 23e8624e4143eb309de76426b3ef65d98f4b271d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 20:58:56 +0000 Subject: [PATCH 05/25] fix the test-suite sandbox svn: r12907 --- collects/tests/mzscheme/testing.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index cb60a31e5a..1f29258597 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -79,11 +79,12 @@ transcript. (define (load-in-sandbox file) (define-syntax-rule (S id) (dynamic-require 'scheme/sandbox 'id)) (let ([e ((S call-with-trusted-sandbox-configuration) - (parameterize ([(S sandbox-input) current-input-port] - [(S sandbox-output) current-output-port] - [(S sandbox-error-output) current-error-port] - [(S sandbox-memory-limit) 100]) ; 100mb per box - ((S make-evaluator) '(begin) #:requires (list 'scheme))))]) + (lambda () + (parameterize ([(S sandbox-input) current-input-port] + [(S sandbox-output) current-output-port] + [(S sandbox-error-output) current-error-port] + [(S sandbox-memory-limit) 100]) ; 100mb per box + ((S make-evaluator) '(begin) #:requires (list 'scheme)))))]) (e `(load-relative "testing.ss")) (e `(define real-error-port (quote ,real-error-port))) (e `(define Section-prefix ,Section-prefix)) From 3773b48ca9693e606716e162838024634424fff3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 21:11:02 +0000 Subject: [PATCH 06/25] fix accounting bug svn: r12908 --- src/mzscheme/gc2/mem_account.c | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 55c611894e..74bc79e794 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -213,7 +213,7 @@ inline static void clean_up_owner_table(NewGC *gc) inline static unsigned long custodian_usage(NewGC*gc, void *custodian) { - OTEntry **owner_table = gc->owner_table; + OTEntry **owner_table; unsigned long retval = 0; int i; @@ -226,6 +226,8 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian) } i = custodian_to_owner_set(gc, (Scheme_Custodian *)custodian); + + owner_table = gc->owner_table; if (owner_table[i]) retval = owner_table[i]->memory_use; else From 69556b1881da5f75f1350c22e7824632ba6be560 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Fri, 19 Dec 2008 21:14:36 +0000 Subject: [PATCH 07/25] Updated planet utility to accept full grammar for scribblings field in info.ss svn: r12909 --- collects/planet/util.ss | 78 +++++++++++++++++++++++++++++------------ 1 file changed, 56 insertions(+), 22 deletions(-) diff --git a/collects/planet/util.ss b/collects/planet/util.ss index 95ad315ad7..e53dc52ec6 100644 --- a/collects/planet/util.ss +++ b/collects/planet/util.ss @@ -299,6 +299,44 @@ ;; or the scribble renderer gets very confused (define SCRIBBLE-DOCUMENT-DIR "planet-docs/") +;; scribble-entry? : Any -> Boolean +;; Recognizes valid list entries in info.ss's scribblings field. +(define scribble-entry? + (match-lambda + [(or (list (? string?)) + (list (? string?) (? scribble-flags?)) + (list (? string?) (? scribble-flags?) (? scribble-category?)) + (list (? string?) (? scribble-flags?) (? scribble-category?) (? string?))) + #t] + [_ #f])) + +;; scribble-flags? : Any -> Boolean +;; Recognizes a list of flags from an info.ss scribblings entry. +(define scribble-flags? + (match-lambda + [(list (? symbol?) ...) #t] + [_ #f])) + +;; scribble-category : Any -> Boolean +;; Recognizes a category descriptor from an info.ss scribblings entry. +(define scribble-category? + (match-lambda + [(or (list (? symbol?)) + (list (? symbol?) (? real?))) #t] + [_ #f])) + +;; scribble-entry-file : ScribbleEntry -> String +;; Produces the filename of an info.ss scribblings entry. +(define scribble-entry-file + (match-lambda [(list file _ ...) file])) + +;; scribble-entry-flags : ScribbleEntry -> (Listof Symbol) +;; Produces the list of flags from an info.ss scribblings entry. +(define scribble-entry-flags + (match-lambda + [(list _) null] + [(list _ flags _ ...) flags])) + ;; make-planet-archive: path [path] -> path ;; Makes a .plt archive file suitable for PLaneT whose contents are ;; all files in the given directory and returns that file's name. @@ -327,7 +365,7 @@ (λ (bad) (set! warnings (cons bad warnings))) (λ (err) (set! critical-errors (cons err critical-errors))))]) (or real-info (λ (x [y (λ () (error 'info.ss (format "undefined field: ~a" x)))]) (y))))) - + (let ([scribble-files (info.ss 'scribblings (λ () '()))]) (define (outdir file-str) @@ -346,21 +384,22 @@ (error (format "malformed scribblings field; expected (listof (list string (listof symbol))), received ~e" scribble-files))) (for ([entry scribble-files]) - (match entry - [`(,(? string? filename) (,(? symbol? flags) ...)) - (unless (and (relative-path? filename) - (subpath? abs-dir filename) - (bytes=? (filename-extension filename) #"scrbl")) - (error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory")) - (unless (file-exists? (build-path abs-dir filename)) - (error (format "scribblings file ~a not found" filename))) - (printf "Building: ~a\n" filename) - (let* ([name.scrbl (file-name-from-path filename)] - [name (path-replace-suffix name.scrbl #"")]) - (render (build-path filename) - (build-path SCRIBBLE-DOCUMENT-DIR name) - (memq 'multi-page flags)))] - [_ (error "malformed scribblings entry")]))))) + (unless (scribble-entry? entry) + (error "malformed scribblings entry")) + (let* ([filename (scribble-entry-file entry)] + [flags (scribble-entry-flags entry)]) + (unless (and (relative-path? filename) + (subpath? abs-dir filename) + (bytes=? (filename-extension filename) #"scrbl")) + (error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory")) + (unless (file-exists? (build-path abs-dir filename)) + (error (format "scribblings file ~a not found" filename))) + (printf "Building: ~a\n" filename) + (let* ([name.scrbl (file-name-from-path filename)] + [name (path-replace-suffix name.scrbl #"")]) + (render (build-path filename) + (build-path SCRIBBLE-DOCUMENT-DIR name) + (memq 'multi-page flags)))))))) (unless (or (null? critical-errors) @@ -591,12 +630,7 @@ [scribblings (lambda (s) (and (list? s) - (andmap - (lambda (item) - (match item - [`(,(? string?) (,(? symbol?) ...)) #t] - [_ #f])) - s))) + (andmap scribble-entry? s))) (void) (unless scribblings (warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))] From 9ea047a05e1b1f033b3ba0815a86b74201cf17a0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 23:39:55 +0000 Subject: [PATCH 08/25] fix ptr-set! to allow installing function points into an offset cpointer svn: r12910 --- src/foreign/foreign.c | 18 +++++++++++------- src/foreign/foreign.ssc | 18 +++++++++++------- 2 files changed, 22 insertions(+), 14 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 0518cd0397..53c08951b5 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2166,13 +2166,15 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); else size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 3) { - scheme_signal_error - (MYNAME": setting fpointer value with extra arguments"); - } else if (SCHEME_CPTRP(argv[0])) { - ptr = SCHEME_CPTR_VAL(argv[0]); + if (SCHEME_CPTRP(argv[0])) { + /* offset is ok */ } else if SCHEME_FFIOBJP(argv[0]) { + if (argc > 3) { + scheme_signal_error + (MYNAME": cannot set fpointer value with offset"); + } ptr = ((ffi_obj_struct*)(argv[0]))->obj; } else { scheme_signal_error @@ -2183,9 +2185,11 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 4) { + } + + if (argc > 4) { if (!SAME_OBJ(argv[2],abs_sym)) - scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); + scheme_wrong_type(MYNAME, "'abs", 2, argc, argv); if (!SCHEME_INTP(argv[3])) scheme_wrong_type(MYNAME, "integer", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index fc8193244b..95f5ad4abd 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1616,13 +1616,15 @@ static Scheme_Object *do_memop(const char *who, int mode, if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); else size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 3) { - scheme_signal_error - (MYNAME": setting fpointer value with extra arguments"); - } else if (SCHEME_CPTRP(argv[0])) { - ptr = SCHEME_CPTR_VAL(argv[0]); + if (SCHEME_CPTRP(argv[0])) { + /* offset is ok */ } else if SCHEME_FFIOBJP(argv[0]) { + if (argc > 3) { + scheme_signal_error + (MYNAME": cannot set fpointer value with offset"); + } ptr = ((ffi_obj_struct*)(argv[0]))->obj; } else { scheme_signal_error @@ -1633,9 +1635,11 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 4) { + } + + if (argc > 4) { if (!SAME_OBJ(argv[2],abs_sym)) - scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); + scheme_wrong_type(MYNAME, "'abs", 2, argc, argv); if (!SCHEME_INTP(argv[3])) scheme_wrong_type(MYNAME, "integer", 3, argc, argv); delta += SCHEME_INT_VAL(argv[3]); From 7dc56df9499127695e4fc09d754bdd4cdd411fa5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 23:59:33 +0000 Subject: [PATCH 09/25] add FFI types _string/utf-16/null and _string/ucs-4/null svn: r12911 --- collects/mzlib/foreign.ss | 5 +- collects/scribblings/foreign/types.scrbl | 17 +++- src/foreign/foreign.c | 115 +++++++++++++++++++++-- src/foreign/foreign.ssc | 31 +++++- 4 files changed, 152 insertions(+), 16 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index fa2520d35e..a945f09967 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -680,8 +680,9 @@ ;; String types ;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type (note: these do not use #f as NULL). -(provide _string/ucs-4 _string/utf-16) +;; utf-16 type (note: the non-/null variants do not use #f as NULL). +(provide _string/ucs-4 _string/utf-16 + _string/ucs-4/null _string/utf-16/null) ;; 8-bit string encodings, #f is NULL (define ((false-or-op op) x) (and x (op x))) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 064b494d7f..b2d83ec418 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -163,15 +163,24 @@ strings, which corresponds to C's @cpp{char*} type. In addition to translating byte strings, @scheme[#f] corresponds to the @cpp{NULL} pointer. -@defthing[_string/ucs-4 ctype?]{ +@deftogether[( +@defthing[_string/ucs-4 ctype?] +@defthing[_string/ucs-4/null ctype?] +)]{ A type for Scheme's native Unicode strings, which are in UCS-4 format. -These correspond to the C @cpp{mzchar*} type used by PLT Scheme.} +These correspond to the C @cpp{mzchar*} type used by PLT Scheme. The +@schemeidfont{/null} variant treats @scheme[#f] as @cpp{NULL} and +vice-versa.} -@defthing[_string/utf-16 ctype?]{ +@deftogether[( +@defthing[_string/utf-16 ctype?] +@defthing[_string/utf-16/null ctype?] +)]{ -Unicode strings in UTF-16 format.} +Unicode strings in UTF-16 format. The @schemeidfont{/null} variant +treats @scheme[#f] as @cpp{NULL} and vice-versa.} @defthing[_path ctype?]{ diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 53c08951b5..f29da13eb9 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -461,7 +461,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) #endif #endif -unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) +#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o)) + +static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs) +{ + if (SCHEME_FALSEP(ucs)) return NULL; + return SCHEME_CHAR_STR_VAL(ucs); +} + +static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) { long ulen; unsigned short *res; @@ -471,11 +479,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) return res; } +static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs) +{ + if (SCHEME_FALSEP(ucs)) return NULL; + return ucs4_string_to_utf16_pointer(ucs); +} + Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) { long ulen; mzchar *res; int end; + if (!utf) return scheme_false; for (end=0; utf[end] != 0; end++) { /**/ } res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0); return scheme_make_sized_char_string(res, ulen, 0); @@ -696,7 +711,17 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: scheme_make_char_string_without_copying() */ -#define FOREIGN_string_utf_16 (19) +#define FOREIGN_string_ucs_4_null (19) +/* Type Name: string/ucs-4/null (string_ucs_4_null) + * LibFfi type: ffi_type_pointer + * C type: mzchar* + * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() + * Scheme->C: ucs4_string_or_null_to_ucs4_pointer() + * S->C offset: 0 + * C->Scheme: scheme_make_char_string_without_copying() + */ + +#define FOREIGN_string_utf_16 (20) /* Type Name: string/utf-16 (string_utf_16) * LibFfi type: ffi_type_pointer * C type: unsigned short* @@ -706,10 +731,20 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: utf16_pointer_to_ucs4_string() */ +#define FOREIGN_string_utf_16_null (21) +/* Type Name: string/utf-16/null (string_utf_16_null) + * LibFfi type: ffi_type_pointer + * C type: unsigned short* + * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() + * Scheme->C: ucs4_string_or_null_to_utf16_pointer() + * S->C offset: 0 + * C->Scheme: utf16_pointer_to_ucs4_string() + */ + /* Byte strings -- not copying C strings, #f is NULL. * (note: these are not like char* which is just a pointer) */ -#define FOREIGN_bytes (20) +#define FOREIGN_bytes (22) /* Type Name: bytes * LibFfi type: ffi_type_pointer * C type: char* @@ -719,7 +754,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: (==NULL)?scheme_false:scheme_make_byte_string_without_copying() */ -#define FOREIGN_path (21) +#define FOREIGN_path (23) /* Type Name: path * LibFfi type: ffi_type_pointer * C type: char* @@ -729,7 +764,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * C->Scheme: (==NULL)?scheme_false:scheme_make_path_without_copying() */ -#define FOREIGN_symbol (22) +#define FOREIGN_symbol (24) /* Type Name: symbol * LibFfi type: ffi_type_pointer * C type: char* @@ -742,7 +777,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* This is for any C pointer: #f is NULL, cpointer values as well as * ffi-obj and string values pass their pointer. When used as a return * value, either a cpointer object or #f is returned. */ -#define FOREIGN_pointer (23) +#define FOREIGN_pointer (25) /* Type Name: pointer * LibFfi type: ffi_type_pointer * C type: void* @@ -754,7 +789,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* This is used for passing and Scheme_Object* value as is. Useful for * functions that know about Scheme_Object*s, like MzScheme's. */ -#define FOREIGN_scheme (24) +#define FOREIGN_scheme (26) /* Type Name: scheme * LibFfi type: ffi_type_pointer * C type: Scheme_Object* @@ -767,7 +802,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /* Special type, not actually used for anything except to mark values * that are treated like pointers but not referenced. Used for * creating function types. */ -#define FOREIGN_fpointer (25) +#define FOREIGN_fpointer (27) /* Type Name: fpointer * LibFfi type: ffi_type_pointer * C type: -none- @@ -795,7 +830,9 @@ typedef union _ForeignAny { double x_doubleS; int x_bool; mzchar* x_string_ucs_4; + mzchar* x_string_ucs_4_null; unsigned short* x_string_utf_16; + unsigned short* x_string_utf_16_null; char* x_bytes; char* x_path; char* x_symbol; @@ -804,7 +841,7 @@ typedef union _ForeignAny { } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ -#define FOREIGN_struct (26) +#define FOREIGN_struct (28) /*****************************************************************************/ /* Type objects */ @@ -925,7 +962,9 @@ static int ctype_sizeof(Scheme_Object *type) case FOREIGN_doubleS: return sizeof(double); case FOREIGN_bool: return sizeof(int); case FOREIGN_string_ucs_4: return sizeof(mzchar*); + case FOREIGN_string_ucs_4_null: return sizeof(mzchar*); case FOREIGN_string_utf_16: return sizeof(unsigned short*); + case FOREIGN_string_utf_16_null: return sizeof(unsigned short*); case FOREIGN_bytes: return sizeof(char*); case FOREIGN_path: return sizeof(char*); case FOREIGN_symbol: return sizeof(char*); @@ -1201,7 +1240,9 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_doubleS: return scheme_make_double(REF_CTYPE(double)); case FOREIGN_bool: return (REF_CTYPE(int)?scheme_true:scheme_false); case FOREIGN_string_ucs_4: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*)); + case FOREIGN_string_ucs_4_null: return scheme_make_char_string_without_copying(REF_CTYPE(mzchar*)); case FOREIGN_string_utf_16: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*)); + case FOREIGN_string_utf_16_null: return utf16_pointer_to_ucs4_string(REF_CTYPE(unsigned short*)); case FOREIGN_bytes: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_byte_string_without_copying(REF_CTYPE(char*)); case FOREIGN_path: return (REF_CTYPE(char*)==NULL)?scheme_false:scheme_make_path_without_copying(REF_CTYPE(char*)); case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*)); @@ -1465,6 +1506,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_wrong_type("Scheme->C","string/ucs-4",0,1,&(val)); return NULL; /* hush the compiler */ } + case FOREIGN_string_ucs_4_null: +#ifdef SCHEME_BIG_ENDIAN + if (sizeof(mzchar*)C","string/ucs-4/null",0,1,&(val)); + return NULL; /* hush the compiler */ + } case FOREIGN_string_utf_16: #ifdef SCHEME_BIG_ENDIAN if (sizeof(unsigned short*)C","string/utf-16",0,1,&(val)); return NULL; /* hush the compiler */ } + case FOREIGN_string_utf_16_null: +#ifdef SCHEME_BIG_ENDIAN + if (sizeof(unsigned short*)C","string/utf-16/null",0,1,&(val)); + return NULL; /* hush the compiler */ + } case FOREIGN_bytes: #ifdef SCHEME_BIG_ENDIAN if (sizeof(char*)scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("string/ucs-4/null"); + t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); + t->so.type = ctype_tag; + t->basetype = (s); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4_null); + scheme_add_global("_string/ucs-4/null", (Scheme_Object*)t, menv); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; @@ -2908,6 +2998,13 @@ void scheme_init_foreign(Scheme_Env *env) t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); + s = scheme_intern_symbol("string/utf-16/null"); + t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); + t->so.type = ctype_tag; + t->basetype = (s); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16_null); + scheme_add_global("_string/utf-16/null", (Scheme_Object*)t, menv); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 95f5ad4abd..c83fd900ff 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -392,7 +392,15 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) #endif #endif -unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) +#define SCHEME_FALSEP_OR_CHAR_STRINGP(o) (SCHEME_FALSEP(o) || SCHEME_CHAR_STRINGP(o)) + +static mzchar *ucs4_string_or_null_to_ucs4_pointer(Scheme_Object *ucs) +{ + if (SCHEME_FALSEP(ucs)) return NULL; + return SCHEME_CHAR_STR_VAL(ucs); +} + +static unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) { long ulen; unsigned short *res; @@ -402,11 +410,18 @@ unsigned short *ucs4_string_to_utf16_pointer(Scheme_Object *ucs) return res; } +static unsigned short *ucs4_string_or_null_to_utf16_pointer(Scheme_Object *ucs) +{ + if (SCHEME_FALSEP(ucs)) return NULL; + return ucs4_string_to_utf16_pointer(ucs); +} + Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) { long ulen; mzchar *res; int end; + if (!utf) return scheme_false; for (end=0; utf[end] != 0; end++) { /**/ } res = scheme_utf16_to_ucs4(utf, 0, end, NULL, -1, &ulen, 0); return scheme_make_sized_char_string(res, ulen, 0); @@ -644,6 +659,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) 's->c "SCHEME_CHAR_STR_VAL" 'c->s "scheme_make_char_string_without_copying") +(defctype 'string/ucs-4/null + 'ftype "pointer" + 'ctype "mzchar*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_ucs4_pointer" + 'c->s "scheme_make_char_string_without_copying") + (defctype 'string/utf-16 'ftype "pointer" 'ctype "unsigned short*" @@ -651,6 +673,13 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) 's->c "ucs4_string_to_utf16_pointer" 'c->s "utf16_pointer_to_ucs4_string") +(defctype 'string/utf-16/null + 'ftype "pointer" + 'ctype "unsigned short*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_utf16_pointer" + 'c->s "utf16_pointer_to_ucs4_string") + (~ "/* Byte strings -- not copying C strings, #f is NULL." \\ " * (note: these are not like char* which is just a pointer) */" \\ ) From a62b6a312809f2cc9b10a8cc9b92b73f4b9ef69f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 20 Dec 2008 03:06:59 +0000 Subject: [PATCH 10/25] fix _-identifier? typo svn: r12912 --- collects/mzlib/foreign.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index a945f09967..a01579b35f 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1478,7 +1478,7 @@ (identifiers? #'(slot ...))) (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE) (identifiers? #'(slot ...))) + (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) From 82ead03b92f7288fede1aaf6679312fc5d2093f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Dec 2008 05:09:35 +0000 Subject: [PATCH 11/25] change _fpointer handling to work with function pointers in structs and other such uses; add 'function-ptr' casting operation svn: r12913 --- collects/ffi/objc.ss | 15 ++++--- collects/mzlib/foreign.ss | 9 +++- collects/scribblings/foreign/types.scrbl | 21 +++++---- collects/tests/mzscheme/foreign-test.ss | 8 +++- src/foreign/foreign.c | 55 +++++++++++------------- src/foreign/foreign.ssc | 52 ++++++++++------------ 6 files changed, 81 insertions(+), 79 deletions(-) diff --git a/collects/ffi/objc.ss b/collects/ffi/objc.ss index 37e67c5092..8c9be4ccb9 100644 --- a/collects/ffi/objc.ss +++ b/collects/ffi/objc.ss @@ -1,5 +1,5 @@ #lang scheme/base -(require scheme/foreign (only-in '#%foreign ffi-call) +(require scheme/foreign scheme/stxparam (for-syntax scheme/base)) (unsafe!) @@ -73,12 +73,13 @@ (define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type) ;; First type in `types' vector is the result type (or (hash-ref msgSends types #f) - (let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0)) - '(float double double*)) - msgSend_fpret - msgSend) - (list* first-arg-type _SEL (cdr (vector->list types))) - (vector-ref types 0))]) + (let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0)) + '(float double double*)) + msgSend_fpret + msgSend) + (_cprocedure + (list* first-arg-type _SEL (cdr (vector->list types))) + (vector-ref types 0)))]) (hash-set! msgSends types m) m))) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index a01579b35f..42a9103364 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -62,7 +62,7 @@ _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum _float _double _double* - _bool _pointer _scheme _fpointer + _bool _pointer _scheme _fpointer function-ptr (unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) @@ -676,6 +676,13 @@ (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) +(define (function-ptr p fun-ctype) + (if (cpointer? p) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + ((ctype-c->scheme fun-ctype) p) + (raise-type-error 'function-ptr "function ctype" fun-ctype)) + (raise-type-error 'function-ptr "cpointer" p))) + ;; ---------------------------------------------------------------------------- ;; String types diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index b2d83ec418..595968b27e 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -279,15 +279,14 @@ PLT Scheme's C API.} @defthing[_fpointer ctype?]{ -Similar to @scheme[_pointer], except that it should be used with -function pointers. Using these pointers avoids one dereferencing, -which is the proper way of dealing with function pointers. This type -should be used only in rare situations where you need to pass a -foreign function pointer to a foreign function; using a -@scheme[_cprocedure] type is possible for such situations, but -inefficient, as every call will go through Scheme unnecessarily. -Otherwise, @scheme[_cprocedure] should be used (it is based on -@scheme[_fpointer]).} +Similar to @scheme[_pointer], except that when an @scheme[_fpointer] +is extracted from a pointer produced by @scheme[ffi-obj-ref], then a +level of indirection is skipped. A level of indirection is similarly +skipped when extracting a pointer via @scheme[get-ffi-obj]. + +A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer], +and normally @scheme[_cprocedure] should be used instead of +@scheme[_fpointer].} @; ------------------------------------------------------------ @@ -440,6 +439,10 @@ For example, specifies a function that receives an integer and a string, but the foreign function receives the string first.} +@defproc[(function-ptr [ptr cpointer?] [fun-type ctype?]) cpointer?]{ + +Casts @scheme[ptr] to a function pointer of type @scheme[fun-type].} + @; ---------------------------------------------------------------------- @subsection[#:tag "foreign:custom-types"]{Custom Function Types} diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index bb624d4ddb..c55ab2c358 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -101,9 +101,15 @@ (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) ;; --- + (test* 4 'g2 _int (lambda (p) p)) + ;; --- (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))) + (test* 4 'g3 _pointer (lambda (p) ((function-ptr p (_fun _int -> _int)) 3))) + ;; Equivalentlly, 'g3 is a static variable that holds a function pointer. By + ;; looking it up with _fpointer, we get its address, which then works + ;; with ptr-ref to extract the function. + (test* 7 'g3 _fpointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 6))) ;; --- (test ((lambda (x f) ((f (+ x 1)) (- x 1))) 3 (lambda (x) (lambda (y) (+ y (* x x))))) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index f29da13eb9..6d927005b6 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -805,7 +805,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_fpointer (27) /* Type Name: fpointer * LibFfi type: ffi_type_pointer - * C type: -none- + * C type: void* * Predicate: -none- * Scheme->C: -none- * S->C offset: 0 @@ -838,6 +838,7 @@ typedef union _ForeignAny { char* x_symbol; void* x_pointer; Scheme_Object* x_scheme; + void* x_fpointer; } ForeignAny; /* This is a tag that is used to identify user-made struct types. */ @@ -970,7 +971,7 @@ static int ctype_sizeof(Scheme_Object *type) case FOREIGN_symbol: return sizeof(char*); case FOREIGN_pointer: return sizeof(void*); case FOREIGN_scheme: return sizeof(Scheme_Object*); - case FOREIGN_fpointer: return 0; + case FOREIGN_fpointer: return sizeof(void*); /* for structs */ default: return CTYPE_PRIMTYPE(type)->size; } @@ -1219,8 +1220,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the REF_CTYPE trick for pointers */ - return (Scheme_Object*)W_OFFSET(src, delta); + return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { case FOREIGN_void: return scheme_void; case FOREIGN_int8: return scheme_make_integer(REF_CTYPE(Tsint8)); @@ -1248,7 +1248,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_symbol: return scheme_intern_symbol(REF_CTYPE(char*)); case FOREIGN_pointer: return scheme_make_foreign_cpointer(REF_CTYPE(void*)); case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); - case FOREIGN_fpointer: return scheme_void; + case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_struct: return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); @@ -1280,7 +1280,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, type = CTYPE_BASETYPE(type); } if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the SET_CTYPE trick for pointers */ + /* No need for the SET_CTYPE trick for pointers. */ if (SCHEME_FFICALLBACKP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback; else if (SCHEME_CPTRP(val)) @@ -2202,19 +2202,24 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 2) - scheme_signal_error - (MYNAME": referencing fpointer with extra arguments"); - else + if (SCHEME_FFIOBJP(argv[0])) { + /* The ffiobj pointer is the function pointer. */ ptr = argv[0]; - } else if (size < 0) { + delta = (long)&(((ffi_obj_struct*)0x0)->obj); + } + } + + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 3) { + } + + if (argc > 3) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); if (!SCHEME_INTP(argv[3])) @@ -2223,6 +2228,8 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } return C2SCHEME(argv[1], ptr, delta, 0); @@ -2248,22 +2255,9 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); - if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (SCHEME_CPTRP(argv[0])) { - /* offset is ok */ - } else if SCHEME_FFIOBJP(argv[0]) { - if (argc > 3) { - scheme_signal_error - (MYNAME": cannot set fpointer value with offset"); - } - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { @@ -2279,6 +2273,8 @@ static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0); @@ -2475,9 +2471,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p); diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index c83fd900ff..50e2f77854 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -743,7 +743,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (~ "/* Special type, not actually used for anything except to mark values" \\ " * that are treated like pointers but not referenced. Used for" \\ " * creating function types. */") -(defctype 'fpointer 'ftype "pointer" 'ctype #f) +(defctype 'fpointer 'ftype "pointer" 'ctype "void*") :} typedef union _ForeignAny { @@ -1022,8 +1022,7 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, else return _scheme_apply(CTYPE_USER_C2S(type), 1, (Scheme_Object**)(&res)); } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the REF_CTYPE trick for pointers */ - return (Scheme_Object*)W_OFFSET(src, delta); + return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { {:(for-each-type (~ "case FOREIGN_"cname": return " @@ -1062,7 +1061,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, type = CTYPE_BASETYPE(type); } if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { - /* No need for the SET_CTYPE trick for pointers */ + /* No need for the SET_CTYPE trick for pointers. */ if (SCHEME_FFICALLBACKP(val)) ((void**)W_OFFSET(dst,delta))[0] = ((ffi_callback_struct*)val)->callback; else if (SCHEME_CPTRP(val)) @@ -1076,7 +1075,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, (define (wrong-type obj type) (list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));")) (~ "case FOREIGN_"cname":") - (if ctype + (if (and ctype (not (equal? stype "fpointer"))) (let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")] [f (lambda (p) (if (procedure? p) (p "val" x) (list p"(val)")))]) @@ -1600,19 +1599,24 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); + if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (argc > 2) - scheme_signal_error - (MYNAME": referencing fpointer with extra arguments"); - else + if (SCHEME_FFIOBJP(argv[0])) { + /* The ffiobj pointer is the function pointer. */ ptr = argv[0]; - } else if (size < 0) { + delta = (long)&(((ffi_obj_struct*)0x0)->obj); + } + } + + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { scheme_wrong_type(MYNAME, "non-void-C-type", 1, argc, argv); - } else if (argc > 3) { + } + + if (argc > 3) { if (!SAME_OBJ(argv[2],abs_sym)) scheme_wrong_type(MYNAME, "abs-flag", 2, argc, argv); if (!SCHEME_INTP(argv[3])) @@ -1621,6 +1625,8 @@ static Scheme_Object *do_memop(const char *who, int mode, } else if (argc > 2) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } return C2SCHEME(argv[1], ptr, delta, 0); @@ -1644,22 +1650,9 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); - else size = ctype_sizeof(base); + size = ctype_sizeof(base); - if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) { - if (SCHEME_CPTRP(argv[0])) { - /* offset is ok */ - } else if SCHEME_FFIOBJP(argv[0]) { - if (argc > 3) { - scheme_signal_error - (MYNAME": cannot set fpointer value with offset"); - } - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + if (size < 0) { /* should not happen */ scheme_wrong_type(MYNAME, "C-type", 1, argc, argv); } else if (size == 0) { @@ -1675,6 +1668,8 @@ static Scheme_Object *do_memop(const char *who, int mode, } else if (argc > 3) { if (!SCHEME_INTP(argv[2])) scheme_wrong_type(MYNAME, "integer", 2, argc, argv); + if (!size) + scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } SCHEME2C(argv[1], ptr, delta, val, NULL, NULL, 0); @@ -1867,9 +1862,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p); From ab84e51c0fcb5160a8077bda356f9f9ad8010553 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 20 Dec 2008 08:50:19 +0000 Subject: [PATCH 12/25] Welcome to a new PLT day. svn: r12914 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8480331818..11ff3fef4f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19dec2008") +#lang scheme/base (provide stamp) (define stamp "20dec2008") From 5cc3b529a0406f0c046020f51889f4b6ed4fa2b9 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Sat, 20 Dec 2008 17:42:38 +0000 Subject: [PATCH 13/25] Re: Robby svn: r12915 --- collects/stepper/private/xml-snip-helpers.ss | 2 +- collects/xml/private/sig.ss | 1 + collects/xml/private/xexpr.ss | 4 +++ collects/xml/test.ss | 37 +++++++++++++------- collects/xml/xml.scrbl | 9 ++++- 5 files changed, 39 insertions(+), 14 deletions(-) diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss index dbf2c0a18e..8a46053c83 100644 --- a/collects/stepper/private/xml-snip-helpers.ss +++ b/collects/stepper/private/xml-snip-helpers.ss @@ -53,7 +53,7 @@ (let* ([source-name (get-source-name editor)] [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)] [xml (read-xml port)] - [xexpr (xml->xexpr (document-element xml))] + [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))] [clean-xexpr (if eliminate-whitespace-in-empty-tags? (eliminate-whitespace-in-empty-tags xexpr) xexpr)] diff --git a/collects/xml/private/sig.ss b/collects/xml/private/sig.ss index 9abd1387d7..6deac29f88 100644 --- a/collects/xml/private/sig.ss +++ b/collects/xml/private/sig.ss @@ -41,6 +41,7 @@ xexpr->string xexpr-drop-empty-attributes xexpr? + permissive? correct-xexpr? validate-xexpr (struct exn:invalid-xexpr (code)) diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 6d512b30f4..5ad02cf369 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -146,6 +146,9 @@ (pair? (cdr b)) (string? (cadr b)) (null? (cddr b)))) + + ; permissive? : parameter bool + (define permissive? (make-parameter #f)) ;; xml->xexpr : Content -> Xexpr (define (xml->xexpr x) @@ -169,6 +172,7 @@ [(entity? x) (entity-text x)] [(or (comment? x) (pi? x) (cdata? x)) x] [(document? x) (error 'xml->xexpr "Expected content, given ~e\nUse document-element to extract the content." x)] + [(permissive?) x] [else (error 'xml->xexpr "Expected content, given ~e" x)])))) ;; attribute->srep : Attribute -> Attribute-srep diff --git a/collects/xml/test.ss b/collects/xml/test.ss index 3cc340c2e8..c2f1c57a29 100644 --- a/collects/xml/test.ss +++ b/collects/xml/test.ss @@ -3,13 +3,13 @@ (module test mzscheme (require xml/xml) - - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; utils ;; - + ;; test-bad-read-input : format-str str -> void ;; First argument is the input, second is the error message (define (test-bad-read-input format-str err-string) @@ -20,11 +20,11 @@ (report-err format-str (exn-message x) err-string)))]) (read-xml (open-input-string str)) (report-err str "no error" err-string)))) - + ;; tests-failed : number ;; incremened for each test that fails (define tests-failed 0) - + ;; report-err : string string string -> void ;; reports an error in the test suite ;; increments tests-failed. @@ -32,7 +32,7 @@ (set! tests-failed (+ tests-failed 1)) (printf "FAILED test: ~a~n got: ~a~n expected: ~a~n" test got expected)) - + ;; done : -> void ;; prints out a message saying the tests are done. ;; if any tests failed, prints a message saying how many @@ -40,13 +40,13 @@ (if (= tests-failed 0) (printf "All tests passed~n") (printf "~a tests failed~n" tests-failed))) - - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; reader error tests ;; - + (test-bad-read-input "<" "read-xml: lex-error: at position 1.1/2: unexpected eof") (test-bad-read-input "" "read-xml: parse-error: unclosed `a' tag at [1.0/1 1.3/4]") (test-bad-read-input @@ -54,7 +54,7 @@ "read-xml: parse-error: start tag `a' at [1.0/1 1.3/4] doesn't match end tag `b' at [1.3/4 1.7/8]") (test-bad-read-input "" "read-xml: lex-error: at position 1.4/5: expected / or > to close tag `a'") - + (test-bad-read-input "~n<" "read-xml: lex-error: at position 2.1/3: unexpected eof") (test-bad-read-input "~n" "read-xml: parse-error: unclosed `a' tag at [2.0/2 2.3/5]") (test-bad-read-input @@ -62,8 +62,21 @@ "read-xml: parse-error: start tag `a' at [2.0/2 2.3/5] doesn't match end tag `b' at [2.3/5 2.7/9]") (test-bad-read-input "~n" "read-xml: lex-error: at position 2.4/6: expected / or > to close tag `a'") - - + + ;; permissive? + (with-handlers ([exn? + (lambda (exn) + (regexp-match #rx"Expected content," (exn-message exn)))]) + (report-err "Non-permissive" (xml->xexpr #f) "Exception")) + + (with-handlers ([exn? + (lambda (exn) + (report-err "Permissive" "Exception" "#f"))]) + (parameterize ([permissive? #t]) + (let ([tmp (xml->xexpr #f)]) + (when tmp + (report-err "Permissive" tmp "#f"))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; done diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 0555df9526..dc89b9042d 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -235,9 +235,16 @@ like @scheme[display-xml].} @section{XML and X-expression Conversions} +@defboolparam[permissive? v]{ + If this is set to non-false, then @scheme[xml->xexpr] will allow + non-XML objects, such as other structs, in the content of the converted XML + and leave them in place in the resulting ``@tech{X-expression}''. +} + @defproc[(xml->xexpr [content content?]) xexpr?]{ -Converts document content into an @tech{X-expression}.} +Converts document content into an @tech{X-expression}, using +@scheme[permissive?] to determine if foreign objects are allowed.} @defproc[(xexpr->xml [xexpr xexpr?]) content?]{ From 76fc27813a4a7bf4180a7f86182637d0873e4a99 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 20 Dec 2008 22:56:29 +0000 Subject: [PATCH 14/25] added overwrite mode menu item svn: r12916 --- collects/drscheme/private/unit.ss | 17 ++++++++++++++++- .../english-string-constants.ss | 4 +++- 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/collects/drscheme/private/unit.ss b/collects/drscheme/private/unit.ss index 9e943f22bf..8f22224638 100644 --- a/collects/drscheme/private/unit.ss +++ b/collects/drscheme/private/unit.ss @@ -3082,7 +3082,7 @@ module browser threading seems wrong. (define/override (edit-menu:between-find-and-preferences edit-menu) (super edit-menu:between-find-and-preferences edit-menu) - (new menu-item% + (new menu:can-restore-menu-item% [label (string-constant complete-word)] [shortcut #\/] [parent edit-menu] @@ -3096,6 +3096,21 @@ module browser threading seems wrong. (send (get-edit-target-object) auto-complete))]) (add-modes-submenu edit-menu)) + (define/override (edit-menu:between-select-all-and-find edit-menu) + (new menu:can-restore-checkable-menu-item% + [label (string-constant overwrite-mode)] + [parent edit-menu] + [demand-callback + (λ (mi) + (let ([target (get-edit-target-object)]) + (send mi enable (get-edit-target-object)) + (send mi check (and target (send target get-overwrite-mode)))))] + [callback (λ (x y) + (let ([target (get-edit-target-object)]) + (send target set-overwrite-mode + (not (send target get-overwrite-mode)))))]) + (super edit-menu:between-select-all-and-find edit-menu)) + ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key))) (define capability-menu-items (make-hasheq)) (define/public (register-capability-menu-item key menu) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index efeed1ebf2..059fdfb60e 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -676,6 +676,8 @@ please adhere to these guidelines: (complete-word "Complete Word") ; the complete word menu item in the edit menu (no-completions "... no completions available") ; shows up in the completions menu when there are no completions (in italics) + (overwrite-mode "Overwrite Mode") + (preferences-info "Configure your preferences") (preferences-menu-item "Preferences...") @@ -845,7 +847,7 @@ please adhere to these guidelines: (close-tab "Close Tab") ;; must not have any &s in it. (close-tab-amp "&Close Tab") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item - ;;; edit-menu + ;;; edit menu (split-menu-item-label "&Split") (collapse-menu-item-label "C&ollapse") From c2685be3a90fd1977388d6759c12f0c7bbee5ba0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 21 Dec 2008 07:21:28 +0000 Subject: [PATCH 15/25] added preference that disables overwrite mode svn: r12917 --- collects/framework/private/keymap.ss | 11 ++++++----- collects/framework/private/main.ss | 2 ++ collects/framework/private/preferences.ss | 4 ++++ collects/string-constants/english-string-constants.ss | 1 + 4 files changed, 13 insertions(+), 5 deletions(-) diff --git a/collects/framework/private/keymap.ss b/collects/framework/private/keymap.ss index 4c84f95c86..8fe8fec90a 100644 --- a/collects/framework/private/keymap.ss +++ b/collects/framework/private/keymap.ss @@ -860,8 +860,9 @@ [toggle-overwrite (λ (edit event) - (send edit set-overwrite-mode - (not (send edit get-overwrite-mode))))] + (when (preferences:get 'framework:overwrite-mode-keybindings) + (send edit set-overwrite-mode + (not (send edit get-overwrite-mode)))))] [down-into-embedded-editor (λ (text event) @@ -1016,7 +1017,7 @@ (add "forward-to-next-embedded-editor" forward-to-next-embedded-editor) (add "back-to-prev-embedded-editor" back-to-prev-embedded-editor) - (add "toggle-overwrite" toggle-overwrite) + (add "toggle-overwrite (when enabled in prefs)" toggle-overwrite) (add "exit" (λ (edit event) (let ([frame (send edit get-frame)]) @@ -1241,8 +1242,8 @@ (map "c:space" "toggle-anchor") - (map "insert" "toggle-overwrite") - (map-meta "o" "toggle-overwrite") + (map "insert" "toggle-overwrite (when enabled in prefs)") + (map-meta "o" "toggle-overwrite (when enabled in prefs)") (map-meta "g" "goto-line") diff --git a/collects/framework/private/main.ss b/collects/framework/private/main.ss index bf02b824ef..97a074b8a7 100644 --- a/collects/framework/private/main.ss +++ b/collects/framework/private/main.ss @@ -20,6 +20,8 @@ (application-preferences-handler (λ () (preferences:show-dialog))) +(preferences:set-default 'framework:overwrite-mode-keybindings #f boolean?) + (preferences:set-default 'framework:ask-about-paste-normalization #t boolean?) (preferences:set-default 'framework:do-paste-normalization #t boolean?) diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 55967d0331..5bb3db1dde 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -447,6 +447,10 @@ the state transitions / contracts are: 'framework:do-paste-normalization (string-constant normalize-string-preference) values values) + (make-check editor-panel + 'framework:overwrite-mode-keybindings + (string-constant enable-overwrite-mode-keybindings) + values values) (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 059fdfb60e..85676e530e 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -677,6 +677,7 @@ please adhere to these guidelines: (no-completions "... no completions available") ; shows up in the completions menu when there are no completions (in italics) (overwrite-mode "Overwrite Mode") + (enable-overwrite-mode-keybindings "Enable overwrite mode keybindings") (preferences-info "Configure your preferences") (preferences-menu-item "Preferences...") From 72768ef333c0e6b381e25e847f41f836e1de382b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 21 Dec 2008 08:50:22 +0000 Subject: [PATCH 16/25] Welcome to a new PLT day. svn: r12918 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 11ff3fef4f..6296650688 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20dec2008") +#lang scheme/base (provide stamp) (define stamp "21dec2008") From 424ec50bfb3b755103b0516c4a0e69d40ed67811 Mon Sep 17 00:00:00 2001 From: John Clements Date: Sun, 21 Dec 2008 10:00:47 +0000 Subject: [PATCH 17/25] ... svn: r12919 --- collects/typed-scheme/ts-guide.scrbl | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/ts-guide.scrbl index e6e1845ca5..f662e135cb 100644 --- a/collects/typed-scheme/ts-guide.scrbl +++ b/collects/typed-scheme/ts-guide.scrbl @@ -14,6 +14,8 @@ @author["Sam Tobin-Hochstadt"] +@index["typecheck"] + Typed Scheme is a Scheme-like language, with a type system that supports common Scheme programming idioms. Explicit type declarations are required --- that is, there is no type inference. The language From ec600c59bb9caa15f10fb68844677e56a4ce86dc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Dec 2008 13:57:46 +0000 Subject: [PATCH 18/25] fine-tune typechecking index entry svn: r12920 --- collects/mzlib/foreign.ss | 6 ++++-- collects/scribblings/scribble/basic.scrbl | 8 +++++++- collects/typed-scheme/ts-guide.scrbl | 2 +- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 42a9103364..5c04be9b6d 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -677,9 +677,11 @@ [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) (define (function-ptr p fun-ctype) - (if (cpointer? p) + (if (or (cpointer? p) (procedure? p)) (if (eq? (ctype->layout fun-ctype) 'fpointer) - ((ctype-c->scheme fun-ctype) p) + (if (procedure? p) + ((ctype-scheme->c fun-ctype) p) + ((ctype-c->scheme fun-ctype) p)) (raise-type-error 'function-ptr "function ctype" fun-ctype)) (raise-type-error 'function-ptr "cpointer" p))) diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index fab7f6089e..d4a6131cb8 100644 --- a/collects/scribblings/scribble/basic.scrbl +++ b/collects/scribblings/scribble/basic.scrbl @@ -189,7 +189,13 @@ strings for a hierarchy, such as @scheme['("strings" "plain")] for a the strings are ``cleaned'' using @scheme[clean-up-index-strings]. The strings (without clean-up) also serve as the text to render in the index. The @tech{decode}d @scheme[pre-content] is the text to appear -inline as the index target.} +inline as the index target. + +Use @scheme[index] when an index entry should point to a specific word +or phrase within the typeset document (i.e., the +@scheme[pre-content]). Use @scheme[section-index], instead, to create +an index entry that leads to a section, instead of a specific word or +phrase within the section.} @defproc[(index* [words (listof string?)] diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/ts-guide.scrbl index f662e135cb..079a86fb02 100644 --- a/collects/typed-scheme/ts-guide.scrbl +++ b/collects/typed-scheme/ts-guide.scrbl @@ -14,7 +14,7 @@ @author["Sam Tobin-Hochstadt"] -@index["typecheck"] +@section-index["typechecking"] Typed Scheme is a Scheme-like language, with a type system that supports common Scheme programming idioms. Explicit type declarations From 4aa7d2da44d87a915f84ee0c934cabee91750f73 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Dec 2008 13:59:47 +0000 Subject: [PATCH 19/25] minor clarification to section-index docs svn: r12921 --- collects/scribblings/scribble/basic.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index d4a6131cb8..7b86d27330 100644 --- a/collects/scribblings/scribble/basic.scrbl +++ b/collects/scribblings/scribble/basic.scrbl @@ -219,7 +219,7 @@ Like @scheme[index], but the word to index is determined by applying Creates a @scheme[part-index-decl] to be associated with the enclosing section by @scheme[decode]. The @scheme[word]s serve as both the keys -and as the rendered forms of the keys.} +and as the rendered forms of the keys within the index.} @defproc[(index-section [#:tag tag (or/c false/c string?) "doc-index"]) From fb7fa06fa0abd13809f421c8f3e74f0eac11dc90 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Dec 2008 14:32:32 +0000 Subject: [PATCH 20/25] fix reference doc typos svn: r12922 --- collects/scribblings/reference/read.scrbl | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/reference/read.scrbl b/collects/scribblings/reference/read.scrbl index 90888d3141..5bfe75800f 100644 --- a/collects/scribblings/reference/read.scrbl +++ b/collects/scribblings/reference/read.scrbl @@ -27,8 +27,8 @@ See @secref["reader"] for information on the default reader in @scheme[read-syntax] mode.} @defproc[(read/recursive [in input-port? (current-input-port)] - [start (or/c character? #f) #f] - [readtable readtable? (current-readtable)] + [start (or/c char? #f) #f] + [readtable (or/c readtable? #f) (current-readtable)] [graph? any/c #f]) any]{ @@ -75,8 +75,8 @@ See @secref["readtables"] for an extended example that uses @defproc[(read-syntax/recursive [source-name any/c (object-name in)] [in input-port? (current-input-port)] - [start (or/c character? #f) #f] - [readtable readtable? (current-readtable)] + [start (or/c char? #f) #f] + [readtable (or/c readtable? #f) (current-readtable)] [graph? any/c #f]) any]{ @@ -315,8 +315,8 @@ Like @scheme[read-syntax], but for Honu mode (see @secref["parse-honu"]).} @defproc[(read-honu/recursive [in input-port? (current-input-port)] - [start (or/c character? #f) #f] - [readtable readtable? (current-readtable)] + [start (or/c char? #f) #f] + [readtable (or/c readtable? #f) (current-readtable)] [graph? any/c #f]) any]{ @@ -325,8 +325,8 @@ Like @scheme[read/recursive], but for Honu mode (see @defproc[(read-honu-syntax/recursive [source-name any/c (object-name in)] [in input-port? (current-input-port)] - [start (or/c character? #f) #f] - [readtable readtable? (current-readtable)] + [start (or/c char? #f) #f] + [readtable (or/c readtable? #f) (current-readtable)] [graph? any/c #f]) any]{ From c33c7b8fcb2170d2180ae929ebfb28157b1a1311 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 22 Dec 2008 08:50:34 +0000 Subject: [PATCH 21/25] Welcome to a new PLT day. svn: r12923 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 6296650688..9d390fdea7 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "21dec2008") +#lang scheme/base (provide stamp) (define stamp "22dec2008") From 1c4ad34b2e2051d7936be778b5cb8911c859b988 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 22 Dec 2008 13:36:32 +0000 Subject: [PATCH 22/25] add irritants to R6RS exception messages svn: r12924 --- collects/rnrs/base-6.ss | 26 ++++++++++++++++++++------ 1 file changed, 20 insertions(+), 6 deletions(-) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 4084ec3a06..1ba57a14d3 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -403,13 +403,25 @@ (define vector-map (make-mapper "vector" for/list map in-vector vector-length vector->list list->vector)) +(define (add-irritants msg irritants) + (if (null? irritants) + msg + (apply + string-append + msg + "\n irritants:" + (map (lambda (s) + (format "\n ~e" s)) + irritants)))) (define (r6rs:error who msg . irritants) (raise (make-exn:fail:r6rs - (if who - (format "~a: ~a" who msg) - msg) + (add-irritants + (if who + (format "~a: ~a" who msg) + msg) + irritants) (current-continuation-marks) msg who @@ -418,9 +430,11 @@ (define (assertion-violation who msg . irritants) (raise (make-exn:fail:contract:r6rs - (if who - (format "~a: ~a" who msg) - msg) + (add-irritants + (if who + (format "~a: ~a" who msg) + msg) + irritants) (current-continuation-marks) msg who From 6669f3da21843d2e77494cb8e495d69ee32c0e47 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Mon, 22 Dec 2008 13:50:04 +0000 Subject: [PATCH 23/25] Synch German string constants with latest; some fixes. svn: r12925 --- .../german-string-constants.ss | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index 94dce2899e..2a0aaf85c6 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -574,8 +574,10 @@ (complete-word "Wort vervollständigen") ; the complete word menu item in the edit menu (no-completions "... keine Vervollständigungen verfügbar") ; shows up in the completions menu when there are no completions (in italics) + (overwrite-mode "Überschreib-Modus") + (enable-overwrite-mode-keybindings "Tastenbelegungen für Überschreib-Modus aktivieren") - (preferences-info "Konfiguriere die Einstellungen") + (preferences-info "Die Einstellungen konfigurieren") (preferences-menu-item "Einstellungen...") (keybindings-info "Aktuelle Tastaturbelegung anzeigen") @@ -741,7 +743,7 @@ (close-tab-amp "Tab &schließen") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item - ;;; edit-menu + ;;; edit menu (split-menu-item-label "&Splitten") (collapse-menu-item-label "Einfalten") @@ -763,7 +765,7 @@ (force-quit-menu-item-help-string "Benutzt custodian-shutdown-all, um die Auswertung abzubrechen") (limit-memory-menu-item-label "Speicherverbrauch einschränken...") (limit-memory-msg-1 "Das Limit wird beim nächsten Programmstart aktiv") - (limit-memory-msg-2 "und muß mindestens 1 Megabyte betragen.") + (limit-memory-msg-2 "und muss mindestens ein Megabyte betragen.") (limit-memory-unlimited "nicht einschränken") (limit-memory-limited "einschränken") (limit-memory-megabytes "Megabytes") @@ -802,9 +804,9 @@ (create "Erzeugen") (please-specify-a-filename "Bitte einen Dateinamen angeben.") (~a-must-end-with-~a - "Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Der Dateiname muß auf \".~a\" enden.") + "Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Der Dateiname muss auf \".~a\" enden.") (macosx-executables-must-end-with-app - "Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Unter Mac OS X muß der Dateiname auf \".app\" enden.") + "Der Dateiname auf \".~a\"\n\n ~a\n\nist nicht zulässig. Unter Mac OS X muss der Dateiname auf \".app\" enden.") (warning-directory-will-be-replaced "WARNUNG: Das Verzeichnis:\n\n ~a\n\nsoll überschrieben werden. Weitermachen?") @@ -837,9 +839,9 @@ (whole-part "Ganzzahliger Anteil") (numerator "Zähler") (denominator "Nenner") - (insert-number/bad-whole-part "Der ganzzahlige Anteil muß eine ganze Zahl sein") - (insert-number/bad-numerator "Der Zähler einer Zahl muß eine nichtnegative ganze Zahl sein") - (insert-number/bad-denominator "Der Nenner einer Zahl muß eine nichtnegative ganze Zahl sein") + (insert-number/bad-whole-part "Der ganzzahlige Anteil muss eine ganze Zahl sein") + (insert-number/bad-numerator "Der Zähler einer Zahl muss eine nichtnegative ganze Zahl sein") + (insert-number/bad-denominator "Der Nenner einer Zahl muss eine nichtnegative ganze Zahl sein") (insert-fraction-menu-item-label "Bruch einfügen...") From 8c8728337eab05e6e64d2379bfdfde1b18c67703 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 22 Dec 2008 21:17:07 +0000 Subject: [PATCH 24/25] new guide chapter on Scheme dialects, and small clean-up for some other docs svn: r12926 --- collects/frtime/frtime.scrbl | 2 +- collects/planet/planet.scrbl | 97 ++++++++------ collects/r5rs/r5rs.scrbl | 2 +- collects/r6rs/scribblings/r6rs.scrbl | 36 +++++ collects/scribblings/guide/compile.scrbl | 2 +- collects/scribblings/guide/dialects.scrbl | 155 ++++++++++++++++++++++ collects/scribblings/guide/guide.scrbl | 23 +--- collects/scribblings/guide/other.scrbl | 25 ++++ collects/scribblings/guide/welcome.scrbl | 8 +- 9 files changed, 287 insertions(+), 63 deletions(-) create mode 100644 collects/scribblings/guide/dialects.scrbl create mode 100644 collects/scribblings/guide/other.scrbl diff --git a/collects/frtime/frtime.scrbl b/collects/frtime/frtime.scrbl index 5e379bd9c9..d88278bf7e 100644 --- a/collects/frtime/frtime.scrbl +++ b/collects/frtime/frtime.scrbl @@ -14,7 +14,7 @@ @author["Greg Cooper"] -The @scheme[frtime.ss] language supports declarative construction of +The @schememodname[frtime] language supports declarative construction of reactive systems in a syntax very similar to that of MzScheme. To interact with FrTime, select FrTime from the "Choose Language" menu. You can also make FrTime the language for a module: diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index 6e6c8cd782..25a91acd5f 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -16,10 +16,6 @@ @author["Jacob Matthews"] -@PLaneT is PLT Scheme's centralized package repository. It consists of -two parts: , which contains packages contributed by users, and -the @PLaneT client, which is built in to PLT Scheme. - The @PLaneT system is a method for automatically sharing code packages, both as libraries and as full applications, that gives every user of a @PLaneT client the illusion of having a local copy of every code @@ -60,7 +56,7 @@ package (a library for interacting with the @link["http://www.postgresql.org/"]{PostgresQL} database), as of this writing you would copy and paste the line: -@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))] +@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))] into your program. This line requires the file @filepath{spgsql.ss} in package version 2.3 of the @filepath{spgsql.plt} package written by @@ -72,7 +68,7 @@ installed. Second, it requires the module in file @filepath{spgsql.ss} from that package, making all of its exported bindings available for use. Unlike with most package-distribution systems, package downloading and -installation in PLaneT is @italic{transparent} --- there's no need for +installation in PLaneT is @emph{transparent}: there's no need for you to do anything special the first time you want to use a package, and there's no need for you to even know whether or not a particular package is installed on your computer or the computers where your code @@ -80,10 +76,10 @@ will be deployed. @subsection{Shorthand Syntax} -As of PLT Scheme version 4.0, the code snippet in section -@secref{finding-a-package} can also be written using a new shorter syntax: +As of PLT Scheme version 4.0, the code snippet above can also be +written using a new shorter syntax: -@scheme[(require (planet schematics/spgsql:2:3/spgsql))] +@schemeblock[(require (planet schematics/spgsql:2:3/spgsql))] The two forms behave identically. In the abbreviated syntax, however, it is illegal to write the trailing @scheme{.ss} suffix on the file @@ -108,11 +104,11 @@ number that encodes backwards-compatibility information.} The most basic planet require line, which is what is used in the form -@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))] +@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 3)))] in longhand notation, or -@scheme[(require (planet schematics/spgsql:2:3/spgsql))] +@schemeblock[(require (planet schematics/spgsql:2:3/spgsql))] in shorthand notation, should be read ``Require from PLaneT @italic{any} release of Schematics' @filepath{spgsql.plt} package that @@ -121,11 +117,11 @@ package version used is determined by @seclink["search-order"]{the PLaneT search order}.) To signal this explicitly, it is possible to write -@scheme[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 (+ 3))))] +@schemeblock[(require (planet "spgsql.ss" ("schematics" "spgsql.plt" 2 (+ 3))))] or -@scheme[(require (planet schematics/spgsql:2:>=3/spgsql))] +@schemeblock[(require (planet schematics/spgsql:2:>=3/spgsql))] both of which mean the same thing as the first pair of require lines. @@ -148,11 +144,12 @@ in third-party libraries was already working around. In those cases, it may help to make use of the ``upper bound'' form of the planet require, in longhand form: -@scheme[(require (planet "reduction-semantics.ss" ("robby" "redex.plt" 4 (- 3))))] +@schemeblock[(require (planet "reduction-semantics.ss" + ("robby" "redex.plt" 4 (- 3))))] and using shorthand notation: -@scheme[(require (planet robby/redex:4:<=3/reduction-semantics))] +@schemeblock[(require (planet robby/redex:4:<=3/reduction-semantics))] In this require line, any version of the package @filepath{redex.plt} from package version 4.0 to package version 4.3 will match the require @@ -163,11 +160,11 @@ which package is actually loaded). It is also possible to specify both an upper and a lower bound, using the planet require's ``range'' form: -@scheme[(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 (9 10))))] +@schemeblock[(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 (9 10))))] or -@scheme[(require (planet schematics/schemeunit:2:9-10/test))] +@schemeblock[(require (planet schematics/schemeunit:2:9-10/test))] This form matches any package in the specified range (inclusive on both ends), in this example the specifications match either package @@ -180,11 +177,11 @@ a package as a special case (choosing the upper and lower bounds to be equal), but this is a common enough case that it has special support with the ``exact-match'' form: -@scheme[(require (planet "unzip.ss" ("dherman" "zip.plt" 2 (= 1))))] +@schemeblock[(require (planet "unzip.ss" ("dherman" "zip.plt" 2 (= 1))))] or -@scheme[(require (planet dherman/zip:2:=1/unzip))] +@schemeblock[(require (planet dherman/zip:2:=1/unzip))] match only the exact package version 2.1 of the @filepath{zip.plt} package. @@ -384,25 +381,39 @@ within the PLaneT archive named by , to the standard output port. This command does not unpack or install the named .plt file. +@section[#:tag "hash-lang-planet"]{The @schememodname[planet] Language} + +@defmodulelang[planet] + +When used with @hash-lang[], @schememodname[planet] must be followed +by a short-form PLaneT path. The path is used in the same way that +@hash-lang[] uses plain identifiers: @schemeidfont{/lang/reader} is +added to the given path to determine a module that supplies a module +reader. + +The @schememodname[planet] module (as opposed to the reader used with +@hash-lang[]) implements the @exec{planet} command-line tool. + @section{Utility Libraries} The planet collection provides configuration and utilities for using PLaneT. -@subsection{config.ss: Client Configuration} - -The config.ss library provides several parameters useful for configuring how -PLaneT works. - -Note that while these parameters can be useful to modify -programmatically, PLaneT code runs at module-expansion time and so -most user programs cannot set them until PLaneT has already -run. Therefore to meaningfully change these settings it is best to -manually edit the config.ss file. +@subsection{Client Configuration} @defmodule[planet/config] +The @schememodname[planet/config] library provides several parameters +useful for configuring how PLaneT works. + +Note that while these parameters can be useful to modify +programmatically, PLaneT code runs at module-expansion time, so +most user programs cannot set them until PLaneT has already +run. Therefore, to meaningfully change these settings, it is best to +manually edit the config.ss file. + @defparam[PLANET-DIR dir path-string?]{ -The root PLaneT directory. If the environment variable PLTPLANETDIR is +The root PLaneT directory. If the environment variable +@indexed-envvar{PLTPLANETDIR} is set, default is its value; otherwise the default is the directory in which @filepath{config.ss} is found.} @@ -455,33 +466,42 @@ The port on the server the client should connect to if @scheme[USE-HTTP-DOWNLOADS?] is @scheme[#f]. The default value for this parameter is @scheme[270].} -@subsection[#:tag "util.ss"]{util.ss: Utilities} +@subsection[#:tag "util.ss"]{Utilities} -The @filepath{util.ss} library supports examination of the pieces of +@defmodule[planet/util] + +The @schememodname[planet/util] library supports examination of the pieces of PLaneT. It is meant primarily to support debugging and to allow easier development of higher-level package-management tools. The functionality exposed by @seclink["cmdline"]{the @exec{planet} command-line tool} is also available programmatically through this library. -@defmodule[planet/util] - @defproc[(download/install-pkg [owner string?] [pkg string?] [maj natural-number/c] [min natural-number/c]) - (or/c pkg? false/c)]{ + (or/c pkg? #f)]{ Downloads and installs the package specifed by the given owner name, package name, major and minor version number. Returns false if no such package is available; otherwise returns a package structure for the installed package.} @defparam[current-cache-contents contents - ((string? ((string? ((natural-number/c (natural-number/c ...)) ...)) ...)) ...)]{ + (listof + (list/c string? + (listof + (list/c string? + (cons/c natural-number/c + (listof natural-number/c))))))]{ Holds a listing of all package names and versions installed in the local cache.} @defproc[(current-linkage) - ((path-string? (string? (string?) natural-number/c natural-number/c) ...) ...)]{ + (listof (list/c path-string? + (list/c string? + (list/c string?) + natural-number/c + natural-number/c)))]{ Returns the current linkage table. The linkage table is an association between file locations (encoded as path strings) @@ -489,7 +509,8 @@ and concrete planet package versions. If a require line in the associated file r this table is consulted to determine a particular concrete package to satisfy the request.} @defproc[(make-planet-archive [directory path-string?] - [output-file (or/c path? path-string?) (string-append (path->string name) ".plt")]) + [output-file (or/c path? path-string?) + (string-append (path->string name) ".plt")]) path-string?]{ Makes a .plt archive file suitable for PLaneT whose contents are all files in the given directory and returns that file's name. If the diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index fb36a9caaf..f500cae2e0 100644 --- a/collects/r5rs/r5rs.scrbl +++ b/collects/r5rs/r5rs.scrbl @@ -161,7 +161,7 @@ containing the bindings of @schememodname[r5rs]. Procedure values are installed into the namespace using @scheme[namespace-require/copy], so that they can be redefined. -The @scheme[scheme-null-environment] function returns a namespace +The @scheme[null-environment] function returns a namespace containing the syntactic forms of @schememodname[r5rs], not including @scheme[#%module-begin] (which is not useful outside of a module). diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl index 0417d768e4..1958fe569c 100644 --- a/collects/r6rs/scribblings/r6rs.scrbl +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -9,6 +9,7 @@ rnrs/conditions-6 rnrs/io/simple-6 rnrs/r5rs-6 + r6rs (only-in scheme/base lib current-library-collection-paths @@ -167,6 +168,41 @@ are searched in order, and before the installation's collections. @; ---------------------------------------- +@section[#:tag "r6rs-mod"]{@|r6rs| Module Language} + +@defmodulelang[r6rs] + +The @schememodname[r6rs] language is usually used in the form +@schememetafont{#!}@schememodname[r6rs], which is equivalent to +@scheme[#, @hash-lang[] #, @schememodname[r6rs]] and is also valid +@|r6rs| syntax. + +The @schememodname[r6rs] module language provides only a +@schemeidfont{#%module-begin} binding, which is used to process the +entire module body (see @scheme[module]). It allows the body of a +module to use the syntax of either a @|r6rs| library or a @|r6rs| +top-level program. + +@defform*[#:literals (library import export) + [(#%module-begin + (library library-name + (export export-spec ...) + (import import-spec ...) + library-body ...)) + (#%module-begin + (import import-spec ...) + program-body ...)]]{ + +An @schememodname[r6rs] module that contains a single @scheme[library] +form defines an @|r6rs| library, while a module body that starts with +an @scheme[import] form defined an @|r6rs| top-level program. + +The @scheme[library], @scheme[export], and @scheme[import] identifiers +are not exported by the @schememodname[r6rs] library; they are +recognized through equivalence to unbound identifiers.} + +@; ---------------------------------------- + @section[#:tag "libpaths"]{Libraries and Collections} An @|r6rs| library name is sequence of symbols, optionally followed by diff --git a/collects/scribblings/guide/compile.scrbl b/collects/scribblings/guide/compile.scrbl index c5a2b037da..0950f5d7e8 100644 --- a/collects/scribblings/guide/compile.scrbl +++ b/collects/scribblings/guide/compile.scrbl @@ -14,7 +14,7 @@ So far, we have talked about three main PLT Scheme executables: running PLT Scheme programs (and that can be used as a development environment in interactive mode);} - @item{@exec{mred}, which is like @scheme{mzscheme}, but for GUI + @item{@exec{mred}, which is like @exec{mzscheme}, but for GUI applications.} ] diff --git a/collects/scribblings/guide/dialects.scrbl b/collects/scribblings/guide/dialects.scrbl new file mode 100644 index 0000000000..e76b24edf4 --- /dev/null +++ b/collects/scribblings/guide/dialects.scrbl @@ -0,0 +1,155 @@ +#lang scribble/doc +@(require scribble/manual + "guide-utils.ss") + +@(define r6rs @elem{R@superscript{6}RS}) +@(define r5rs @elem{R@superscript{5}RS}) + +@title[#:tag "dialects" #:style 'toc]{Dialects of Scheme} + +PLT Scheme is one dialect of the Scheme programming language, and +there are many others. Indeed, ``Scheme'' is perhaps more of an idea +than a specific language. + +The @hash-lang[] prefix on modules is a particular feature of PLT +Scheme, and programs that start with @hash-lang[] are unlikely to run +in other implementations of Scheme. At the same time, programs that do +not start with @hash-lang[] (or another PLT Scheme module form) do not +work with the default mode of most PLT Scheme tools. + +``PLT Scheme'' is not, however, the only dialect of Scheme supported +by PLT Scheme tools. On the contrary, PLT Scheme tools are designed to +support multiple dialects of Scheme and even multiple languages, which +allows the PLT Scheme tool suite to serve multiple communities. PLT +Scheme also gives programmers and researchers the tools they need to +create new and improved languages. + +@local-table-of-contents[] + +@; -------------------------------------------------- + +@section[#:tag "standards"]{Standards} + +Standard dialects of Scheme include the ones defined by @|r5rs| and +@|r6rs|. + +@subsection{@|r5rs|} + +``@|r5rs|'' stands for @link["../r5rs-std/index.html"]{The +Revised@superscript{5} Report on the Algorithmic Language Scheme}, and +it is currently the most widely implemented Scheme standard. + +PLT Scheme tools in their default modes do not conform to @|r5rs|, +mainly because PLT Scheme tools generally expect modules, and @|r5rs| +does not define a module system. Typical single-file @|r5rs| programs +can be converted to PLT Scheme programs by prefixing them with +@scheme[#, @hash-lang[] #, @schememodname[r5rs]], but other Scheme +systems do not recognize @scheme[#, @hash-lang[] #, +@schememodname[r5rs]] (which is not part of the @|r5rs| standard). The +@exec{plt-r5rs} executable more directly conforms to the @|r5rs| +standard. + +Aside from the module system, the syntactic forms and functions of +@|r5rs| and PLT Scheme differ. Only simple @|r5rs| become PLT Scheme +programs when prefixed with @scheme[#, @hash-lang[] scheme], and +relatively few PLT Scheme programs become @|r5rs| programs when a +@hash-lang[] line is removed. Also, when mixing ``@|r5rs| modules'' +with PLT Scheme modules, beware that @|r5rs| pairs correspond to PLT +Scheme mutable pairs (as constructed with @scheme[mcons]). + +See @other-manual['(lib "r5rs/r5rs.scrbl")] for more +information about running @|r5rs| programs with PLT Scheme. + +@subsection{@|r6rs|} + +``@|r6rs|'' stands for @link["../r6rs-std/index.html"]{The +Revised@superscript{6} Report on the Algorithmic Language Scheme}, +which extends @|r5rs| with a module system that is similar to the PLT +Scheme module system. + +When an @|r6rs| library or top-level program is prefixed with +@schememetafont{#!}@schememodname[r6rs] (which is valid @|r6rs| +syntax), then it can also be used as a PLT Scheme program. This works +because @schememetafont{#!} in PLT Scheme is treated as a shorthand +for @hash-lang[] followed by a space, so +@schememetafont{#!}@schememodname[r6rs] selects the +@schememodname[r6rs] module language. As with @|r5rs|, however, beware +that the syntactic forms and functions of @|r6rs| differ from PLT +Scheme, and @|r6rs| pairs are mutable pairs. + +See @other-manual['(lib "r6rs/scribblings/r6rs.scrbl")] for more +information about running @|r6rs| programs with PLT Scheme. + +@; -------------------------------------------------- + +@section[#:tag "more-hash-lang"]{More PLT Schemes} + +Like ``Scheme'' itself, even ``PLT Scheme'' is more of an idea about +programming languages than a language in the usual sense. Macros can +extend a base language (as described in @secref["macros"]), but macros +and alternate parsers can construct an entirely new language from the +ground up. + +The @hash-lang[] line that starts a PLT Scheme module declares the +base language of the module. By ``PLT Scheme,'' we usually mean +@hash-lang[] followed by the base language @schememodname[scheme] or +@schememodname[scheme/base] (of which @schememodname[scheme] is an +extension). The PLT Scheme distribution provides additional languages, +including the following: + +@itemize[ + + @item{@schememodname[typed-scheme] --- like + @schememodname[scheme/base], but statically typed; see + @other-manual['(lib "typed-scheme/ts-guide.scrbl")]} + + @item{@schememodname[lazy] --- like @schememodname[scheme/base], but + avoids evaluating an expression until its value is needed; see + @other-manual['(lib "lazy/lazy.scrbl")]} + + @item{@schememodname[frtime] --- changes evaluation in an even more + radical way to support reactive programming; see + @other-manual['(lib "frtime/frtime.scrbl")]} + + @item{@schememodname[scribble/doc] --- a language, which looks more + like Latex than Scheme, for writing documentation; see + @other-manual['(lib "scribblings/scribble/scribble.scrbl")]} + +] + +Each of these languages is used by starting module with the language +name after @hash-lang[]. For example, this source of this very +document starts with @scheme[#, @hash-lang[] scribble/doc]. + +PLT Scheme users can define their own languages. A language name maps +to its implementation through a module path by adding +@schemeidfont{/lang/reader}. For example, the language name +@schememodname[scribble/doc] is expanded to +@scheme[scribble/doc/lang/reader], which is the module that implements +the surface-syntax parser. The parser, in turn, generates a +@scheme[module] form, which determines the base language at the level +of syntactic forms an functions. + +Some language names act as language loaders. For example, +@schememodname[s-exp] as a language uses the usual PLT Scheme parser +for surface-syntax reading, and then it uses the module path after +@schememodname[s-exp] for the language's syntactic forms. Thus, +@scheme[#, @hash-lang[] #, @schememodname[s-exp] "mylang.ss"] parses +the module body using the normal PLT Scheme reader, by then imports +the initial syntax and functions for the module body from +@scheme["mylang.ss"]. Similarly, @scheme[#, @hash-lang[] #, +@schememodname[planet] _planet-path] loads a language via +@seclink["top" #:doc '(lib "planet/planet.scrbl")]{@|PLaneT|}. + +@; -------------------------------------------------- + +@section[#:tag "teaching-langs"]{Teaching} + +The @|HtDP| textbook relies on pedagogic variants of Scheme that +smooth the introduction of programming concepts for new programmers. +The languages are documented in @other-manual['(lib +"scribblings/htdp-langs/htdp-langs.scrbl")]. + +The @|HtDP| languages are typically not used with @hash-lang[] +prefixes, but are instead used within DrScheme by selecting the +language from the @onscreen{Choose Language...} dialog. diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index 8cb705429f..f75f2a94c6 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/collects/scribblings/guide/guide.scrbl @@ -58,28 +58,9 @@ precise details to @|MzScheme| and other reference manuals. @include-section["compile.scrbl"] -@; ---------------------------------------------------------------------- -@section{More Libraries} +@include-section["other.scrbl"] -@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the PLT -Scheme graphics toolbox, whose core is implemented by the @exec{mred} -executable. - -@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes -tools for using Scheme to access libraries that are normally used by C -programs. - -@other-manual['(lib "web-server/scribblings/web-server.scrbl")] -describes the PLT Scheme web server, which supports servlets -implemented in Scheme. - -@link["../index.html"]{PLT Scheme Documentation} lists documentation -for many other installed libraries. Run @exec{plt-help} to find -documentation for libraries that are installed on your system and -specific to your user account. - -@link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more -downloadable packages contributed by PLT Scheme users. +@include-section["dialects.scrbl"] @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/guide/other.scrbl b/collects/scribblings/guide/other.scrbl new file mode 100644 index 0000000000..998a37aaee --- /dev/null +++ b/collects/scribblings/guide/other.scrbl @@ -0,0 +1,25 @@ +#lang scribble/doc +@(require scribble/manual + "guide-utils.ss") + +@title{More Libraries} + +@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the PLT +Scheme graphics toolbox, whose core is implemented by the @exec{mred} +executable. + +@other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes +tools for using Scheme to access libraries that are normally used by C +programs. + +@other-manual['(lib "web-server/scribblings/web-server.scrbl")] +describes the PLT Scheme web server, which supports servlets +implemented in Scheme. + +@link["../index.html"]{PLT Scheme Documentation} lists documentation +for many other installed libraries. Run @exec{plt-help} to find +documentation for libraries that are installed on your system and +specific to your user account. + +@link["http://planet.plt-scheme.org/"]{@|PLaneT|} offers even more +downloadable packages contributed by PLT Scheme users. diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index ca68a82a1c..63954205ae 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -13,7 +13,10 @@ Depending on how you look at it, @bold{PLT Scheme} is @itemize{ @item{a @defterm{programming language}---a descendant of Scheme, which - is a dialect of Lisp;} + is a dialect of Lisp; + + @margin-note{See @secref["dialects"] for more information on + other dialects of Scheme and how they relate to PLT Scheme.}} @item{a @defterm{family} of programming languages---variants of Scheme, and more; or} @@ -54,6 +57,9 @@ that's above the text area. DrScheme then understands that you mean to work in the normal variant of Scheme (as opposed to the smaller @schememodname[scheme/base], or many other possibilities). +@margin-note{@secref["more-hash-lang"] describes some of the other + possibilities.} + If you've used DrScheme before with something other than a program that starts @hash-lang[], DrScheme will remember the last language that you used, instead of inferring the language from the @hash-lang[] From 2ce9667ae46b454457c445360a5301ea1cbed616 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 22 Dec 2008 21:26:39 +0000 Subject: [PATCH 25/25] edits and backpointers related to Scheme dialects in the guide svn: r12927 --- collects/r5rs/r5rs.scrbl | 4 ++++ collects/r6rs/scribblings/r6rs.scrbl | 4 ++++ collects/scribblings/guide/dialects.scrbl | 4 ++-- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index f500cae2e0..6da1ff522a 100644 --- a/collects/r5rs/r5rs.scrbl +++ b/collects/r5rs/r5rs.scrbl @@ -25,6 +25,10 @@ on the Algorithmic Language Scheme} defines a dialect of Scheme. We use @defterm{@|r5rs|} to refer to both the standard and the language defined by the standard. +@margin-note{See @seclink[#:doc '(lib "scribblings/guide/guide.scrbl") + "dialects"] for general information about different + dialects of Scheme within PLT Scheme.} + The default dialect of Scheme provided by @exec{mzscheme} and other PLT Scheme tools differs from @|r5rs| in many ways, but PLT Scheme includes tools and libraries for running @|r5rs| programs. diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl index 1958fe569c..9a6436bfeb 100644 --- a/collects/r6rs/scribblings/r6rs.scrbl +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -28,6 +28,10 @@ on the Algorithmic Language Scheme} defines a dialect of Scheme. We use @defterm{@|r6rs|} to refer to both the standard and the language defined by the standard. +@margin-note{See @seclink[#:doc '(lib "scribblings/guide/guide.scrbl") + "dialects"] for general information about different + dialects of Scheme within PLT Scheme.} + @|r6rs| defines both @defterm{libraries} and @defterm{top-level programs}. Both correspond to PLT Scheme @defterm{modules} (see @secref[#:doc guide-src "modules"]). That is, although @|r6rs| defines diff --git a/collects/scribblings/guide/dialects.scrbl b/collects/scribblings/guide/dialects.scrbl index e76b24edf4..41786daaf7 100644 --- a/collects/scribblings/guide/dialects.scrbl +++ b/collects/scribblings/guide/dialects.scrbl @@ -17,12 +17,12 @@ in other implementations of Scheme. At the same time, programs that do not start with @hash-lang[] (or another PLT Scheme module form) do not work with the default mode of most PLT Scheme tools. -``PLT Scheme'' is not, however, the only dialect of Scheme supported +``PLT Scheme'' is not, however, the only dialect of Scheme that is supported by PLT Scheme tools. On the contrary, PLT Scheme tools are designed to support multiple dialects of Scheme and even multiple languages, which allows the PLT Scheme tool suite to serve multiple communities. PLT Scheme also gives programmers and researchers the tools they need to -create new and improved languages. +explore and create new languages. @local-table-of-contents[]