Syncing up to trunk, including Matthew's fix.

svn: r13099

collects/lang/private/beginner-funs.ss

@@ -32,18 +32,18 @@
       ((beginner-* *) (num num num ... -> num)
        "to compute the product of all of the input numbers")
       ((beginner-/ /) (num num num ... -> num)
-       "to divide the first by the second (and all following) number(s);"
+       "to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)"
        " only the first number can be zero.")
       (max (real real ... -> real)
 	"to determine the largest number")
       (min (real real ... -> real)
 	"to determine the smallest number")       
       (quotient (int int -> int)
-	"to compute the quotient of two integers")
+	"to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)")
       (remainder (int int -> int)
-	"to compute the remainder of dividing the first by the second integer")
+	"to determine the remainder of dividing the first by the second integer")
       (modulo (int int -> int)
-	"to compute first number modulo second number")    
+	"to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)") 
       (sqr (num -> num)
 	"to compute the square of a number")
       (sqrt (num -> num)

collects/macro-debugger/stxclass/private/lib.ss

@@ -69,6 +69,20 @@
                  #:pattern 'static
                  #:reason "not an identifier"))))
 
+(define-basic-syntax-class (static-of name pred)
+  ([value 0])
+  (lambda (x name pred)
+    (let/ec escape
+      (define (bad)
+        (escape (fail-sc x
+                         #:pattern 'name
+                         #:reason (format "not bound as ~a" name))))
+      (if (identifier? x)
+          (let ([value (syntax-local-value x bad)])
+            (unless (pred value) (bad))
+            (list value))
+          (bad)))))
+
 (define-basic-syntax-class struct-name
   ([descriptor 0]
    [constructor 0]

collects/macro-debugger/stxclass/private/parse.ss

@@ -74,7 +74,7 @@
   (with-syntax ([k k] [x x] [p p] [reason reason]
                 [fc-expr (frontier->expr fc)])
     #`(let ([failcontext fc-expr])
-        (printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
+        #;(printf "failed: reason=~s, p=~s\n  fc=~s\n" reason p failcontext)
         (k x p 'reason failcontext))))
 
 ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK)

collects/macro-debugger/stxclass/private/rep.ss

@@ -185,7 +185,9 @@
                     [args (cdr p)])
                 (unless (equal? (length (sc-inputs stxclass)) (length args))
                   (raise-syntax-error 'syntax-class
-                                      "too few arguments for syntax class"
+                                      (format "too few arguments for syntax class ~a (expected ~s)"
+                                              (sc-name stxclass)
+                                              (length (sc-inputs stxclass)))
                                       id))
                 (values id stxclass args (ssc? stxclass))))]
         [else (values id #f null #f)]))

collects/macro-debugger/stxclass/private/util.ss

@@ -214,6 +214,7 @@
                  [_
                   (loop (stx-cdr x) (cons ee ex) #t)]))]
             [(stx-null? x)
+             (internal-definition-context-seal intdef)
              (reverse ex)]))))
 
 

collects/macro-debugger/syntax-browser/controller.ss

@@ -1,6 +1,7 @@
 
 #lang scheme/base
 (require scheme/class
+         macro-debugger/util/class-iop
          "interfaces.ss"
          "partition.ss"
          "../util/notify.ss")
@@ -31,7 +32,7 @@
     (super-new)
     (listen-selected-syntax
      (lambda (new-value)
-       (for-each (lambda (display) (send display refresh))
+       (for-each (lambda (display) (send: display display<%> refresh))
                  displays)))))
 
 ;; mark-manager-mixin
@@ -62,7 +63,7 @@
              (new partition% (relation (cdr name+proc)))))))
     (listen-secondary-partition
      (lambda (p)
-       (for-each (lambda (d) (send d refresh))
+       (for-each (lambda (d) (send: d display<%> refresh))
                  displays)))
     (super-new)))
 

collects/macro-debugger/syntax-browser/display.ss

@@ -3,6 +3,7 @@
 (require scheme/class
          scheme/gui
          scheme/match
+         macro-debugger/util/class-iop
          "pretty-printer.ss"
          "interfaces.ss"
          "util.ss")
@@ -17,7 +18,7 @@
   (define output-port (open-output-string/count-lines))
   (define range
     (pretty-print-syntax stx output-port 
-                         (send controller get-primary-partition)
+                         (send: controller controller<%> get-primary-partition)
                          (send config get-colors)
                          (send config get-suffix-option)
                          columns))
@@ -42,13 +43,14 @@
 
 ;; add-clickbacks : text% range% controller<%> number -> void
 (define (add-clickbacks text range controller insertion-point)
-  (for ([range (send range all-ranges)])
+  (for ([range (send: range range<%> all-ranges)])
     (let ([stx (range-obj range)]
           [start (range-start range)]
           [end (range-end range)])
       (send text set-clickback (+ insertion-point start) (+ insertion-point end)
             (lambda (_1 _2 _3)
-              (send controller set-selected-syntax stx))))))
+              (send: controller selection-manager<%>
+                     set-selected-syntax stx))))))
 
 ;; set-standard-font : text% config number number -> void
 (define (set-standard-font text config start end)
@@ -81,7 +83,9 @@
           (begin-edit-sequence)
           (change-style unhighlight-d start-position end-position))
         (apply-extra-styles)
-        (let ([selected-syntax (send controller get-selected-syntax)])
+        (let ([selected-syntax
+               (send: controller selection-manager<%>
+                      get-selected-syntax)])
           (apply-secondary-partition-styles selected-syntax)
           (apply-selection-styles selected-syntax))
         (send* text
@@ -126,9 +130,11 @@
         (let ([delta (new style-delta%)])
           (send delta set-delta-foreground color)
           delta))
-      (define color-styles (list->vector (map color-style (send config get-colors))))
+      (define color-styles
+        (list->vector (map color-style (send config get-colors))))
       (define overflow-style (color-style "darkgray"))
-      (define color-partition (send controller get-primary-partition))
+      (define color-partition
+        (send: controller mark-manager<%> get-primary-partition))
       (define offset start-position)
       (for-each
        (lambda (range)
@@ -139,12 +145,12 @@
                  (primary-style stx color-partition color-styles overflow-style)
                  (+ offset start)
                  (+ offset end))))
-       (send range all-ranges)))
+       (send: range range<%> all-ranges)))
 
     ;; primary-style : syntax partition (vector-of style-delta%) style-delta%
     ;;               -> style-delta%
     (define/private (primary-style stx partition color-vector overflow)
-      (let ([n (send partition get-partition stx)])
+      (let ([n (send: partition partition<%> get-partition stx)])
         (cond [(< n (vector-length color-vector))
                (vector-ref color-vector n)]
               [else
@@ -157,7 +163,7 @@
     ;; Applies externally-added styles (such as highlighting)
     (define/private (apply-extra-styles)
       (for ([(stx style-deltas) extra-styles])
-        (for ([r (send range get-ranges stx)])
+        (for ([r (send: range range<%> get-ranges stx)])
           (for ([style-delta style-deltas])
             (restyle-range r style-delta)))))
 
@@ -166,23 +172,25 @@
     ;; in the same partition in blue.
     (define/private (apply-secondary-partition-styles selected-syntax)
       (when (identifier? selected-syntax)
-        (let ([partition (send controller get-secondary-partition)])
+        (let ([partition
+               (send: controller secondary-partition<%>
+                      get-secondary-partition)])
           (when partition
-            (for-each (lambda (id)
+            (for ([id (send: range range<%> get-identifier-list)])
-                        (when (send partition same-partition? selected-syntax id)
+              (when (send: partition partition<%>
-                          (draw-secondary-connection id)))
+                           same-partition? selected-syntax id)
-                      (send range get-identifier-list))))))
+                (draw-secondary-connection id)))))))
 
     ;; apply-selection-styles : syntax -> void
     ;; Styles subterms eq to the selected syntax
     (define/private (apply-selection-styles selected-syntax)
-      (let ([rs (send range get-ranges selected-syntax)])
+      (for ([r (send: range range<%> get-ranges selected-syntax)])
-        (for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
+        (restyle-range r select-highlight-d)))
 
     ;; draw-secondary-connection : syntax -> void
     (define/private (draw-secondary-connection stx2)
-      (let ([rs (send range get-ranges stx2)])
+      (for ([r (send range get-ranges stx2)])
-        (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
+        (restyle-range r select-sub-highlight-d)))
 
     ;; restyle-range : (cons num num) style-delta% -> void
     (define/private (restyle-range r style)
@@ -258,4 +266,3 @@
 (define select-sub-highlight-d (highlight-style-delta subselection-color #f))
 
 (define unhighlight-d (highlight-style-delta "white" #f))
-

collects/macro-debugger/syntax-browser/frame.ss

@@ -1,4 +1,3 @@
-
 #lang scheme/base
 (require scheme/class
          scheme/gui
@@ -20,10 +19,9 @@
 ;; browse-syntaxes : (list-of syntax) -> void
 (define (browse-syntaxes stxs)
   (let ((w (make-syntax-browser)))
-    (for-each (lambda (stx)
+    (for ([stx stxs])
       (send w add-syntax stx)
-                (send w add-separator))
+      (send w add-separator))))
-              stxs)))
 
 ;; make-syntax-browser : -> syntax-browser<%>
 (define (make-syntax-browser)

collects/macro-debugger/syntax-browser/interfaces.ss

@@ -1,37 +1,33 @@
 
 #lang scheme/base
-(require scheme/class)
+(require scheme/class
+         macro-debugger/util/class-iop)
 (provide (all-defined-out))
 
 ;; displays-manager<%>
-(define displays-manager<%>
+(define-interface displays-manager<%>
-  (interface ()
+  (;; add-syntax-display : display<%> -> void
-    ;; add-syntax-display : display<%> -> void
    add-syntax-display
 
    ;; remove-all-syntax-displays : -> void
    remove-all-syntax-displays))
 
 ;; selection-manager<%>
-(define selection-manager<%>
+(define-interface selection-manager<%>
-  (interface ()
+  (;; selected-syntax : syntax/#f
-    ;; selected-syntax : syntax/#f
    set-selected-syntax
    get-selected-syntax
-    listen-selected-syntax
+   listen-selected-syntax))
-    ))
 
 ;; mark-manager<%>
 ;; Manages marks, mappings from marks to colors
-(define mark-manager<%>
+(define-interface mark-manager<%>
-  (interface ()
+  (;; get-primary-partition : -> partition
-    ;; get-primary-partition : -> partition
    get-primary-partition))
 
 ;; secondary-partition<%>
-(define secondary-partition<%>
+(define-interface secondary-partition<%>
-  (interface (displays-manager<%>)
+  (;; get-secondary-partition : -> partition<%>
-    ;; get-secondary-partition : -> partition<%>
    get-secondary-partition
 
    ;; set-secondary-partition : partition<%> -> void
@@ -50,32 +46,44 @@
    listen-identifier=?))
 
 ;; controller<%>
-(define controller<%>
+(define-interface/dynamic controller<%>
   (interface (displays-manager<%>
               selection-manager<%>
               mark-manager<%> 
-              secondary-partition<%>)))
+              secondary-partition<%>))
+  (add-syntax-display
+   remove-all-syntax-displays
+   set-selected-syntax
+   get-selected-syntax
+   listen-selected-syntax
+   get-primary-partition
+   get-secondary-partition
+   set-secondary-partition
+   listen-secondary-partition
+   get-identifier=?
+   set-identifier=?
+   listen-identifier=?))
+
 
 ;; host<%>
-(define host<%>
+(define-interface host<%>
-  (interface ()
+  (;; get-controller : -> controller<%>
-    ;; get-controller : -> controller<%>
    get-controller
 
    ;; add-keymap : text snip
-    add-keymap
+   add-keymap))
-    ))
-
 
 ;; display<%>
-(define display<%>
+(define-interface display<%>
-  (interface ()
+  (;; refresh : -> void
-    ;; refresh : -> void
    refresh
 
    ;; highlight-syntaxes : (list-of syntax) color -> void
    highlight-syntaxes
 
+   ;; underline-syntaxes : (listof syntax) -> void
+   underline-syntaxes
+
    ;; get-start-position : -> number
    get-start-position
 
@@ -86,9 +94,8 @@
    get-range))
 
 ;; range<%>
-(define range<%>
+(define-interface range<%>
-  (interface ()
+  (;; get-ranges : datum -> (list-of (cons number number))
-    ;; get-ranges : datum -> (list-of (cons number number))
    get-ranges
 
    ;; all-ranges : (list-of Range)
@@ -98,41 +105,37 @@
    ;; get-identifier-list : (list-of identifier)
    get-identifier-list))
 
+
 ;; A Range is (make-range datum number number)
 (define-struct range (obj start end))
 
 
 ;; syntax-prefs<%>
-(define syntax-prefs<%>
+(define-interface syntax-prefs<%>
-  (interface ()
+  (pref:width
-    pref:width
    pref:height
    pref:props-percentage
    pref:props-shown?))
 
 ;; widget-hooks<%>
-(define widget-hooks<%>
+(define-interface widget-hooks<%>
-  (interface ()
+  (;; setup-keymap : -> void
-    ;; setup-keymap : -> void
    setup-keymap
 
    ;; shutdown : -> void
-    shutdown
+   shutdown))
-    ))
 
 ;; keymap-hooks<%>
-(define keymap-hooks<%>
+(define-interface keymap-hooks<%>
-  (interface ()
+  (;; make-context-menu : -> context-menu<%>
-    ;; make-context-menu : -> context-menu<%>
    make-context-menu
 
    ;; get-context-menu% : -> class
    get-context-menu%))
 
 ;; context-menu-hooks<%>
-(define context-menu-hooks<%>
+(define-interface context-menu-hooks<%>
-  (interface ()
+  (add-edit-items
-    add-edit-items
    after-edit-items
    add-selection-items
    after-selection-items
@@ -143,19 +146,16 @@
 ;;----------
 
 ;; Convenience widget, specialized for displaying stx and not much else
-(define syntax-browser<%>
+(define-interface syntax-browser<%>
-  (interface ()
+  (add-syntax
-    add-syntax
    add-text
    add-separator
    erase-all
    select-syntax
-    get-text
+   get-text))
-    ))
 
-(define partition<%>
+(define-interface partition<%>
-  (interface ()
+  (;; get-partition : any -> number
-    ;; get-partition : any -> number
    get-partition
 
    ;; same-partition? : any any -> number

collects/macro-debugger/syntax-browser/properties.ss

@@ -2,6 +2,7 @@
 #lang scheme/base
 (require scheme/class
          scheme/gui
+         macro-debugger/util/class-iop
          "interfaces.ss"
          "util.ss"
          "../util/mpi.ss")
@@ -24,7 +25,7 @@
     (field (text (new text%)))
     (field (pdisplayer (new properties-displayer% (text text))))
 
-    (send controller listen-selected-syntax
+    (send: controller selection-manager<%> listen-selected-syntax
            (lambda (stx)
              (set! selected-syntax stx)
              (refresh)))

collects/macro-debugger/syntax-browser/widget.ss

@@ -6,6 +6,7 @@
          scheme/list
          scheme/match
          syntax/boundmap
+         macro-debugger/util/class-iop
          "interfaces.ss"
          "controller.ss"
          "display.ss"
@@ -119,7 +120,8 @@
       (let ([display (internal-add-syntax stx)]
             [definite-table (make-hasheq)])
         (for-each (lambda (hi-stxs hi-color)
-                    (send display highlight-syntaxes hi-stxs hi-color))
+                    (send: display display<%>
+                           highlight-syntaxes hi-stxs hi-color))
                   hi-stxss
                   hi-colors)
         (for ([definite definites])
@@ -128,20 +130,20 @@
             (for ([shifted-definite (hash-ref shift-table definite null)])
               (hash-set! definite-table shifted-definite #t))))
         (when alpha-table
-          (let ([range (send display get-range)]
+          (let ([range (send: display display<%> get-range)]
-                [start (send display get-start-position)])
+                [start (send: display display<%> get-start-position)])
             (let* ([binders0
                     (module-identifier-mapping-map alpha-table (lambda (k v) k))]
                    [binders
                     (apply append (map get-binders binders0))])
-              (send display underline-syntaxes binders))
+              (send: display display<%> underline-syntaxes binders))
-            (for ([id (send range get-identifier-list)])
+            (for ([id (send: range range<%> get-identifier-list)])
               (define definite? (hash-ref definite-table id #f))
               (when #f ;; DISABLED
                 (add-binding-billboard start range id definite?))
               (for ([binder (get-binders id)])
-                (for ([binder-r (send range get-ranges binder)])
+                (for ([binder-r (send: range range<%> get-ranges binder)])
-                  (for ([id-r (send range get-ranges id)])
+                  (for ([id-r (send: range range<%> get-ranges id)])
                     (add-binding-arrow start binder-r id-r definite?)))))))
         (void)))
 
@@ -169,7 +171,7 @@
                            (+ start (cdr id-r))
                            (string-append "from " (mpi->string src-mod))
                            (if definite? "blue" "purple")))
-                   (send range get-ranges id))]
+                   (send: range range<%> get-ranges id))]
         [_ (void)]))
 
     (define/public (add-separator)
@@ -182,7 +184,7 @@
       (with-unlock -text
         (send -text erase)
         (send -text delete-all-drawings))
-      (send controller remove-all-syntax-displays))
+      (send: controller displays-manager<%> remove-all-syntax-displays))
 
     (define/public (get-text) -text)
 

collects/macro-debugger/util/class-ct.ss

@@ -0,0 +1,73 @@
+#lang scheme/base
+(require (for-template scheme/base
+                       scheme/class)
+         macro-debugger/stxclass/stxclass)
+
+(provide static-interface?
+         make-static-interface
+         static-interface-dynamic
+         static-interface-members
+
+         make-checked-binding
+         checked-binding?
+         checked-binding-dynamic
+         checked-binding-iface
+
+         checked-binding
+         static-interface)
+
+(define-struct static-interface (dynamic members)
+  #:omit-define-syntaxes
+  #:property prop:procedure
+             (lambda (self stx)
+               (syntax-case stx ()
+                 [(ifname . args)
+                  (datum->syntax stx (cons #'(#%expression ifname) #'args) stx)]
+                 [ifname
+                  (identifier? #'ifname)
+                  (static-interface-dynamic self)])))
+
+(define-struct raw-checked-binding (dynamic iface)
+  #:omit-define-syntaxes
+  #:property prop:procedure
+             (lambda (self stx)
+               (syntax-case stx (set!)
+                 [(set! var expr)
+                  #`(let ([newval expr])
+                      (unless (is-a? newval #,(static-interface-dynamic
+                                               (raw-checked-binding-iface self)))
+                        (error 'check "interface check failed on: ~e" newval))
+                      (set! #,(raw-checked-binding-dynamic self) newval))]
+                 [(var . args)
+                  (datum->syntax stx (cons #'(#%expression var) #'args) stx)]
+                 [var
+                  (identifier? #'var)
+                  (raw-checked-binding-dynamic self)]
+                 [else
+                  (raise-syntax-error #f "oops" stx)])))
+
+(define (make-checked-binding dynamic iface)
+  (make-set!-transformer
+   (make-raw-checked-binding dynamic iface)))
+
+(define (checked-binding? x)
+  (and (set!-transformer? x)
+       (raw-checked-binding? (set!-transformer-procedure x))))
+
+(define (checked-binding-dynamic x)
+  (raw-checked-binding-dynamic (set!-transformer-procedure x)))
+
+(define (checked-binding-iface x)
+  (raw-checked-binding-iface (set!-transformer-procedure x)))
+
+;; Syntax
+
+(define-syntax-class static-interface
+  (pattern x
+           #:declare x (static-of 'static-interface static-interface?)
+           #:with value #'x.value))
+
+(define-syntax-class checked-binding
+  (pattern x
+           #:declare x (static-of 'checked-binding checked-binding?)
+           #:with value #'x.value))

collects/macro-debugger/util/class-iop.ss

@@ -0,0 +1,213 @@
+#lang scheme/base
+(require scheme/class
+         (for-syntax scheme/base
+                     macro-debugger/stxclass/stxclass
+                     "class-ct.ss"))
+(provide define-interface
+         define-interface/dynamic
+
+         send:
+         send*:
+         send/apply:
+
+         define:
+         lambda:
+         init:
+         init-private:)
+
+;; Configuration
+(define-for-syntax warn-on-dynamic-interfaces? #f)
+(define-for-syntax warn-on-dynamic-object-check-generation? #f)
+(define-for-syntax define-dotted-names #f)
+
+;; define-interface SYNTAX
+;; (define-interface NAME (IDENTIFIER ...))
+;; Defines NAME as an interface.
+(define-syntax (define-interface stx)
+  (syntax-parse stx
+    [(_ name:id (mname:id ...))
+     #'(define-interface/dynamic name
+         (let ([name (interface () mname ...)]) name)
+         (mname ...))]))
+
+;; define-interface/dynamic SYNTAX
+;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
+;; Defines NAME as a static interface containing the names listed.
+;; The EXPR is used as the dynamic componenent of the interface, and 
+;; it should contain a superset of the names listed.
+(define-syntax (define-interface/dynamic stx)
+  (syntax-parse stx
+    [(_ name:id dynamic-interface:expr (mname:id ...))
+     (with-syntax ([(dynamic-name) (generate-temporaries #'(name))])
+       #'(begin (define dynamic-name
+                  (let ([dynamic-name dynamic-interface])
+                    (for-each 
+                     (lambda (m)
+                       (unless (method-in-interface? m dynamic-name)
+                         (error 'name "dynamic interface missing method '~s'" m)))
+                     '(mname ...))
+                    dynamic-name))
+                (define-syntax name
+                  (make-static-interface #'dynamic-name '(mname ...)))))]))
+
+;; Helper
+
+(begin-for-syntax
+  (define (check-method-in-interface for-whom method si)
+    (unless (member (syntax-e method) (static-interface-members si))
+      (raise-syntax-error for-whom
+                          "method not in static interface"
+                          method))))
+
+;; Checked send
+
+(define-syntax (send: stx)
+  (syntax-parse stx
+    [(send: obj:expr iface:static-interface method:id . args)
+     (begin (check-method-in-interface 'send: #'method #'iface.value)
+            (syntax/loc stx
+              (send (check-object<:interface send: obj iface)
+                    method . args)))]))
+
+(define-syntax (send*: stx)
+  (syntax-parse stx
+    [(send*: obj:expr iface:static-interface (method:id . args) ...)
+     (begin (for ([method (syntax->list #'(method ...))])
+              (check-method-in-interface 'send*: method #'iface.value))
+            (syntax/loc stx 
+              (send* (check-object<:interface send*: obj iface)
+                (method . args) ...)))]))
+
+(define-syntax (send/apply: stx)
+  (syntax-parse stx
+    [(send/apply: obj:expr iface:static-interface method:id . args)
+     (begin (check-method-in-interface 'send/apply: #'method #'iface.value)
+            (syntax/loc stx 
+              (send/apply (check-object<:interface send/apply obj iface)
+                          method . args)))]))
+
+;;
+
+;; check-object<:interface SYNTAX
+(define-syntax (check-object<:interface stx)
+  (syntax-parse stx
+    [(_ for-whom obj:checked-binding iface:static-interface)
+     (if (eq? (checked-binding-iface #'obj.value) #'iface.value)
+         #'obj
+         (syntax/loc stx
+           (check-object<:interface for-whom
+                                    (#%expression obj)
+                                    (#%expression iface))))]
+    [(_ for-whom obj:expr iface:expr)
+     (begin
+       (when warn-on-dynamic-object-check-generation?
+         (printf "dynamic object check: ~s,~s~n"
+                 (syntax-source #'obj)
+                 (syntax-line #'obj)))
+       #'(dynamic:check-object<:interface 'for-whom obj iface))]))
+
+(define (dynamic:check-object<:interface for-whom obj iface)
+  (unless (is-a? obj iface)
+    (error for-whom "interface check failed on: ~e" obj))
+  obj)
+
+;;
+
+(define-syntax (define: stx)
+  (syntax-parse stx
+    [(_ name:id iface:static-interface expr)
+     (let ([si #'iface.value])
+       (with-syntax ([(name-internal) (generate-temporaries #'(name))]
+                     [(method ...) (static-interface-members si)]
+                     [(name.method ...)
+                      (map (lambda (m)
+                             (datum->syntax #'name
+                                            (string->symbol (format "~a.~a" (syntax-e #'name) m))))
+                           (static-interface-members si))])
+         #`(begin (define name-internal
+                    (check-object<:interface define: expr iface))
+                  (define-syntax name
+                    (make-checked-binding
+                     #'name-internal
+                     (syntax-local-value #'iface)))
+                  #,(if define-dotted-names
+                        #'(begin
+                            (define-syntax name.method
+                              (syntax-rules ()
+                                [(name.method . args)
+                                 (send: name iface method . args)]))
+                            ...)
+                        #'(begin)))))]
+    [(_ (f:id . args) . body)
+     #'(define f (lambda: args . body))]))
+
+(define-syntax (lambda: stx)
+  ;; FIXME: rewrite as stxclass
+  (define (arg->define stx temp)
+    (syntax-case stx ()
+      [(arg : iface) 
+       (and (identifier? #'arg)
+            (eq? ': (syntax-e #':)))
+       #`(define: arg iface #,temp)]
+      [arg
+       (identifier? #'arg)
+       #`(define-syntax arg (make-rename-transformer #'#,temp))]))
+  (syntax-parse stx
+    [(_ (arg ...) . body)
+     (let ([temporaries (generate-temporaries #'(arg ...))])
+       (with-syntax ([(temp ...) temporaries]
+                     [(checked-definition ...)
+                      (map arg->define
+                           (syntax->list #'(arg ...))
+                           temporaries)])
+         #'(lambda (temp ...)
+             (let ()
+               checked-definition ...
+               (let () . body)))))]))
+
+
+;; FIXME: unsafe due to mutation
+(define-syntax (init-field: stx)
+  (syntax-parse stx
+    [(_ (name:id iface:static-interface) ...)
+     #'(begin (init1: init-field name iface) ...)]))
+
+(define-syntax (init: stx)
+  (syntax-parse stx
+    [(_ (name:id iface:static-interface) ...)
+     #'(begin (init1: init name iface) ...)]))
+
+(define-syntax (init1: stx)
+  (syntax-parse stx
+    [(_ init name:id iface:static-interface)
+     (with-syntax ([(name-internal) (generate-temporaries #'(name))])
+       #'(begin (init (name name-internal))
+                (void (check-object<:interface init: name-internal iface))
+                (define-syntax name 
+                  (make-checked-binding
+                   #'name-internal
+                   (syntax-local-value #'iface)))))]))
+
+(define-syntax (init-private stx)
+  (syntax-parse stx
+    [(init-private form ...)
+     #'(begin (init-private1 form) ...)]))
+
+(define-syntax (init-private1 stx)
+  (syntax-parse stx
+    [(init-private1 id:id)
+     (with-syntax ([(id-internal) (generate-temporaries #'(id))])
+       #'(begin (init (id-internal id))
+                (define id id-internal)))]))
+
+(define-syntax (init-private: stx)
+  (syntax-parse stx
+    [(_ (name:id iface:static-interface) ...)
+     #'(begin (init-private1: name iface) ...)]))
+
+(define-syntax (init-private1: stx)
+  (syntax-parse stx
+    [(_ name:id iface:static-interface)
+     (with-syntax ([(id-internal) (generate-temporaries #'(id))])
+       #'(begin (init (id-internal name))
+                (define: name iface id-internal)))]))

collects/redex/private/rg-test.ss

@@ -495,11 +495,12 @@
                     #:var (list (λ _ 'x) (λ _ 'y))))
         (term (λ (x) (hole y)))))
 
-;; current-output : (-> (-> any) string)
+;; output : (-> (-> void) string)
-(define (current-output thunk)
+(define (output thunk)
   (let ([p (open-output-string)])
     (parameterize ([current-output-port p])
-      (thunk))
+      (unless (void? (thunk))
+        (error 'output "expected void result")))
     (begin0
       (get-output-string p)
       (close-output-port p))))
@@ -510,28 +511,38 @@
     (d 5)
     (e e 4)
     (n number))
-  (test (current-output (λ () (redex-check lang d #f))) 
+  (test (output (λ () (redex-check lang d #f))) 
         "counterexample found after 1 attempts:\n5\n")
-  (test (redex-check lang d #t) #t)
+  (test (output (λ () (redex-check lang d #t))) "")
-  (test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t)
+  (test (output (λ () (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2)))
-  (test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t)
+        "")
-  (test (current-output (λ () (redex-check lang (d e) #f)))
+  (test (output (λ () (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2)))
+        "")
+  (test (output (λ () (redex-check lang (d e) #f)))
         "counterexample found after 1 attempts:\n(5 4)\n")
-  (test (current-output (λ () (redex-check lang d (error 'pred-raised))))
+  (let* ([p (open-output-string)]
-        "counterexample found after 1 attempts:\n5\n")
+         [m (parameterize ([current-error-port p])
+              (with-handlers ([exn:fail? exn-message])
+                (redex-check lang d (error 'pred-raised))
+                'no-exn-raised))])
+    (test m "error: pred-raised")
+    (test (get-output-string p) #rx"checking 5 raises.*\n$")
+    (close-output-port p))
   (test (parameterize ([check-randomness (make-random 0 0)])
+          (output
+           (λ ()
              (redex-check lang n (eq? 42 (term n)) 
                           #:attempts 1
-                       #:source (reduction-relation lang (--> 42 x))))
+                          #:source (reduction-relation lang (--> 42 x))))))
-        #t)
+        "")
-  (test (current-output
+  (test (output
          (λ ()
            (parameterize ([check-randomness (make-random 0 0)])
              (redex-check lang n (eq? 42 (term n)) 
                           #:attempts 1
                           #:source (reduction-relation lang (--> 0 x z))))))
         "counterexample found (z) after 1 attempts:\n0\n")
-  (test (current-output
+  (test (output
          (λ ()
            (parameterize ([check-randomness (make-random 1)])
              (redex-check lang d (eq? 42 (term n)) 
@@ -539,19 +550,23 @@
                           #:source (reduction-relation lang (--> 0 x z))))))
         "counterexample found after 1 attempts:\n5\n")
   (test (let ([r (reduction-relation lang (--> 0 x z))])
+          (output 
+           (λ ()
              (redex-check lang n (number? (term n)) 
                           #:attempts 10
-                       #:source r))
+                          #:source r))))
-        #t)
+        "")
   (let ()
     (define-metafunction lang
       [(mf 0) 0]
       [(mf 42) 0])
     (test (parameterize ([check-randomness (make-random 0 1)])
+            (output 
+             (λ ()
                (redex-check lang (n) (eq? 42 (term n)) 
                             #:attempts 1
-                         #:source mf))
+                            #:source mf))))
-          #t))
+          ""))
   (let ()
     (define-language L)
     (test (with-handlers ([exn:fail? exn-message])
@@ -601,21 +616,21 @@
     [(i any ...) (any ...)])
   
   ;; Dom(f) < Ctc(f)
-  (test (current-output 
+  (test (output 
          (λ () 
            (parameterize ([generation-decisions 
                            (decisions #:num (list (λ _ 2) (λ _ 5)))])
              (check-metafunction-contract f))))
         "counterexample found after 1 attempts:\n(5)\n")
   ;; Rng(f) > Codom(f)
-  (test (current-output
+  (test (output
          (λ () 
            (parameterize ([generation-decisions
                            (decisions #:num (list (λ _ 3)))])
              (check-metafunction-contract f))))
         "counterexample found after 1 attempts:\n(3)\n")
   ;; LHS matches multiple ways
-  (test (current-output
+  (test (output
          (λ () 
            (parameterize ([generation-decisions
                            (decisions #:num (list (λ _ 1) (λ _ 1))
@@ -623,9 +638,9 @@
              (check-metafunction-contract g))))
         "counterexample found after 1 attempts:\n(1 1)\n")
   ;; OK -- generated from Dom(h)
-  (test (check-metafunction-contract h) #t)
+  (test (output (λ () (check-metafunction-contract h))) "")
   ;; OK -- generated from pattern (any ...)
-  (test (check-metafunction-contract i #:attempts 5) #t))
+  (test (output (λ () (check-metafunction-contract i #:attempts 5))) ""))
 
 ;; check-reduction-relation
 (let ()
@@ -653,11 +668,11 @@
           (reverse '((+ (+)) 0))))
   
   (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))])
-    (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t)
+    (test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) "")
-    (test (current-output 
+    (test (output 
            (λ () (check-reduction-relation S (λ (x) #f))))
           "counterexample found after 1 attempts with name:\n1\n")
-    (test (current-output 
+    (test (output 
            (λ () (check-reduction-relation S (curry eq? 1))))
           "counterexample found after 1 attempts with unnamed:\n3\n"))
   
@@ -671,11 +686,13 @@
             with
             [(--> (9 a) b)
              (==> a b)])])
-    (test (check-reduction-relation 
+    (test (output
+           (λ ()
+             (check-reduction-relation 
               T (curry equal? '(9 4)) 
               #:attempts 1
-           #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))
+              #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x)))))))
-          #t)))
+          "")))
 
 ; check-metafunction
 (let ()
@@ -688,7 +705,8 @@
             (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1)
             generated) 
           (reverse '((1) (2)))))
-  (test (current-output (λ () (check-metafunction m (curry eq? 1))))
+  (test (output (λ () (check-metafunction m (λ (_) #t)))) "")
+  (test (output (λ () (check-metafunction m (curry eq? 1))))
         #rx"counterexample found after 1 attempts with clause #1")
   (test (with-handlers ([exn:fail:contract? exn-message])
           (check-metafunction m #t #:attempts 'NaN))

collects/redex/private/rg.ss

@@ -680,7 +680,7 @@ To do a better job of not generating programs with free variables,
          (quasisyntax/loc stx
            (let ([att attempts])
              (assert-nat 'redex-check att)
-             (or (check-property 
+             (check-property 
               (cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f)
                     (let ([lang-gen (generate lang (random-decisions lang))])
                       #,(if (not source-stx)
@@ -714,7 +714,7 @@ To do a better job of not generating programs with free variables,
                          (if source (format " (~a) " source) " ") attempt)
                 (pretty-print term port))
               (check-randomness))
-                 (void))))))]))
+             (void)))))]))
 
 (define (check-property gens-srcs match match-fail property attempts display [random random])
   (let loop ([remaining attempts])
@@ -729,7 +729,11 @@ To do a better job of not generating programs with free variables,
                         [(term bindings) 
                          (generator (attempt->size attempt) attempt)])
             (if (andmap (λ (bindings) 
-                          (with-handlers ([exn:fail? (λ (_) #f)])
+                          (with-handlers ([exn:fail? (λ (exn) 
+                                                       (fprintf (current-error-port)
+                                                                "checking ~s raises ~s\n"
+                                                                term exn)
+                                                       (raise exn))])
                             (property term bindings)))
                         (cond [(and match (match term)) 
                                => (curry map (compose make-bindings match-bindings))]
@@ -758,11 +762,14 @@ To do a better job of not generating programs with free variables,
            (list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f))
            #f
            #f
-           (λ (t _) (begin (term (name ,@t)) #t))
+           (λ (t _) 
+             (with-handlers ([exn:fail:redex? (λ (_) #f)])
+               (begin (term (name ,@t)) #t)))
            att
            (λ (term attempt _ port)
              (fprintf port "counterexample found after ~a attempts:\n" attempt)
-             (pretty-print term port))))))]))
+             (pretty-print term port)))
+          (void))))]))
 
 (define (check-property-many lang pats srcs prop decisions attempts)
   (let ([lang-gen (generate lang (decisions lang))])
@@ -777,7 +784,8 @@ To do a better job of not generating programs with free variables,
        (λ (term attempt source port)
          (fprintf port "counterexample found after ~a attempts with ~a:\n" 
                   attempt source)
-         (pretty-print term port))))))
+         (pretty-print term port))))
+    (void)))
 
 (define (metafunc-srcs m)
   (build-list (length (metafunc-proc-lhs-pats m))
@@ -792,14 +800,13 @@ To do a better job of not generating programs with free variables,
        (syntax/loc stx
          (let ([att attempts])
            (assert-nat 'check-metafunction att)
-           (or (check-property-many 
+           (check-property-many 
             (metafunc-proc-lang m)
             (metafunc-proc-lhs-pats m)
             (metafunc-srcs m)
             property
             (generation-decisions)
-                att)
+            att))))]))
-               (void)))))]))
 
 (define (reduction-relation-srcs r)
   (map (λ (proc) (or (rewrite-proc-name proc) 'unnamed))
@@ -809,14 +816,13 @@ To do a better job of not generating programs with free variables,
          relation property 
          #:decisions [decisions random-decisions]
          #:attempts [attempts default-check-attempts])
-  (or (check-property-many
+  (check-property-many
    (reduction-relation-lang relation)
    (map rewrite-proc-lhs (reduction-relation-make-procs relation))
    (reduction-relation-srcs relation)
    property
    decisions
-       attempts)
+   attempts))
-      (void)))
 
 (define-signature decisions^
   (next-variable-decision

collects/repos-time-stamp/stamp.ss

@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "12jan2009")
+#lang scheme/base (provide stamp) (define stamp "13jan2009")

src/mzscheme/src/env.c

@@ -2609,6 +2609,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
 	  if (SCHEME_FALSEP(val)) {
 	    /* Corresponds to a run-time binding (but will be replaced later
 	       through a renaming to a different binding) */
+            if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
+              return scheme_make_local(scheme_local_type, 0, 0);
             return NULL;
 	  }
 
@@ -2647,6 +2649,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
       if (!(flags & SCHEME_OUT_OF_CONTEXT_OK))
         scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
                             "identifier used out of context");
+      if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL)
+        return scheme_make_local(scheme_local_type, 0, 0);
       return NULL;
     }
   }

src/mzscheme/src/eval.c

@@ -5379,7 +5379,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 				       ? SCHEME_RESOLVE_MODIDS
 				       : 0)
                                     + ((!rec[drec].comp && (rec[drec].depth == -2))
-                                       ? SCHEME_OUT_OF_CONTEXT_OK
+                                       ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
                                        : 0),
 				    rec[drec].certs, env->in_modidx, 
 				    &menv, &protected, &lexical_binding_id);
@@ -5486,7 +5486,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 				       ? SCHEME_RESOLVE_MODIDS
 				       : 0)
                                     + ((!rec[drec].comp && (rec[drec].depth == -2))
-                                       ? SCHEME_OUT_OF_CONTEXT_OK
+                                       ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
                                        : 0),
 				    erec1.certs, env->in_modidx, 
 				    &menv, NULL, NULL);
@@ -5572,7 +5572,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 				  + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
 				  + SCHEME_DONT_MARK_USE
                                   + ((!rec[drec].comp && (rec[drec].depth == -2))
-                                     ? SCHEME_OUT_OF_CONTEXT_OK
+                                     ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
                                      : 0),
 				  rec[drec].certs, env->in_modidx, 
 				  &menv, NULL, NULL);
@@ -5615,7 +5615,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 				  + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
 				  + SCHEME_DONT_MARK_USE
                                   + ((!rec[drec].comp && (rec[drec].depth == -2))
-                                     ? SCHEME_OUT_OF_CONTEXT_OK
+                                     ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL)
                                      : 0),
 				  rec[drec].certs, env->in_modidx, 
 				  &menv, NULL, NULL);

src/mzscheme/src/schpriv.h

@@ -2350,6 +2350,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count);
 #define SCHEME_RESOLVE_MODIDS 1024
 #define SCHEME_NO_CERT_CHECKS 2048
 #define SCHEME_REFERENCING 4096
+#define SCHEME_OUT_OF_CONTEXT_LOCAL 8192
 
 Scheme_Hash_Table *scheme_map_constants_to_globals(void);
 

src/mzscheme/src/stxobj.c

@@ -3109,6 +3109,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx)
   return scheme_false;
 }
 
+#define EXPLAIN_RESOLVE 0
+#if EXPLAIN_RESOLVE
+static int explain_resolves = 1;
+# define EXPLAIN(x) if (explain_resolves) { x; }
+#else
+# define EXPLAIN(x) /* empty */
+#endif
+
 static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env)
 /* Compares the marks in two wraps lists. A result of 2 means that the
    result depended on a barrier env. For a rib-based renaming, we need
@@ -3273,6 +3281,7 @@ static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env
 
     /* Done if both reached the end: */
     if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) {
+      EXPLAIN(fprintf(stderr, "    %d vs. %d marks\n", a_mark_cnt, b_mark_cnt));
       if (a_mark_cnt == b_mark_cnt) {
         while (a_mark_cnt--) {
           if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt]))
@@ -3364,14 +3373,6 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks)
   }
 }
 
-#define EXPLAIN_RESOLVE 0
-#if EXPLAIN_RESOLVE
-static int explain_resolves = 0;
-# define EXPLAIN(x) if (explain_resolves) { x; }
-#else
-# define EXPLAIN(x) /* empty */
-#endif
-
 static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth)
 {
   int l1, l2;
@@ -3898,8 +3899,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
 	is_rib = NULL;
       }
 
-      EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d%s\n", depth, is_rib ? 1 : 0,
+      EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0,
                       SCHEME_VEC_SIZE(rename), 
+                      SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "<simp>",
                       SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash"));
 
       c = SCHEME_RENAME_LEN(rename);

src/worksp/mred/mred.manifest

@@ -1,7 +1,7 @@
 <?xml version="1.0" encoding="UTF-8" standalone="yes"?> 
 <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> 
 <assemblyIdentity 
-version="4.1.3.9" 
+version="4.1.3.10" 
 processorArchitecture="X86" 
 name="Org.PLT-Scheme.MrEd" 
 type="win32" 

src/worksp/mred/mred.rc

@@ -20,8 +20,8 @@ APPLICATION             ICON    DISCARDABLE     "mred.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,9
+ FILEVERSION 4,1,3,10
- PRODUCTVERSION 4,1,3,9
+ PRODUCTVERSION 4,1,3,10
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -39,11 +39,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme GUI application\0"
             VALUE "InternalName", "MrEd\0"
-            VALUE "FileVersion", "4, 1, 3, 9\0"
+            VALUE "FileVersion", "4, 1, 3, 10\0"
             VALUE "LegalCopyright", "Copyright © 1995-2009\0"
             VALUE "OriginalFilename", "MrEd.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 9\0"
+            VALUE "ProductVersion", "4, 1, 3, 10\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzcom.rc

@@ -53,8 +53,8 @@ END
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,9
+ FILEVERSION 4,1,3,10
- PRODUCTVERSION 4,1,3,9
+ PRODUCTVERSION 4,1,3,10
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -70,12 +70,12 @@ BEGIN
         BLOCK "040904b0"
         BEGIN
             VALUE "FileDescription", "MzCOM Module"
-            VALUE "FileVersion", "4, 1, 3, 9"
+            VALUE "FileVersion", "4, 1, 3, 10"
             VALUE "InternalName", "MzCOM"
             VALUE "LegalCopyright", "Copyright 2000-2009 PLT (Paul Steckler)"
             VALUE "OriginalFilename", "MzCOM.EXE"
             VALUE "ProductName", "MzCOM Module"
-            VALUE "ProductVersion", "4, 1, 3, 9"
+            VALUE "ProductVersion", "4, 1, 3, 10"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/mzcom/mzobj.rgs

@@ -1,19 +1,19 @@
 HKCR
 {
-	MzCOM.MzObj.4.1.3.9 = s 'MzObj Class'
+	MzCOM.MzObj.4.1.3.10 = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
 	}
 	MzCOM.MzObj = s 'MzObj Class'
 	{
 		CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}'
-		CurVer = s 'MzCOM.MzObj.4.1.3.9'
+		CurVer = s 'MzCOM.MzObj.4.1.3.10'
 	}
 	NoRemove CLSID
 	{
 		ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class'
 		{
-			ProgID = s 'MzCOM.MzObj.4.1.3.9'
+			ProgID = s 'MzCOM.MzObj.4.1.3.10'
 			VersionIndependentProgID = s 'MzCOM.MzObj'
 			ForceRemove 'Programmable'
 			LocalServer32 = s '%MODULE%'

src/worksp/mzscheme/mzscheme.rc

@@ -29,8 +29,8 @@ APPLICATION             ICON    DISCARDABLE     "mzscheme.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,9
+ FILEVERSION 4,1,3,10
- PRODUCTVERSION 4,1,3,9
+ PRODUCTVERSION 4,1,3,10
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -48,11 +48,11 @@ BEGIN
             VALUE "CompanyName", "PLT Scheme Inc.\0"
             VALUE "FileDescription", "PLT Scheme application\0"
             VALUE "InternalName", "MzScheme\0"
-            VALUE "FileVersion", "4, 1, 3, 9\0"
+            VALUE "FileVersion", "4, 1, 3, 10\0"
             VALUE "LegalCopyright", "Copyright <20>© 1995-2009\0"
             VALUE "OriginalFilename", "mzscheme.exe\0"
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 9\0"
+            VALUE "ProductVersion", "4, 1, 3, 10\0"
         END
     END
     BLOCK "VarFileInfo"

src/worksp/starters/start.rc

@@ -22,8 +22,8 @@ APPLICATION             ICON    DISCARDABLE     "mzstart.ico"
 //
 
 VS_VERSION_INFO VERSIONINFO
- FILEVERSION 4,1,3,9
+ FILEVERSION 4,1,3,10
- PRODUCTVERSION 4,1,3,9
+ PRODUCTVERSION 4,1,3,10
  FILEFLAGSMASK 0x3fL
 #ifdef _DEBUG
  FILEFLAGS 0x1L
@@ -45,7 +45,7 @@ BEGIN
 #ifdef MZSTART
             VALUE "FileDescription", "PLT Scheme Launcher\0"
 #endif
-            VALUE "FileVersion", "4, 1, 3, 9\0"
+            VALUE "FileVersion", "4, 1, 3, 10\0"
 #ifdef MRSTART
             VALUE "InternalName", "mrstart\0"
 #endif
@@ -60,7 +60,7 @@ BEGIN
             VALUE "OriginalFilename", "MzStart.exe\0"
 #endif
             VALUE "ProductName", "PLT Scheme\0"
-            VALUE "ProductVersion", "4, 1, 3, 9\0"
+            VALUE "ProductVersion", "4, 1, 3, 10\0"
         END
     END
     BLOCK "VarFileInfo"