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/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/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/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/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/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))) 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 diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index fa2520d35e..5c04be9b6d 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,12 +676,22 @@ (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) +(define (function-ptr p fun-ctype) + (if (or (cpointer? p) (procedure? p)) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + (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))) + ;; ---------------------------------------------------------------------------- ;; 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))) @@ -1477,7 +1487,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 ...)))])) 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/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."))] diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index fb36a9caaf..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. @@ -161,7 +165,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..9a6436bfeb 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 @@ -27,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 @@ -167,6 +172,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/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 12fc3fd4b8..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 "18dec2008") +#lang scheme/base (provide stamp) (define stamp "22dec2008") 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 diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 064b494d7f..595968b27e 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?]{ @@ -270,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].} @; ------------------------------------------------------------ @@ -431,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/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..41786daaf7 --- /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 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 +explore and create new 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[] 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]{ diff --git a/collects/scribblings/scribble/basic.scrbl b/collects/scribblings/scribble/basic.scrbl index fab7f6089e..7b86d27330 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?)] @@ -213,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"]) 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/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index efeed1ebf2..85676e530e 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -676,6 +676,9 @@ 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") + (enable-overwrite-mode-keybindings "Enable overwrite mode keybindings") + (preferences-info "Configure your preferences") (preferences-menu-item "Preferences...") @@ -845,7 +848,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") 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...") 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/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)) diff --git a/collects/typed-scheme/ts-guide.scrbl b/collects/typed-scheme/ts-guide.scrbl index e6e1845ca5..079a86fb02 100644 --- a/collects/typed-scheme/ts-guide.scrbl +++ b/collects/typed-scheme/ts-guide.scrbl @@ -14,6 +14,8 @@ @author["Sam Tobin-Hochstadt"] +@section-index["typechecking"] + 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 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?]{ diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 0518cd0397..6d927005b6 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,10 +802,10 @@ 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- + * C type: void* * Predicate: -none- * Scheme->C: -none- * S->C offset: 0 @@ -795,16 +830,19 @@ 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; void* x_pointer; Scheme_Object* x_scheme; + void* x_fpointer; } 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,13 +963,15 @@ 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*); 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; } @@ -1180,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)); @@ -1201,13 +1240,15 @@ 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*)); 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); @@ -1239,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)) @@ -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*) 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])) @@ -2140,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); @@ -2165,33 +2255,26 @@ 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); - 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]); - } else if SCHEME_FFIOBJP(argv[0]) { - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + size = ctype_sizeof(base); + + 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 > 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]); } 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); @@ -2388,9 +2471,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p); @@ -2897,6 +2977,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_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; @@ -2904,6 +2991,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 fc8193244b..50e2f77854 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) */" \\ ) @@ -714,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 { @@ -993,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 " @@ -1033,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)) @@ -1047,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)")))]) @@ -1571,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])) @@ -1592,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); @@ -1615,33 +1650,26 @@ 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); - 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]); - } else if SCHEME_FFIOBJP(argv[0]) { - ptr = ((ffi_obj_struct*)(argv[0]))->obj; - } else { - scheme_signal_error - (MYNAME": bad lvalue (NULL or string)"); - } - } else if (size < 0) { + size = ctype_sizeof(base); + + 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 > 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]); } 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); @@ -1834,9 +1862,6 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) for (i=0; isize); free(p); 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 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++; }