Sync again

svn: r12928

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))

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)]))
 

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)

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))
+      (let ([m (function-ptr (if (memq (ctype->layout (vector-ref types 0))
-                                   '(float double double*))
+                                       '(float double double*))
-                             msgSend_fpret
+                                 msgSend_fpret
-                             msgSend)
+                                 msgSend)
-                         (list* first-arg-type _SEL (cdr (vector->list types)))
+                             (_cprocedure
-                         (vector-ref types 0))])
+                              (list* first-arg-type _SEL (cdr (vector->list types)))
+                              (vector-ref types 0)))])
         (hash-set! msgSends types m)
         m)))
 

collects/framework/private/keymap.ss

@@ -860,8 +860,9 @@
            
            [toggle-overwrite
             (λ (edit event)
-              (send edit set-overwrite-mode
+              (when (preferences:get 'framework:overwrite-mode-keybindings)
-                    (not (send edit get-overwrite-mode))))]
+                (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 "insert" "toggle-overwrite (when enabled in prefs)")
-          (map-meta "o" "toggle-overwrite")
+          (map-meta "o" "toggle-overwrite (when enabled in prefs)")
           
           (map-meta "g" "goto-line")
           

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?)
 

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)))
   

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:

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"))

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]
@@ -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)
+    (empty-board 3)
-          (make-cell (make-posn 0 1) false)
-          (make-cell (make-posn 1 0) false))
     (make-posn 0 0)
     'playing
-    2)))
+    3)))
  0)
 (check-expect
  (pinhole-x
   (world->image
    (make-world
-    (list (make-cell (make-posn 0 0) false)
+    (empty-board 3)
-          (make-cell (make-posn 0 1) false)
-          (make-cell (make-posn 1 0) false))
     (make-posn 0 1)
     'playing
-    2)))
+    3)))
  0)
 
 
-;; board->image : board number -> image
+;; board->image : board number (posn -> boolean) -> image
-(define (board->image cs world-size)
+(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
+(check-expect (board->image (list (make-cell (make-posn 0 0) false))
-(define (cell->image c)
+                            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))
+(check-expect (cell->image (make-cell (make-posn 0 0) false) false)
-              (move-pinhole (circle circle-radius 'solid 'lightblue)
+              (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)
+;; build-bfs-table : world (or/c 'boundary posn) -> distance-table
-  (local [(define board-size (world-size world))
+(define (build-bfs-table world init-point)
-          (define blocked (make-hash))
+  (local [;; posn : posn
-          (define ht (make-hash))
+          ;; dist : number
-          (define (search p)
+          (define-struct queue-ent (posn dist))
+          
+          (define neighbors/w (neighbors world))
+          
+          (define (bfs queue dist-table)
             (cond
-              [(hash-ref blocked p)
+              [(empty? queue) dist-table]
-               '∞]
-              [(on-boundary? p board-size) 
-               ((lambda (a b) b)
-                (hash-set! ht p 0)
-                0)]
-              [(not (boolean? (hash-ref ht p #f)))
-               (hash-ref ht p)]
               [else
-               ((lambda (a b c) c)
+               (local [(define hd (first queue))]
-                (hash-set! ht p '∞)
+                 (cond
-                (hash-set! 
+                   [(boolean? (hash-ref dist-table (queue-ent-posn hd) #f))
-                 ht
+                    (local [(define dist (queue-ent-dist hd))
-                 p
+                            (define p (queue-ent-posn hd))]
-                 (add1/f (min-l (map search 
+                      (bfs 
-                                     (adjacent p board-size)))))
+                       (append (rest queue) 
-                (hash-ref ht p))]))]
+                               (map (lambda (p) (make-queue-ent p (+ dist 1)))
-    ((lambda (a b c) c)
+                                    (neighbors/w p)))
-     (for-each (lambda (cell)
+                       (hash-set dist-table p dist)))]
-                 (hash-set! blocked 
+                   [else
-                            (cell-p cell)
+                    (bfs (rest queue) dist-table)]))]))]
-                            (cell-blocked? cell)))
-               (world-board world))
-     (search (world-cat world))
-     (hash-map ht make-dist-cell))))
                     
-;; build-table : world -> distance-map
+    (hash-map 
-(define (build-table world)
+     (bfs (list (make-queue-ent init-point 0))
-  (build-distance (world-board world)
+          (make-immutable-hash/list-init))
-                  (world-cat world)
+     make-dist-cell)))
-                  '()
-                  '()
-                  (world-size world)))
 
-;; build-distance : board posn distance-map (listof posn) number -> distance-map
+;; same-sets? : (listof X) (listof X) -> boolean
-(define (build-distance board p t visited board-size)
+(define (same-sets? l1 l2)
-  (cond
+  (and (andmap (lambda (e1) (member e1 l2)) l1)
-    [(cell-blocked? (lookup-board board p)) 
+       (andmap (lambda (e2) (member e2 l1)) l2)))
-     (add-to-table p '∞ t)]
-    [(on-boundary? p board-size)
-     (add-to-table p 0 t)]
-    [(in-table? t p)
-     t]
-    [(member p visited)
-     (add-to-table p '∞ t)]
-    [else
-     (local [(define neighbors (adjacent p board-size))
-             (define neighbors-t (build-distances
-                                  board
-                                  neighbors
-                                  t
-                                  (cons p visited)
-                                  board-size))]
-       (add-to-table p
-                     (add1/f 
-                      (min-l 
-                       (map (lambda (neighbor)
-                              (lookup-in-table neighbors-t neighbor))
-                            neighbors)))
-                     neighbors-t))]))
 
-;; build-distances : board (listof posn) distance-map (listof posn) number 
+(check-expect (same-sets? (list) (list)) true)
-;;                -> distance-map
+(check-expect (same-sets? (list) (list 1)) false)
-(define (build-distances board ps t visited board-size)
+(check-expect (same-sets? (list 1) (list)) false)
-  (cond
+(check-expect (same-sets? (list 1 2) (list 2 1)) true)
-    [(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)) 
+(check-expect (same-sets? 
-                              (make-posn 0 0)
+               (build-bfs-table (make-world (empty-board 3) (make-posn 1 1) 'playing 3)
-                              '()
+                                'boundary)
-                              '()
+               (list
-                              1)
+                (make-dist-cell 'boundary 0)
-              (list (make-dist-cell (make-posn 0 0) '∞)))
                 
-(check-expect (build-distance (list (make-cell (make-posn 0 1) false)
+                (make-dist-cell (make-posn 1 0) 1)
-                                    (make-cell (make-posn 1 0) false)
+                (make-dist-cell (make-posn 2 0) 1)
-                                    (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-dist-cell (make-posn 0 1) 1)
-                                    (make-cell (make-posn 1 0) true)
+                (make-dist-cell (make-posn 1 1) 2)
-                                    (make-cell (make-posn 1 1) false) 
+                (make-dist-cell (make-posn 2 1) 1)
-                                    (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
+                (make-dist-cell (make-posn 1 2) 1)
-               (append-all
+                (make-dist-cell (make-posn 2 2) 1)))
-                (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))
               true)
-(check-expect (in-table? (list (make-dist-cell (make-posn 2 1) 3))
+
-                         (make-posn 1 2))
+(check-expect (same-sets? 
-              false)
+               (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)
+;; on-cats-path? : world -> posn -> boolean
-(check-expect (on-boundary? (make-posn 1 0) 13) true)
+;; returns true when the posn is on the shortest path 
-(check-expect (on-boundary? (make-posn 12 1) 13) true)
+;; from the cat to the edge of the board, in the given world
-(check-expect (on-boundary? (make-posn 1 12) 13) true)
+(define (on-cats-path? w)
-(check-expect (on-boundary? (make-posn 1 1) 13) false)
+  (local [(define edge-distance-map (build-bfs-table w 'boundary))
-(check-expect (on-boundary? (make-posn 10 10) 13) false)
+          (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
-            (cond
+      [(even? y)
-              [(even? y)
+       (list (make-posn (- x 1) (- y 1))
-               (list (make-posn (- x 1) (- y 1))
+             (make-posn x (- y 1))
-                     (make-posn x (- y 1))
+             (make-posn (- x 1) y)
-                     (make-posn (- x 1) y)
+             (make-posn (+ x 1) y)
-                     (make-posn (+ x 1) y)
+             (make-posn (- x 1) (+ y 1))
-                     (make-posn (- x 1) (+ y 1))
+             (make-posn x (+ y 1)))]
-                     (make-posn x (+ y 1)))]
+      [else
-              [else
+       (list (make-posn x (- y 1))
-               (list (make-posn x (- y 1))
+             (make-posn (+ x 1) (- y 1))
-                     (make-posn (+ x 1) (- y 1))
+             (make-posn (- x 1) y)
-                     (make-posn (- x 1) y)
+             (make-posn (+ x 1) y)
-                     (make-posn (+ x 1) y)
+             (make-posn x (+ y 1))
-                     (make-posn x (+ y 1))
+             (make-posn (+ x 1) (+ 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 (+/f x y)
-(define (min/f x y)
   (cond
-    [(equal? x '∞) y]
+    [(or (equal? x '∞) (equal? y '∞))
-    [(equal? y '∞) x]
+     '∞]
-    [else (min x y)]))
+    [else 
-(check-expect (min/f '∞ 1) 1)
+     (+ x y)]))
-(check-expect (min/f 1 '∞) 1)
-(check-expect (min/f '∞ '∞) '∞)
-(check-expect (min/f 1 2) 1)
 
-;; add1/f : number or '∞ -> number or '∞
+(check-expect (+/f '∞ '∞) '∞)
-(define (add1/f n)
+(check-expect (+/f '∞ 1) '∞)
-  (cond
+(check-expect (+/f 1 '∞) '∞)
-    [(equal? n '∞) '∞]
+(check-expect (+/f 1 2) 3)
-    [else (add1 n)]))
-(check-expect (add1/f 1) 2)
-(check-expect (add1/f '∞) '∞)
 
 ;                                          
 ;                                          
@@ -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)
+        (block-cell (cell-p to-block) all-cells)
-                             (make-cell (cell-p c) true)
-                             c))
-             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
+        (empty-board board-size)
-         (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)))))))
         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 

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)))

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}
+@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game
-and has essentailly the same rules.
+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[]
+}

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).
+;; utf-16 type (note: the non-/null variants do not use #f as NULL).
-(provide _string/ucs-4 _string/utf-16)
+(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 ...)))]))
 

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
+As of PLT Scheme version 4.0, the code snippet above can also be
-@secref{finding-a-package} can also be written using a new shorter syntax:
+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 <plt-file>, 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}
+@subsection{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.
 
 @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

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<directory> [path<file>] -> path<file>
 ;; Makes a .plt archive file suitable for PLaneT whose contents are
 ;; all files in the given directory and returns that file's name.
@@ -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
+                   (unless (scribble-entry? entry)
-                     [`(,(? string? filename) (,(? symbol? flags) ...))
+                     (error "malformed scribblings entry"))
-                      (unless (and (relative-path? filename) 
+                   (let* ([filename (scribble-entry-file entry)]
-                                   (subpath? abs-dir filename)
+                          [flags (scribble-entry-flags entry)])
-                                   (bytes=? (filename-extension filename) #"scrbl"))
+                     (unless (and (relative-path? filename) 
-                        (error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
+                                  (subpath? abs-dir filename)
-                      (unless (file-exists? (build-path abs-dir filename))
+                                  (bytes=? (filename-extension filename) #"scrbl"))
-                        (error (format "scribblings file ~a not found" filename)))
+                       (error "illegal scribblings file ~a (must be a file with extension .scrbl in the package directory or a subdirectory"))
-                      (printf "Building: ~a\n" filename)
+                     (unless (file-exists? (build-path abs-dir filename))
-                      (let* ([name.scrbl (file-name-from-path filename)]
+                       (error (format "scribblings file ~a not found" filename)))
-                             [name       (path-replace-suffix name.scrbl #"")])
+                     (printf "Building: ~a\n" filename)
-                        (render (build-path filename)
+                     (let* ([name.scrbl (file-name-from-path filename)]
-                                (build-path SCRIBBLE-DOCUMENT-DIR name)
+                            [name       (path-replace-suffix name.scrbl #"")])
-                                (memq 'multi-page flags)))]
+                       (render (build-path filename)
-                     [_ (error "malformed scribblings entry")])))))
+                               (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
+                              (andmap scribble-entry? s)))
-                               (lambda (item)
-                                 (match item
-                                   [`(,(? string?) (,(? symbol?) ...)) #t]
-                                   [_ #f]))
-                               s)))
                        (void)
                        (unless scribblings
                          (warn "Package does not specify a scribblings field. Without a scribblings field, the package will not have browsable online documentation."))]

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).
 

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

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "18dec2008")
+#lang scheme/base (provide stamp) (define stamp "22dec2008")

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
+    (add-irritants
-        (format "~a: ~a" who msg)
+     (if who
-        msg)
+         (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
+    (add-irritants
-        (format "~a: ~a" who msg)
+     (if who
-        msg)
+         (format "~a: ~a" who msg)
+         msg)
+     irritants)
     (current-continuation-marks)
     msg
     who

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
+Similar to @scheme[_pointer], except that when an @scheme[_fpointer]
-function pointers.  Using these pointers avoids one dereferencing,
+is extracted from a pointer produced by @scheme[ffi-obj-ref], then a
-which is the proper way of dealing with function pointers.  This type
+level of indirection is skipped. A level of indirection is similarly
-should be used only in rare situations where you need to pass a
+skipped when extracting a pointer via @scheme[get-ffi-obj].
-foreign function pointer to a foreign function; using a
+
-@scheme[_cprocedure] type is possible for such situations, but
+A type generated by @scheme[_cprocedure] builds on @scheme[_fpointer],
-inefficient, as every call will go through Scheme unnecessarily.
+and normally @scheme[_cprocedure] should be used instead of
-Otherwise, @scheme[_cprocedure] should be used (it is based on
+@scheme[_fpointer].}
-@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}

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.}
 
 ]

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.

collects/scribblings/guide/guide.scrbl

@@ -58,28 +58,9 @@ precise details to @|MzScheme| and other reference manuals.
 
 @include-section["compile.scrbl"]
 
-@; ----------------------------------------------------------------------
+@include-section["other.scrbl"]
-@section{More Libraries}
 
-@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the PLT
+@include-section["dialects.scrbl"]
-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.
 
 @; ----------------------------------------------------------------------
 

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.

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[]

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]
+                         [start (or/c char? #f) #f]
-                         [readtable readtable? (current-readtable)]
+                         [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]
+                                [start (or/c char? #f) #f]
-                                [readtable readtable? (current-readtable)]
+                                [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]
+                              [start (or/c char? #f) #f]
-                              [readtable readtable? (current-readtable)]
+                              [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]
+                                     [start (or/c char? #f) #f]
-                                     [readtable readtable? (current-readtable)]
+                                     [readtable (or/c readtable? #f) (current-readtable)]
                                      [graph? any/c #f])
           any]{
 

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"])

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)]

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")
  

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-whole-part "Der ganzzahlige Anteil muss eine ganze Zahl sein")
- (insert-number/bad-numerator "Der Zähler einer Zahl muß eine nichtnegative 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 muß 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...")
 

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)))))

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]
+            (lambda ()
-                           [(S sandbox-output) current-output-port]
+              (parameterize ([(S sandbox-input) current-input-port]
-                           [(S sandbox-error-output) current-error-port]
+                             [(S sandbox-output) current-output-port]
-                           [(S sandbox-memory-limit) 100]) ; 100mb per box
+                             [(S sandbox-error-output) current-error-port]
-              ((S make-evaluator) '(begin) #:requires (list 'scheme))))])
+                             [(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))

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

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))

collects/xml/private/xexpr.ss

@@ -147,6 +147,9 @@
              (string? (cadr b))
              (null? (cddr b))))
       
+      ; permissive? : parameter bool
+      (define permissive? (make-parameter #f))
+
       ;; xml->xexpr : Content -> Xexpr
       (define (xml->xexpr x)
         (let* ([non-dropping-combine
@@ -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

collects/xml/test.ss

@@ -63,6 +63,19 @@
   (test-bad-read-input
    "~n<a <a>" "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")))))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;

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?]{
 

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(<C>)
  */
 
-#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>)
+ * Scheme->C:   ucs4_string_or_null_to_ucs4_pointer(<Scheme>)
+ * S->C offset: 0
+ * C->Scheme:   scheme_make_char_string_without_copying(<C>)
+ */
+
+#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(<C>)
  */
 
+#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>)
+ * Scheme->C:   ucs4_string_or_null_to_utf16_pointer(<Scheme>)
+ * S->C offset: 0
+ * C->Scheme:   utf16_pointer_to_ucs4_string(<C>)
+ */
+
 /* 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:   (<C>==NULL)?scheme_false:scheme_make_byte_string_without_copying(<C>)
  */
 
-#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:   (<C>==NULL)?scheme_false:scheme_make_path_without_copying(<C>)
  */
 
-#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_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
-    return (Scheme_Object*)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*)<sizeof(int) && ret_loc) {
+        ((int*)W_OFFSET(dst,delta))[0] = 0;
+        delta += (sizeof(int)-sizeof(mzchar*));
+      }
+#endif
+      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
+        mzchar* tmp;
+        tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val));
+        if (basetype_p == NULL ||tmp == NULL) {
+          (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
+        } else {
+          *basetype_p = FOREIGN_string_ucs_4_null;
+          return tmp;
+        }
+      } else {
+        scheme_wrong_type("Scheme->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*)<sizeof(int) && ret_loc) {
@@ -1486,6 +1548,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         scheme_wrong_type("Scheme->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*)<sizeof(int) && ret_loc) {
+        ((int*)W_OFFSET(dst,delta))[0] = 0;
+        delta += (sizeof(int)-sizeof(unsigned short*));
+      }
+#endif
+      if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) {
+        unsigned short* tmp;
+        tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val));
+        if (basetype_p == NULL ||tmp == NULL) {
+          (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp;
+          return NULL;
+        } else {
+          *basetype_p = FOREIGN_string_utf_16_null;
+          return tmp;
+        }
+      } else {
+        scheme_wrong_type("Scheme->C","string/utf-16/null",0,1,&(val));
+        return NULL; /* hush the compiler */
+      }
     case FOREIGN_bytes:
 #ifdef SCHEME_BIG_ENDIAN
       if (sizeof(char*)<sizeof(int) && ret_loc) {
@@ -2119,19 +2202,24 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[])
     scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
   if (NULL == (base = get_ctype_base(argv[1])))
     scheme_wrong_type(MYNAME, "C-type", 1, argc, argv);
-  else size = ctype_sizeof(base);
+  size = ctype_sizeof(base);
+
   if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
-    if (argc > 2)
+    if (SCHEME_FFIOBJP(argv[0])) {
-      scheme_signal_error
+      /* The ffiobj pointer is the function pointer. */
-        (MYNAME": referencing fpointer with extra arguments");
-    else
       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);
+  size = ctype_sizeof(base);
-  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
+
-    if (argc > 3) {
+  if (size < 0) {
-      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) {
     /* 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; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
   avalues = NULL;
   switch (CTYPE_PRIMLABEL(base)) {
-  case FOREIGN_fpointer: /* need to allocate a pointer */
-    p = scheme_make_foreign_cpointer(oval.x_pointer);
-    break;
   case FOREIGN_struct:
     memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
     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;

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_make_foreign_cpointer(*(void **)W_OFFSET(src, delta));
-    return (Scheme_Object*)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)
+    if (SCHEME_FFIOBJP(argv[0])) {
-      scheme_signal_error
+      /* The ffiobj pointer is the function pointer. */
-        (MYNAME": referencing fpointer with extra arguments");
-    else
       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);
+  size = ctype_sizeof(base);
-  if (CTYPE_PRIMLABEL(base) == FOREIGN_fpointer) {
+
-    if (argc > 3) {
+  if (size < 0) {
-      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) {
     /* 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; i<nargs; i++) { avalues[i] = NULL; } /* no need for these refs */
   avalues = NULL;
   switch (CTYPE_PRIMLABEL(base)) {
-  case FOREIGN_fpointer: /* need to allocate a pointer */
-    p = scheme_make_foreign_cpointer(oval.x_pointer);
-    break;
   case FOREIGN_struct:
     memcpy(newp, p, CTYPE_PRIMTYPE(base)->size);
     free(p);

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

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)

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;

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;
@@ -4888,13 +4888,7 @@ module_optimize(Scheme_Object *data, Optimize_Info *info)
 	    if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) {
 	      pos = SCHEME_TOPLEVEL_POS(a);
 
-	      if (!ready_table) {
+              next_pos_ready = pos;
-		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);
 	    }
 	  }
 	}
@@ -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: */

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);

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++;
   }